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.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.444 by root, Thu May 1 08:09:18 2014 UTC

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

Diff Legend

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