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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.439 by root, Tue Nov 19 05:16:01 2013 UTC

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

Diff Legend

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