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

Diff Legend

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