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

Diff Legend

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