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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.427 by root, Wed Dec 5 14:35:34 2012 UTC

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

Diff Legend

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