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

Diff Legend

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