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

Diff Legend

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