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

Diff Legend

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