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

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

Diff Legend

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