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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.406 by root, Sat Jun 11 13:49:00 2011 UTC

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

Diff Legend

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