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.434 by root, Sat Nov 2 19:48:50 2013 UTC

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

Diff Legend

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