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

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

Diff Legend

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