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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.430 by root, Wed Dec 19 23:36:16 2012 UTC

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

Diff Legend

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