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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.395 by root, Fri May 6 07:22:14 2011 UTC

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

Diff Legend

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