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

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

Diff Legend

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