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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.254 by root, Fri Nov 7 20:27:47 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# define REGISTER_STACK(cctx,start,end) (cctx)->valgrind_id = VALGRIND_STACK_REGISTER ((start), (end))
52#else
53# define REGISTER_STACK(cctx,start,end)
54#endif
55
56/* the maximum number of idle cctx that will be pooled */
57static int cctx_max_idle = 4;
58
59#define PERL_VERSION_ATLEAST(a,b,c) \
60 (PERL_REVISION > (a) \
61 || (PERL_REVISION == (a) \
62 && (PERL_VERSION > (b) \
63 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
64
65#if !PERL_VERSION_ATLEAST (5,6,0)
66# ifndef PL_ppaddr
67# define PL_ppaddr ppaddr
68# endif
69# ifndef call_sv
70# define call_sv perl_call_sv
71# endif
72# ifndef get_sv
73# define get_sv perl_get_sv
74# endif
75# ifndef get_cv
76# define get_cv perl_get_cv
77# endif
78# ifndef IS_PADGV
79# define IS_PADGV(v) 0
80# endif
81# ifndef IS_PADCONST
82# define IS_PADCONST(v) 0
83# endif
84#endif
85
86/* 5.11 */
87#ifndef CxHASARGS
88# define CxHASARGS(cx) (cx)->blk_sub.hasargs
89#endif
90
91/* 5.10.0 */
92#ifndef SvREFCNT_inc_NN
93# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
94#endif
95
96/* 5.8.8 */
97#ifndef GV_NOTQUAL
98# define GV_NOTQUAL 0
99#endif
100#ifndef newSV
101# define newSV(l) NEWSV(0,l)
102#endif
103
104/* 5.8.7 */
105#ifndef SvRV_set
106# define SvRV_set(s,v) SvRV(s) = (v)
107#endif
108
109#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
110# undef CORO_STACKGUARD
111#endif
112
113#ifndef CORO_STACKGUARD
114# define CORO_STACKGUARD 0
115#endif
116
117/* prefer perl internal functions over our own? */
118#ifndef CORO_PREFER_PERL_FUNCTIONS
119# define CORO_PREFER_PERL_FUNCTIONS 0
120#endif
121
122/* The next macros try to return the current stack pointer, in an as
123 * portable way as possible. */
124#define dSTACKLEVEL volatile char stacklevel
125#define STACKLEVEL ((void *)&stacklevel)
126
127#define IN_DESTRUCT (PL_main_cv == Nullcv)
128
129#if __GNUC__ >= 3
130# define attribute(x) __attribute__(x)
131# define BARRIER __asm__ __volatile__ ("" : : : "memory")
132# define expect(expr,value) __builtin_expect ((expr),(value))
133#else
134# define attribute(x)
135# define BARRIER
136# define expect(expr,value) (expr)
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
147static perl_mutex coro_lock;
148# define LOCK do { MUTEX_LOCK (&coro_lock); } while (0)
149# define UNLOCK do { MUTEX_UNLOCK (&coro_lock); } while (0)
150#else
151# define LOCK (void)0
152# define UNLOCK (void)0
153#endif
154
155/* helper storage struct for Coro::AIO */
156struct io_state
157{
158 AV *res;
159 int errorno;
160 I32 laststype;
161 int laststatval;
162 Stat_t statcache;
163};
164
165static double (*nvtime)(); /* so why doesn't it take void? */
166
167static U32 cctx_gen;
168static size_t cctx_stacksize = CORO_STACKSIZE;
169static struct CoroAPI coroapi;
170static AV *main_mainstack; /* used to differentiate between $main and others */
171static JMPENV *main_top_env;
172static HV *coro_state_stash, *coro_stash;
173static volatile SV *coro_mortal; /* will be freed/thrown after next transfer */
174
175static GV *irsgv; /* $/ */
176static GV *stdoutgv; /* *STDOUT */
177static SV *rv_diehook;
178static SV *rv_warnhook;
179static HV *hv_sig; /* %SIG */
180
181/* async_pool helper stuff */
182static SV *sv_pool_rss;
183static SV *sv_pool_size;
184static AV *av_async_pool;
185
186/* Coro::AnyEvent */
187static SV *sv_activity;
188
189static struct coro_cctx *cctx_first;
190static int cctx_count, cctx_idle;
191
192enum {
193 CC_MAPPED = 0x01,
194 CC_NOREUSE = 0x02, /* throw this away after tracing */
195 CC_TRACE = 0x04,
196 CC_TRACE_SUB = 0x08, /* trace sub calls */
197 CC_TRACE_LINE = 0x10, /* trace each statement */
198 CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
199};
200
201/* this is a structure representing a c-level coroutine */
202typedef struct coro_cctx {
203 struct coro_cctx *next;
204
205 /* the stack */
206 void *sptr;
207 size_t ssize;
208
209 /* cpu state */
210 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
211 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
212 JMPENV *top_env;
213 coro_context cctx;
214
215 U32 gen;
216#if CORO_USE_VALGRIND
217 int valgrind_id;
218#endif
219 unsigned char flags;
220} coro_cctx;
221
222enum {
223 CF_RUNNING = 0x0001, /* coroutine is running */
224 CF_READY = 0x0002, /* coroutine is ready */
225 CF_NEW = 0x0004, /* has never been switched to */
226 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
227};
228
229/* the structure where most of the perl state is stored, overlaid on the cxstack */
230typedef struct {
231 SV *defsv;
232 AV *defav;
233 SV *errsv;
234 SV *irsgv;
235#define VAR(name,type) type name;
236# include "state.h"
237#undef VAR
238} perl_slots;
239
240#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
241
242/* this is a structure representing a perl-level coroutine */
11struct coro { 243struct coro {
12 U8 dowarn; 244 /* the c coroutine allocated to this perl coroutine, if any */
13 AV *defav; 245 coro_cctx *cctx;
14 246
15 PERL_SI *curstackinfo; 247 /* process data */
16 AV *curstack;
17 AV *mainstack; 248 AV *mainstack;
18 SV **stack_sp; 249 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 250
41 AV *args; 251 AV *args; /* data associated with this coroutine (initial args) */
252 int refcnt; /* coroutines are refcounted, yes */
253 int flags; /* CF_ flags */
254 HV *hv; /* the perl hash associated with this coro, if any */
255
256 /* statistics */
257 int usecount; /* number of transfers to this coro */
258
259 /* coro process data */
260 int prio;
261 SV *throw; /* exception to be thrown */
262
263 /* async_pool */
264 SV *saved_deffh;
265
266 /* linked list */
267 struct coro *next, *prev;
42}; 268};
43 269
44typedef struct coro *Coro__State; 270typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 271typedef struct coro *Coro__State_or_hashref;
46 272
47static HV *padlist_cache; 273/** Coro ********************************************************************/
48 274
49/* mostly copied from op.c:cv_clone2 */ 275#define PRIO_MAX 3
50STATIC AV * 276#define PRIO_HIGH 1
51clone_padlist (AV *protopadlist) 277#define PRIO_NORMAL 0
278#define PRIO_LOW -1
279#define PRIO_IDLE -3
280#define PRIO_MIN -4
281
282/* for Coro.pm */
283static SV *coro_current;
284static SV *coro_readyhook;
285static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
286static int coro_nready;
287static struct coro *coro_first;
288
289/** lowlevel stuff **********************************************************/
290
291static SV *
292coro_get_sv (pTHX_ const char *name, int create)
52{ 293{
53 AV *av; 294#if PERL_VERSION_ATLEAST (5,10,0)
54 I32 ix; 295 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE); 296 get_sv (name, create);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE); 297#endif
57 SV **pname = AvARRAY (protopad_name); 298 return get_sv (name, create);
58 SV **ppad = AvARRAY (protopad); 299}
59 I32 fname = AvFILLp (protopad_name); 300
60 I32 fpad = AvFILLp (protopad); 301static AV *
302coro_get_av (pTHX_ const char *name, int create)
303{
304#if PERL_VERSION_ATLEAST (5,10,0)
305 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
306 get_av (name, create);
307#endif
308 return get_av (name, create);
309}
310
311static HV *
312coro_get_hv (pTHX_ const char *name, int create)
313{
314#if PERL_VERSION_ATLEAST (5,10,0)
315 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
316 get_hv (name, create);
317#endif
318 return get_hv (name, create);
319}
320
321static AV *
322coro_clone_padlist (pTHX_ CV *cv)
323{
324 AV *padlist = CvPADLIST (cv);
61 AV *newpadlist, *newpad_name, *newpad; 325 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 326
72 newpadlist = newAV (); 327 newpadlist = newAV ();
73 AvREAL_off (newpadlist); 328 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 329#if PERL_VERSION_ATLEAST (5,10,0)
330 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
331#else
332 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
333#endif
334 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
335 --AvFILLp (padlist);
336
337 av_store (newpadlist, 0, SvREFCNT_inc_NN (*av_fetch (padlist, 0, FALSE)));
75 av_store (newpadlist, 1, (SV *) newpad); 338 av_store (newpadlist, 1, (SV *)newpad);
76 339
77 av = newAV (); /* will be @_ */ 340 return newpadlist;
78 av_extend (av, 0); 341}
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 342
82 for (ix = fpad; ix > 0; ix--) 343static void
344free_padlist (pTHX_ AV *padlist)
345{
346 /* may be during global destruction */
347 if (SvREFCNT (padlist))
83 { 348 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 349 I32 i = AvFILLp (padlist);
85 if (namesv && namesv != &PL_sv_undef) 350 while (i >= 0)
86 { 351 {
87 char *name = SvPVX (namesv); /* XXX */ 352 SV **svp = av_fetch (padlist, i--, FALSE);
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 353 if (svp)
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 } 354 {
92 else
93 { /* our own lexical */
94 SV *sv; 355 SV *sv;
95 if (*name == '&') 356 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96 sv = SvREFCNT_inc (ppad[ix]); 357 SvREFCNT_dec (sv);
97 else if (*name == '@') 358
98 sv = (SV *) newAV (); 359 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 } 360 }
107 } 361 }
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 362
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); 363 SvREFCNT_dec ((SV*)padlist);
364 }
365}
366
367static int
368coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
369{
370 AV *padlist;
371 AV *av = (AV *)mg->mg_obj;
372
373 /* casting is fun. */
374 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
375 free_padlist (aTHX_ padlist);
376
377 SvREFCNT_dec (av); /* sv_magicext increased the refcount */
378
379 return 0;
380}
381
382#define CORO_MAGIC_type_cv PERL_MAGIC_ext
383#define CORO_MAGIC_type_state PERL_MAGIC_ext
384
385static MGVTBL coro_cv_vtbl = {
386 0, 0, 0, 0,
387 coro_cv_free
388};
389
390#define CORO_MAGIC(sv, type) \
391 SvMAGIC (sv) \
392 ? SvMAGIC (sv)->mg_type == type \
393 ? SvMAGIC (sv) \
394 : mg_find (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 (((SV *)(sv)), CORO_MAGIC_type_state)
399
400static 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/* the next two functions merely cache the padlists */
427static void
428get_padlist (pTHX_ CV *cv)
429{
430 MAGIC *mg = CORO_MAGIC_cv (cv);
431 AV *av;
432
433 if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))
434 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
435 else
436 {
437#if CORO_PREFER_PERL_FUNCTIONS
438 /* this is probably cleaner? but also slower! */
439 /* in practise, it seems to be less stable */
440 CV *cp = Perl_cv_clone (cv);
441 CvPADLIST (cv) = CvPADLIST (cp);
442 CvPADLIST (cp) = 0;
443 SvREFCNT_dec (cp);
444#else
445 CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
446#endif
447 }
448}
449
450static void
451put_padlist (pTHX_ CV *cv)
452{
453 MAGIC *mg = CORO_MAGIC_cv (cv);
454 AV *av;
455
456 if (expect_false (!mg))
457 mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
458
459 av = (AV *)mg->mg_obj;
460
461 if (expect_false (AvFILLp (av) >= AvMAX (av)))
462 av_extend (av, AvMAX (av) + 1);
463
464 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
465}
466
467/** load & save, init *******************************************************/
468
469static void
470load_perl (pTHX_ Coro__State c)
471{
472 perl_slots *slot = c->slot;
473 c->slot = 0;
474
475 PL_mainstack = c->mainstack;
476
477 GvSV (PL_defgv) = slot->defsv;
478 GvAV (PL_defgv) = slot->defav;
479 GvSV (PL_errgv) = slot->errsv;
480 GvSV (irsgv) = slot->irsgv;
481
482 #define VAR(name,type) PL_ ## name = slot->name;
483 # include "state.h"
484 #undef VAR
485
486 {
487 dSP;
488
489 CV *cv;
490
491 /* now do the ugly restore mess */
492 while (expect_true (cv = (CV *)POPs))
493 {
494 put_padlist (aTHX_ cv); /* mark this padlist as available */
495 CvDEPTH (cv) = PTR2IV (POPs);
496 CvPADLIST (cv) = (AV *)POPs;
497 }
498
499 PUTBACK;
159 } 500 }
160} 501}
161 502
162/* the next tow functions merely cache the padlists */
163STATIC void
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}
173
174STATIC void
175put_padlist (CV *cv)
176{
177 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
178
179 if (SvTYPE (*he) != SVt_PVAV)
180 {
181 SvREFCNT_dec (*he);
182 *he = (SV *)newAV ();
183 }
184
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186}
187
188static void 503static void
189save_state(pTHX_ Coro__State c) 504save_perl (pTHX_ Coro__State c)
190{ 505{
191 { 506 {
192 dSP; 507 dSP;
193 I32 cxix = cxstack_ix; 508 I32 cxix = cxstack_ix;
509 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 510 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 511
197 /* 512 /*
198 * the worst thing you can imagine happens first - we have to save 513 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 514 * (and reinitialize) all cv's in the whole callchain :(
200 */ 515 */
201 516
202 PUSHs (Nullsv); 517 XPUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 518 /* this loop was inspired by pp_caller */
204 for (;;) 519 for (;;)
205 { 520 {
206 while (cxix >= 0) 521 while (expect_true (cxix >= 0))
207 { 522 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 523 PERL_CONTEXT *cx = &ccstk[cxix--];
209 524
210 if (CxTYPE(cx) == CXt_SUB) 525 if (expect_true (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT))
211 { 526 {
212 CV *cv = cx->blk_sub.cv; 527 CV *cv = cx->blk_sub.cv;
528
213 if (CvDEPTH(cv)) 529 if (expect_true (CvDEPTH (cv)))
214 { 530 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3); 531 EXTEND (SP, 3);
219 PUSHs ((SV *)CvDEPTH(cv));
220 PUSHs ((SV *)CvPADLIST(cv)); 532 PUSHs ((SV *)CvPADLIST (cv));
533 PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
221 PUSHs ((SV *)cv); 534 PUSHs ((SV *)cv);
222 535
223 get_padlist (cv);
224
225 CvDEPTH(cv) = 0; 536 CvDEPTH (cv) = 0;
226#ifdef USE_THREADS 537 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 } 538 }
233 } 539 }
234 else if (CxTYPE(cx) == CXt_FORMAT) 540 }
541
542 if (expect_true (top_si->si_type == PERLSI_MAIN))
543 break;
544
545 top_si = top_si->si_prev;
546 ccstk = top_si->si_cxstack;
547 cxix = top_si->si_cxix;
548 }
549
550 PUTBACK;
551 }
552
553 /* allocate some space on the context stack for our purposes */
554 /* we manually unroll here, as usually 2 slots is enough */
555 if (SLOT_COUNT >= 1) CXINC;
556 if (SLOT_COUNT >= 2) CXINC;
557 if (SLOT_COUNT >= 3) CXINC;
558 {
559 int i;
560 for (i = 3; i < SLOT_COUNT; ++i)
561 CXINC;
562 }
563 cxstack_ix -= SLOT_COUNT; /* undo allocation */
564
565 c->mainstack = PL_mainstack;
566
567 {
568 perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
569
570 slot->defav = GvAV (PL_defgv);
571 slot->defsv = DEFSV;
572 slot->errsv = ERRSV;
573 slot->irsgv = GvSV (irsgv);
574
575 #define VAR(name,type) slot->name = PL_ ## name;
576 # include "state.h"
577 #undef VAR
578 }
579}
580
581/*
582 * allocate various perl stacks. This is an exact copy
583 * of perl.c:init_stacks, except that it uses less memory
584 * on the (sometimes correct) assumption that coroutines do
585 * not usually need a lot of stackspace.
586 */
587#if CORO_PREFER_PERL_FUNCTIONS
588# define coro_init_stacks init_stacks
589#else
590static void
591coro_init_stacks (pTHX)
592{
593 PL_curstackinfo = new_stackinfo(32, 8);
594 PL_curstackinfo->si_type = PERLSI_MAIN;
595 PL_curstack = PL_curstackinfo->si_stack;
596 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
597
598 PL_stack_base = AvARRAY(PL_curstack);
599 PL_stack_sp = PL_stack_base;
600 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
601
602 New(50,PL_tmps_stack,32,SV*);
603 PL_tmps_floor = -1;
604 PL_tmps_ix = -1;
605 PL_tmps_max = 32;
606
607 New(54,PL_markstack,16,I32);
608 PL_markstack_ptr = PL_markstack;
609 PL_markstack_max = PL_markstack + 16;
610
611#ifdef SET_MARK_OFFSET
612 SET_MARK_OFFSET;
613#endif
614
615 New(54,PL_scopestack,8,I32);
616 PL_scopestack_ix = 0;
617 PL_scopestack_max = 8;
618
619 New(54,PL_savestack,24,ANY);
620 PL_savestack_ix = 0;
621 PL_savestack_max = 24;
622
623#if !PERL_VERSION_ATLEAST (5,10,0)
624 New(54,PL_retstack,4,OP*);
625 PL_retstack_ix = 0;
626 PL_retstack_max = 4;
627#endif
628}
629#endif
630
631/*
632 * destroy the stacks, the callchain etc...
633 */
634static void
635coro_destruct_stacks (pTHX)
636{
637 while (PL_curstackinfo->si_next)
638 PL_curstackinfo = PL_curstackinfo->si_next;
639
640 while (PL_curstackinfo)
641 {
642 PERL_SI *p = PL_curstackinfo->si_prev;
643
644 if (!IN_DESTRUCT)
645 SvREFCNT_dec (PL_curstackinfo->si_stack);
646
647 Safefree (PL_curstackinfo->si_cxstack);
648 Safefree (PL_curstackinfo);
649 PL_curstackinfo = p;
650 }
651
652 Safefree (PL_tmps_stack);
653 Safefree (PL_markstack);
654 Safefree (PL_scopestack);
655 Safefree (PL_savestack);
656#if !PERL_VERSION_ATLEAST (5,10,0)
657 Safefree (PL_retstack);
658#endif
659}
660
661static size_t
662coro_rss (pTHX_ struct coro *coro)
663{
664 size_t rss = sizeof (*coro);
665
666 if (coro->mainstack)
667 {
668 perl_slots tmp_slot;
669 perl_slots *slot;
670
671 if (coro->flags & CF_RUNNING)
672 {
673 slot = &tmp_slot;
674
675 #define VAR(name,type) slot->name = PL_ ## name;
676 # include "state.h"
677 #undef VAR
678 }
679 else
680 slot = coro->slot;
681
682 if (slot)
683 {
684 rss += sizeof (slot->curstackinfo);
685 rss += (slot->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
686 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (slot->curstack)) * sizeof (SV *);
687 rss += slot->tmps_max * sizeof (SV *);
688 rss += (slot->markstack_max - slot->markstack_ptr) * sizeof (I32);
689 rss += slot->scopestack_max * sizeof (I32);
690 rss += slot->savestack_max * sizeof (ANY);
691
692#if !PERL_VERSION_ATLEAST (5,10,0)
693 rss += slot->retstack_max * sizeof (OP *);
694#endif
695 }
696 }
697
698 return rss;
699}
700
701/** coroutine stack handling ************************************************/
702
703static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg);
704static int (*orig_sigelem_set) (pTHX_ SV *sv, MAGIC *mg);
705static int (*orig_sigelem_clr) (pTHX_ SV *sv, MAGIC *mg);
706
707/* apparently < 5.8.8 */
708#ifndef MgPV_nolen_const
709#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
710 SvPV_nolen((SV*)((mg)->mg_ptr)) : \
711 (const char*)(mg)->mg_ptr)
712#endif
713
714/*
715 * This overrides the default magic get method of %SIG elements.
716 * The original one doesn't provide for reading back of PL_diehook/PL_warnhook
717 * and instead of tryign to save and restore the hash elements, we just provide
718 * readback here.
719 * We only do this when the hook is != 0, as they are often set to 0 temporarily,
720 * not expecting this to actually change the hook. This is a potential problem
721 * when a schedule happens then, but we ignore this.
722 */
723static int
724coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
725{
726 const char *s = MgPV_nolen_const (mg);
727
728 if (*s == '_')
729 {
730 SV **svp = 0;
731
732 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
733 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
734
735 if (svp)
736 {
737 sv_setsv (sv, *svp ? *svp : &PL_sv_undef);
738 return 0;
739 }
740 }
741
742 return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
743}
744
745static int
746coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
747{
748 const char *s = MgPV_nolen_const (mg);
749
750 if (*s == '_')
751 {
752 SV **svp = 0;
753
754 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
755 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
756
757 if (svp)
758 {
759 SV *old = *svp;
760 *svp = 0;
761 SvREFCNT_dec (old);
762 return 0;
763 }
764 }
765
766 return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
767}
768
769static int
770coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
771{
772 const char *s = MgPV_nolen_const (mg);
773
774 if (*s == '_')
775 {
776 SV **svp = 0;
777
778 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
779 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
780
781 if (svp)
782 {
783 SV *old = *svp;
784 *svp = newSVsv (sv);
785 SvREFCNT_dec (old);
786 return 0;
787 }
788 }
789
790 return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
791}
792
793static void
794coro_setup (pTHX_ struct coro *coro)
795{
796 /*
797 * emulate part of the perl startup here.
798 */
799 coro_init_stacks (aTHX);
800
801 PL_runops = RUNOPS_DEFAULT;
802 PL_curcop = &PL_compiling;
803 PL_in_eval = EVAL_NULL;
804 PL_comppad = 0;
805 PL_curpm = 0;
806 PL_curpad = 0;
807 PL_localizing = 0;
808 PL_dirty = 0;
809 PL_restartop = 0;
810#if PERL_VERSION_ATLEAST (5,10,0)
811 PL_parser = 0;
812#endif
813
814 /* recreate the die/warn hooks */
815 PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
816 PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
817
818 GvSV (PL_defgv) = newSV (0);
819 GvAV (PL_defgv) = coro->args; coro->args = 0;
820 GvSV (PL_errgv) = newSV (0);
821 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
822 PL_rs = newSVsv (GvSV (irsgv));
823 PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
824
825 {
826 dSP;
827 LOGOP myop;
828
829 Zero (&myop, 1, LOGOP);
830 myop.op_next = Nullop;
831 myop.op_flags = OPf_WANT_VOID;
832
833 PUSHMARK (SP);
834 XPUSHs (sv_2mortal (av_shift (GvAV (PL_defgv))));
835 PUTBACK;
836 PL_op = (OP *)&myop;
837 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
838 SPAGAIN;
839 }
840
841 /* this newly created coroutine might be run on an existing cctx which most
842 * likely was suspended in set_stacklevel, called from entersub.
843 * set_stacklevl doesn't do anything on return, but entersub does LEAVE,
844 * so we ENTER here for symmetry
845 */
846 ENTER;
847}
848
849static void
850coro_destruct (pTHX_ struct coro *coro)
851{
852 if (!IN_DESTRUCT)
853 {
854 /* restore all saved variables and stuff */
855 LEAVE_SCOPE (0);
856 assert (PL_tmps_floor == -1);
857
858 /* free all temporaries */
859 FREETMPS;
860 assert (PL_tmps_ix == -1);
861
862 /* unwind all extra stacks */
863 POPSTACK_TO (PL_mainstack);
864
865 /* unwind main stack */
866 dounwind (-1);
867 }
868
869 SvREFCNT_dec (GvSV (PL_defgv));
870 SvREFCNT_dec (GvAV (PL_defgv));
871 SvREFCNT_dec (GvSV (PL_errgv));
872 SvREFCNT_dec (PL_defoutgv);
873 SvREFCNT_dec (PL_rs);
874 SvREFCNT_dec (GvSV (irsgv));
875
876 SvREFCNT_dec (PL_diehook);
877 SvREFCNT_dec (PL_warnhook);
878
879 SvREFCNT_dec (coro->saved_deffh);
880 SvREFCNT_dec (coro->throw);
881
882 coro_destruct_stacks (aTHX);
883}
884
885static void
886free_coro_mortal (pTHX)
887{
888 if (expect_true (coro_mortal))
889 {
890 SvREFCNT_dec (coro_mortal);
891 coro_mortal = 0;
892 }
893}
894
895static int
896runops_trace (pTHX)
897{
898 COP *oldcop = 0;
899 int oldcxix = -2;
900 struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
901 coro_cctx *cctx = coro->cctx;
902
903 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
904 {
905 PERL_ASYNC_CHECK ();
906
907 if (cctx->flags & CC_TRACE_ALL)
908 {
909 if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
910 {
911 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
912 SV **bot, **top;
913 AV *av = newAV (); /* return values */
914 SV **cb;
915 dSP;
916
917 GV *gv = CvGV (cx->blk_sub.cv);
918 SV *fullname = sv_2mortal (newSV (0));
919 if (isGV (gv))
920 gv_efullname3 (fullname, gv, 0);
921
922 bot = PL_stack_base + cx->blk_oldsp + 1;
923 top = cx->blk_gimme == G_ARRAY ? SP + 1
924 : cx->blk_gimme == G_SCALAR ? bot + 1
925 : bot;
926
927 av_extend (av, top - bot);
928 while (bot < top)
929 av_push (av, SvREFCNT_inc_NN (*bot++));
930
931 PL_runops = RUNOPS_DEFAULT;
932 ENTER;
933 SAVETMPS;
934 EXTEND (SP, 3);
935 PUSHMARK (SP);
936 PUSHs (&PL_sv_no);
937 PUSHs (fullname);
938 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
939 PUTBACK;
940 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
941 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
942 SPAGAIN;
943 FREETMPS;
944 LEAVE;
945 PL_runops = runops_trace;
946 }
947
948 if (oldcop != PL_curcop)
949 {
950 oldcop = PL_curcop;
951
952 if (PL_curcop != &PL_compiling)
953 {
954 SV **cb;
955
956 if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
957 {
958 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
959
960 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
961 {
962 runops_proc_t old_runops = PL_runops;
963 dSP;
964 GV *gv = CvGV (cx->blk_sub.cv);
965 SV *fullname = sv_2mortal (newSV (0));
966
967 if (isGV (gv))
968 gv_efullname3 (fullname, gv, 0);
969
970 PL_runops = RUNOPS_DEFAULT;
971 ENTER;
972 SAVETMPS;
973 EXTEND (SP, 3);
974 PUSHMARK (SP);
975 PUSHs (&PL_sv_yes);
976 PUSHs (fullname);
977 PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
978 PUTBACK;
979 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
980 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
981 SPAGAIN;
982 FREETMPS;
983 LEAVE;
984 PL_runops = runops_trace;
985 }
986
987 oldcxix = cxstack_ix;
988 }
989
990 if (cctx->flags & CC_TRACE_LINE)
991 {
992 dSP;
993
994 PL_runops = RUNOPS_DEFAULT;
995 ENTER;
996 SAVETMPS;
997 EXTEND (SP, 3);
998 PL_runops = RUNOPS_DEFAULT;
999 PUSHMARK (SP);
1000 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
1001 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
1002 PUTBACK;
1003 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_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 }
1012 }
1013 }
1014
1015 TAINT_NOT;
1016 return 0;
1017}
1018
1019/* inject a fake call to Coro::State::_cctx_init into the execution */
1020/* _cctx_init should be careful, as it could be called at almost any time */
1021/* during execution of a perl program */
1022static void NOINLINE
1023cctx_prepare (pTHX_ coro_cctx *cctx)
1024{
1025 dSP;
1026 LOGOP myop;
1027
1028 PL_top_env = &PL_start_env;
1029
1030 if (cctx->flags & CC_TRACE)
1031 PL_runops = runops_trace;
1032
1033 Zero (&myop, 1, LOGOP);
1034 myop.op_next = PL_op;
1035 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
1036
1037 PUSHMARK (SP);
1038 EXTEND (SP, 2);
1039 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
1040 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
1041 PUTBACK;
1042 PL_op = (OP *)&myop;
1043 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
1044 SPAGAIN;
1045}
1046
1047/*
1048 * this is a _very_ stripped down perl interpreter ;)
1049 */
1050static void
1051cctx_run (void *arg)
1052{
1053 dTHX;
1054
1055 /* cctx_run is the alternative tail of transfer(), so unlock here. */
1056 UNLOCK;
1057
1058 /* we now skip the entersub that lead to transfer() */
1059 PL_op = PL_op->op_next;
1060
1061 /* inject a fake subroutine call to cctx_init */
1062 cctx_prepare (aTHX_ (coro_cctx *)arg);
1063
1064 /* somebody or something will hit me for both perl_run and PL_restartop */
1065 PL_restartop = PL_op;
1066 perl_run (PL_curinterp);
1067
1068 /*
1069 * If perl-run returns we assume exit() was being called or the coro
1070 * fell off the end, which seems to be the only valid (non-bug)
1071 * reason for perl_run to return. We try to exit by jumping to the
1072 * bootstrap-time "top" top_env, as we cannot restore the "main"
1073 * coroutine as Coro has no such concept
1074 */
1075 PL_top_env = main_top_env;
1076 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
1077}
1078
1079static coro_cctx *
1080cctx_new ()
1081{
1082 coro_cctx *cctx;
1083 void *stack_start;
1084 size_t stack_size;
1085
1086 ++cctx_count;
1087 Newz (0, cctx, 1, coro_cctx);
1088
1089 cctx->gen = cctx_gen;
1090
1091#if HAVE_MMAP
1092 cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
1093 /* mmap supposedly does allocate-on-write for us */
1094 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
1095
1096 if (cctx->sptr != (void *)-1)
1097 {
1098# if CORO_STACKGUARD
1099 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
1100# endif
1101 stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
1102 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
1103 cctx->flags |= CC_MAPPED;
1104 }
1105 else
1106#endif
1107 {
1108 cctx->ssize = cctx_stacksize * (long)sizeof (long);
1109 New (0, cctx->sptr, cctx_stacksize, long);
1110
1111 if (!cctx->sptr)
1112 {
1113 perror ("FATAL: unable to allocate stack for coroutine");
1114 _exit (EXIT_FAILURE);
1115 }
1116
1117 stack_start = cctx->sptr;
1118 stack_size = cctx->ssize;
1119 }
1120
1121 REGISTER_STACK (cctx, (char *)stack_start, (char *)stack_start + stack_size);
1122 coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
1123
1124 return cctx;
1125}
1126
1127static void
1128cctx_destroy (coro_cctx *cctx)
1129{
1130 if (!cctx)
1131 return;
1132
1133 --cctx_count;
1134 coro_destroy (&cctx->cctx);
1135
1136 /* coro_transfer creates new, empty cctx's */
1137 if (cctx->sptr)
1138 {
1139#if CORO_USE_VALGRIND
1140 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1141#endif
1142
1143#if HAVE_MMAP
1144 if (cctx->flags & CC_MAPPED)
1145 munmap (cctx->sptr, cctx->ssize);
1146 else
1147#endif
1148 Safefree (cctx->sptr);
1149 }
1150
1151 Safefree (cctx);
1152}
1153
1154/* wether this cctx should be destructed */
1155#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1156
1157static coro_cctx *
1158cctx_get (pTHX)
1159{
1160 while (expect_true (cctx_first))
1161 {
1162 coro_cctx *cctx = cctx_first;
1163 cctx_first = cctx->next;
1164 --cctx_idle;
1165
1166 if (expect_true (!CCTX_EXPIRED (cctx)))
1167 return cctx;
1168
1169 cctx_destroy (cctx);
1170 }
1171
1172 return cctx_new ();
1173}
1174
1175static void
1176cctx_put (coro_cctx *cctx)
1177{
1178 assert (("cctx_put called on non-initialised cctx", cctx->sptr));
1179
1180 /* free another cctx if overlimit */
1181 if (expect_false (cctx_idle >= cctx_max_idle))
1182 {
1183 coro_cctx *first = cctx_first;
1184 cctx_first = first->next;
1185 --cctx_idle;
1186
1187 cctx_destroy (first);
1188 }
1189
1190 ++cctx_idle;
1191 cctx->next = cctx_first;
1192 cctx_first = cctx;
1193}
1194
1195/** coroutine switching *****************************************************/
1196
1197static void
1198transfer_check (pTHX_ struct coro *prev, struct coro *next)
1199{
1200 if (expect_true (prev != next))
1201 {
1202 if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1203 croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
1204
1205 if (expect_false (next->flags & CF_RUNNING))
1206 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
1207
1208 if (expect_false (next->flags & CF_DESTROYED))
1209 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
1210
1211#if !PERL_VERSION_ATLEAST (5,10,0)
1212 if (expect_false (PL_lex_state != LEX_NOTPARSING))
1213 croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version");
1214#endif
1215 }
1216}
1217
1218/* always use the TRANSFER macro */
1219static void NOINLINE
1220transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1221{
1222 dSTACKLEVEL;
1223
1224 /* sometimes transfer is only called to set idle_sp */
1225 if (expect_false (!next))
1226 {
1227 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
1228 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1229 }
1230 else if (expect_true (prev != next))
1231 {
1232 static volatile int has_throw;
1233 coro_cctx *prev__cctx;
1234
1235 if (expect_false (prev->flags & CF_NEW))
1236 {
1237 /* create a new empty/source context */
1238 ++cctx_count;
1239 New (0, prev->cctx, 1, coro_cctx);
1240 prev->cctx->sptr = 0;
1241 coro_create (&prev->cctx->cctx, 0, 0, 0, 0);
1242
1243 prev->flags &= ~CF_NEW;
1244 prev->flags |= CF_RUNNING;
1245 }
1246
1247 prev->flags &= ~CF_RUNNING;
1248 next->flags |= CF_RUNNING;
1249
1250 LOCK;
1251
1252 /* first get rid of the old state */
1253 save_perl (aTHX_ prev);
1254
1255 if (expect_false (next->flags & CF_NEW))
1256 {
1257 /* need to start coroutine */
1258 next->flags &= ~CF_NEW;
1259 /* setup coroutine call */
1260 coro_setup (aTHX_ next);
1261 }
1262 else
1263 load_perl (aTHX_ next);
1264
1265 prev__cctx = prev->cctx;
1266
1267 /* possibly "free" the cctx */
1268 if (expect_true (
1269 prev__cctx->idle_sp == STACKLEVEL
1270 && !(prev__cctx->flags & CC_TRACE)
1271 && !force_cctx
1272 ))
1273 {
1274 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
1275 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
1276
1277 prev->cctx = 0;
1278
1279 /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
1280 /* without this the next cctx_get might destroy the prev__cctx while still in use */
1281 if (expect_false (CCTX_EXPIRED (prev__cctx)))
1282 if (!next->cctx)
1283 next->cctx = cctx_get (aTHX);
1284
1285 cctx_put (prev__cctx);
1286 }
1287
1288 ++next->usecount;
1289
1290 if (expect_true (!next->cctx))
1291 next->cctx = cctx_get (aTHX);
1292
1293 has_throw = !!next->throw;
1294
1295 if (expect_false (prev__cctx != next->cctx))
1296 {
1297 prev__cctx->top_env = PL_top_env;
1298 PL_top_env = next->cctx->top_env;
1299 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
1300 }
1301
1302 free_coro_mortal (aTHX);
1303 UNLOCK;
1304
1305 if (expect_false (has_throw))
1306 {
1307 struct coro *coro = SvSTATE (coro_current);
1308
1309 if (coro->throw)
1310 {
1311 SV *exception = coro->throw;
1312 coro->throw = 0;
1313 sv_setsv (ERRSV, exception);
1314 croak (0);
1315 }
1316 }
1317 }
1318}
1319
1320struct transfer_args
1321{
1322 struct coro *prev, *next;
1323};
1324
1325#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1326#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1327
1328/** high level stuff ********************************************************/
1329
1330static int
1331coro_state_destroy (pTHX_ struct coro *coro)
1332{
1333 if (coro->flags & CF_DESTROYED)
1334 return 0;
1335
1336 coro->flags |= CF_DESTROYED;
1337
1338 if (coro->flags & CF_READY)
1339 {
1340 /* reduce nready, as destroying a ready coro effectively unreadies it */
1341 /* alternative: look through all ready queues and remove the coro */
1342 LOCK;
1343 --coro_nready;
1344 UNLOCK;
1345 }
1346 else
1347 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1348
1349 if (coro->mainstack && coro->mainstack != main_mainstack)
1350 {
1351 struct coro temp;
1352
1353 if (coro->flags & CF_RUNNING)
1354 croak ("FATAL: tried to destroy currently running coroutine");
1355
1356 save_perl (aTHX_ &temp);
1357 load_perl (aTHX_ coro);
1358
1359 coro_destruct (aTHX_ coro);
1360
1361 load_perl (aTHX_ &temp);
1362
1363 coro->slot = 0;
1364 }
1365
1366 cctx_destroy (coro->cctx);
1367 SvREFCNT_dec (coro->args);
1368
1369 if (coro->next) coro->next->prev = coro->prev;
1370 if (coro->prev) coro->prev->next = coro->next;
1371 if (coro == coro_first) coro_first = coro->next;
1372
1373 return 1;
1374}
1375
1376static int
1377coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1378{
1379 struct coro *coro = (struct coro *)mg->mg_ptr;
1380 mg->mg_ptr = 0;
1381
1382 coro->hv = 0;
1383
1384 if (--coro->refcnt < 0)
1385 {
1386 coro_state_destroy (aTHX_ coro);
1387 Safefree (coro);
1388 }
1389
1390 return 0;
1391}
1392
1393static int
1394coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1395{
1396 struct coro *coro = (struct coro *)mg->mg_ptr;
1397
1398 ++coro->refcnt;
1399
1400 return 0;
1401}
1402
1403static MGVTBL coro_state_vtbl = {
1404 0, 0, 0, 0,
1405 coro_state_free,
1406 0,
1407#ifdef MGf_DUP
1408 coro_state_dup,
1409#else
1410# define MGf_DUP 0
1411#endif
1412};
1413
1414static void
1415prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
1416{
1417 ta->prev = SvSTATE (prev_sv);
1418 ta->next = SvSTATE (next_sv);
1419 TRANSFER_CHECK (*ta);
1420}
1421
1422static void
1423api_transfer (SV *prev_sv, SV *next_sv)
1424{
1425 dTHX;
1426 struct transfer_args ta;
1427
1428 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1429 TRANSFER (ta, 1);
1430}
1431
1432/** Coro ********************************************************************/
1433
1434static void
1435coro_enq (pTHX_ SV *coro_sv)
1436{
1437 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1438}
1439
1440static SV *
1441coro_deq (pTHX)
1442{
1443 int prio;
1444
1445 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
1446 if (AvFILLp (coro_ready [prio]) >= 0)
1447 return av_shift (coro_ready [prio]);
1448
1449 return 0;
1450}
1451
1452static int
1453api_ready (SV *coro_sv)
1454{
1455 dTHX;
1456 struct coro *coro;
1457 SV *sv_hook;
1458 void (*xs_hook)(void);
1459
1460 if (SvROK (coro_sv))
1461 coro_sv = SvRV (coro_sv);
1462
1463 coro = SvSTATE (coro_sv);
1464
1465 if (coro->flags & CF_READY)
1466 return 0;
1467
1468 coro->flags |= CF_READY;
1469
1470 LOCK;
1471
1472 sv_hook = coro_nready ? 0 : coro_readyhook;
1473 xs_hook = coro_nready ? 0 : coroapi.readyhook;
1474
1475 coro_enq (aTHX_ SvREFCNT_inc_NN (coro_sv));
1476 ++coro_nready;
1477
1478 UNLOCK;
1479
1480 if (sv_hook)
1481 {
1482 dSP;
1483
1484 ENTER;
1485 SAVETMPS;
1486
1487 PUSHMARK (SP);
1488 PUTBACK;
1489 call_sv (sv_hook, G_DISCARD);
1490 SPAGAIN;
1491
1492 FREETMPS;
1493 LEAVE;
1494 }
1495
1496 if (xs_hook)
1497 xs_hook ();
1498
1499 return 1;
1500}
1501
1502static int
1503api_is_ready (SV *coro_sv)
1504{
1505 dTHX;
1506 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1507}
1508
1509static void
1510prepare_schedule (pTHX_ struct transfer_args *ta)
1511{
1512 SV *prev_sv, *next_sv;
1513
1514 for (;;)
1515 {
1516 LOCK;
1517 next_sv = coro_deq (aTHX);
1518
1519 /* nothing to schedule: call the idle handler */
1520 if (expect_false (!next_sv))
1521 {
1522 dSP;
1523 UNLOCK;
1524
1525 ENTER;
1526 SAVETMPS;
1527
1528 PUSHMARK (SP);
1529 PUTBACK;
1530 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1531 SPAGAIN;
1532
1533 FREETMPS;
1534 LEAVE;
1535 continue;
1536 }
1537
1538 ta->next = SvSTATE (next_sv);
1539
1540 /* cannot transfer to destroyed coros, skip and look for next */
1541 if (expect_false (ta->next->flags & CF_DESTROYED))
1542 {
1543 UNLOCK;
1544 SvREFCNT_dec (next_sv);
1545 /* coro_nready is already taken care of by destroy */
1546 continue;
1547 }
1548
1549 --coro_nready;
1550 UNLOCK;
1551 break;
1552 }
1553
1554 /* free this only after the transfer */
1555 prev_sv = SvRV (coro_current);
1556 ta->prev = SvSTATE (prev_sv);
1557 TRANSFER_CHECK (*ta);
1558 assert (ta->next->flags & CF_READY);
1559 ta->next->flags &= ~CF_READY;
1560 SvRV_set (coro_current, next_sv);
1561
1562 LOCK;
1563 free_coro_mortal (aTHX);
1564 coro_mortal = prev_sv;
1565 UNLOCK;
1566}
1567
1568static void
1569prepare_cede (pTHX_ struct transfer_args *ta)
1570{
1571 api_ready (coro_current);
1572 prepare_schedule (aTHX_ ta);
1573}
1574
1575static int
1576prepare_cede_notself (pTHX_ struct transfer_args *ta)
1577{
1578 if (coro_nready)
1579 {
1580 SV *prev = SvRV (coro_current);
1581 prepare_schedule (aTHX_ ta);
1582 api_ready (prev);
1583 return 1;
1584 }
1585 else
1586 return 0;
1587}
1588
1589static void
1590api_schedule (void)
1591{
1592 dTHX;
1593 struct transfer_args ta;
1594
1595 prepare_schedule (aTHX_ &ta);
1596 TRANSFER (ta, 1);
1597}
1598
1599static int
1600api_cede (void)
1601{
1602 dTHX;
1603 struct transfer_args ta;
1604
1605 prepare_cede (aTHX_ &ta);
1606
1607 if (expect_true (ta.prev != ta.next))
1608 {
1609 TRANSFER (ta, 1);
1610 return 1;
1611 }
1612 else
1613 return 0;
1614}
1615
1616static int
1617api_cede_notself (void)
1618{
1619 dTHX;
1620 struct transfer_args ta;
1621
1622 if (prepare_cede_notself (aTHX_ &ta))
1623 {
1624 TRANSFER (ta, 1);
1625 return 1;
1626 }
1627 else
1628 return 0;
1629}
1630
1631static void
1632api_trace (SV *coro_sv, int flags)
1633{
1634 dTHX;
1635 struct coro *coro = SvSTATE (coro_sv);
1636
1637 if (flags & CC_TRACE)
1638 {
1639 if (!coro->cctx)
1640 coro->cctx = cctx_new ();
1641 else if (!(coro->cctx->flags & CC_TRACE))
1642 croak ("cannot enable tracing on coroutine with custom stack");
1643
1644 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1645 }
1646 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1647 {
1648 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1649
1650 if (coro->flags & CF_RUNNING)
1651 PL_runops = RUNOPS_DEFAULT;
1652 else
1653 coro->slot->runops = RUNOPS_DEFAULT;
1654 }
1655}
1656
1657static int
1658coro_gensub_free (pTHX_ SV *sv, MAGIC *mg)
1659{
1660 AV *padlist;
1661 AV *av = (AV *)mg->mg_obj;
1662
1663 abort ();
1664
1665 return 0;
1666}
1667
1668static MGVTBL coro_gensub_vtbl = {
1669 0, 0, 0, 0,
1670 coro_gensub_free
1671};
1672
1673/*****************************************************************************/
1674/* PerlIO::cede */
1675
1676typedef struct
1677{
1678 PerlIOBuf base;
1679 NV next, every;
1680} PerlIOCede;
1681
1682static IV
1683PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1684{
1685 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1686
1687 self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
1688 self->next = nvtime () + self->every;
1689
1690 return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
1691}
1692
1693static SV *
1694PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
1695{
1696 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1697
1698 return newSVnv (self->every);
1699}
1700
1701static IV
1702PerlIOCede_flush (pTHX_ PerlIO *f)
1703{
1704 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1705 double now = nvtime ();
1706
1707 if (now >= self->next)
1708 {
1709 api_cede ();
1710 self->next = now + self->every;
1711 }
1712
1713 return PerlIOBuf_flush (aTHX_ f);
1714}
1715
1716static PerlIO_funcs PerlIO_cede =
1717{
1718 sizeof(PerlIO_funcs),
1719 "cede",
1720 sizeof(PerlIOCede),
1721 PERLIO_K_DESTRUCT | PERLIO_K_RAW,
1722 PerlIOCede_pushed,
1723 PerlIOBuf_popped,
1724 PerlIOBuf_open,
1725 PerlIOBase_binmode,
1726 PerlIOCede_getarg,
1727 PerlIOBase_fileno,
1728 PerlIOBuf_dup,
1729 PerlIOBuf_read,
1730 PerlIOBuf_unread,
1731 PerlIOBuf_write,
1732 PerlIOBuf_seek,
1733 PerlIOBuf_tell,
1734 PerlIOBuf_close,
1735 PerlIOCede_flush,
1736 PerlIOBuf_fill,
1737 PerlIOBase_eof,
1738 PerlIOBase_error,
1739 PerlIOBase_clearerr,
1740 PerlIOBase_setlinebuf,
1741 PerlIOBuf_get_base,
1742 PerlIOBuf_bufsiz,
1743 PerlIOBuf_get_ptr,
1744 PerlIOBuf_get_cnt,
1745 PerlIOBuf_set_ptrcnt,
1746};
1747
1748
1749MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
1750
1751PROTOTYPES: DISABLE
1752
1753BOOT:
1754{
1755#ifdef USE_ITHREADS
1756 MUTEX_INIT (&coro_lock);
1757#endif
1758 BOOT_PAGESIZE;
1759
1760 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
1761 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
1762
1763 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
1764 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
1765 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
1766
1767 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
1768 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
1769 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
1770
1771 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1772
1773 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1774 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1775 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1776 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1777
1778 main_mainstack = PL_mainstack;
1779 main_top_env = PL_top_env;
1780
1781 while (main_top_env->je_prev)
1782 main_top_env = main_top_env->je_prev;
1783
1784 coroapi.ver = CORO_API_VERSION;
1785 coroapi.rev = CORO_API_REVISION;
1786 coroapi.transfer = api_transfer;
1787
1788 {
1789 SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
1790
1791 if (!svp) croak ("Time::HiRes is required");
1792 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
1793
1794 nvtime = INT2PTR (double (*)(), SvIV (*svp));
1795 }
1796
1797 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1798}
1799
1800SV *
1801new (char *klass, ...)
1802 CODE:
1803{
1804 struct coro *coro;
1805 MAGIC *mg;
1806 HV *hv;
1807 int i;
1808
1809 Newz (0, coro, 1, struct coro);
1810 coro->args = newAV ();
1811 coro->flags = CF_NEW;
1812
1813 if (coro_first) coro_first->prev = coro;
1814 coro->next = coro_first;
1815 coro_first = coro;
1816
1817 coro->hv = hv = newHV ();
1818 mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
1819 mg->mg_flags |= MGf_DUP;
1820 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1821
1822 av_extend (coro->args, items - 1);
1823 for (i = 1; i < items; i++)
1824 av_push (coro->args, newSVsv (ST (i)));
1825}
1826 OUTPUT:
1827 RETVAL
1828
1829# these not obviously related functions are all rolled into the same xs
1830# function to increase chances that they all will call transfer with the same
1831# stack offset
1832void
1833_set_stacklevel (...)
1834 ALIAS:
1835 Coro::State::transfer = 1
1836 Coro::schedule = 2
1837 Coro::cede = 3
1838 Coro::cede_notself = 4
1839 CODE:
1840{
1841 struct transfer_args ta;
1842
1843 PUTBACK;
1844 switch (ix)
1845 {
1846 case 0:
1847 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1848 ta.next = 0;
1849 break;
1850
1851 case 1:
1852 if (items != 2)
1853 croak ("Coro::State::transfer (prev, next) expects two arguments, not %d", items);
1854
1855 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
1856 break;
1857
1858 case 2:
1859 prepare_schedule (aTHX_ &ta);
1860 break;
1861
1862 case 3:
1863 prepare_cede (aTHX_ &ta);
1864 break;
1865
1866 case 4:
1867 if (!prepare_cede_notself (aTHX_ &ta))
1868 XSRETURN_EMPTY;
1869
1870 break;
1871 }
1872 SPAGAIN;
1873
1874 BARRIER;
1875 PUTBACK;
1876 TRANSFER (ta, 0);
1877 SPAGAIN; /* might be the sp of a different coroutine now */
1878 /* be extra careful not to ever do anything after TRANSFER */
1879}
1880
1881bool
1882_destroy (SV *coro_sv)
1883 CODE:
1884 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1885 OUTPUT:
1886 RETVAL
1887
1888void
1889_exit (int code)
1890 PROTOTYPE: $
1891 CODE:
1892 _exit (code);
1893
1894int
1895cctx_stacksize (int new_stacksize = 0)
1896 CODE:
1897 RETVAL = cctx_stacksize;
1898 if (new_stacksize)
1899 {
1900 cctx_stacksize = new_stacksize;
1901 ++cctx_gen;
1902 }
1903 OUTPUT:
1904 RETVAL
1905
1906int
1907cctx_max_idle (int max_idle = 0)
1908 CODE:
1909 RETVAL = cctx_max_idle;
1910 if (max_idle > 1)
1911 cctx_max_idle = max_idle;
1912 OUTPUT:
1913 RETVAL
1914
1915int
1916cctx_count ()
1917 CODE:
1918 RETVAL = cctx_count;
1919 OUTPUT:
1920 RETVAL
1921
1922int
1923cctx_idle ()
1924 CODE:
1925 RETVAL = cctx_idle;
1926 OUTPUT:
1927 RETVAL
1928
1929void
1930list ()
1931 PPCODE:
1932{
1933 struct coro *coro;
1934 for (coro = coro_first; coro; coro = coro->next)
1935 if (coro->hv)
1936 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1937}
1938
1939void
1940call (Coro::State coro, SV *coderef)
1941 ALIAS:
1942 eval = 1
1943 CODE:
1944{
1945 if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
1946 {
1947 struct coro temp;
1948
1949 if (!(coro->flags & CF_RUNNING))
235 { 1950 {
236 /* I never used formats, so how should I know how these are implemented? */ 1951 PUTBACK;
237 /* my bold guess is as a simple, plain sub... */ 1952 save_perl (aTHX_ &temp);
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 1953 load_perl (aTHX_ coro);
1954 }
1955
1956 {
1957 dSP;
1958 ENTER;
1959 SAVETMPS;
1960 PUTBACK;
1961 PUSHSTACK;
1962 PUSHMARK (SP);
1963
1964 if (ix)
1965 eval_sv (coderef, 0);
1966 else
1967 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1968
1969 POPSTACK;
1970 SPAGAIN;
1971 FREETMPS;
1972 LEAVE;
1973 PUTBACK;
1974 }
1975
1976 if (!(coro->flags & CF_RUNNING))
1977 {
1978 save_perl (aTHX_ coro);
1979 load_perl (aTHX_ &temp);
1980 SPAGAIN;
239 } 1981 }
240 } 1982 }
241
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} 1983}
281 1984
282#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0) 1985SV *
283#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0) 1986is_ready (Coro::State coro)
1987 PROTOTYPE: $
1988 ALIAS:
1989 is_ready = CF_READY
1990 is_running = CF_RUNNING
1991 is_new = CF_NEW
1992 is_destroyed = CF_DESTROYED
1993 CODE:
1994 RETVAL = boolSV (coro->flags & ix);
1995 OUTPUT:
1996 RETVAL
284 1997
285static void 1998void
286load_state(pTHX_ Coro__State c) 1999api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
287{
288 PL_dowarn = c->dowarn;
289 GvAV (PL_defgv) = c->defav;
290 PL_curstackinfo = c->curstackinfo;
291 PL_curstack = c->curstack;
292 PL_mainstack = c->mainstack;
293 PL_stack_sp = c->stack_sp;
294 PL_op = c->op;
295 PL_curpad = c->curpad;
296 PL_stack_base = c->stack_base;
297 PL_stack_max = c->stack_max;
298 PL_tmps_stack = c->tmps_stack;
299 PL_tmps_floor = c->tmps_floor;
300 PL_tmps_ix = c->tmps_ix;
301 PL_tmps_max = c->tmps_max;
302 PL_markstack = c->markstack;
303 PL_markstack_ptr = c->markstack_ptr;
304 PL_markstack_max = c->markstack_max;
305 PL_scopestack = c->scopestack;
306 PL_scopestack_ix = c->scopestack_ix;
307 PL_scopestack_max = c->scopestack_max;
308 PL_savestack = c->savestack;
309 PL_savestack_ix = c->savestack_ix;
310 PL_savestack_max = c->savestack_max;
311 PL_retstack = c->retstack;
312 PL_retstack_ix = c->retstack_ix;
313 PL_retstack_max = c->retstack_max;
314 PL_curcop = c->curcop;
315 2000
2001SV *
2002has_cctx (Coro::State coro)
2003 PROTOTYPE: $
2004 CODE:
2005 RETVAL = boolSV (!!coro->cctx);
2006 OUTPUT:
2007 RETVAL
2008
2009int
2010is_traced (Coro::State coro)
2011 PROTOTYPE: $
2012 CODE:
2013 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
2014 OUTPUT:
2015 RETVAL
2016
2017IV
2018rss (Coro::State coro)
2019 PROTOTYPE: $
2020 ALIAS:
2021 usecount = 1
2022 CODE:
2023 switch (ix)
316 { 2024 {
317 dSP; 2025 case 0: RETVAL = coro_rss (aTHX_ coro); break;
318 CV *cv; 2026 case 1: RETVAL = coro->usecount; break;
319
320 /* now do the ugly restore mess */
321 while ((cv = (CV *)POPs))
322 {
323 AV *padlist = (AV *)POPs;
324
325 put_padlist (cv);
326 CvPADLIST(cv) = padlist;
327 CvDEPTH(cv) = (I32)POPs;
328
329#ifdef USE_THREADS
330 CvOWNER(cv) = (struct perl_thread *)POPs;
331 error does not work either
332#endif
333 } 2027 }
2028 OUTPUT:
2029 RETVAL
334 2030
335 PUTBACK; 2031void
336 } 2032force_cctx ()
337} 2033 CODE:
2034 struct coro *coro = SvSTATE (coro_current);
2035 coro->cctx->idle_sp = 0;
338 2036
339/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 2037void
340STATIC void 2038swap_defsv (Coro::State self)
341destroy_stacks(pTHX) 2039 PROTOTYPE: $
342{ 2040 ALIAS:
343 /* die does this while calling POPSTACK, but I just don't see why. */ 2041 swap_defav = 1
344 /* OTOH, die does not have a memleak, but we do... */ 2042 CODE:
345 dounwind(-1); 2043 if (!self->slot)
2044 croak ("cannot swap state with coroutine that has no saved state");
2045 else
2046 {
2047 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
2048 SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
346 2049
347 /* is this ugly, I ask? */ 2050 SV *tmp = *src; *src = *dst; *dst = tmp;
348 while (PL_scopestack_ix) 2051 }
349 LEAVE;
350 2052
351 while (PL_curstackinfo->si_next)
352 PL_curstackinfo = PL_curstackinfo->si_next;
353
354 while (PL_curstackinfo)
355 {
356 PERL_SI *p = PL_curstackinfo->si_prev;
357
358 SvREFCNT_dec(PL_curstackinfo->si_stack);
359 Safefree(PL_curstackinfo->si_cxstack);
360 Safefree(PL_curstackinfo);
361 PL_curstackinfo = p;
362 }
363
364 if (PL_scopestack_ix != 0)
365 Perl_warner(aTHX_ WARN_INTERNAL,
366 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367 (long)PL_scopestack_ix);
368 if (PL_savestack_ix != 0)
369 Perl_warner(aTHX_ WARN_INTERNAL,
370 "Unbalanced saves: %ld more saves than restores\n",
371 (long)PL_savestack_ix);
372 if (PL_tmps_floor != -1)
373 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374 (long)PL_tmps_floor + 1);
375 /*
376 */
377 Safefree(PL_tmps_stack);
378 Safefree(PL_markstack);
379 Safefree(PL_scopestack);
380 Safefree(PL_savestack);
381 Safefree(PL_retstack);
382}
383
384#define SUB_INIT "Coro::State::_newcoro"
385
386MODULE = Coro::State PACKAGE = Coro::State 2053MODULE = Coro::State PACKAGE = Coro
387
388PROTOTYPES: ENABLE
389 2054
390BOOT: 2055BOOT:
391 if (!padlist_cache) 2056{
392 padlist_cache = newHV (); 2057 int i;
393 2058
394Coro::State 2059 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
395_newprocess(args) 2060 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
396 SV * args 2061 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
2062
2063 coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
2064 SvREADONLY_on (coro_current);
2065
2066 coro_stash = gv_stashpv ("Coro", TRUE);
2067
2068 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
2069 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
2070 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
2071 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
2072 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
2073 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
2074
2075 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
2076 coro_ready[i] = newAV ();
2077
2078 {
2079 SV *sv = perl_get_sv ("Coro::API", TRUE);
2080 perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
2081
2082 coroapi.schedule = api_schedule;
2083 coroapi.cede = api_cede;
2084 coroapi.cede_notself = api_cede_notself;
2085 coroapi.ready = api_ready;
2086 coroapi.is_ready = api_is_ready;
2087 coroapi.nready = &coro_nready;
2088 coroapi.current = coro_current;
2089
2090 GCoroAPI = &coroapi;
2091 sv_setiv (sv, (IV)&coroapi);
2092 SvREADONLY_on (sv);
2093 }
2094}
2095
2096void
2097_set_current (SV *current)
397 PROTOTYPE: $ 2098 PROTOTYPE: $
2099 CODE:
2100 SvREFCNT_dec (SvRV (coro_current));
2101 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
2102
2103void
2104_set_readyhook (SV *hook)
2105 PROTOTYPE: $
398 CODE: 2106 CODE:
399 Coro__State coro;
400
401 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
402 croak ("Coro::State::newprocess expects an arrayref");
403 2107 LOCK;
404 New (0, coro, 1, struct coro); 2108 SvREFCNT_dec (coro_readyhook);
2109 coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
2110 UNLOCK;
405 2111
406 coro->mainstack = 0; /* actual work is done inside transfer */ 2112int
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 2113prio (Coro::State coro, int newprio = 0)
408 2114 ALIAS:
2115 nice = 1
2116 CODE:
2117{
409 RETVAL = coro; 2118 RETVAL = coro->prio;
410 OUTPUT: 2119
2120 if (items > 1)
2121 {
2122 if (ix)
2123 newprio = coro->prio - newprio;
2124
2125 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
2126 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
2127
2128 coro->prio = newprio;
2129 }
2130}
2131 OUTPUT:
411 RETVAL 2132 RETVAL
412 2133
2134SV *
2135ready (SV *self)
2136 PROTOTYPE: $
2137 CODE:
2138 RETVAL = boolSV (api_ready (self));
2139 OUTPUT:
2140 RETVAL
2141
2142int
2143nready (...)
2144 PROTOTYPE:
2145 CODE:
2146 RETVAL = coro_nready;
2147 OUTPUT:
2148 RETVAL
2149
413void 2150void
414transfer(prev,next) 2151throw (Coro::State self, SV *throw = &PL_sv_undef)
415 Coro::State_or_hashref prev 2152 PROTOTYPE: $;$
416 Coro::State_or_hashref next
417 CODE: 2153 CODE:
2154 SvREFCNT_dec (self->throw);
2155 self->throw = SvOK (throw) ? newSVsv (throw) : 0;
418 2156
419 if (prev != next) 2157# for async_pool speedup
2158void
2159_pool_1 (SV *cb)
2160 CODE:
2161{
2162 struct coro *coro = SvSTATE (coro_current);
2163 HV *hv = (HV *)SvRV (coro_current);
2164 AV *defav = GvAV (PL_defgv);
2165 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
2166 AV *invoke_av;
2167 int i, len;
2168
2169 if (!invoke)
420 { 2170 {
421 /* 2171 SV *old = PL_diehook;
422 * this could be done in newprocess which would lead to 2172 PL_diehook = 0;
423 * extremely elegant and fast (just SAVE/LOAD) 2173 SvREFCNT_dec (old);
424 * code here, but lazy allocation of stacks has also 2174 croak ("\3async_pool terminate\2\n");
425 * some virtues and the overhead of the if() is nil.
426 */
427 if (next->mainstack)
428 {
429 SAVE (prev);
430 LOAD (next);
431 /* mark this state as in-use */
432 next->mainstack = 0;
433 next->tmps_ix = -2;
434 }
435 else if (next->tmps_ix == -2)
436 {
437 croak ("tried to transfer to running coroutine");
438 }
439 else
440 {
441 SAVE (prev);
442
443 /*
444 * emulate part of the perl startup here.
445 */
446 UNOP myop;
447
448 init_stacks (); /* from perl.c */
449 PL_op = (OP *)&myop;
450 /*PL_curcop = 0;*/
451 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452
453 SPAGAIN;
454 Zero(&myop, 1, UNOP);
455 myop.op_next = Nullop;
456 myop.op_flags = OPf_WANT_VOID;
457
458 PUSHMARK(SP);
459 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460 PUTBACK;
461 /*
462 * the next line is slightly wrong, as PL_op->op_next
463 * is actually being executed so we skip the first op.
464 * that doesn't matter, though, since it is only
465 * pp_nextstate and we never return...
466 */
467 PL_op = Perl_pp_entersub(aTHX);
468 SPAGAIN;
469
470 ENTER;
471 }
472 } 2175 }
473 2176
2177 SvREFCNT_dec (coro->saved_deffh);
2178 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
2179
2180 hv_store (hv, "desc", sizeof ("desc") - 1,
2181 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
2182
2183 invoke_av = (AV *)SvRV (invoke);
2184 len = av_len (invoke_av);
2185
2186 sv_setsv (cb, AvARRAY (invoke_av)[0]);
2187
2188 if (len > 0)
2189 {
2190 av_fill (defav, len - 1);
2191 for (i = 0; i < len; ++i)
2192 av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
2193 }
2194
2195 SvREFCNT_dec (invoke);
2196}
2197
474void 2198void
475DESTROY(coro) 2199_pool_2 (SV *cb)
476 Coro::State coro 2200 CODE:
2201{
2202 struct coro *coro = SvSTATE (coro_current);
2203
2204 sv_setsv (cb, &PL_sv_undef);
2205
2206 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
2207 coro->saved_deffh = 0;
2208
2209 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
2210 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2211 {
2212 SV *old = PL_diehook;
2213 PL_diehook = 0;
2214 SvREFCNT_dec (old);
2215 croak ("\3async_pool terminate\2\n");
2216 }
2217
2218 av_clear (GvAV (PL_defgv));
2219 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
2220 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
2221
2222 coro->prio = 0;
2223
2224 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
2225 api_trace (coro_current, 0);
2226
2227 av_push (av_async_pool, newSVsv (coro_current));
2228}
2229
2230#if 0
2231
2232void
2233_generator_call (...)
2234 PROTOTYPE: @
2235 PPCODE:
2236 fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
2237 xxxx
2238 abort ();
2239
2240SV *
2241gensub (SV *sub, ...)
2242 PROTOTYPE: &;@
477 CODE: 2243 CODE:
2244{
2245 struct coro *coro;
2246 MAGIC *mg;
2247 CV *xcv;
2248 CV *ncv = (CV *)newSV_type (SVt_PVCV);
2249 int i;
478 2250
479 if (coro->mainstack) 2251 CvGV (ncv) = CvGV (cv);
2252 CvFILE (ncv) = CvFILE (cv);
2253
2254 Newz (0, coro, 1, struct coro);
2255 coro->args = newAV ();
2256 coro->flags = CF_NEW;
2257
2258 av_extend (coro->args, items - 1);
2259 for (i = 1; i < items; i++)
2260 av_push (coro->args, newSVsv (ST (i)));
2261
2262 CvISXSUB_on (ncv);
2263 CvXSUBANY (ncv).any_ptr = (void *)coro;
2264
2265 xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
2266
2267 CvXSUB (ncv) = CvXSUB (xcv);
2268 CvANON_on (ncv);
2269
2270 mg = sv_magicext ((SV *)ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char *)coro, 0);
2271 RETVAL = newRV_noinc ((SV *)ncv);
2272}
2273 OUTPUT:
2274 RETVAL
2275
2276#endif
2277
2278
2279MODULE = Coro::State PACKAGE = Coro::AIO
2280
2281void
2282_get_state (SV *self)
2283 PPCODE:
2284{
2285 AV *defav = GvAV (PL_defgv);
2286 AV *av = newAV ();
2287 int i;
2288 SV *data_sv = newSV (sizeof (struct io_state));
2289 struct io_state *data = (struct io_state *)SvPVX (data_sv);
2290 SvCUR_set (data_sv, sizeof (struct io_state));
2291 SvPOK_only (data_sv);
2292
2293 data->errorno = errno;
2294 data->laststype = PL_laststype;
2295 data->laststatval = PL_laststatval;
2296 data->statcache = PL_statcache;
2297
2298 av_extend (av, AvFILLp (defav) + 1 + 1);
2299
2300 for (i = 0; i <= AvFILLp (defav); ++i)
2301 av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
2302
2303 av_push (av, data_sv);
2304
2305 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
2306
2307 api_ready (self);
2308}
2309
2310void
2311_set_state (SV *state)
2312 PROTOTYPE: $
2313 PPCODE:
2314{
2315 AV *av = (AV *)SvRV (state);
2316 struct io_state *data = (struct io_state *)SvPVX (AvARRAY (av)[AvFILLp (av)]);
2317 int i;
2318
2319 errno = data->errorno;
2320 PL_laststype = data->laststype;
2321 PL_laststatval = data->laststatval;
2322 PL_statcache = data->statcache;
2323
2324 EXTEND (SP, AvFILLp (av));
2325 for (i = 0; i < AvFILLp (av); ++i)
2326 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
2327}
2328
2329
2330MODULE = Coro::State PACKAGE = Coro::AnyEvent
2331
2332BOOT:
2333 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
2334
2335SV *
2336_schedule (...)
2337 PROTOTYPE: @
2338 CODE:
2339{
2340 static int incede;
2341
2342 api_cede_notself ();
2343
2344 ++incede;
2345 while (coro_nready >= incede && api_cede ())
2346 ;
2347
2348 sv_setsv (sv_activity, &PL_sv_undef);
2349 if (coro_nready >= incede)
480 { 2350 {
481 struct coro temp; 2351 PUSHMARK (SP);
482 2352 PUTBACK;
483 SAVE(aTHX_ (&temp)); 2353 call_pv ("Coro::AnyEvent::_activity", G_DISCARD | G_EVAL);
484 LOAD(aTHX_ coro); 2354 SPAGAIN;
485
486 destroy_stacks ();
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488
489 LOAD((&temp));
490 } 2355 }
491 2356
492 SvREFCNT_dec (coro->args); 2357 --incede;
493 Safefree (coro); 2358}
494 2359
495 2360
2361MODULE = Coro::State PACKAGE = PerlIO::cede
2362
2363BOOT:
2364 PerlIO_define_layer (aTHX_ &PerlIO_cede);

Diff Legend

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