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

Diff Legend

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