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

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

Diff Legend

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