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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.423 by root, Mon Oct 8 23:13:36 2012 UTC

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

Diff Legend

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