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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.392 by root, Fri Apr 29 15:43:27 2011 UTC

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

Diff Legend

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