ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro/Coro/State.xs
(Generate patch)

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.448 by root, Thu Jun 4 22:58:28 2015 UTC

1/* this works around a bug in mingw32 providing a non-working setjmp */
2#define USE_NO_MINGW_SETJMP_TWO_ARGS
3
4#define NDEBUG 1 /* perl usually disables NDEBUG later */
5
6#include "libcoro/coro.c"
7
8#define PERL_NO_GET_CONTEXT
9#define PERL_EXT
10
1#include "EXTERN.h" 11#include "EXTERN.h"
2#include "perl.h" 12#include "perl.h"
3#include "XSUB.h" 13#include "XSUB.h"
14#include "perliol.h"
4 15
5#if 0 16#include "schmorp.h"
6# define CHK(x) (void *)0 17
18#define ECB_NO_THREADS 1
19#define ECB_NO_LIBM 1
20#include "ecb.h"
21
22#include <stddef.h>
23#include <stdio.h>
24#include <errno.h>
25#include <assert.h>
26
27#ifndef SVs_PADSTALE
28# define SVs_PADSTALE 0
29#endif
30
31#ifdef PadARRAY
32# define NEWPADAPI 1
33# define newPADLIST(var) (Newz (0, var, 1, PADLIST), Newx (PadlistARRAY (var), 2, PAD *))
7#else 34#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 35typedef AV PADNAMELIST;
36# if !PERL_VERSION_ATLEAST(5,8,0)
37typedef AV PADLIST;
38typedef AV PAD;
9#endif 39# endif
40# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
41# define PadlistMAX(pl) AvFILLp (pl)
42# define PadlistNAMES(pl) (*PadlistARRAY (pl))
43# define PadARRAY AvARRAY
44# define PadMAX AvFILLp
45# define newPADLIST(var) ((var) = newAV (), av_extend (var, 1))
46#endif
47#ifndef PadnamelistREFCNT
48# define PadnamelistREFCNT(pnl) SvREFCNT (pnl)
49#endif
50#ifndef PadnamelistREFCNT_dec
51# define PadnamelistREFCNT_dec(pnl) SvREFCNT_dec (pnl)
52#endif
10 53
54/* 5.19.something has replaced SVt_BIND by SVt_INVLIST */
55/* we just alias it to SVt_IV, as that is sufficient for swap_sv for now */
56#if PERL_VERSION_ATLEAST(5,19,0)
57# define SVt_BIND SVt_IV
58#endif
59
60#if defined(_WIN32)
61# undef HAS_GETTIMEOFDAY
62# undef setjmp
63# undef longjmp
64# undef _exit
65# define setjmp _setjmp /* deep magic */
66#else
67# include <inttypes.h> /* most portable stdint.h */
68#endif
69
70/* the maximum number of idle cctx that will be pooled */
71static int cctx_max_idle = 4;
72
73#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)
74# define HAS_SCOPESTACK_NAME 1
75#endif
76
77/* prefer perl internal functions over our own? */
78#ifndef CORO_PREFER_PERL_FUNCTIONS
79# define CORO_PREFER_PERL_FUNCTIONS 0
80#endif
81
82/* The next macros try to return the current stack pointer, in an as
83 * portable way as possible. */
84#if __GNUC__ >= 4
85# define dSTACKLEVEL int stacklevel_dummy
86# define STACKLEVEL __builtin_frame_address (0)
87#else
88# define dSTACKLEVEL volatile void *stacklevel
89# define STACKLEVEL ((void *)&stacklevel)
90#endif
91
92#define IN_DESTRUCT PL_dirty
93
94#include "CoroAPI.h"
95#define GCoroAPI (&coroapi) /* very sneaky */
96
97#ifdef USE_ITHREADS
98# if CORO_PTHREAD
99static void *coro_thx;
100# endif
101#endif
102
103#ifdef __linux
104# include <time.h> /* for timespec */
105# include <syscall.h> /* for SYS_* */
106# ifdef SYS_clock_gettime
107# define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts))
108# define CORO_CLOCK_MONOTONIC 1
109# define CORO_CLOCK_THREAD_CPUTIME_ID 3
110# endif
111#endif
112
113static double (*nvtime)(); /* so why doesn't it take void? */
114static void (*u2time)(pTHX_ UV ret[2]);
115
116/* we hijack an hopefully unused CV flag for our purposes */
117#define CVf_SLF 0x4000
118static OP *pp_slf (pTHX);
119static void slf_destroy (pTHX_ struct coro *coro);
120
121static U32 cctx_gen;
122static size_t cctx_stacksize = CORO_STACKSIZE;
123static struct CoroAPI coroapi;
124static AV *main_mainstack; /* used to differentiate between $main and others */
125static JMPENV *main_top_env;
126static HV *coro_state_stash, *coro_stash;
127static volatile SV *coro_mortal; /* will be freed/thrown after next transfer */
128
129static AV *av_destroy; /* destruction queue */
130static SV *sv_manager; /* the manager coro */
131static SV *sv_idle; /* $Coro::idle */
132
133static GV *irsgv; /* $/ */
134static GV *stdoutgv; /* *STDOUT */
135static SV *rv_diehook;
136static SV *rv_warnhook;
137static HV *hv_sig; /* %SIG */
138
139/* async_pool helper stuff */
140static SV *sv_pool_rss;
141static SV *sv_pool_size;
142static SV *sv_async_pool_idle; /* description string */
143static AV *av_async_pool; /* idle pool */
144static SV *sv_Coro; /* class string */
145static CV *cv_pool_handler;
146
147/* Coro::AnyEvent */
148static SV *sv_activity;
149
150/* enable processtime/realtime profiling */
151static char enable_times;
152typedef U32 coro_ts[2];
153static coro_ts time_real, time_cpu;
154static char times_valid;
155
156static struct coro_cctx *cctx_first;
157static int cctx_count, cctx_idle;
158
159enum
160{
161 CC_MAPPED = 0x01,
162 CC_NOREUSE = 0x02, /* throw this away after tracing */
163 CC_TRACE = 0x04,
164 CC_TRACE_SUB = 0x08, /* trace sub calls */
165 CC_TRACE_LINE = 0x10, /* trace each statement */
166 CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
167};
168
169/* this is a structure representing a c-level coroutine */
170typedef struct coro_cctx
171{
172 struct coro_cctx *next;
173
174 /* the stack */
175 struct coro_stack stack;
176
177 /* cpu state */
178 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
179#ifndef NDEBUG
180 JMPENV *idle_te; /* same as idle_sp, but for top_env */
181#endif
182 JMPENV *top_env;
183 coro_context cctx;
184
185 U32 gen;
186#if CORO_USE_VALGRIND
187 int valgrind_id;
188#endif
189 unsigned char flags;
190} coro_cctx;
191
192static coro_cctx *cctx_current; /* the currently running cctx */
193
194/*****************************************************************************/
195
196static MGVTBL coro_state_vtbl;
197
198enum
199{
200 CF_RUNNING = 0x0001, /* coroutine is running */
201 CF_READY = 0x0002, /* coroutine is ready */
202 CF_NEW = 0x0004, /* has never been switched to */
203 CF_ZOMBIE = 0x0008, /* coroutine data has been freed */
204 CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */
205 CF_NOCANCEL = 0x0020, /* cannot cancel, set slf_frame.data to 1 (hackish) */
206};
207
208/* the structure where most of the perl state is stored, overlaid on the cxstack */
209typedef struct
210{
211 #define VARx(name,expr,type) type name;
212 #include "state.h"
213} perl_slots;
214
215/* how many context stack entries do we need for perl_slots */
216#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
217
218/* this is a structure representing a perl-level coroutine */
11struct coro { 219struct coro
12 U8 dowarn; 220{
13 AV *defav; 221 /* the C coroutine allocated to this perl coroutine, if any */
14 222 coro_cctx *cctx;
15 PERL_SI *curstackinfo; 223
16 AV *curstack; 224 /* ready queue */
225 struct coro *next_ready;
226
227 /* state data */
228 struct CoroSLF slf_frame; /* saved slf frame */
17 AV *mainstack; 229 AV *mainstack;
18 SV **stack_sp; 230 perl_slots *slot; /* basically the saved sp */
19 OP *op;
20 SV **curpad;
21 SV **stack_base;
22 SV **stack_max;
23 SV **tmps_stack;
24 I32 tmps_floor;
25 I32 tmps_ix;
26 I32 tmps_max;
27 I32 *markstack;
28 I32 *markstack_ptr;
29 I32 *markstack_max;
30 I32 *scopestack;
31 I32 scopestack_ix;
32 I32 scopestack_max;
33 ANY *savestack;
34 I32 savestack_ix;
35 I32 savestack_max;
36 OP **retstack;
37 I32 retstack_ix;
38 I32 retstack_max;
39 COP *curcop;
40 231
41 AV *args; 232 CV *startcv; /* the CV to execute */
233 AV *args; /* data associated with this coroutine (initial args) */
234 int flags; /* CF_ flags */
235 HV *hv; /* the perl hash associated with this coro, if any */
236
237 /* statistics */
238 int usecount; /* number of transfers to this coro */
239
240 /* coro process data */
241 int prio;
242 SV *except; /* exception to be thrown */
243 SV *rouse_cb; /* last rouse callback */
244 AV *on_destroy; /* callbacks or coros to notify on destroy */
245 AV *status; /* the exit status list */
246
247 /* async_pool */
248 SV *saved_deffh;
249 SV *invoke_cb;
250 AV *invoke_av;
251
252 /* on_enter/on_leave */
253 AV *on_enter;
254 AV *on_leave;
255
256 /* swap_sv */
257 AV *swap_sv;
258
259 /* times */
260 coro_ts t_cpu, t_real;
261
262 /* linked list */
263 struct coro *next, *prev;
42}; 264};
43 265
44typedef struct coro *Coro__State; 266typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 267typedef struct coro *Coro__State_or_hashref;
46 268
47static HV *padlist_cache; 269/* the following variables are effectively part of the perl context */
270/* and get copied between struct coro and these variables */
271/* the main reason we don't support windows process emulation */
272static struct CoroSLF slf_frame; /* the current slf frame */
48 273
49/* mostly copied from op.c:cv_clone2 */ 274/** Coro ********************************************************************/
50STATIC AV * 275
51clone_padlist (AV *protopadlist) 276#define CORO_PRIO_MAX 3
277#define CORO_PRIO_HIGH 1
278#define CORO_PRIO_NORMAL 0
279#define CORO_PRIO_LOW -1
280#define CORO_PRIO_IDLE -3
281#define CORO_PRIO_MIN -4
282
283/* for Coro.pm */
284static SV *coro_current;
285static SV *coro_readyhook;
286static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */
287static CV *cv_coro_run;
288static struct coro *coro_first;
289#define coro_nready coroapi.nready
290
291/** JIT *********************************************************************/
292
293#if CORO_JIT
294 /* APPLE doesn't have mmap though */
295 #define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__)
296 #ifndef CORO_JIT_TYPE
297 #if ECB_AMD64 && CORO_JIT_UNIXY
298 #define CORO_JIT_TYPE "amd64-unix"
299 #elif __i386 && CORO_JIT_UNIXY
300 #define CORO_JIT_TYPE "x86-unix"
301 #endif
302 #endif
303#endif
304
305#if !defined(CORO_JIT_TYPE) || _POSIX_MEMORY_PROTECTION <= 0
306 #undef CORO_JIT
307#endif
308
309#if CORO_JIT
310 typedef void (*load_save_perl_slots_type)(perl_slots *);
311 static load_save_perl_slots_type load_perl_slots, save_perl_slots;
312#endif
313
314/** Coro::Select ************************************************************/
315
316static OP *(*coro_old_pp_sselect) (pTHX);
317static SV *coro_select_select;
318
319/* horrible hack, but if it works... */
320static OP *
321coro_pp_sselect (pTHX)
52{ 322{
53 AV *av; 323 dSP;
54 I32 ix; 324 PUSHMARK (SP - 4); /* fake argument list */
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE); 325 XPUSHs (coro_select_select);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE); 326 PUTBACK;
57 SV **pname = AvARRAY (protopad_name); 327
58 SV **ppad = AvARRAY (protopad); 328 /* entersub is an UNOP, select a LISTOP... keep your fingers crossed */
59 I32 fname = AvFILLp (protopad_name); 329 PL_op->op_flags |= OPf_STACKED;
60 I32 fpad = AvFILLp (protopad); 330 PL_op->op_private = 0;
61 AV *newpadlist, *newpad_name, *newpad; 331 return PL_ppaddr [OP_ENTERSUB](aTHX);
332}
333
334/** time stuff **************************************************************/
335
336#ifdef HAS_GETTIMEOFDAY
337
338ecb_inline void
339coro_u2time (pTHX_ UV ret[2])
340{
341 struct timeval tv;
342 gettimeofday (&tv, 0);
343
344 ret [0] = tv.tv_sec;
345 ret [1] = tv.tv_usec;
346}
347
348ecb_inline double
349coro_nvtime (void)
350{
351 struct timeval tv;
352 gettimeofday (&tv, 0);
353
354 return tv.tv_sec + tv.tv_usec * 1e-6;
355}
356
357ecb_inline void
358time_init (pTHX)
359{
360 nvtime = coro_nvtime;
361 u2time = coro_u2time;
362}
363
364#else
365
366ecb_inline void
367time_init (pTHX)
368{
62 SV **npad; 369 SV **svp;
63 370
64 newpad_name = newAV (); 371 require_pv ("Time/HiRes.pm");
65 for (ix = fname; ix >= 0; ix--)
66 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
67 372
68 newpad = newAV (); 373 svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
69 av_fill (newpad, AvFILLp (protopad));
70 npad = AvARRAY (newpad);
71 374
72 newpadlist = newAV (); 375 if (!svp) croak ("Time::HiRes is required, but missing. Caught");
376 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught");
377
378 nvtime = INT2PTR (double (*)(), SvIV (*svp));
379
380 svp = hv_fetch (PL_modglobal, "Time::U2time", 12, 0);
381 u2time = INT2PTR (void (*)(pTHX_ UV ret[2]), SvIV (*svp));
382}
383
384#endif
385
386/** lowlevel stuff **********************************************************/
387
388static SV * ecb_noinline
389coro_get_sv (pTHX_ const char *name, int create)
390{
391#if PERL_VERSION_ATLEAST (5,10,0)
392 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
393 get_sv (name, create);
394#endif
395 return get_sv (name, create);
396}
397
398static AV * ecb_noinline
399coro_get_av (pTHX_ const char *name, int create)
400{
401#if PERL_VERSION_ATLEAST (5,10,0)
402 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
403 get_av (name, create);
404#endif
405 return get_av (name, create);
406}
407
408static HV * ecb_noinline
409coro_get_hv (pTHX_ const char *name, int create)
410{
411#if PERL_VERSION_ATLEAST (5,10,0)
412 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
413 get_hv (name, create);
414#endif
415 return get_hv (name, create);
416}
417
418ecb_inline void
419coro_times_update (void)
420{
421#ifdef coro_clock_gettime
422 struct timespec ts;
423
424 ts.tv_sec = ts.tv_nsec = 0;
425 coro_clock_gettime (CORO_CLOCK_THREAD_CPUTIME_ID, &ts);
426 time_cpu [0] = ts.tv_sec; time_cpu [1] = ts.tv_nsec;
427
428 ts.tv_sec = ts.tv_nsec = 0;
429 coro_clock_gettime (CORO_CLOCK_MONOTONIC, &ts);
430 time_real [0] = ts.tv_sec; time_real [1] = ts.tv_nsec;
431#else
432 dTHX;
433 UV tv[2];
434
435 u2time (aTHX_ tv);
436 time_real [0] = tv [0];
437 time_real [1] = tv [1] * 1000;
438#endif
439}
440
441ecb_inline void
442coro_times_add (struct coro *c)
443{
444 c->t_real [1] += time_real [1];
445 if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; }
446 c->t_real [0] += time_real [0];
447
448 c->t_cpu [1] += time_cpu [1];
449 if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; }
450 c->t_cpu [0] += time_cpu [0];
451}
452
453ecb_inline void
454coro_times_sub (struct coro *c)
455{
456 if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; }
457 c->t_real [1] -= time_real [1];
458 c->t_real [0] -= time_real [0];
459
460 if (c->t_cpu [1] < time_cpu [1]) { c->t_cpu [1] += 1000000000; --c->t_cpu [0]; }
461 c->t_cpu [1] -= time_cpu [1];
462 c->t_cpu [0] -= time_cpu [0];
463}
464
465/*****************************************************************************/
466/* magic glue */
467
468#define CORO_MAGIC_type_cv 26
469#define CORO_MAGIC_type_state PERL_MAGIC_ext
470
471#define CORO_MAGIC_NN(sv, type) \
472 (ecb_expect_true (SvMAGIC (sv)->mg_type == type) \
473 ? SvMAGIC (sv) \
474 : mg_find (sv, type))
475
476#define CORO_MAGIC(sv, type) \
477 (ecb_expect_true (SvMAGIC (sv)) \
478 ? CORO_MAGIC_NN (sv, type) \
479 : 0)
480
481#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
482#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)
483
484ecb_inline MAGIC *
485SvSTATEhv_p (pTHX_ SV *coro)
486{
487 MAGIC *mg;
488
489 if (ecb_expect_true (
490 SvTYPE (coro) == SVt_PVHV
491 && (mg = CORO_MAGIC_state (coro))
492 && mg->mg_virtual == &coro_state_vtbl
493 ))
494 return mg;
495
496 return 0;
497}
498
499ecb_inline struct coro *
500SvSTATE_ (pTHX_ SV *coro)
501{
502 MAGIC *mg;
503
504 if (SvROK (coro))
505 coro = SvRV (coro);
506
507 mg = SvSTATEhv_p (aTHX_ coro);
508 if (!mg)
509 croak ("Coro::State object required");
510
511 return (struct coro *)mg->mg_ptr;
512}
513
514#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
515
516/* faster than SvSTATE, but expects a coroutine hv */
517#define SvSTATE_hv(hv) ((struct coro *)CORO_MAGIC_NN ((SV *)hv, CORO_MAGIC_type_state)->mg_ptr)
518#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))
519
520/*****************************************************************************/
521/* padlist management and caching */
522
523ecb_inline PADLIST *
524coro_derive_padlist (pTHX_ CV *cv)
525{
526 PADLIST *padlist = CvPADLIST (cv);
527 PADLIST *newpadlist;
528 PADNAMELIST *padnames;
529 PAD *newpad;
530 PADOFFSET off = PadlistMAX (padlist) + 1;
531
532#if NEWPADAPI
533
534 /* if we had the original CvDEPTH, we might be able to steal the CvDEPTH+1 entry instead */
535 /* 20131102194744.GA6705@schmorp.de, 20131102195825.2013.qmail@lists-nntp.develooper.com */
536 while (!PadlistARRAY (padlist)[off - 1])
537 --off;
538
539 Perl_pad_push (aTHX_ padlist, off);
540
541 newpad = PadlistARRAY (padlist)[off];
542 PadlistARRAY (padlist)[off] = 0;
543
544#else
545
546#if PERL_VERSION_ATLEAST (5,10,0)
547 Perl_pad_push (aTHX_ padlist, off);
548#else
549 Perl_pad_push (aTHX_ padlist, off, 1);
550#endif
551
552 newpad = PadlistARRAY (padlist)[off];
553 PadlistMAX (padlist) = off - 1;
554
555#endif
556
557 newPADLIST (newpadlist);
558#if !PERL_VERSION_ATLEAST(5,15,3)
559 /* Padlists are AvREAL as of 5.15.3. See perl bug #98092 and perl commit 7d953ba. */
73 AvREAL_off (newpadlist); 560 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 561#endif
75 av_store (newpadlist, 1, (SV *) newpad);
76 562
77 av = newAV (); /* will be @_ */ 563 /* Already extended to 2 elements by newPADLIST. */
78 av_extend (av, 0); 564 PadlistMAX (newpadlist) = 1;
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 565
82 for (ix = fpad; ix > 0; ix--) 566 padnames = PadlistNAMES (padlist);
567 ++PadnamelistREFCNT (padnames);
568 PadlistNAMES (newpadlist) = padnames;
569
570 PadlistARRAY (newpadlist)[1] = newpad;
571
572 return newpadlist;
573}
574
575ecb_inline void
576free_padlist (pTHX_ PADLIST *padlist)
577{
578 /* may be during global destruction */
579 if (!IN_DESTRUCT)
83 { 580 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 581 I32 i = PadlistMAX (padlist);
85 if (namesv && namesv != &PL_sv_undef) 582
583 while (i > 0) /* special-case index 0 */
86 { 584 {
87 char *name = SvPVX (namesv); /* XXX */ 585 /* we try to be extra-careful here */
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 586 PAD *pad = PadlistARRAY (padlist)[i--];
89 { /* lexical from outside? */ 587
90 npad[ix] = SvREFCNT_inc (ppad[ix]); 588 if (pad)
91 } 589 {
92 else 590 I32 j = PadMAX (pad);
93 { /* our own lexical */ 591
94 SV *sv; 592 while (j >= 0)
95 if (*name == '&') 593 SvREFCNT_dec (PadARRAY (pad)[j--]);
594
595 PadMAX (pad) = -1;
96 sv = SvREFCNT_inc (ppad[ix]); 596 SvREFCNT_dec (pad);
97 else if (*name == '@')
98 sv = (SV *) newAV ();
99 else if (*name == '%')
100 sv = (SV *) newHV ();
101 else
102 sv = NEWSV (0, 0);
103 if (!SvPADBUSY (sv))
104 SvPADMY_on (sv);
105 npad[ix] = sv;
106 } 597 }
107 } 598 }
108 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
109 {
110 npad[ix] = SvREFCNT_inc (ppad[ix]);
111 }
112 else
113 {
114 SV *sv = NEWSV (0, 0);
115 SvPADTMP_on (sv);
116 npad[ix] = sv;
117 }
118 }
119 599
120#if 0 /* NONOTUNDERSTOOD */ 600 PadnamelistREFCNT_dec (PadlistNAMES (padlist));
121 /* Now that vars are all in place, clone nested closures. */
122 601
123 for (ix = fpad; ix > 0; ix--) { 602#if NEWPADAPI
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 603 Safefree (PadlistARRAY (padlist));
125 if (namesv 604 Safefree (padlist);
126 && namesv != &PL_sv_undef 605#else
127 && !(SvFLAGS(namesv) & SVf_FAKE)
128 && *SvPVX(namesv) == '&'
129 && CvCLONE(ppad[ix]))
130 {
131 CV *kid = cv_clone((CV*)ppad[ix]);
132 SvREFCNT_dec(ppad[ix]);
133 CvCLONE_on(kid);
134 SvPADMY_on(kid);
135 npad[ix] = (SV*)kid;
136 }
137 }
138#endif
139
140 return newpadlist;
141}
142
143STATIC AV *
144free_padlist (AV *padlist)
145{
146 /* may be during global destruction */
147 if (SvREFCNT(padlist))
148 {
149 I32 i = AvFILLp(padlist); 606 AvFILLp (padlist) = -1;
150 while (i >= 0) 607 AvREAL_off (padlist);
151 {
152 SV **svp = av_fetch(padlist, i--, FALSE);
153 SV *sv = svp ? *svp : Nullsv;
154 if (sv)
155 SvREFCNT_dec(sv);
156 }
157
158 SvREFCNT_dec((SV*)padlist); 608 SvREFCNT_dec ((SV*)padlist);
609#endif
610 }
611}
612
613static int
614coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
615{
616 PADLIST *padlist;
617 PADLIST **padlists = (PADLIST **)(mg->mg_ptr + sizeof(size_t));
618 size_t len = *(size_t *)mg->mg_ptr;
619
620 /* perl manages to free our internal AV and _then_ call us */
621 if (IN_DESTRUCT)
622 return 0;
623
624 while (len--)
625 free_padlist (aTHX_ padlists[len]);
626
627 return 0;
628}
629
630static MGVTBL coro_cv_vtbl = {
631 0, 0, 0, 0,
632 coro_cv_free
633};
634
635/* the next two functions merely cache the padlists */
636ecb_inline void
637get_padlist (pTHX_ CV *cv)
638{
639 MAGIC *mg = CORO_MAGIC_cv (cv);
640 size_t *lenp;
641
642 if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr)))
643 CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp];
644 else
645 {
646#if CORO_PREFER_PERL_FUNCTIONS
647 /* this is probably cleaner? but also slower! */
648 /* in practise, it seems to be less stable */
649 CV *cp = Perl_cv_clone (aTHX_ cv);
650 CvPADLIST (cv) = CvPADLIST (cp);
651 CvPADLIST (cp) = 0;
652 SvREFCNT_dec (cp);
653#else
654 CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);
655#endif
656 }
657}
658
659ecb_inline void
660put_padlist (pTHX_ CV *cv)
661{
662 MAGIC *mg = CORO_MAGIC_cv (cv);
663
664 if (ecb_expect_false (!mg))
665 {
666 mg = sv_magicext ((SV *)cv, 0, CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
667 Newz (0, mg->mg_ptr ,sizeof (size_t) + sizeof (PADLIST *), char);
668 mg->mg_len = 1; /* so mg_free frees mg_ptr */
669 }
670 else
671 Renew (mg->mg_ptr,
672 sizeof(size_t) + (*(size_t *)mg->mg_ptr + 1) * sizeof(PADLIST *),
673 char);
674
675 ((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv);
676}
677
678/** load & save, init *******************************************************/
679
680ecb_inline void
681swap_sv (SV *a, SV *b)
682{
683 const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
684 SV tmp;
685
686 /* swap sv_any */
687 SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
688
689 /* swap sv_flags */
690 SvFLAGS (&tmp) = SvFLAGS (a);
691 SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
692 SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
693
694#if PERL_VERSION_ATLEAST (5,10,0)
695 /* perl 5.10 and later complicates this _quite_ a bit, but it also
696 * is much faster, so no quarrels here. alternatively, we could
697 * sv_upgrade to avoid this.
698 */
699 {
700 /* swap sv_u */
701 tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
702
703 /* if SvANY points to the head, we need to adjust the pointers,
704 * as the pointer for a still points to b, and maybe vice versa.
705 */
706 #define svany_in_head(type) \
707 (((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type)))
708
709 if (svany_in_head (SvTYPE (a)))
710 SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
711
712 if (svany_in_head (SvTYPE (b)))
713 SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
159 } 714 }
715#endif
160} 716}
161 717
162STATIC AV * 718/* swap sv heads, at least logically */
163unuse_padlist (AV *padlist)
164{
165 free_padlist (padlist);
166}
167
168static void 719static void
169SAVE(pTHX_ Coro__State c) 720swap_svs (pTHX_ Coro__State c)
170{ 721{
722 int i;
723
724 for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
725 swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
726}
727
728#define SWAP_SVS(coro) \
729 if (ecb_expect_false ((coro)->swap_sv)) \
730 swap_svs (aTHX_ (coro))
731
732static void
733on_enterleave_call (pTHX_ SV *cb);
734
735static void
736load_perl (pTHX_ Coro__State c)
737{
738 perl_slots *slot = c->slot;
739 c->slot = 0;
740
741 PL_mainstack = c->mainstack;
742
743#if CORO_JIT
744 load_perl_slots (slot);
745#else
746 #define VARx(name,expr,type) expr = slot->name;
747 #include "state.h"
748#endif
749
750 {
751 dSP;
752
753 CV *cv;
754
755 /* now do the ugly restore mess */
756 while (ecb_expect_true (cv = (CV *)POPs))
757 {
758 put_padlist (aTHX_ cv); /* mark this padlist as available */
759 CvDEPTH (cv) = PTR2IV (POPs);
760 CvPADLIST (cv) = (PADLIST *)POPs;
761 }
762
763 PUTBACK;
764 }
765
766 slf_frame = c->slf_frame;
767 CORO_THROW = c->except;
768
769 if (ecb_expect_false (enable_times))
770 {
771 if (ecb_expect_false (!times_valid))
772 coro_times_update ();
773
774 coro_times_sub (c);
775 }
776
777 if (ecb_expect_false (c->on_enter))
778 {
779 int i;
780
781 for (i = 0; i <= AvFILLp (c->on_enter); ++i)
782 on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);
783 }
784
785 SWAP_SVS (c);
786}
787
788static void
789save_perl (pTHX_ Coro__State c)
790{
791 SWAP_SVS (c);
792
793 if (ecb_expect_false (c->on_leave))
794 {
795 int i;
796
797 for (i = AvFILLp (c->on_leave); i >= 0; --i)
798 on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]);
799 }
800
801 times_valid = 0;
802
803 if (ecb_expect_false (enable_times))
804 {
805 coro_times_update (); times_valid = 1;
806 coro_times_add (c);
807 }
808
809 c->except = CORO_THROW;
810 c->slf_frame = slf_frame;
811
171 { 812 {
172 dSP; 813 dSP;
173 I32 cxix = cxstack_ix; 814 I32 cxix = cxstack_ix;
815 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 816 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 817
177 /* 818 /*
178 * the worst thing you can imagine happens first - we have to save 819 * the worst thing you can imagine happens first - we have to save
179 * (and reinitialize) all cv's in the whole callchain :( 820 * (and reinitialize) all cv's in the whole callchain :(
180 */ 821 */
181 822
182 PUSHs (Nullsv); 823 XPUSHs (Nullsv);
183 /* this loop was inspired by pp_caller */ 824 /* this loop was inspired by pp_caller */
184 for (;;) 825 for (;;)
185 { 826 {
186 while (cxix >= 0) 827 while (ecb_expect_true (cxix >= 0))
187 { 828 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 829 PERL_CONTEXT *cx = &ccstk[cxix--];
189 830
190 if (CxTYPE(cx) == CXt_SUB) 831 if (ecb_expect_true (CxTYPE (cx) == CXt_SUB) || ecb_expect_false (CxTYPE (cx) == CXt_FORMAT))
191 { 832 {
192 CV *cv = cx->blk_sub.cv; 833 CV *cv = cx->blk_sub.cv;
834
193 if (CvDEPTH(cv)) 835 if (ecb_expect_true (CvDEPTH (cv)))
194 { 836 {
195#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv));
197#endif
198 EXTEND (SP, 3); 837 EXTEND (SP, 3);
199 PUSHs ((SV *)CvDEPTH(cv));
200 PUSHs ((SV *)CvPADLIST(cv)); 838 PUSHs ((SV *)CvPADLIST (cv));
839 PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
201 PUSHs ((SV *)cv); 840 PUSHs ((SV *)cv);
202 841
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));
204
205 CvDEPTH(cv) = 0; 842 CvDEPTH (cv) = 0;
206#ifdef USE_THREADS 843 get_padlist (aTHX_ cv);
207 CvOWNER(cv) = 0;
208 error must unlock this cv etc.. etc...
209 if you are here wondering about this error message then
210 the reason is that it will not work as advertised yet
211#endif
212 } 844 }
213 } 845 }
214 else if (CxTYPE(cx) == CXt_FORMAT) 846 }
847
848 if (ecb_expect_true (top_si->si_type == PERLSI_MAIN))
849 break;
850
851 top_si = top_si->si_prev;
852 ccstk = top_si->si_cxstack;
853 cxix = top_si->si_cxix;
854 }
855
856 PUTBACK;
857 }
858
859 /* allocate some space on the context stack for our purposes */
860 if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max))
861 {
862 unsigned int i;
863
864 for (i = 0; i < SLOT_COUNT; ++i)
865 CXINC;
866
867 cxstack_ix -= SLOT_COUNT; /* undo allocation */
868 }
869
870 c->mainstack = PL_mainstack;
871
872 {
873 perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
874
875#if CORO_JIT
876 save_perl_slots (slot);
877#else
878 #define VARx(name,expr,type) slot->name = expr;
879 #include "state.h"
880#endif
881 }
882}
883
884/*
885 * allocate various perl stacks. This is almost an exact copy
886 * of perl.c:init_stacks, except that it uses less memory
887 * on the (sometimes correct) assumption that coroutines do
888 * not usually need a lot of stackspace.
889 */
890#if CORO_PREFER_PERL_FUNCTIONS
891# define coro_init_stacks(thx) init_stacks ()
892#else
893static void
894coro_init_stacks (pTHX)
895{
896 PL_curstackinfo = new_stackinfo(32, 4 + SLOT_COUNT); /* 3 is minimum due to perl rounding down in scope.c:GROW() */
897 PL_curstackinfo->si_type = PERLSI_MAIN;
898 PL_curstack = PL_curstackinfo->si_stack;
899 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
900
901 PL_stack_base = AvARRAY(PL_curstack);
902 PL_stack_sp = PL_stack_base;
903 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
904
905 New(50,PL_tmps_stack,32,SV*);
906 PL_tmps_floor = -1;
907 PL_tmps_ix = -1;
908 PL_tmps_max = 32;
909
910 New(54,PL_markstack,16,I32);
911 PL_markstack_ptr = PL_markstack;
912 PL_markstack_max = PL_markstack + 16;
913
914#ifdef SET_MARK_OFFSET
915 SET_MARK_OFFSET;
916#endif
917
918 New(54,PL_scopestack,8,I32);
919 PL_scopestack_ix = 0;
920 PL_scopestack_max = 8;
921#if HAS_SCOPESTACK_NAME
922 New(54,PL_scopestack_name,8,const char*);
923#endif
924
925 New(54,PL_savestack,24,ANY);
926 PL_savestack_ix = 0;
927 PL_savestack_max = 24;
928
929#if !PERL_VERSION_ATLEAST (5,10,0)
930 New(54,PL_retstack,4,OP*);
931 PL_retstack_ix = 0;
932 PL_retstack_max = 4;
933#endif
934}
935#endif
936
937/*
938 * destroy the stacks, the callchain etc...
939 */
940static void
941coro_destruct_stacks (pTHX)
942{
943 while (PL_curstackinfo->si_next)
944 PL_curstackinfo = PL_curstackinfo->si_next;
945
946 while (PL_curstackinfo)
947 {
948 PERL_SI *p = PL_curstackinfo->si_prev;
949
950 if (!IN_DESTRUCT)
951 SvREFCNT_dec (PL_curstackinfo->si_stack);
952
953 Safefree (PL_curstackinfo->si_cxstack);
954 Safefree (PL_curstackinfo);
955 PL_curstackinfo = p;
956 }
957
958 Safefree (PL_tmps_stack);
959 Safefree (PL_markstack);
960 Safefree (PL_scopestack);
961#if HAS_SCOPESTACK_NAME
962 Safefree (PL_scopestack_name);
963#endif
964 Safefree (PL_savestack);
965#if !PERL_VERSION_ATLEAST (5,10,0)
966 Safefree (PL_retstack);
967#endif
968}
969
970#define CORO_RSS \
971 rss += sizeof (SYM (curstackinfo)); \
972 rss += (SYM (curstackinfo->si_cxmax) + 1) * sizeof (PERL_CONTEXT); \
973 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (SYM (curstack))) * sizeof (SV *); \
974 rss += SYM (tmps_max) * sizeof (SV *); \
975 rss += (SYM (markstack_max) - SYM (markstack_ptr)) * sizeof (I32); \
976 rss += SYM (scopestack_max) * sizeof (I32); \
977 rss += SYM (savestack_max) * sizeof (ANY);
978
979static size_t
980coro_rss (pTHX_ struct coro *coro)
981{
982 size_t rss = sizeof (*coro);
983
984 if (coro->mainstack)
985 {
986 if (coro->flags & CF_RUNNING)
987 {
988 #define SYM(sym) PL_ ## sym
989 CORO_RSS;
990 #undef SYM
991 }
992 else
993 {
994 #define SYM(sym) coro->slot->sym
995 CORO_RSS;
996 #undef SYM
997 }
998 }
999
1000 return rss;
1001}
1002
1003/** coroutine stack handling ************************************************/
1004
1005static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg);
1006static int (*orig_sigelem_set) (pTHX_ SV *sv, MAGIC *mg);
1007static int (*orig_sigelem_clr) (pTHX_ SV *sv, MAGIC *mg);
1008
1009/* apparently < 5.8.8 */
1010#ifndef MgPV_nolen_const
1011#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
1012 SvPV_nolen((SV*)((mg)->mg_ptr)) : \
1013 (const char*)(mg)->mg_ptr)
1014#endif
1015
1016/*
1017 * This overrides the default magic get method of %SIG elements.
1018 * The original one doesn't provide for reading back of PL_diehook/PL_warnhook
1019 * and instead of trying to save and restore the hash elements (extremely slow),
1020 * we just provide our own readback here.
1021 */
1022static int ecb_cold
1023coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
1024{
1025 const char *s = MgPV_nolen_const (mg);
1026
1027 if (*s == '_')
1028 {
1029 SV **svp = 0;
1030
1031 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
1032 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
1033
1034 if (svp)
1035 {
1036 SV *ssv;
1037
1038 if (!*svp)
1039 ssv = &PL_sv_undef;
1040 else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
1041 ssv = sv_2mortal (newRV_inc (*svp));
1042 else
1043 ssv = *svp;
1044
1045 sv_setsv (sv, ssv);
1046 return 0;
1047 }
1048 }
1049
1050 return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
1051}
1052
1053static int ecb_cold
1054coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
1055{
1056 const char *s = MgPV_nolen_const (mg);
1057
1058 if (*s == '_')
1059 {
1060 SV **svp = 0;
1061
1062 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
1063 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
1064
1065 if (svp)
1066 {
1067 SV *old = *svp;
1068 *svp = 0;
1069 SvREFCNT_dec (old);
1070 return 0;
1071 }
1072 }
1073
1074 return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
1075}
1076
1077static int ecb_cold
1078coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
1079{
1080 const char *s = MgPV_nolen_const (mg);
1081
1082 if (*s == '_')
1083 {
1084 SV **svp = 0;
1085
1086 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
1087 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
1088
1089 if (svp)
1090 {
1091 SV *old = *svp;
1092 *svp = SvOK (sv) ? newSVsv (sv) : 0;
1093 SvREFCNT_dec (old);
1094 return 0;
1095 }
1096 }
1097
1098 return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
1099}
1100
1101static void
1102prepare_nop (pTHX_ struct coro_transfer_args *ta)
1103{
1104 /* kind of mega-hacky, but works */
1105 ta->next = ta->prev = (struct coro *)ta;
1106}
1107
1108static int
1109slf_check_nop (pTHX_ struct CoroSLF *frame)
1110{
1111 return 0;
1112}
1113
1114static int
1115slf_check_repeat (pTHX_ struct CoroSLF *frame)
1116{
1117 return 1;
1118}
1119
1120static UNOP init_perl_op;
1121
1122ecb_noinline static void /* noinline to keep it out of the transfer fast path */
1123init_perl (pTHX_ struct coro *coro)
1124{
1125 /*
1126 * emulate part of the perl startup here.
1127 */
1128 coro_init_stacks (aTHX);
1129
1130 PL_runops = RUNOPS_DEFAULT;
1131 PL_curcop = &PL_compiling;
1132 PL_in_eval = EVAL_NULL;
1133 PL_comppad = 0;
1134 PL_comppad_name = 0;
1135 PL_comppad_name_fill = 0;
1136 PL_comppad_name_floor = 0;
1137 PL_curpm = 0;
1138 PL_curpad = 0;
1139 PL_localizing = 0;
1140 PL_restartop = 0;
1141#if PERL_VERSION_ATLEAST (5,10,0)
1142 PL_parser = 0;
1143#endif
1144 PL_hints = 0;
1145
1146 /* recreate the die/warn hooks */
1147 PL_diehook = SvREFCNT_inc (rv_diehook);
1148 PL_warnhook = SvREFCNT_inc (rv_warnhook);
1149
1150 GvSV (PL_defgv) = newSV (0);
1151 GvAV (PL_defgv) = coro->args; coro->args = 0;
1152 GvSV (PL_errgv) = newSV (0);
1153 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
1154 GvHV (PL_hintgv) = newHV ();
1155#if PERL_VERSION_ATLEAST (5,10,0)
1156 hv_magic (GvHV (PL_hintgv), 0, PERL_MAGIC_hints);
1157#endif
1158 PL_rs = newSVsv (GvSV (irsgv));
1159 PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
1160
1161 {
1162 dSP;
1163 UNOP myop;
1164
1165 Zero (&myop, 1, UNOP);
1166 myop.op_next = Nullop;
1167 myop.op_type = OP_ENTERSUB;
1168 myop.op_flags = OPf_WANT_VOID;
1169
1170 PUSHMARK (SP);
1171 PUSHs ((SV *)coro->startcv);
1172 PUTBACK;
1173 PL_op = (OP *)&myop;
1174 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
1175 }
1176
1177 /* this newly created coroutine might be run on an existing cctx which most
1178 * likely was suspended in pp_slf, so we have to emulate entering pp_slf here.
1179 */
1180 slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */
1181 slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */
1182 slf_frame.destroy = 0;
1183
1184 /* and we have to provide the pp_slf op in any case, so pp_slf can skip it */
1185 init_perl_op.op_next = PL_op;
1186 init_perl_op.op_type = OP_ENTERSUB;
1187 init_perl_op.op_ppaddr = pp_slf;
1188 /* no flags etc. required, as an init function won't be called */
1189
1190 PL_op = (OP *)&init_perl_op;
1191
1192 /* copy throw, in case it was set before init_perl */
1193 CORO_THROW = coro->except;
1194
1195 SWAP_SVS (coro);
1196
1197 if (ecb_expect_false (enable_times))
1198 {
1199 coro_times_update ();
1200 coro_times_sub (coro);
1201 }
1202}
1203
1204static void
1205coro_unwind_stacks (pTHX)
1206{
1207 if (!IN_DESTRUCT)
1208 {
1209 /* restore all saved variables and stuff */
1210 LEAVE_SCOPE (0);
1211 assert (PL_tmps_floor == -1);
1212
1213 /* free all temporaries */
1214 FREETMPS;
1215 assert (PL_tmps_ix == -1);
1216
1217 /* unwind all extra stacks */
1218 POPSTACK_TO (PL_mainstack);
1219
1220 /* unwind main stack */
1221 dounwind (-1);
1222 }
1223}
1224
1225static void
1226destroy_perl (pTHX_ struct coro *coro)
1227{
1228 SV *svf [9];
1229
1230 {
1231 SV *old_current = SvRV (coro_current);
1232 struct coro *current = SvSTATE (old_current);
1233
1234 assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));
1235
1236 save_perl (aTHX_ current);
1237
1238 /* this will cause transfer_check to croak on block*/
1239 SvRV_set (coro_current, (SV *)coro->hv);
1240
1241 load_perl (aTHX_ coro);
1242
1243 coro_unwind_stacks (aTHX);
1244
1245 /* restore swapped sv's */
1246 SWAP_SVS (coro);
1247
1248 coro_destruct_stacks (aTHX);
1249
1250 /* now save some sv's to be free'd later */
1251 svf [0] = GvSV (PL_defgv);
1252 svf [1] = (SV *)GvAV (PL_defgv);
1253 svf [2] = GvSV (PL_errgv);
1254 svf [3] = (SV *)PL_defoutgv;
1255 svf [4] = PL_rs;
1256 svf [5] = GvSV (irsgv);
1257 svf [6] = (SV *)GvHV (PL_hintgv);
1258 svf [7] = PL_diehook;
1259 svf [8] = PL_warnhook;
1260 assert (9 == sizeof (svf) / sizeof (*svf));
1261
1262 SvRV_set (coro_current, old_current);
1263
1264 load_perl (aTHX_ current);
1265 }
1266
1267 {
1268 unsigned int i;
1269
1270 for (i = 0; i < sizeof (svf) / sizeof (*svf); ++i)
1271 SvREFCNT_dec (svf [i]);
1272
1273 SvREFCNT_dec (coro->saved_deffh);
1274 SvREFCNT_dec (coro->rouse_cb);
1275 SvREFCNT_dec (coro->invoke_cb);
1276 SvREFCNT_dec (coro->invoke_av);
1277 }
1278}
1279
1280ecb_inline void
1281free_coro_mortal (pTHX)
1282{
1283 if (ecb_expect_true (coro_mortal))
1284 {
1285 SvREFCNT_dec ((SV *)coro_mortal);
1286 coro_mortal = 0;
1287 }
1288}
1289
1290static int
1291runops_trace (pTHX)
1292{
1293 COP *oldcop = 0;
1294 int oldcxix = -2;
1295
1296 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
1297 {
1298 PERL_ASYNC_CHECK ();
1299
1300 if (cctx_current->flags & CC_TRACE_ALL)
1301 {
1302 if (PL_op->op_type == OP_LEAVESUB && cctx_current->flags & CC_TRACE_SUB)
1303 {
1304 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1305 SV **bot, **top;
1306 AV *av = newAV (); /* return values */
1307 SV **cb;
1308 dSP;
1309
1310 GV *gv = CvGV (cx->blk_sub.cv);
1311 SV *fullname = sv_2mortal (newSV (0));
1312 if (isGV (gv))
1313 gv_efullname3 (fullname, gv, 0);
1314
1315 bot = PL_stack_base + cx->blk_oldsp + 1;
1316 top = cx->blk_gimme == G_ARRAY ? SP + 1
1317 : cx->blk_gimme == G_SCALAR ? bot + 1
1318 : bot;
1319
1320 av_extend (av, top - bot);
1321 while (bot < top)
1322 av_push (av, SvREFCNT_inc_NN (*bot++));
1323
1324 PL_runops = RUNOPS_DEFAULT;
1325 ENTER;
1326 SAVETMPS;
1327 EXTEND (SP, 3);
1328 PUSHMARK (SP);
1329 PUSHs (&PL_sv_no);
1330 PUSHs (fullname);
1331 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
1332 PUTBACK;
1333 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
1334 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1335 SPAGAIN;
1336 FREETMPS;
1337 LEAVE;
1338 PL_runops = runops_trace;
1339 }
1340
1341 if (oldcop != PL_curcop)
1342 {
1343 oldcop = PL_curcop;
1344
1345 if (PL_curcop != &PL_compiling)
1346 {
1347 SV **cb;
1348
1349 if (oldcxix != cxstack_ix && cctx_current->flags & CC_TRACE_SUB)
1350 {
1351 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1352
1353 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
1354 {
1355 dSP;
1356 GV *gv = CvGV (cx->blk_sub.cv);
1357 SV *fullname = sv_2mortal (newSV (0));
1358
1359 if (isGV (gv))
1360 gv_efullname3 (fullname, gv, 0);
1361
1362 PL_runops = RUNOPS_DEFAULT;
1363 ENTER;
1364 SAVETMPS;
1365 EXTEND (SP, 3);
1366 PUSHMARK (SP);
1367 PUSHs (&PL_sv_yes);
1368 PUSHs (fullname);
1369 PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
1370 PUTBACK;
1371 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
1372 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1373 SPAGAIN;
1374 FREETMPS;
1375 LEAVE;
1376 PL_runops = runops_trace;
1377 }
1378
1379 oldcxix = cxstack_ix;
1380 }
1381
1382 if (cctx_current->flags & CC_TRACE_LINE)
1383 {
1384 dSP;
1385
1386 PL_runops = RUNOPS_DEFAULT;
1387 ENTER;
1388 SAVETMPS;
1389 EXTEND (SP, 3);
1390 PL_runops = RUNOPS_DEFAULT;
1391 PUSHMARK (SP);
1392 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
1393 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
1394 PUTBACK;
1395 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
1396 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1397 SPAGAIN;
1398 FREETMPS;
1399 LEAVE;
1400 PL_runops = runops_trace;
1401 }
1402 }
1403 }
1404 }
1405 }
1406
1407 TAINT_NOT;
1408 return 0;
1409}
1410
1411static struct CoroSLF cctx_ssl_frame;
1412
1413static void
1414slf_prepare_set_stacklevel (pTHX_ struct coro_transfer_args *ta)
1415{
1416 ta->prev = 0;
1417}
1418
1419static int
1420slf_check_set_stacklevel (pTHX_ struct CoroSLF *frame)
1421{
1422 *frame = cctx_ssl_frame;
1423
1424 return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */
1425}
1426
1427/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */
1428static void ecb_noinline
1429cctx_prepare (pTHX)
1430{
1431 PL_top_env = &PL_start_env;
1432
1433 if (cctx_current->flags & CC_TRACE)
1434 PL_runops = runops_trace;
1435
1436 /* we already must be executing an SLF op, there is no other valid way
1437 * that can lead to creation of a new cctx */
1438 assert (("FATAL: can't prepare slf-less cctx in Coro module (please report)",
1439 slf_frame.prepare && PL_op->op_ppaddr == pp_slf));
1440
1441 /* we must emulate leaving pp_slf, which is done inside slf_check_set_stacklevel */
1442 cctx_ssl_frame = slf_frame;
1443
1444 slf_frame.prepare = slf_prepare_set_stacklevel;
1445 slf_frame.check = slf_check_set_stacklevel;
1446}
1447
1448/* the tail of transfer: execute stuff we can only do after a transfer */
1449ecb_inline void
1450transfer_tail (pTHX)
1451{
1452 free_coro_mortal (aTHX);
1453}
1454
1455/* try to exit the same way perl's main function would do */
1456/* we do not bother resetting the environment or other things *7
1457/* that are not, uhm, essential */
1458/* this obviously also doesn't work when perl is embedded */
1459static void ecb_noinline ecb_cold
1460perlish_exit (pTHX)
1461{
1462 int exitstatus = perl_destruct (PL_curinterp);
1463 perl_free (PL_curinterp);
1464 exit (exitstatus);
1465}
1466
1467/*
1468 * this is a _very_ stripped down perl interpreter ;)
1469 */
1470static void
1471cctx_run (void *arg)
1472{
1473#ifdef USE_ITHREADS
1474# if CORO_PTHREAD
1475 PERL_SET_CONTEXT (coro_thx);
1476# endif
1477#endif
1478 {
1479 dTHX;
1480
1481 /* normally we would need to skip the entersub here */
1482 /* not doing so will re-execute it, which is exactly what we want */
1483 /* PL_nop = PL_nop->op_next */
1484
1485 /* inject a fake subroutine call to cctx_init */
1486 cctx_prepare (aTHX);
1487
1488 /* cctx_run is the alternative tail of transfer() */
1489 transfer_tail (aTHX);
1490
1491 /* somebody or something will hit me for both perl_run and PL_restartop */
1492 PL_restartop = PL_op;
1493 perl_run (PL_curinterp);
1494 /*
1495 * Unfortunately, there is no way to get at the return values of the
1496 * coro body here, as perl_run destroys these. Likewise, we cannot catch
1497 * runtime errors here, as this is just a random interpreter, not a thread.
1498 */
1499
1500 /*
1501 * If perl-run returns we assume exit() was being called or the coro
1502 * fell off the end, which seems to be the only valid (non-bug)
1503 * reason for perl_run to return. We try to mimic whatever perl is normally
1504 * doing in that case. YMMV.
1505 */
1506 perlish_exit (aTHX);
1507 }
1508}
1509
1510static coro_cctx *
1511cctx_new (void)
1512{
1513 coro_cctx *cctx;
1514
1515 ++cctx_count;
1516 New (0, cctx, 1, coro_cctx);
1517
1518 cctx->gen = cctx_gen;
1519 cctx->flags = 0;
1520 cctx->idle_sp = 0; /* can be accessed by transfer between cctx_run and set_stacklevel, on throw */
1521
1522 return cctx;
1523}
1524
1525/* create a new cctx only suitable as source */
1526static coro_cctx *
1527cctx_new_empty (void)
1528{
1529 coro_cctx *cctx = cctx_new ();
1530
1531 cctx->stack.sptr = 0;
1532 coro_create (&cctx->cctx, 0, 0, 0, 0);
1533
1534 return cctx;
1535}
1536
1537/* create a new cctx suitable as destination/running a perl interpreter */
1538static coro_cctx *
1539cctx_new_run (void)
1540{
1541 coro_cctx *cctx = cctx_new ();
1542
1543 if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
1544 {
1545 perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1546 _exit (EXIT_FAILURE);
1547 }
1548
1549 coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze);
1550
1551 return cctx;
1552}
1553
1554static void
1555cctx_destroy (coro_cctx *cctx)
1556{
1557 if (!cctx)
1558 return;
1559
1560 assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
1561
1562 --cctx_count;
1563 coro_destroy (&cctx->cctx);
1564
1565 coro_stack_free (&cctx->stack);
1566
1567 Safefree (cctx);
1568}
1569
1570/* wether this cctx should be destructed */
1571#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1572
1573static coro_cctx *
1574cctx_get (pTHX)
1575{
1576 while (ecb_expect_true (cctx_first))
1577 {
1578 coro_cctx *cctx = cctx_first;
1579 cctx_first = cctx->next;
1580 --cctx_idle;
1581
1582 if (ecb_expect_true (!CCTX_EXPIRED (cctx)))
1583 return cctx;
1584
1585 cctx_destroy (cctx);
1586 }
1587
1588 return cctx_new_run ();
1589}
1590
1591static void
1592cctx_put (coro_cctx *cctx)
1593{
1594 assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr));
1595
1596 /* free another cctx if overlimit */
1597 if (ecb_expect_false (cctx_idle >= cctx_max_idle))
1598 {
1599 coro_cctx *first = cctx_first;
1600 cctx_first = first->next;
1601 --cctx_idle;
1602
1603 cctx_destroy (first);
1604 }
1605
1606 ++cctx_idle;
1607 cctx->next = cctx_first;
1608 cctx_first = cctx;
1609}
1610
1611/** coroutine switching *****************************************************/
1612
1613static void
1614transfer_check (pTHX_ struct coro *prev, struct coro *next)
1615{
1616 /* TODO: throwing up here is considered harmful */
1617
1618 if (ecb_expect_true (prev != next))
1619 {
1620 if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1621 croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");
1622
1623 if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED)))
1624 croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");
1625
1626#if !PERL_VERSION_ATLEAST (5,10,0)
1627 if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING))
1628 croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");
1629#endif
1630 }
1631}
1632
1633/* always use the TRANSFER macro */
1634static void ecb_noinline /* noinline so we have a fixed stackframe */
1635transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1636{
1637 dSTACKLEVEL;
1638
1639 /* sometimes transfer is only called to set idle_sp */
1640 if (ecb_expect_false (!prev))
1641 {
1642 cctx_current->idle_sp = STACKLEVEL;
1643 assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1644 }
1645 else if (ecb_expect_true (prev != next))
1646 {
1647 coro_cctx *cctx_prev;
1648
1649 if (ecb_expect_false (prev->flags & CF_NEW))
1650 {
1651 /* create a new empty/source context */
1652 prev->flags &= ~CF_NEW;
1653 prev->flags |= CF_RUNNING;
1654 }
1655
1656 prev->flags &= ~CF_RUNNING;
1657 next->flags |= CF_RUNNING;
1658
1659 /* first get rid of the old state */
1660 save_perl (aTHX_ prev);
1661
1662 if (ecb_expect_false (next->flags & CF_NEW))
1663 {
1664 /* need to start coroutine */
1665 next->flags &= ~CF_NEW;
1666 /* setup coroutine call */
1667 init_perl (aTHX_ next);
1668 }
1669 else
1670 load_perl (aTHX_ next);
1671
1672 /* possibly untie and reuse the cctx */
1673 if (ecb_expect_true (
1674 cctx_current->idle_sp == STACKLEVEL
1675 && !(cctx_current->flags & CC_TRACE)
1676 && !force_cctx
1677 ))
1678 {
1679 /* I assume that stacklevel is a stronger indicator than PL_top_env changes */
1680 assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));
1681
1682 /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */
1683 /* without this the next cctx_get might destroy the running cctx while still in use */
1684 if (ecb_expect_false (CCTX_EXPIRED (cctx_current)))
1685 if (ecb_expect_true (!next->cctx))
1686 next->cctx = cctx_get (aTHX);
1687
1688 cctx_put (cctx_current);
1689 }
1690 else
1691 prev->cctx = cctx_current;
1692
1693 ++next->usecount;
1694
1695 cctx_prev = cctx_current;
1696 cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);
1697
1698 next->cctx = 0;
1699
1700 if (ecb_expect_false (cctx_prev != cctx_current))
1701 {
1702 cctx_prev->top_env = PL_top_env;
1703 PL_top_env = cctx_current->top_env;
1704 coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);
1705 }
1706
1707 transfer_tail (aTHX);
1708 }
1709}
1710
1711#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1712#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1713
1714/** high level stuff ********************************************************/
1715
1716/* this function is actually Coro, not Coro::State, but we call it from here */
1717/* because it is convenient - but it hasn't been declared yet for that reason */
1718static void
1719coro_call_on_destroy (pTHX_ struct coro *coro);
1720
1721static void
1722coro_state_destroy (pTHX_ struct coro *coro)
1723{
1724 if (coro->flags & CF_ZOMBIE)
1725 return;
1726
1727 slf_destroy (aTHX_ coro);
1728
1729 coro->flags |= CF_ZOMBIE;
1730
1731 if (coro->flags & CF_READY)
1732 {
1733 /* reduce nready, as destroying a ready coro effectively unreadies it */
1734 /* alternative: look through all ready queues and remove the coro */
1735 --coro_nready;
1736 }
1737 else
1738 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1739
1740 if (coro->next) coro->next->prev = coro->prev;
1741 if (coro->prev) coro->prev->next = coro->next;
1742 if (coro == coro_first) coro_first = coro->next;
1743
1744 if (coro->mainstack
1745 && coro->mainstack != main_mainstack
1746 && coro->slot
1747 && !PL_dirty)
1748 destroy_perl (aTHX_ coro);
1749
1750 cctx_destroy (coro->cctx);
1751 SvREFCNT_dec (coro->startcv);
1752 SvREFCNT_dec (coro->args);
1753 SvREFCNT_dec (coro->swap_sv);
1754 SvREFCNT_dec (CORO_THROW);
1755
1756 coro_call_on_destroy (aTHX_ coro);
1757
1758 /* more destruction mayhem in coro_state_free */
1759}
1760
1761static int
1762coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1763{
1764 struct coro *coro = (struct coro *)mg->mg_ptr;
1765 mg->mg_ptr = 0;
1766
1767 coro_state_destroy (aTHX_ coro);
1768 SvREFCNT_dec (coro->on_destroy);
1769 SvREFCNT_dec (coro->status);
1770
1771 Safefree (coro);
1772
1773 return 0;
1774}
1775
1776static int ecb_cold
1777coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1778{
1779 /* called when perl clones the current process the slow way (windows process emulation) */
1780 /* WE SIMply nuke the pointers in the copy, causing perl to croak */
1781 mg->mg_ptr = 0;
1782 mg->mg_virtual = 0;
1783
1784 return 0;
1785}
1786
1787static MGVTBL coro_state_vtbl = {
1788 0, 0, 0, 0,
1789 coro_state_free,
1790 0,
1791#ifdef MGf_DUP
1792 coro_state_dup,
1793#else
1794# define MGf_DUP 0
1795#endif
1796};
1797
1798static void
1799prepare_transfer (pTHX_ struct coro_transfer_args *ta, SV *prev_sv, SV *next_sv)
1800{
1801 ta->prev = SvSTATE (prev_sv);
1802 ta->next = SvSTATE (next_sv);
1803 TRANSFER_CHECK (*ta);
1804}
1805
1806static void
1807api_transfer (pTHX_ SV *prev_sv, SV *next_sv)
1808{
1809 struct coro_transfer_args ta;
1810
1811 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1812 TRANSFER (ta, 1);
1813}
1814
1815/** Coro ********************************************************************/
1816
1817ecb_inline void
1818coro_enq (pTHX_ struct coro *coro)
1819{
1820 struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
1821
1822 SvREFCNT_inc_NN (coro->hv);
1823
1824 coro->next_ready = 0;
1825 *(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
1826 ready [1] = coro;
1827}
1828
1829ecb_inline struct coro *
1830coro_deq (pTHX)
1831{
1832 int prio;
1833
1834 for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
1835 {
1836 struct coro **ready = coro_ready [prio];
1837
1838 if (ready [0])
1839 {
1840 struct coro *coro = ready [0];
1841 ready [0] = coro->next_ready;
1842 return coro;
1843 }
1844 }
1845
1846 return 0;
1847}
1848
1849static void
1850invoke_sv_ready_hook_helper (void)
1851{
1852 dTHX;
1853 dSP;
1854
1855 ENTER;
1856 SAVETMPS;
1857
1858 PUSHMARK (SP);
1859 PUTBACK;
1860 call_sv (coro_readyhook, G_VOID | G_DISCARD);
1861
1862 FREETMPS;
1863 LEAVE;
1864}
1865
1866static int
1867api_ready (pTHX_ SV *coro_sv)
1868{
1869 struct coro *coro = SvSTATE (coro_sv);
1870
1871 if (coro->flags & CF_READY)
1872 return 0;
1873
1874 coro->flags |= CF_READY;
1875
1876 coro_enq (aTHX_ coro);
1877
1878 if (!coro_nready++)
1879 if (coroapi.readyhook)
1880 coroapi.readyhook ();
1881
1882 return 1;
1883}
1884
1885static int
1886api_is_ready (pTHX_ SV *coro_sv)
1887{
1888 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1889}
1890
1891/* expects to own a reference to next->hv */
1892ecb_inline void
1893prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)
1894{
1895 SV *prev_sv = SvRV (coro_current);
1896
1897 ta->prev = SvSTATE_hv (prev_sv);
1898 ta->next = next;
1899
1900 TRANSFER_CHECK (*ta);
1901
1902 SvRV_set (coro_current, (SV *)next->hv);
1903
1904 free_coro_mortal (aTHX);
1905 coro_mortal = prev_sv;
1906}
1907
1908static void
1909prepare_schedule (pTHX_ struct coro_transfer_args *ta)
1910{
1911 for (;;)
1912 {
1913 struct coro *next = coro_deq (aTHX);
1914
1915 if (ecb_expect_true (next))
1916 {
1917 /* cannot transfer to destroyed coros, skip and look for next */
1918 if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED)))
1919 SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */
1920 else
1921 {
1922 next->flags &= ~CF_READY;
1923 --coro_nready;
1924
1925 prepare_schedule_to (aTHX_ ta, next);
1926 break;
1927 }
1928 }
1929 else
1930 {
1931 /* nothing to schedule: call the idle handler */
1932 if (SvROK (sv_idle)
1933 && SvOBJECT (SvRV (sv_idle)))
1934 {
1935 if (SvRV (sv_idle) == SvRV (coro_current))
1936 {
1937 require_pv ("Carp");
1938
1939 {
1940 dSP;
1941
1942 ENTER;
1943 SAVETMPS;
1944
1945 PUSHMARK (SP);
1946 XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::idle blocked itself - did you try to block inside an event loop callback? Caught", 0)));
1947 PUTBACK;
1948 call_pv ("Carp::confess", G_VOID | G_DISCARD);
1949
1950 FREETMPS;
1951 LEAVE;
1952 }
1953 }
1954
1955 ++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
1956 api_ready (aTHX_ SvRV (sv_idle));
1957 --coro_nready;
1958 }
1959 else
1960 {
1961 /* TODO: deprecated, remove, cannot work reliably *//*D*/
1962 dSP;
1963
1964 ENTER;
1965 SAVETMPS;
1966
1967 PUSHMARK (SP);
1968 PUTBACK;
1969 call_sv (sv_idle, G_VOID | G_DISCARD);
1970
1971 FREETMPS;
1972 LEAVE;
1973 }
1974 }
1975 }
1976}
1977
1978ecb_inline void
1979prepare_cede (pTHX_ struct coro_transfer_args *ta)
1980{
1981 api_ready (aTHX_ coro_current);
1982 prepare_schedule (aTHX_ ta);
1983}
1984
1985ecb_inline void
1986prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
1987{
1988 SV *prev = SvRV (coro_current);
1989
1990 if (coro_nready)
1991 {
1992 prepare_schedule (aTHX_ ta);
1993 api_ready (aTHX_ prev);
1994 }
1995 else
1996 prepare_nop (aTHX_ ta);
1997}
1998
1999static void
2000api_schedule (pTHX)
2001{
2002 struct coro_transfer_args ta;
2003
2004 prepare_schedule (aTHX_ &ta);
2005 TRANSFER (ta, 1);
2006}
2007
2008static void
2009api_schedule_to (pTHX_ SV *coro_sv)
2010{
2011 struct coro_transfer_args ta;
2012 struct coro *next = SvSTATE (coro_sv);
2013
2014 SvREFCNT_inc_NN (coro_sv);
2015 prepare_schedule_to (aTHX_ &ta, next);
2016}
2017
2018static int
2019api_cede (pTHX)
2020{
2021 struct coro_transfer_args ta;
2022
2023 prepare_cede (aTHX_ &ta);
2024
2025 if (ecb_expect_true (ta.prev != ta.next))
2026 {
2027 TRANSFER (ta, 1);
2028 return 1;
2029 }
2030 else
2031 return 0;
2032}
2033
2034static int
2035api_cede_notself (pTHX)
2036{
2037 if (coro_nready)
2038 {
2039 struct coro_transfer_args ta;
2040
2041 prepare_cede_notself (aTHX_ &ta);
2042 TRANSFER (ta, 1);
2043 return 1;
2044 }
2045 else
2046 return 0;
2047}
2048
2049static void
2050api_trace (pTHX_ SV *coro_sv, int flags)
2051{
2052 struct coro *coro = SvSTATE (coro_sv);
2053
2054 if (coro->flags & CF_RUNNING)
2055 croak ("cannot enable tracing on a running coroutine, caught");
2056
2057 if (flags & CC_TRACE)
2058 {
2059 if (!coro->cctx)
2060 coro->cctx = cctx_new_run ();
2061 else if (!(coro->cctx->flags & CC_TRACE))
2062 croak ("cannot enable tracing on coroutine with custom stack, caught");
2063
2064 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
2065 }
2066 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
2067 {
2068 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
2069
2070 if (coro->flags & CF_RUNNING)
2071 PL_runops = RUNOPS_DEFAULT;
2072 else
2073 coro->slot->runops = RUNOPS_DEFAULT;
2074 }
2075}
2076
2077static void
2078coro_push_av (pTHX_ AV *av, I32 gimme_v)
2079{
2080 if (AvFILLp (av) >= 0 && gimme_v != G_VOID)
2081 {
2082 dSP;
2083
2084 if (gimme_v == G_SCALAR)
2085 XPUSHs (AvARRAY (av)[AvFILLp (av)]);
2086 else
2087 {
2088 int i;
2089 EXTEND (SP, AvFILLp (av) + 1);
2090
2091 for (i = 0; i <= AvFILLp (av); ++i)
2092 PUSHs (AvARRAY (av)[i]);
2093 }
2094
2095 PUTBACK;
2096 }
2097}
2098
2099static void
2100coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)
2101{
2102 if (!coro->on_destroy)
2103 coro->on_destroy = newAV ();
2104
2105 av_push (coro->on_destroy, cb);
2106}
2107
2108static void
2109slf_destroy_join (pTHX_ struct CoroSLF *frame)
2110{
2111 SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv);
2112}
2113
2114static int
2115slf_check_join (pTHX_ struct CoroSLF *frame)
2116{
2117 struct coro *coro = (struct coro *)frame->data;
2118
2119 if (!coro->status)
2120 return 1;
2121
2122 frame->destroy = 0;
2123
2124 coro_push_av (aTHX_ coro->status, GIMME_V);
2125
2126 SvREFCNT_dec ((SV *)coro->hv);
2127
2128 return 0;
2129}
2130
2131static void
2132slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2133{
2134 struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef);
2135
2136 if (items > 1)
2137 croak ("join called with too many arguments");
2138
2139 if (coro->status)
2140 frame->prepare = prepare_nop;
2141 else
2142 {
2143 coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current)));
2144 frame->prepare = prepare_schedule;
2145 }
2146
2147 frame->check = slf_check_join;
2148 frame->destroy = slf_destroy_join;
2149 frame->data = (void *)coro;
2150 SvREFCNT_inc (coro->hv);
2151}
2152
2153static void
2154coro_call_on_destroy (pTHX_ struct coro *coro)
2155{
2156 AV *od = coro->on_destroy;
2157
2158 if (!od)
2159 return;
2160
2161 coro->on_destroy = 0;
2162 sv_2mortal ((SV *)od);
2163
2164 while (AvFILLp (od) >= 0)
2165 {
2166 SV *cb = sv_2mortal (av_pop (od));
2167
2168 /* coro hv's (and only hv's at the moment) are supported as well */
2169 if (SvSTATEhv_p (aTHX_ cb))
2170 api_ready (aTHX_ cb);
2171 else
2172 {
2173 dSP; /* don't disturb outer sp */
2174 PUSHMARK (SP);
2175
2176 if (coro->status)
2177 {
2178 PUTBACK;
2179 coro_push_av (aTHX_ coro->status, G_ARRAY);
2180 SPAGAIN;
2181 }
2182
2183 PUTBACK;
2184 call_sv (cb, G_VOID | G_DISCARD);
2185 }
2186 }
2187}
2188
2189static void
2190coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
2191{
2192 AV *av;
2193
2194 if (coro->status)
2195 {
2196 av = coro->status;
2197 av_clear (av);
2198 }
2199 else
2200 av = coro->status = newAV ();
2201
2202 /* items are actually not so common, so optimise for this case */
2203 if (items)
2204 {
2205 int i;
2206
2207 av_extend (av, items - 1);
2208
2209 for (i = 0; i < items; ++i)
2210 av_push (av, SvREFCNT_inc_NN (arg [i]));
2211 }
2212}
2213
2214static void
2215slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv)
2216{
2217 av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */
2218 api_ready (aTHX_ sv_manager);
2219
2220 frame->prepare = prepare_schedule;
2221 frame->check = slf_check_repeat;
2222
2223 /* as a minor optimisation, we could unwind all stacks here */
2224 /* but that puts extra pressure on pp_slf, and is not worth much */
2225 /*coro_unwind_stacks (aTHX);*/
2226}
2227
2228static void
2229slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2230{
2231 HV *coro_hv = (HV *)SvRV (coro_current);
2232
2233 coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items);
2234 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
2235}
2236
2237static void
2238slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2239{
2240 HV *coro_hv;
2241 struct coro *coro;
2242
2243 if (items <= 0)
2244 croak ("Coro::cancel called without coro object,");
2245
2246 coro = SvSTATE (arg [0]);
2247 coro_hv = coro->hv;
2248
2249 coro_set_status (aTHX_ coro, arg + 1, items - 1);
2250
2251 if (ecb_expect_false (coro->flags & CF_NOCANCEL))
2252 {
2253 /* coro currently busy cancelling something, so just notify it */
2254 coro->slf_frame.data = (void *)coro;
2255
2256 frame->prepare = prepare_nop;
2257 frame->check = slf_check_nop;
2258 }
2259 else if (coro_hv == (HV *)SvRV (coro_current))
2260 {
2261 /* cancelling the current coro is allowed, and equals terminate */
2262 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
2263 }
2264 else
2265 {
2266 struct coro *self = SvSTATE_current;
2267
2268 if (!self)
2269 croak ("Coro::cancel called outside of thread content,");
2270
2271 /* otherwise we cancel directly, purely for speed reasons
2272 * unfortunately, this requires some magic trickery, as
2273 * somebody else could cancel us, so we have to fight the cancellation.
2274 * this is ugly, and hopefully fully worth the extra speed.
2275 * besides, I can't get the slow-but-safe version working...
2276 */
2277 slf_frame.data = 0;
2278 self->flags |= CF_NOCANCEL;
2279 coro_state_destroy (aTHX_ coro);
2280 self->flags &= ~CF_NOCANCEL;
2281
2282 if (slf_frame.data)
2283 {
2284 /* while we were busy we have been cancelled, so terminate */
2285 slf_init_terminate_cancel_common (aTHX_ frame, self->hv);
2286 }
2287 else
2288 {
2289 frame->prepare = prepare_nop;
2290 frame->check = slf_check_nop;
2291 }
2292 }
2293}
2294
2295static int
2296slf_check_safe_cancel (pTHX_ struct CoroSLF *frame)
2297{
2298 frame->prepare = 0;
2299 coro_unwind_stacks (aTHX);
2300
2301 slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current));
2302
2303 return 1;
2304}
2305
2306static int
2307safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)
2308{
2309 if (coro->cctx)
2310 croak ("coro inside C callback, unable to cancel at this time, caught");
2311
2312 if (coro->flags & CF_NEW)
2313 {
2314 coro_set_status (aTHX_ coro, arg, items);
2315 coro_state_destroy (aTHX_ coro);
2316 }
2317 else
2318 {
2319 if (!coro->slf_frame.prepare)
2320 croak ("coro outside an SLF function, unable to cancel at this time, caught");
2321
2322 slf_destroy (aTHX_ coro);
2323
2324 coro_set_status (aTHX_ coro, arg, items);
2325 coro->slf_frame.prepare = prepare_nop;
2326 coro->slf_frame.check = slf_check_safe_cancel;
2327
2328 api_ready (aTHX_ (SV *)coro->hv);
2329 }
2330
2331 return 1;
2332}
2333
2334/*****************************************************************************/
2335/* async pool handler */
2336
2337static int
2338slf_check_pool_handler (pTHX_ struct CoroSLF *frame)
2339{
2340 HV *hv = (HV *)SvRV (coro_current);
2341 struct coro *coro = (struct coro *)frame->data;
2342
2343 if (!coro->invoke_cb)
2344 return 1; /* loop till we have invoke */
2345 else
2346 {
2347 hv_store (hv, "desc", sizeof ("desc") - 1,
2348 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
2349
2350 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
2351
2352 {
2353 dSP;
2354 XPUSHs (sv_2mortal (coro->invoke_cb)); coro->invoke_cb = 0;
2355 PUTBACK;
2356 }
2357
2358 SvREFCNT_dec (GvAV (PL_defgv));
2359 GvAV (PL_defgv) = coro->invoke_av;
2360 coro->invoke_av = 0;
2361
2362 return 0;
2363 }
2364}
2365
2366static void
2367slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2368{
2369 HV *hv = (HV *)SvRV (coro_current);
2370 struct coro *coro = SvSTATE_hv ((SV *)hv);
2371
2372 if (ecb_expect_true (coro->saved_deffh))
2373 {
2374 /* subsequent iteration */
2375 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
2376 coro->saved_deffh = 0;
2377
2378 if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
2379 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2380 {
2381 slf_init_terminate_cancel_common (aTHX_ frame, hv);
2382 return;
2383 }
2384 else
2385 {
2386 av_clear (GvAV (PL_defgv));
2387 hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
2388
2389 coro->prio = 0;
2390
2391 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
2392 api_trace (aTHX_ coro_current, 0);
2393
2394 frame->prepare = prepare_schedule;
2395 av_push (av_async_pool, SvREFCNT_inc (hv));
2396 }
2397 }
2398 else
2399 {
2400 /* first iteration, simply fall through */
2401 frame->prepare = prepare_nop;
2402 }
2403
2404 frame->check = slf_check_pool_handler;
2405 frame->data = (void *)coro;
2406}
2407
2408/*****************************************************************************/
2409/* rouse callback */
2410
2411#define CORO_MAGIC_type_rouse PERL_MAGIC_ext
2412
2413static void
2414coro_rouse_callback (pTHX_ CV *cv)
2415{
2416 dXSARGS;
2417 SV *data = (SV *)S_GENSUB_ARG;
2418
2419 if (SvTYPE (SvRV (data)) != SVt_PVAV)
2420 {
2421 /* first call, set args */
2422 SV *coro = SvRV (data);
2423 AV *av = newAV ();
2424
2425 SvRV_set (data, (SV *)av);
2426
2427 /* better take a full copy of the arguments */
2428 while (items--)
2429 av_store (av, items, newSVsv (ST (items)));
2430
2431 api_ready (aTHX_ coro);
2432 SvREFCNT_dec (coro);
2433 }
2434
2435 XSRETURN_EMPTY;
2436}
2437
2438static int
2439slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
2440{
2441 SV *data = (SV *)frame->data;
2442
2443 if (CORO_THROW)
2444 return 0;
2445
2446 if (SvTYPE (SvRV (data)) != SVt_PVAV)
2447 return 1;
2448
2449 /* now push all results on the stack */
2450 {
2451 dSP;
2452 AV *av = (AV *)SvRV (data);
2453 int i;
2454
2455 EXTEND (SP, AvFILLp (av) + 1);
2456 for (i = 0; i <= AvFILLp (av); ++i)
2457 PUSHs (sv_2mortal (AvARRAY (av)[i]));
2458
2459 /* we have stolen the elements, so set length to zero and free */
2460 AvFILLp (av) = -1;
2461 av_undef (av);
2462
2463 PUTBACK;
2464 }
2465
2466 return 0;
2467}
2468
2469static void
2470slf_init_rouse_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2471{
2472 SV *cb;
2473
2474 if (items)
2475 cb = arg [0];
2476 else
2477 {
2478 struct coro *coro = SvSTATE_current;
2479
2480 if (!coro->rouse_cb)
2481 croak ("Coro::rouse_wait called without rouse callback, and no default rouse callback found either,");
2482
2483 cb = sv_2mortal (coro->rouse_cb);
2484 coro->rouse_cb = 0;
2485 }
2486
2487 if (!SvROK (cb)
2488 || SvTYPE (SvRV (cb)) != SVt_PVCV
2489 || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
2490 croak ("Coro::rouse_wait called with illegal callback argument,");
2491
2492 {
2493 CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
2494 SV *data = (SV *)S_GENSUB_ARG;
2495
2496 frame->data = (void *)data;
2497 frame->prepare = SvTYPE (SvRV (data)) == SVt_PVAV ? prepare_nop : prepare_schedule;
2498 frame->check = slf_check_rouse_wait;
2499 }
2500}
2501
2502static SV *
2503coro_new_rouse_cb (pTHX)
2504{
2505 HV *hv = (HV *)SvRV (coro_current);
2506 struct coro *coro = SvSTATE_hv (hv);
2507 SV *data = newRV_inc ((SV *)hv);
2508 SV *cb = s_gensub (aTHX_ coro_rouse_callback, (void *)data);
2509
2510 sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0);
2511 SvREFCNT_dec (data); /* magicext increases the refcount */
2512
2513 SvREFCNT_dec (coro->rouse_cb);
2514 coro->rouse_cb = SvREFCNT_inc_NN (cb);
2515
2516 return cb;
2517}
2518
2519/*****************************************************************************/
2520/* schedule-like-function opcode (SLF) */
2521
2522static UNOP slf_restore; /* restore stack as entersub did, for first-re-run */
2523static const CV *slf_cv;
2524static SV **slf_argv;
2525static int slf_argc, slf_arga; /* count, allocated */
2526static I32 slf_ax; /* top of stack, for restore */
2527
2528/* this restores the stack in the case we patched the entersub, to */
2529/* recreate the stack frame as perl will on following calls */
2530/* since entersub cleared the stack */
2531static OP *
2532pp_restore (pTHX)
2533{
2534 int i;
2535 SV **SP = PL_stack_base + slf_ax;
2536
2537 PUSHMARK (SP);
2538
2539 EXTEND (SP, slf_argc + 1);
2540
2541 for (i = 0; i < slf_argc; ++i)
2542 PUSHs (sv_2mortal (slf_argv [i]));
2543
2544 PUSHs ((SV *)CvGV (slf_cv));
2545
2546 RETURNOP (slf_restore.op_first);
2547}
2548
2549static void
2550slf_prepare_transfer (pTHX_ struct coro_transfer_args *ta)
2551{
2552 SV **arg = (SV **)slf_frame.data;
2553
2554 prepare_transfer (aTHX_ ta, arg [0], arg [1]);
2555}
2556
2557static void
2558slf_init_transfer (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2559{
2560 if (items != 2)
2561 croak ("Coro::State::transfer (prev, next) expects two arguments, not %d,", items);
2562
2563 frame->prepare = slf_prepare_transfer;
2564 frame->check = slf_check_nop;
2565 frame->data = (void *)arg; /* let's hope it will stay valid */
2566}
2567
2568static void
2569slf_init_schedule (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2570{
2571 frame->prepare = prepare_schedule;
2572 frame->check = slf_check_nop;
2573}
2574
2575static void
2576slf_prepare_schedule_to (pTHX_ struct coro_transfer_args *ta)
2577{
2578 struct coro *next = (struct coro *)slf_frame.data;
2579
2580 SvREFCNT_inc_NN (next->hv);
2581 prepare_schedule_to (aTHX_ ta, next);
2582}
2583
2584static void
2585slf_init_schedule_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2586{
2587 if (!items)
2588 croak ("Coro::schedule_to expects a coroutine argument, caught");
2589
2590 frame->data = (void *)SvSTATE (arg [0]);
2591 frame->prepare = slf_prepare_schedule_to;
2592 frame->check = slf_check_nop;
2593}
2594
2595static void
2596slf_init_cede_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2597{
2598 api_ready (aTHX_ SvRV (coro_current));
2599
2600 slf_init_schedule_to (aTHX_ frame, cv, arg, items);
2601}
2602
2603static void
2604slf_init_cede (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2605{
2606 frame->prepare = prepare_cede;
2607 frame->check = slf_check_nop;
2608}
2609
2610static void
2611slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2612{
2613 frame->prepare = prepare_cede_notself;
2614 frame->check = slf_check_nop;
2615}
2616
2617/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
2618static void
2619slf_destroy (pTHX_ struct coro *coro)
2620{
2621 struct CoroSLF frame = coro->slf_frame;
2622
2623 /*
2624 * The on_destroy below most likely is from an SLF call.
2625 * Since by definition the SLF call will not finish when we destroy
2626 * the coro, we will have to force-finish it here, otherwise
2627 * cleanup functions cannot call SLF functions.
2628 */
2629 coro->slf_frame.prepare = 0;
2630
2631 /* this callback is reserved for slf functions needing to do cleanup */
2632 if (frame.destroy && frame.prepare && !PL_dirty)
2633 frame.destroy (aTHX_ &frame);
2634}
2635
2636/*
2637 * these not obviously related functions are all rolled into one
2638 * function to increase chances that they all will call transfer with the same
2639 * stack offset
2640 * SLF stands for "schedule-like-function".
2641 */
2642static OP *
2643pp_slf (pTHX)
2644{
2645 I32 checkmark; /* mark SP to see how many elements check has pushed */
2646
2647 /* set up the slf frame, unless it has already been set-up */
2648 /* the latter happens when a new coro has been started */
2649 /* or when a new cctx was attached to an existing coroutine */
2650 if (ecb_expect_true (!slf_frame.prepare))
2651 {
2652 /* first iteration */
2653 dSP;
2654 SV **arg = PL_stack_base + TOPMARK + 1;
2655 int items = SP - arg; /* args without function object */
2656 SV *gv = *sp;
2657
2658 /* do a quick consistency check on the "function" object, and if it isn't */
2659 /* for us, divert to the real entersub */
2660 if (SvTYPE (gv) != SVt_PVGV
2661 || !GvCV (gv)
2662 || !(CvFLAGS (GvCV (gv)) & CVf_SLF))
2663 return PL_ppaddr[OP_ENTERSUB](aTHX);
2664
2665 if (!(PL_op->op_flags & OPf_STACKED))
2666 {
2667 /* ampersand-form of call, use @_ instead of stack */
2668 AV *av = GvAV (PL_defgv);
2669 arg = AvARRAY (av);
2670 items = AvFILLp (av) + 1;
2671 }
2672
2673 /* now call the init function, which needs to set up slf_frame */
2674 ((coro_slf_cb)CvXSUBANY (GvCV (gv)).any_ptr)
2675 (aTHX_ &slf_frame, GvCV (gv), arg, items);
2676
2677 /* pop args */
2678 SP = PL_stack_base + POPMARK;
2679
2680 PUTBACK;
2681 }
2682
2683 /* now that we have a slf_frame, interpret it! */
2684 /* we use a callback system not to make the code needlessly */
2685 /* complicated, but so we can run multiple perl coros from one cctx */
2686
2687 do
2688 {
2689 struct coro_transfer_args ta;
2690
2691 slf_frame.prepare (aTHX_ &ta);
2692 TRANSFER (ta, 0);
2693
2694 checkmark = PL_stack_sp - PL_stack_base;
2695 }
2696 while (slf_frame.check (aTHX_ &slf_frame));
2697
2698 slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */
2699
2700 /* exception handling */
2701 if (ecb_expect_false (CORO_THROW))
2702 {
2703 SV *exception = sv_2mortal (CORO_THROW);
2704
2705 CORO_THROW = 0;
2706 sv_setsv (ERRSV, exception);
2707 croak (0);
2708 }
2709
2710 /* return value handling - mostly like entersub */
2711 /* make sure we put something on the stack in scalar context */
2712 if (GIMME_V == G_SCALAR
2713 && ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1))
2714 {
2715 dSP;
2716 SV **bot = PL_stack_base + checkmark;
2717
2718 if (sp == bot) /* too few, push undef */
2719 bot [1] = &PL_sv_undef;
2720 else /* too many, take last one */
2721 bot [1] = *sp;
2722
2723 SP = bot + 1;
2724
2725 PUTBACK;
2726 }
2727
2728 return NORMAL;
2729}
2730
2731static void
2732api_execute_slf (pTHX_ CV *cv, coro_slf_cb init_cb, I32 ax)
2733{
2734 int i;
2735 SV **arg = PL_stack_base + ax;
2736 int items = PL_stack_sp - arg + 1;
2737
2738 assert (("FATAL: SLF call with illegal CV value", !CvANON (cv)));
2739
2740 if (PL_op->op_ppaddr != PL_ppaddr [OP_ENTERSUB]
2741 && PL_op->op_ppaddr != pp_slf)
2742 croak ("FATAL: Coro SLF calls can only be made normally, not via goto or any other means, caught");
2743
2744 CvFLAGS (cv) |= CVf_SLF;
2745 CvXSUBANY (cv).any_ptr = (void *)init_cb;
2746 slf_cv = cv;
2747
2748 /* we patch the op, and then re-run the whole call */
2749 /* we have to put the same argument on the stack for this to work */
2750 /* and this will be done by pp_restore */
2751 slf_restore.op_next = (OP *)&slf_restore;
2752 slf_restore.op_type = OP_CUSTOM;
2753 slf_restore.op_ppaddr = pp_restore;
2754 slf_restore.op_first = PL_op;
2755
2756 slf_ax = ax - 1; /* undo the ax++ inside dAXMARK */
2757
2758 if (PL_op->op_flags & OPf_STACKED)
2759 {
2760 if (items > slf_arga)
2761 {
2762 slf_arga = items;
2763 Safefree (slf_argv);
2764 New (0, slf_argv, slf_arga, SV *);
2765 }
2766
2767 slf_argc = items;
2768
2769 for (i = 0; i < items; ++i)
2770 slf_argv [i] = SvREFCNT_inc (arg [i]);
2771 }
2772 else
2773 slf_argc = 0;
2774
2775 PL_op->op_ppaddr = pp_slf;
2776 /*PL_op->op_type = OP_CUSTOM; /* we do behave like entersub still */
2777
2778 PL_op = (OP *)&slf_restore;
2779}
2780
2781/*****************************************************************************/
2782/* dynamic wind */
2783
2784static void
2785on_enterleave_call (pTHX_ SV *cb)
2786{
2787 dSP;
2788
2789 PUSHSTACK;
2790
2791 PUSHMARK (SP);
2792 PUTBACK;
2793 call_sv (cb, G_VOID | G_DISCARD);
2794 SPAGAIN;
2795
2796 POPSTACK;
2797}
2798
2799static SV *
2800coro_avp_pop_and_free (pTHX_ AV **avp)
2801{
2802 AV *av = *avp;
2803 SV *res = av_pop (av);
2804
2805 if (AvFILLp (av) < 0)
2806 {
2807 *avp = 0;
2808 SvREFCNT_dec (av);
2809 }
2810
2811 return res;
2812}
2813
2814static void
2815coro_pop_on_enter (pTHX_ void *coro)
2816{
2817 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_enter);
2818 SvREFCNT_dec (cb);
2819}
2820
2821static void
2822coro_pop_on_leave (pTHX_ void *coro)
2823{
2824 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_leave);
2825 on_enterleave_call (aTHX_ sv_2mortal (cb));
2826}
2827
2828/*****************************************************************************/
2829/* PerlIO::cede */
2830
2831typedef struct
2832{
2833 PerlIOBuf base;
2834 NV next, every;
2835} PerlIOCede;
2836
2837static IV ecb_cold
2838PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2839{
2840 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2841
2842 self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
2843 self->next = nvtime () + self->every;
2844
2845 return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
2846}
2847
2848static SV * ecb_cold
2849PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
2850{
2851 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2852
2853 return newSVnv (self->every);
2854}
2855
2856static IV
2857PerlIOCede_flush (pTHX_ PerlIO *f)
2858{
2859 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2860 double now = nvtime ();
2861
2862 if (now >= self->next)
2863 {
2864 api_cede (aTHX);
2865 self->next = now + self->every;
2866 }
2867
2868 return PerlIOBuf_flush (aTHX_ f);
2869}
2870
2871static PerlIO_funcs PerlIO_cede =
2872{
2873 sizeof(PerlIO_funcs),
2874 "cede",
2875 sizeof(PerlIOCede),
2876 PERLIO_K_DESTRUCT | PERLIO_K_RAW,
2877 PerlIOCede_pushed,
2878 PerlIOBuf_popped,
2879 PerlIOBuf_open,
2880 PerlIOBase_binmode,
2881 PerlIOCede_getarg,
2882 PerlIOBase_fileno,
2883 PerlIOBuf_dup,
2884 PerlIOBuf_read,
2885 PerlIOBuf_unread,
2886 PerlIOBuf_write,
2887 PerlIOBuf_seek,
2888 PerlIOBuf_tell,
2889 PerlIOBuf_close,
2890 PerlIOCede_flush,
2891 PerlIOBuf_fill,
2892 PerlIOBase_eof,
2893 PerlIOBase_error,
2894 PerlIOBase_clearerr,
2895 PerlIOBase_setlinebuf,
2896 PerlIOBuf_get_base,
2897 PerlIOBuf_bufsiz,
2898 PerlIOBuf_get_ptr,
2899 PerlIOBuf_get_cnt,
2900 PerlIOBuf_set_ptrcnt,
2901};
2902
2903/*****************************************************************************/
2904/* Coro::Semaphore & Coro::Signal */
2905
2906static SV *
2907coro_waitarray_new (pTHX_ int count)
2908{
2909 /* a waitarray=semaphore contains a counter IV in $sem->[0] and any waiters after that */
2910 AV *av = newAV ();
2911 SV **ary;
2912
2913 /* unfortunately, building manually saves memory */
2914 Newx (ary, 2, SV *);
2915 AvALLOC (av) = ary;
2916#if PERL_VERSION_ATLEAST (5,10,0)
2917 AvARRAY (av) = ary;
2918#else
2919 /* 5.8.8 needs this syntax instead of AvARRAY = ary, yet */
2920 /* -DDEBUGGING flags this as a bug, despite it perfectly working */
2921 SvPVX ((SV *)av) = (char *)ary;
2922#endif
2923 AvMAX (av) = 1;
2924 AvFILLp (av) = 0;
2925 ary [0] = newSViv (count);
2926
2927 return newRV_noinc ((SV *)av);
2928}
2929
2930/* semaphore */
2931
2932static void
2933coro_semaphore_adjust (pTHX_ AV *av, IV adjust)
2934{
2935 SV *count_sv = AvARRAY (av)[0];
2936 IV count = SvIVX (count_sv);
2937
2938 count += adjust;
2939 SvIVX (count_sv) = count;
2940
2941 /* now wake up as many waiters as are expected to lock */
2942 while (count > 0 && AvFILLp (av) > 0)
2943 {
2944 SV *cb;
2945
2946 /* swap first two elements so we can shift a waiter */
2947 AvARRAY (av)[0] = AvARRAY (av)[1];
2948 AvARRAY (av)[1] = count_sv;
2949 cb = av_shift (av);
2950
2951 if (SvOBJECT (cb))
2952 {
2953 api_ready (aTHX_ cb);
2954 --count;
2955 }
2956 else if (SvTYPE (cb) == SVt_PVCV)
2957 {
2958 dSP;
2959 PUSHMARK (SP);
2960 XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
2961 PUTBACK;
2962 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
2963 }
2964
2965 SvREFCNT_dec (cb);
2966 }
2967}
2968
2969static void
2970coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
2971{
2972 /* call $sem->adjust (0) to possibly wake up some other waiters */
2973 coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0);
2974}
2975
2976static int
2977slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)
2978{
2979 AV *av = (AV *)frame->data;
2980 SV *count_sv = AvARRAY (av)[0];
2981 SV *coro_hv = SvRV (coro_current);
2982
2983 frame->destroy = 0;
2984
2985 /* if we are about to throw, don't actually acquire the lock, just throw */
2986 if (ecb_expect_false (CORO_THROW))
2987 {
2988 /* we still might be responsible for the semaphore, so wake up others */
2989 coro_semaphore_adjust (aTHX_ av, 0);
2990
2991 return 0;
2992 }
2993 else if (SvIVX (count_sv) > 0)
2994 {
2995 if (acquire)
2996 SvIVX (count_sv) = SvIVX (count_sv) - 1;
2997 else
2998 coro_semaphore_adjust (aTHX_ av, 0);
2999
3000 return 0;
3001 }
3002 else
3003 {
3004 int i;
3005 /* if we were woken up but can't down, we look through the whole */
3006 /* waiters list and only add us if we aren't in there already */
3007 /* this avoids some degenerate memory usage cases */
3008 for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */
3009 if (AvARRAY (av)[i] == coro_hv)
3010 return 1;
3011
3012 av_push (av, SvREFCNT_inc (coro_hv));
3013 return 1;
3014 }
3015}
3016
3017static int
3018slf_check_semaphore_down (pTHX_ struct CoroSLF *frame)
3019{
3020 return slf_check_semaphore_down_or_wait (aTHX_ frame, 1);
3021}
3022
3023static int
3024slf_check_semaphore_wait (pTHX_ struct CoroSLF *frame)
3025{
3026 return slf_check_semaphore_down_or_wait (aTHX_ frame, 0);
3027}
3028
3029static void
3030slf_init_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3031{
3032 AV *av = (AV *)SvRV (arg [0]);
3033
3034 if (SvIVX (AvARRAY (av)[0]) > 0)
3035 {
3036 frame->data = (void *)av;
3037 frame->prepare = prepare_nop;
3038 }
3039 else
3040 {
3041 av_push (av, SvREFCNT_inc (SvRV (coro_current)));
3042
3043 frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
3044 frame->prepare = prepare_schedule;
3045 /* to avoid race conditions when a woken-up coro gets terminated */
3046 /* we arrange for a temporary on_destroy that calls adjust (0) */
3047 frame->destroy = coro_semaphore_destroy;
3048 }
3049}
3050
3051static void
3052slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3053{
3054 slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items);
3055 frame->check = slf_check_semaphore_down;
3056}
3057
3058static void
3059slf_init_semaphore_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3060{
3061 if (items >= 2)
3062 {
3063 /* callback form */
3064 AV *av = (AV *)SvRV (arg [0]);
3065 SV *cb_cv = s_get_cv_croak (arg [1]);
3066
3067 av_push (av, SvREFCNT_inc_NN (cb_cv));
3068
3069 if (SvIVX (AvARRAY (av)[0]) > 0)
3070 coro_semaphore_adjust (aTHX_ av, 0);
3071
3072 frame->prepare = prepare_nop;
3073 frame->check = slf_check_nop;
3074 }
3075 else
3076 {
3077 slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items);
3078 frame->check = slf_check_semaphore_wait;
3079 }
3080}
3081
3082/* signal */
3083
3084static void
3085coro_signal_wake (pTHX_ AV *av, int count)
3086{
3087 SvIVX (AvARRAY (av)[0]) = 0;
3088
3089 /* now signal count waiters */
3090 while (count > 0 && AvFILLp (av) > 0)
3091 {
3092 SV *cb;
3093
3094 /* swap first two elements so we can shift a waiter */
3095 cb = AvARRAY (av)[0];
3096 AvARRAY (av)[0] = AvARRAY (av)[1];
3097 AvARRAY (av)[1] = cb;
3098
3099 cb = av_shift (av);
3100
3101 if (SvTYPE (cb) == SVt_PVCV)
3102 {
3103 dSP;
3104 PUSHMARK (SP);
3105 XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
3106 PUTBACK;
3107 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
3108 }
3109 else
3110 {
3111 api_ready (aTHX_ cb);
3112 sv_setiv (cb, 0); /* signal waiter */
3113 }
3114
3115 SvREFCNT_dec (cb);
3116
3117 --count;
3118 }
3119}
3120
3121static int
3122slf_check_signal_wait (pTHX_ struct CoroSLF *frame)
3123{
3124 /* if we are about to throw, also stop waiting */
3125 return SvROK ((SV *)frame->data) && !CORO_THROW;
3126}
3127
3128static void
3129slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3130{
3131 AV *av = (AV *)SvRV (arg [0]);
3132
3133 if (items >= 2)
3134 {
3135 SV *cb_cv = s_get_cv_croak (arg [1]);
3136 av_push (av, SvREFCNT_inc_NN (cb_cv));
3137
3138 if (SvIVX (AvARRAY (av)[0]))
3139 coro_signal_wake (aTHX_ av, 1); /* must be the only waiter */
3140
3141 frame->prepare = prepare_nop;
3142 frame->check = slf_check_nop;
3143 }
3144 else if (SvIVX (AvARRAY (av)[0]))
3145 {
3146 SvIVX (AvARRAY (av)[0]) = 0;
3147 frame->prepare = prepare_nop;
3148 frame->check = slf_check_nop;
3149 }
3150 else
3151 {
3152 SV *waiter = newSVsv (coro_current); /* owned by signal av */
3153
3154 av_push (av, waiter);
3155
3156 frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */
3157 frame->prepare = prepare_schedule;
3158 frame->check = slf_check_signal_wait;
3159 }
3160}
3161
3162/*****************************************************************************/
3163/* Coro::AIO */
3164
3165#define CORO_MAGIC_type_aio PERL_MAGIC_ext
3166
3167/* helper storage struct */
3168struct io_state
3169{
3170 int errorno;
3171 I32 laststype; /* U16 in 5.10.0 */
3172 int laststatval;
3173 Stat_t statcache;
3174};
3175
3176static void
3177coro_aio_callback (pTHX_ CV *cv)
3178{
3179 dXSARGS;
3180 AV *state = (AV *)S_GENSUB_ARG;
3181 SV *coro = av_pop (state);
3182 SV *data_sv = newSV (sizeof (struct io_state));
3183
3184 av_extend (state, items - 1);
3185
3186 sv_upgrade (data_sv, SVt_PV);
3187 SvCUR_set (data_sv, sizeof (struct io_state));
3188 SvPOK_only (data_sv);
3189
3190 {
3191 struct io_state *data = (struct io_state *)SvPVX (data_sv);
3192
3193 data->errorno = errno;
3194 data->laststype = PL_laststype;
3195 data->laststatval = PL_laststatval;
3196 data->statcache = PL_statcache;
3197 }
3198
3199 /* now build the result vector out of all the parameters and the data_sv */
3200 {
3201 int i;
3202
3203 for (i = 0; i < items; ++i)
3204 av_push (state, SvREFCNT_inc_NN (ST (i)));
3205 }
3206
3207 av_push (state, data_sv);
3208
3209 api_ready (aTHX_ coro);
3210 SvREFCNT_dec (coro);
3211 SvREFCNT_dec ((AV *)state);
3212}
3213
3214static int
3215slf_check_aio_req (pTHX_ struct CoroSLF *frame)
3216{
3217 AV *state = (AV *)frame->data;
3218
3219 /* if we are about to throw, return early */
3220 /* this does not cancel the aio request, but at least */
3221 /* it quickly returns */
3222 if (CORO_THROW)
3223 return 0;
3224
3225 /* one element that is an RV? repeat! */
3226 if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
3227 return 1;
3228
3229 /* restore status */
3230 {
3231 SV *data_sv = av_pop (state);
3232 struct io_state *data = (struct io_state *)SvPVX (data_sv);
3233
3234 errno = data->errorno;
3235 PL_laststype = data->laststype;
3236 PL_laststatval = data->laststatval;
3237 PL_statcache = data->statcache;
3238
3239 SvREFCNT_dec (data_sv);
3240 }
3241
3242 /* push result values */
3243 {
3244 dSP;
3245 int i;
3246
3247 EXTEND (SP, AvFILLp (state) + 1);
3248 for (i = 0; i <= AvFILLp (state); ++i)
3249 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (state)[i])));
3250
3251 PUTBACK;
3252 }
3253
3254 return 0;
3255}
3256
3257static void
3258slf_init_aio_req (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3259{
3260 AV *state = (AV *)sv_2mortal ((SV *)newAV ());
3261 SV *coro_hv = SvRV (coro_current);
3262 struct coro *coro = SvSTATE_hv (coro_hv);
3263
3264 /* put our coroutine id on the state arg */
3265 av_push (state, SvREFCNT_inc_NN (coro_hv));
3266
3267 /* first see whether we have a non-zero priority and set it as AIO prio */
3268 if (coro->prio)
3269 {
3270 dSP;
3271
3272 static SV *prio_cv;
3273 static SV *prio_sv;
3274
3275 if (ecb_expect_false (!prio_cv))
3276 {
3277 prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);
3278 prio_sv = newSViv (0);
3279 }
3280
3281 PUSHMARK (SP);
3282 sv_setiv (prio_sv, coro->prio);
3283 XPUSHs (prio_sv);
3284
3285 PUTBACK;
3286 call_sv (prio_cv, G_VOID | G_DISCARD);
3287 }
3288
3289 /* now call the original request */
3290 {
3291 dSP;
3292 CV *req = (CV *)CORO_MAGIC_NN ((SV *)cv, CORO_MAGIC_type_aio)->mg_obj;
3293 int i;
3294
3295 PUSHMARK (SP);
3296
3297 /* first push all args to the stack */
3298 EXTEND (SP, items + 1);
3299
3300 for (i = 0; i < items; ++i)
3301 PUSHs (arg [i]);
3302
3303 /* now push the callback closure */
3304 PUSHs (sv_2mortal (s_gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));
3305
3306 /* now call the AIO function - we assume our request is uncancelable */
3307 PUTBACK;
3308 call_sv ((SV *)req, G_VOID | G_DISCARD);
3309 }
3310
3311 /* now that the request is going, we loop till we have a result */
3312 frame->data = (void *)state;
3313 frame->prepare = prepare_schedule;
3314 frame->check = slf_check_aio_req;
3315}
3316
3317static void
3318coro_aio_req_xs (pTHX_ CV *cv)
3319{
3320 dXSARGS;
3321
3322 CORO_EXECUTE_SLF_XS (slf_init_aio_req);
3323
3324 XSRETURN_EMPTY;
3325}
3326
3327/*****************************************************************************/
3328
3329#if CORO_CLONE
3330# include "clone.c"
3331#endif
3332
3333/*****************************************************************************/
3334
3335static SV *
3336coro_new (pTHX_ HV *stash, SV **argv, int argc, int is_coro)
3337{
3338 SV *coro_sv;
3339 struct coro *coro;
3340 MAGIC *mg;
3341 HV *hv;
3342 SV *cb;
3343 int i;
3344
3345 if (argc > 0)
3346 {
3347 cb = s_get_cv_croak (argv [0]);
3348
3349 if (!is_coro)
3350 {
3351 if (CvISXSUB (cb))
3352 croak ("Coro::State doesn't support XS functions as coroutine start, caught");
3353
3354 if (!CvROOT (cb))
3355 croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught");
3356 }
3357 }
3358
3359 Newz (0, coro, 1, struct coro);
3360 coro->args = newAV ();
3361 coro->flags = CF_NEW;
3362
3363 if (coro_first) coro_first->prev = coro;
3364 coro->next = coro_first;
3365 coro_first = coro;
3366
3367 coro->hv = hv = newHV ();
3368 mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
3369 mg->mg_flags |= MGf_DUP;
3370 coro_sv = sv_bless (newRV_noinc ((SV *)hv), stash);
3371
3372 if (argc > 0)
3373 {
3374 av_extend (coro->args, argc + is_coro - 1);
3375
3376 if (is_coro)
3377 {
3378 av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb));
3379 cb = (SV *)cv_coro_run;
3380 }
3381
3382 coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb);
3383
3384 for (i = 1; i < argc; i++)
3385 av_push (coro->args, newSVsv (argv [i]));
3386 }
3387
3388 return coro_sv;
3389}
3390
3391#ifndef __cplusplus
3392ecb_cold XS(boot_Coro__State);
3393#endif
3394
3395#if CORO_JIT
3396
3397static void ecb_noinline ecb_cold
3398pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)
3399{
3400 dSP;
3401 AV *av = newAV ();
3402
3403 av_store (av, 3, newSVuv (d));
3404 av_store (av, 2, newSVuv (c));
3405 av_store (av, 1, newSVuv (b));
3406 av_store (av, 0, newSVuv (a));
3407
3408 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
3409
3410 PUTBACK;
3411}
3412
3413static void ecb_noinline ecb_cold
3414jit_init (pTHX)
3415{
3416 dSP;
3417 SV *load, *save;
3418 char *map_base;
3419 char *load_ptr, *save_ptr;
3420 STRLEN load_len, save_len, map_len;
3421 int count;
3422
3423 eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
3424
3425 PUSHMARK (SP);
3426 #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
3427 #include "state.h"
3428 count = call_pv ("Coro::State::_jit", G_ARRAY);
3429 SPAGAIN;
3430
3431 save = POPs; save_ptr = SvPVbyte (save, save_len);
3432 load = POPs; load_ptr = SvPVbyte (load, load_len);
3433
3434 map_len = load_len + save_len + 16;
3435
3436 map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
3437
3438 assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED));
3439
3440 load_perl_slots = (load_save_perl_slots_type)map_base;
3441 memcpy (map_base, load_ptr, load_len);
3442
3443 map_base += (load_len + 15) & ~15;
3444
3445 save_perl_slots = (load_save_perl_slots_type)map_base;
3446 memcpy (map_base, save_ptr, save_len);
3447
3448 /* we are good citizens and try to make the page read-only, so the evil evil */
3449 /* hackers might have it a bit more difficult */
3450 mprotect (map_base, map_len, PROT_READ | PROT_EXEC);
3451
3452 PUTBACK;
3453 eval_pv ("undef &Coro::State::_jit", 1);
3454}
3455
3456#endif
3457
3458MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
3459
3460PROTOTYPES: DISABLE
3461
3462BOOT:
3463{
3464#define VARx(name,expr,type) if (sizeof (type) < sizeof (expr)) croak ("FATAL: Coro thread context slot '" # name "' too small for this version of perl.");
3465#include "state.h"
3466#ifdef USE_ITHREADS
3467# if CORO_PTHREAD
3468 coro_thx = PERL_GET_CONTEXT;
3469# endif
3470#endif
3471 /* perl defines these to check for existance first, but why it doesn't */
3472 /* just create them one at init time is not clear to me, except for */
3473 /* programs trying to delete them, but... */
3474 /* anyway, we declare this as invalid and make sure they are initialised here */
3475 DEFSV;
3476 ERRSV;
3477
3478 cctx_current = cctx_new_empty ();
3479
3480 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
3481 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3482
3483 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
3484 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
3485 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
3486
3487 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
3488 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
3489 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
3490
3491 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
3492
3493 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
3494 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
3495 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
3496 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
3497
3498 main_mainstack = PL_mainstack;
3499 main_top_env = PL_top_env;
3500
3501 while (main_top_env->je_prev)
3502 main_top_env = main_top_env->je_prev;
3503
3504 {
3505 SV *slf = sv_2mortal (newSViv (PTR2IV (pp_slf)));
3506
3507 if (!PL_custom_op_names) PL_custom_op_names = newHV ();
3508 hv_store_ent (PL_custom_op_names, slf, newSVpv ("coro_slf", 0), 0);
3509
3510 if (!PL_custom_op_descs) PL_custom_op_descs = newHV ();
3511 hv_store_ent (PL_custom_op_descs, slf, newSVpv ("coro schedule like function", 0), 0);
3512 }
3513
3514 coroapi.ver = CORO_API_VERSION;
3515 coroapi.rev = CORO_API_REVISION;
3516
3517 coroapi.transfer = api_transfer;
3518
3519 coroapi.sv_state = SvSTATE_;
3520 coroapi.execute_slf = api_execute_slf;
3521 coroapi.prepare_nop = prepare_nop;
3522 coroapi.prepare_schedule = prepare_schedule;
3523 coroapi.prepare_cede = prepare_cede;
3524 coroapi.prepare_cede_notself = prepare_cede_notself;
3525
3526 time_init (aTHX);
3527
3528 assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));
3529#if CORO_JIT
3530 PUTBACK;
3531 jit_init (aTHX);
3532 SPAGAIN;
3533#endif
3534}
3535
3536SV *
3537new (SV *klass, ...)
3538 ALIAS:
3539 Coro::new = 1
3540 CODE:
3541 RETVAL = coro_new (aTHX_ ix ? coro_stash : coro_state_stash, &ST (1), items - 1, ix);
3542 OUTPUT:
3543 RETVAL
3544
3545void
3546transfer (...)
3547 PROTOTYPE: $$
3548 CODE:
3549 CORO_EXECUTE_SLF_XS (slf_init_transfer);
3550
3551SV *
3552clone (Coro::State coro)
3553 CODE:
3554{
3555#if CORO_CLONE
3556 struct coro *ncoro = coro_clone (aTHX_ coro);
3557 MAGIC *mg;
3558 /* TODO: too much duplication */
3559 ncoro->hv = newHV ();
3560 mg = sv_magicext ((SV *)ncoro->hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)ncoro, 0);
3561 mg->mg_flags |= MGf_DUP;
3562 RETVAL = sv_bless (newRV_noinc ((SV *)ncoro->hv), SvSTASH (coro->hv));
3563#else
3564 croak ("Coro::State->clone has not been configured into this installation of Coro, realised");
3565#endif
3566}
3567 OUTPUT:
3568 RETVAL
3569
3570int
3571cctx_stacksize (int new_stacksize = 0)
3572 PROTOTYPE: ;$
3573 CODE:
3574 RETVAL = cctx_stacksize;
3575 if (new_stacksize)
3576 {
3577 cctx_stacksize = new_stacksize;
3578 ++cctx_gen;
3579 }
3580 OUTPUT:
3581 RETVAL
3582
3583int
3584cctx_max_idle (int max_idle = 0)
3585 PROTOTYPE: ;$
3586 CODE:
3587 RETVAL = cctx_max_idle;
3588 if (max_idle > 1)
3589 cctx_max_idle = max_idle;
3590 OUTPUT:
3591 RETVAL
3592
3593int
3594cctx_count ()
3595 PROTOTYPE:
3596 CODE:
3597 RETVAL = cctx_count;
3598 OUTPUT:
3599 RETVAL
3600
3601int
3602cctx_idle ()
3603 PROTOTYPE:
3604 CODE:
3605 RETVAL = cctx_idle;
3606 OUTPUT:
3607 RETVAL
3608
3609void
3610list ()
3611 PROTOTYPE:
3612 PPCODE:
3613{
3614 struct coro *coro;
3615 for (coro = coro_first; coro; coro = coro->next)
3616 if (coro->hv)
3617 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
3618}
3619
3620void
3621call (Coro::State coro, SV *coderef)
3622 ALIAS:
3623 eval = 1
3624 CODE:
3625{
3626 if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
3627 {
3628 struct coro *current = SvSTATE_current;
3629 struct CoroSLF slf_save;
3630
3631 if (current != coro)
215 { 3632 {
216 /* I never used formats, so how should I know how these are implemented? */ 3633 PUTBACK;
217 /* my bold guess is as a simple, plain sub... */ 3634 save_perl (aTHX_ current);
218 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 3635 load_perl (aTHX_ coro);
3636 /* the coro is most likely in an active SLF call.
3637 * while not strictly required (the code we execute is
3638 * not allowed to call any SLF functions), it's cleaner
3639 * to reinitialise the slf_frame and restore it later.
3640 * This might one day allow us to actually do SLF calls
3641 * from code executed here.
3642 */
3643 slf_save = slf_frame;
3644 slf_frame.prepare = 0;
3645 SPAGAIN;
3646 }
3647
3648 PUSHSTACK;
3649
3650 PUSHMARK (SP);
3651 PUTBACK;
3652
3653 if (ix)
3654 eval_sv (coderef, 0);
3655 else
3656 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
3657
3658 POPSTACK;
3659 SPAGAIN;
3660
3661 if (current != coro)
3662 {
3663 PUTBACK;
3664 slf_frame = slf_save;
3665 save_perl (aTHX_ coro);
3666 load_perl (aTHX_ current);
3667 SPAGAIN;
219 } 3668 }
220 } 3669 }
221
222 if (top_si->si_type == PERLSI_MAIN)
223 break;
224
225 top_si = top_si->si_prev;
226 ccstk = top_si->si_cxstack;
227 cxix = top_si->si_cxix;
228 }
229
230 PUTBACK;
231 }
232
233 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv);
235 c->curstackinfo = PL_curstackinfo;
236 c->curstack = PL_curstack;
237 c->mainstack = PL_mainstack;
238 c->stack_sp = PL_stack_sp;
239 c->op = PL_op;
240 c->curpad = PL_curpad;
241 c->stack_base = PL_stack_base;
242 c->stack_max = PL_stack_max;
243 c->tmps_stack = PL_tmps_stack;
244 c->tmps_floor = PL_tmps_floor;
245 c->tmps_ix = PL_tmps_ix;
246 c->tmps_max = PL_tmps_max;
247 c->markstack = PL_markstack;
248 c->markstack_ptr = PL_markstack_ptr;
249 c->markstack_max = PL_markstack_max;
250 c->scopestack = PL_scopestack;
251 c->scopestack_ix = PL_scopestack_ix;
252 c->scopestack_max = PL_scopestack_max;
253 c->savestack = PL_savestack;
254 c->savestack_ix = PL_savestack_ix;
255 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop;
260} 3670}
261 3671
262static void 3672SV *
263LOAD(pTHX_ Coro__State c) 3673is_ready (Coro::State coro)
264{
265 PL_dowarn = c->dowarn;
266 GvAV (PL_defgv) = c->defav;
267 PL_curstackinfo = c->curstackinfo;
268 PL_curstack = c->curstack;
269 PL_mainstack = c->mainstack;
270 PL_stack_sp = c->stack_sp;
271 PL_op = c->op;
272 PL_curpad = c->curpad;
273 PL_stack_base = c->stack_base;
274 PL_stack_max = c->stack_max;
275 PL_tmps_stack = c->tmps_stack;
276 PL_tmps_floor = c->tmps_floor;
277 PL_tmps_ix = c->tmps_ix;
278 PL_tmps_max = c->tmps_max;
279 PL_markstack = c->markstack;
280 PL_markstack_ptr = c->markstack_ptr;
281 PL_markstack_max = c->markstack_max;
282 PL_scopestack = c->scopestack;
283 PL_scopestack_ix = c->scopestack_ix;
284 PL_scopestack_max = c->scopestack_max;
285 PL_savestack = c->savestack;
286 PL_savestack_ix = c->savestack_ix;
287 PL_savestack_max = c->savestack_max;
288 PL_retstack = c->retstack;
289 PL_retstack_ix = c->retstack_ix;
290 PL_retstack_max = c->retstack_max;
291 PL_curcop = c->curcop;
292
293 {
294 dSP;
295 CV *cv;
296
297 /* now do the ugly restore mess */
298 while ((cv = (CV *)POPs))
299 {
300 AV *padlist = (AV *)POPs;
301
302 unuse_padlist (CvPADLIST(cv));
303 CvPADLIST(cv) = padlist;
304 CvDEPTH(cv) = (I32)POPs;
305
306#ifdef USE_THREADS
307 CvOWNER(cv) = (struct perl_thread *)POPs;
308 error does not work either
309#endif
310 }
311
312 PUTBACK;
313 }
314}
315
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
317STATIC void
318S_nuke_stacks(pTHX)
319{
320 while (PL_curstackinfo->si_next)
321 PL_curstackinfo = PL_curstackinfo->si_next;
322 while (PL_curstackinfo) {
323 PERL_SI *p = PL_curstackinfo->si_prev;
324 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
325 Safefree(PL_curstackinfo->si_cxstack);
326 Safefree(PL_curstackinfo);
327 PL_curstackinfo = p;
328 }
329 Safefree(PL_tmps_stack);
330 Safefree(PL_markstack);
331 Safefree(PL_scopestack);
332 Safefree(PL_savestack);
333 Safefree(PL_retstack);
334}
335
336#define SUB_INIT "Coro::State::_newcoro"
337
338MODULE = Coro::State PACKAGE = Coro::State
339
340PROTOTYPES: ENABLE
341
342BOOT:
343 if (!padlist_cache)
344 padlist_cache = newHV ();
345
346Coro::State
347_newprocess(args)
348 SV * args
349 PROTOTYPE: $ 3674 PROTOTYPE: $
3675 ALIAS:
3676 is_ready = CF_READY
3677 is_running = CF_RUNNING
3678 is_new = CF_NEW
3679 is_destroyed = CF_ZOMBIE
3680 is_zombie = CF_ZOMBIE
3681 is_suspended = CF_SUSPENDED
3682 CODE:
3683 RETVAL = boolSV (coro->flags & ix);
3684 OUTPUT:
3685 RETVAL
3686
3687void
3688throw (SV *self, SV *exception = &PL_sv_undef)
3689 PROTOTYPE: $;$
350 CODE: 3690 CODE:
351 Coro__State coro; 3691{
3692 struct coro *coro = SvSTATE (self);
3693 struct coro *current = SvSTATE_current;
3694 SV **exceptionp = coro == current ? &CORO_THROW : &coro->except;
3695 SvREFCNT_dec (*exceptionp);
3696 SvGETMAGIC (exception);
3697 *exceptionp = SvOK (exception) ? newSVsv (exception) : 0;
352 3698
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 3699 api_ready (aTHX_ self);
354 croak ("Coro::State::newprocess expects an arrayref"); 3700}
3701
3702void
3703api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
3704 PROTOTYPE: $;$
3705 C_ARGS: aTHX_ coro, flags
3706
3707SV *
3708has_cctx (Coro::State coro)
3709 PROTOTYPE: $
3710 CODE:
3711 /* maybe manage the running flag differently */
3712 RETVAL = boolSV (!!coro->cctx || (coro->flags & CF_RUNNING));
3713 OUTPUT:
3714 RETVAL
3715
3716int
3717is_traced (Coro::State coro)
3718 PROTOTYPE: $
3719 CODE:
3720 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
3721 OUTPUT:
3722 RETVAL
3723
3724UV
3725rss (Coro::State coro)
3726 PROTOTYPE: $
3727 ALIAS:
3728 usecount = 1
3729 CODE:
3730 switch (ix)
3731 {
3732 case 0: RETVAL = coro_rss (aTHX_ coro); break;
3733 case 1: RETVAL = coro->usecount; break;
355 3734 }
356 New (0, coro, 1, struct coro); 3735 OUTPUT:
357
358 coro->mainstack = 0; /* actual work is done inside transfer */
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
360
361 RETVAL = coro; 3736 RETVAL
3737
3738void
3739force_cctx ()
3740 PROTOTYPE:
3741 CODE:
3742 cctx_current->idle_sp = 0;
3743
3744void
3745swap_defsv (Coro::State self)
3746 PROTOTYPE: $
3747 ALIAS:
3748 swap_defav = 1
3749 CODE:
3750 if (!self->slot)
3751 croak ("cannot swap state with coroutine that has no saved state,");
3752 else
3753 {
3754 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
3755 SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
3756
3757 SV *tmp = *src; *src = *dst; *dst = tmp;
3758 }
3759
3760void
3761cancel (Coro::State self)
3762 CODE:
3763 coro_state_destroy (aTHX_ self);
3764
3765SV *
3766enable_times (int enabled = enable_times)
3767 CODE:
3768{
3769 RETVAL = boolSV (enable_times);
3770
3771 if (enabled != enable_times)
3772 {
3773 enable_times = enabled;
3774
3775 coro_times_update ();
3776 (enabled ? coro_times_sub : coro_times_add)(SvSTATE (coro_current));
3777 }
3778}
362 OUTPUT: 3779 OUTPUT:
363 RETVAL 3780 RETVAL
364 3781
365void 3782void
366transfer(prev,next) 3783times (Coro::State self)
367 Coro::State_or_hashref prev 3784 PPCODE:
368 Coro::State_or_hashref next 3785{
3786 struct coro *current = SvSTATE (coro_current);
3787
3788 if (ecb_expect_false (current == self))
3789 {
3790 coro_times_update ();
3791 coro_times_add (SvSTATE (coro_current));
3792 }
3793
3794 EXTEND (SP, 2);
3795 PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));
3796 PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));
3797
3798 if (ecb_expect_false (current == self))
3799 coro_times_sub (SvSTATE (coro_current));
3800}
3801
3802void
3803swap_sv (Coro::State coro, SV *sv, SV *swapsv)
3804 CODE:
3805{
3806 struct coro *current = SvSTATE_current;
3807
3808 if (current == coro)
3809 SWAP_SVS (current);
3810
3811 if (!coro->swap_sv)
3812 coro->swap_sv = newAV ();
3813
3814 av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (sv )));
3815 av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (swapsv)));
3816
3817 if (current == coro)
3818 SWAP_SVS (current);
3819}
3820
3821
3822MODULE = Coro::State PACKAGE = Coro
3823
3824BOOT:
3825{
3826 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
3827 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
3828 cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);
3829 coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);
3830 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
3831 av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);
3832 sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);
3833 sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);
3834
3835 sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
3836 sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);
3837 cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);
3838 CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */
3839
3840 coro_stash = gv_stashpv ("Coro", TRUE);
3841
3842 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));
3843 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));
3844 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
3845 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (CORO_PRIO_LOW));
3846 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (CORO_PRIO_IDLE));
3847 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (CORO_PRIO_MIN));
3848
3849 {
3850 SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
3851
3852 coroapi.schedule = api_schedule;
3853 coroapi.schedule_to = api_schedule_to;
3854 coroapi.cede = api_cede;
3855 coroapi.cede_notself = api_cede_notself;
3856 coroapi.ready = api_ready;
3857 coroapi.is_ready = api_is_ready;
3858 coroapi.nready = coro_nready;
3859 coroapi.current = coro_current;
3860
3861 /*GCoroAPI = &coroapi;*/
3862 sv_setiv (sv, (IV)&coroapi);
3863 SvREADONLY_on (sv);
3864 }
3865}
3866
3867SV *
3868async (...)
3869 PROTOTYPE: &@
369 CODE: 3870 CODE:
3871 RETVAL = coro_new (aTHX_ coro_stash, &ST (0), items, 1);
3872 api_ready (aTHX_ RETVAL);
3873 OUTPUT:
3874 RETVAL
370 3875
371 if (prev != next) 3876void
3877_destroy (Coro::State coro)
3878 CODE:
3879 /* used by the manager thread */
3880 coro_state_destroy (aTHX_ coro);
3881
3882void
3883on_destroy (Coro::State coro, SV *cb)
3884 CODE:
3885 coro_push_on_destroy (aTHX_ coro, newSVsv (cb));
3886
3887void
3888join (...)
3889 CODE:
3890 CORO_EXECUTE_SLF_XS (slf_init_join);
3891
3892void
3893terminate (...)
3894 CODE:
3895 CORO_EXECUTE_SLF_XS (slf_init_terminate);
3896
3897void
3898cancel (...)
3899 CODE:
3900 CORO_EXECUTE_SLF_XS (slf_init_cancel);
3901
3902int
3903safe_cancel (Coro::State self, ...)
3904 C_ARGS: aTHX_ self, &ST (1), items - 1
3905
3906void
3907schedule (...)
3908 CODE:
3909 CORO_EXECUTE_SLF_XS (slf_init_schedule);
3910
3911void
3912schedule_to (...)
3913 CODE:
3914 CORO_EXECUTE_SLF_XS (slf_init_schedule_to);
3915
3916void
3917cede_to (...)
3918 CODE:
3919 CORO_EXECUTE_SLF_XS (slf_init_cede_to);
3920
3921void
3922cede (...)
3923 CODE:
3924 CORO_EXECUTE_SLF_XS (slf_init_cede);
3925
3926void
3927cede_notself (...)
3928 CODE:
3929 CORO_EXECUTE_SLF_XS (slf_init_cede_notself);
3930
3931void
3932_set_current (SV *current)
3933 PROTOTYPE: $
3934 CODE:
3935 SvREFCNT_dec (SvRV (coro_current));
3936 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
3937
3938void
3939_set_readyhook (SV *hook)
3940 PROTOTYPE: $
3941 CODE:
3942 SvREFCNT_dec (coro_readyhook);
3943 SvGETMAGIC (hook);
3944 if (SvOK (hook))
3945 {
3946 coro_readyhook = newSVsv (hook);
3947 CORO_READYHOOK = invoke_sv_ready_hook_helper;
3948 }
3949 else
372 { 3950 {
3951 coro_readyhook = 0;
3952 CORO_READYHOOK = 0;
3953 }
3954
3955int
3956prio (Coro::State coro, int newprio = 0)
3957 PROTOTYPE: $;$
3958 ALIAS:
3959 nice = 1
3960 CODE:
3961{
3962 RETVAL = coro->prio;
3963
3964 if (items > 1)
3965 {
3966 if (ix)
3967 newprio = coro->prio - newprio;
3968
3969 if (newprio < CORO_PRIO_MIN) newprio = CORO_PRIO_MIN;
3970 if (newprio > CORO_PRIO_MAX) newprio = CORO_PRIO_MAX;
3971
3972 coro->prio = newprio;
3973 }
3974}
3975 OUTPUT:
3976 RETVAL
3977
3978SV *
3979ready (SV *self)
3980 PROTOTYPE: $
3981 CODE:
3982 RETVAL = boolSV (api_ready (aTHX_ self));
3983 OUTPUT:
3984 RETVAL
3985
3986int
3987nready (...)
3988 PROTOTYPE:
3989 CODE:
3990 RETVAL = coro_nready;
3991 OUTPUT:
3992 RETVAL
3993
3994void
3995suspend (Coro::State self)
3996 PROTOTYPE: $
3997 CODE:
3998 self->flags |= CF_SUSPENDED;
3999
4000void
4001resume (Coro::State self)
4002 PROTOTYPE: $
4003 CODE:
4004 self->flags &= ~CF_SUSPENDED;
4005
4006void
4007_pool_handler (...)
4008 CODE:
4009 CORO_EXECUTE_SLF_XS (slf_init_pool_handler);
4010
4011void
4012async_pool (SV *cv, ...)
4013 PROTOTYPE: &@
4014 PPCODE:
4015{
4016 HV *hv = (HV *)av_pop (av_async_pool);
4017 AV *av = newAV ();
4018 SV *cb = ST (0);
4019 int i;
4020
4021 av_extend (av, items - 2);
4022 for (i = 1; i < items; ++i)
4023 av_push (av, SvREFCNT_inc_NN (ST (i)));
4024
4025 if ((SV *)hv == &PL_sv_undef)
4026 {
4027 SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1);
4028 hv = (HV *)SvREFCNT_inc_NN (SvRV (sv));
4029 SvREFCNT_dec (sv);
4030 }
4031
4032 {
4033 struct coro *coro = SvSTATE_hv (hv);
4034
4035 assert (!coro->invoke_cb);
4036 assert (!coro->invoke_av);
4037 coro->invoke_cb = SvREFCNT_inc (cb);
4038 coro->invoke_av = av;
4039 }
4040
4041 api_ready (aTHX_ (SV *)hv);
4042
4043 if (GIMME_V != G_VOID)
4044 XPUSHs (sv_2mortal (newRV_noinc ((SV *)hv)));
4045 else
4046 SvREFCNT_dec (hv);
4047}
4048
4049SV *
4050rouse_cb ()
4051 PROTOTYPE:
4052 CODE:
4053 RETVAL = coro_new_rouse_cb (aTHX);
4054 OUTPUT:
4055 RETVAL
4056
4057void
4058rouse_wait (...)
4059 PROTOTYPE: ;$
4060 PPCODE:
4061 CORO_EXECUTE_SLF_XS (slf_init_rouse_wait);
4062
4063void
4064on_enter (SV *block)
4065 ALIAS:
4066 on_leave = 1
4067 PROTOTYPE: &
4068 CODE:
4069{
4070 struct coro *coro = SvSTATE_current;
4071 AV **avp = ix ? &coro->on_leave : &coro->on_enter;
4072
4073 block = s_get_cv_croak (block);
4074
4075 if (!*avp)
4076 *avp = newAV ();
4077
4078 av_push (*avp, SvREFCNT_inc (block));
4079
4080 if (!ix)
4081 on_enterleave_call (aTHX_ block);
4082
4083 LEAVE; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */
4084 SAVEDESTRUCTOR_X (ix ? coro_pop_on_leave : coro_pop_on_enter, (void *)coro);
4085 ENTER; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */
4086}
4087
4088
4089MODULE = Coro::State PACKAGE = PerlIO::cede
4090
4091BOOT:
4092 PerlIO_define_layer (aTHX_ &PerlIO_cede);
4093
4094
4095MODULE = Coro::State PACKAGE = Coro::Semaphore
4096
4097SV *
4098new (SV *klass, SV *count = 0)
4099 CODE:
4100{
4101 int semcnt = 1;
4102
4103 if (count)
4104 {
4105 SvGETMAGIC (count);
4106
4107 if (SvOK (count))
4108 semcnt = SvIV (count);
4109 }
4110
4111 RETVAL = sv_bless (
4112 coro_waitarray_new (aTHX_ semcnt),
4113 GvSTASH (CvGV (cv))
4114 );
4115}
4116 OUTPUT:
4117 RETVAL
4118
4119# helper for Coro::Channel and others
4120SV *
4121_alloc (int count)
4122 CODE:
4123 RETVAL = coro_waitarray_new (aTHX_ count);
4124 OUTPUT:
4125 RETVAL
4126
4127SV *
4128count (SV *self)
4129 CODE:
4130 RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]);
4131 OUTPUT:
4132 RETVAL
4133
4134void
4135up (SV *self, int adjust = 1)
4136 ALIAS:
4137 adjust = 1
4138 CODE:
4139 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), ix ? adjust : 1);
4140
4141void
4142down (...)
4143 CODE:
4144 CORO_EXECUTE_SLF_XS (slf_init_semaphore_down);
4145
4146void
4147wait (...)
4148 CODE:
4149 CORO_EXECUTE_SLF_XS (slf_init_semaphore_wait);
4150
4151void
4152try (SV *self)
4153 PPCODE:
4154{
4155 AV *av = (AV *)SvRV (self);
4156 SV *count_sv = AvARRAY (av)[0];
4157 IV count = SvIVX (count_sv);
4158
4159 if (count > 0)
4160 {
4161 --count;
4162 SvIVX (count_sv) = count;
4163 XSRETURN_YES;
4164 }
4165 else
4166 XSRETURN_NO;
4167}
4168
4169void
4170waiters (SV *self)
4171 PPCODE:
4172{
4173 AV *av = (AV *)SvRV (self);
4174 int wcount = AvFILLp (av) + 1 - 1;
4175
4176 if (GIMME_V == G_SCALAR)
4177 XPUSHs (sv_2mortal (newSViv (wcount)));
4178 else
4179 {
4180 int i;
4181 EXTEND (SP, wcount);
4182 for (i = 1; i <= wcount; ++i)
4183 PUSHs (sv_2mortal (newRV_inc (AvARRAY (av)[i])));
4184 }
4185}
4186
4187MODULE = Coro::State PACKAGE = Coro::SemaphoreSet
4188
4189void
4190_may_delete (SV *sem, int count, unsigned int extra_refs)
4191 PPCODE:
4192{
4193 AV *av = (AV *)SvRV (sem);
4194
4195 if (SvREFCNT ((SV *)av) == 1 + extra_refs
4196 && AvFILLp (av) == 0 /* no waiters, just count */
4197 && SvIV (AvARRAY (av)[0]) == count)
4198 XSRETURN_YES;
4199
4200 XSRETURN_NO;
4201}
4202
4203MODULE = Coro::State PACKAGE = Coro::Signal
4204
4205SV *
4206new (SV *klass)
4207 CODE:
4208 RETVAL = sv_bless (
4209 coro_waitarray_new (aTHX_ 0),
4210 GvSTASH (CvGV (cv))
4211 );
4212 OUTPUT:
4213 RETVAL
4214
4215void
4216wait (...)
4217 CODE:
4218 CORO_EXECUTE_SLF_XS (slf_init_signal_wait);
4219
4220void
4221broadcast (SV *self)
4222 CODE:
4223{
4224 AV *av = (AV *)SvRV (self);
4225 coro_signal_wake (aTHX_ av, AvFILLp (av));
4226}
4227
4228void
4229send (SV *self)
4230 CODE:
4231{
4232 AV *av = (AV *)SvRV (self);
4233
4234 if (AvFILLp (av))
4235 coro_signal_wake (aTHX_ av, 1);
4236 else
4237 SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
4238}
4239
4240IV
4241awaited (SV *self)
4242 CODE:
4243 RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
4244 OUTPUT:
4245 RETVAL
4246
4247
4248MODULE = Coro::State PACKAGE = Coro::AnyEvent
4249
4250BOOT:
4251 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
4252
4253void
4254_schedule (...)
4255 CODE:
4256{
4257 static int incede;
4258
4259 api_cede_notself (aTHX);
4260
4261 ++incede;
4262 while (coro_nready >= incede && api_cede (aTHX))
4263 ;
4264
4265 sv_setsv (sv_activity, &PL_sv_undef);
4266 if (coro_nready >= incede)
4267 {
4268 PUSHMARK (SP);
373 PUTBACK; 4269 PUTBACK;
374 SAVE (aTHX_ prev); 4270 call_pv ("Coro::AnyEvent::_activity", G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
375
376 /*
377 * this could be done in newprocess which would lead to
378 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
379 * code here, but lazy allocation of stacks has also
380 * some virtues and the overhead of the if() is nil.
381 */
382 if (next->mainstack)
383 {
384 LOAD (aTHX_ next);
385 next->mainstack = 0; /* unnecessary but much cleaner */
386 SPAGAIN;
387 }
388 else
389 {
390 /*
391 * emulate part of the perl startup here.
392 */
393 UNOP myop;
394
395 init_stacks ();
396 PL_op = (OP *)&myop;
397 /*PL_curcop = 0;*/
398 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399
400 SPAGAIN;
401 Zero(&myop, 1, UNOP);
402 myop.op_next = Nullop;
403 myop.op_flags = OPf_WANT_VOID;
404
405 PUSHMARK(SP);
406 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
407 PUTBACK;
408 /*
409 * the next line is slightly wrong, as PL_op->op_next
410 * is actually being executed so we skip the first op.
411 * that doesn't matter, though, since it is only
412 * pp_nextstate and we never return...
413 */
414 PL_op = Perl_pp_entersub(aTHX);
415 SPAGAIN;
416
417 ENTER;
418 }
419 } 4271 }
420 4272
4273 --incede;
4274}
4275
4276
4277MODULE = Coro::State PACKAGE = Coro::AIO
4278
421void 4279void
422DESTROY(coro) 4280_register (char *target, char *proto, SV *req)
423 Coro::State coro 4281 CODE:
424 CODE: 4282{
4283 SV *req_cv = s_get_cv_croak (req);
4284 /* newXSproto doesn't return the CV on 5.8 */
4285 CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);
4286 sv_setpv ((SV *)slf_cv, proto);
4287 sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);
4288}
425 4289
426 if (coro->mainstack) 4290MODULE = Coro::State PACKAGE = Coro::Select
4291
4292void
4293patch_pp_sselect ()
4294 CODE:
4295 if (!coro_old_pp_sselect)
427 { 4296 {
428 struct coro temp; 4297 coro_select_select = (SV *)get_cv ("Coro::Select::select", 0);
429 4298 coro_old_pp_sselect = PL_ppaddr [OP_SSELECT];
430 PUTBACK; 4299 PL_ppaddr [OP_SSELECT] = coro_pp_sselect;
431 SAVE(aTHX_ (&temp));
432 LOAD(aTHX_ coro);
433
434 S_nuke_stacks ();
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437 LOAD((&temp));
438 SPAGAIN;
439 } 4300 }
440 4301
441 SvREFCNT_dec (coro->args); 4302void
442 Safefree (coro); 4303unpatch_pp_sselect ()
4304 CODE:
4305 if (coro_old_pp_sselect)
4306 {
4307 PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
4308 coro_old_pp_sselect = 0;
4309 }
443 4310
4311MODULE = Coro::State PACKAGE = Coro::Util
444 4312
4313void
4314_exit (int code)
4315 CODE:
4316 _exit (code);
4317
4318NV
4319time ()
4320 CODE:
4321 RETVAL = nvtime (aTHX);
4322 OUTPUT:
4323 RETVAL
4324
4325NV
4326gettimeofday ()
4327 PPCODE:
4328{
4329 UV tv [2];
4330 u2time (aTHX_ tv);
4331 EXTEND (SP, 2);
4332 PUSHs (sv_2mortal (newSVuv (tv [0])));
4333 PUSHs (sv_2mortal (newSVuv (tv [1])));
4334}
4335

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines