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

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

Diff Legend

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