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

Diff Legend

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