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.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.360 by root, Mon Jun 29 06:14:23 2009 UTC

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

Diff Legend

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