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

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

Diff Legend

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