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.255 by root, Sat Nov 8 04:52:01 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; /* U16 in 5.10.0 */
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
162STATIC AV *
163unuse_padlist (AV *padlist)
164{
165 free_padlist (padlist);
166}
167
168static void 503static void
169SAVE(pTHX_ Coro__State c) 504save_perl (pTHX_ Coro__State c)
170{ 505{
171 { 506 {
172 dSP; 507 dSP;
173 I32 cxix = cxstack_ix; 508 I32 cxix = cxstack_ix;
509 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 510 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 511
177 /* 512 /*
178 * 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
179 * (and reinitialize) all cv's in the whole callchain :( 514 * (and reinitialize) all cv's in the whole callchain :(
180 */ 515 */
181 516
182 PUSHs (Nullsv); 517 XPUSHs (Nullsv);
183 /* this loop was inspired by pp_caller */ 518 /* this loop was inspired by pp_caller */
184 for (;;) 519 for (;;)
185 { 520 {
186 while (cxix >= 0) 521 while (expect_true (cxix >= 0))
187 { 522 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 523 PERL_CONTEXT *cx = &ccstk[cxix--];
189 524
190 if (CxTYPE(cx) == CXt_SUB) 525 if (expect_true (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT))
191 { 526 {
192 CV *cv = cx->blk_sub.cv; 527 CV *cv = cx->blk_sub.cv;
528
193 if (CvDEPTH(cv)) 529 if (expect_true (CvDEPTH (cv)))
194 { 530 {
195#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv));
197#endif
198 EXTEND (SP, 3); 531 EXTEND (SP, 3);
199 PUSHs ((SV *)CvDEPTH(cv));
200 PUSHs ((SV *)CvPADLIST(cv)); 532 PUSHs ((SV *)CvPADLIST (cv));
533 PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
201 PUSHs ((SV *)cv); 534 PUSHs ((SV *)cv);
202 535
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));
204
205 CvDEPTH(cv) = 0; 536 CvDEPTH (cv) = 0;
206#ifdef USE_THREADS 537 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 } 538 }
213 } 539 }
214 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
1657#if 0
1658static int
1659coro_gensub_free (pTHX_ SV *sv, MAGIC *mg)
1660{
1661 AV *padlist;
1662 AV *av = (AV *)mg->mg_obj;
1663
1664 abort ();
1665
1666 return 0;
1667}
1668
1669static MGVTBL coro_gensub_vtbl = {
1670 0, 0, 0, 0,
1671 coro_gensub_free
1672};
1673#endif
1674
1675/*****************************************************************************/
1676/* PerlIO::cede */
1677
1678typedef struct
1679{
1680 PerlIOBuf base;
1681 NV next, every;
1682} PerlIOCede;
1683
1684static IV
1685PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1686{
1687 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1688
1689 self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
1690 self->next = nvtime () + self->every;
1691
1692 return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
1693}
1694
1695static SV *
1696PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
1697{
1698 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1699
1700 return newSVnv (self->every);
1701}
1702
1703static IV
1704PerlIOCede_flush (pTHX_ PerlIO *f)
1705{
1706 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1707 double now = nvtime ();
1708
1709 if (now >= self->next)
1710 {
1711 api_cede ();
1712 self->next = now + self->every;
1713 }
1714
1715 return PerlIOBuf_flush (aTHX_ f);
1716}
1717
1718static PerlIO_funcs PerlIO_cede =
1719{
1720 sizeof(PerlIO_funcs),
1721 "cede",
1722 sizeof(PerlIOCede),
1723 PERLIO_K_DESTRUCT | PERLIO_K_RAW,
1724 PerlIOCede_pushed,
1725 PerlIOBuf_popped,
1726 PerlIOBuf_open,
1727 PerlIOBase_binmode,
1728 PerlIOCede_getarg,
1729 PerlIOBase_fileno,
1730 PerlIOBuf_dup,
1731 PerlIOBuf_read,
1732 PerlIOBuf_unread,
1733 PerlIOBuf_write,
1734 PerlIOBuf_seek,
1735 PerlIOBuf_tell,
1736 PerlIOBuf_close,
1737 PerlIOCede_flush,
1738 PerlIOBuf_fill,
1739 PerlIOBase_eof,
1740 PerlIOBase_error,
1741 PerlIOBase_clearerr,
1742 PerlIOBase_setlinebuf,
1743 PerlIOBuf_get_base,
1744 PerlIOBuf_bufsiz,
1745 PerlIOBuf_get_ptr,
1746 PerlIOBuf_get_cnt,
1747 PerlIOBuf_set_ptrcnt,
1748};
1749
1750
1751MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
1752
1753PROTOTYPES: DISABLE
1754
1755BOOT:
1756{
1757#ifdef USE_ITHREADS
1758 MUTEX_INIT (&coro_lock);
1759#endif
1760 BOOT_PAGESIZE;
1761
1762 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
1763 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
1764
1765 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
1766 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
1767 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
1768
1769 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
1770 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
1771 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
1772
1773 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1774
1775 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1776 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1777 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1778 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1779
1780 main_mainstack = PL_mainstack;
1781 main_top_env = PL_top_env;
1782
1783 while (main_top_env->je_prev)
1784 main_top_env = main_top_env->je_prev;
1785
1786 coroapi.ver = CORO_API_VERSION;
1787 coroapi.rev = CORO_API_REVISION;
1788 coroapi.transfer = api_transfer;
1789
1790 {
1791 SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
1792
1793 if (!svp) croak ("Time::HiRes is required");
1794 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
1795
1796 nvtime = INT2PTR (double (*)(), SvIV (*svp));
1797 }
1798
1799 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1800}
1801
1802SV *
1803new (char *klass, ...)
1804 CODE:
1805{
1806 struct coro *coro;
1807 MAGIC *mg;
1808 HV *hv;
1809 int i;
1810
1811 Newz (0, coro, 1, struct coro);
1812 coro->args = newAV ();
1813 coro->flags = CF_NEW;
1814
1815 if (coro_first) coro_first->prev = coro;
1816 coro->next = coro_first;
1817 coro_first = coro;
1818
1819 coro->hv = hv = newHV ();
1820 mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
1821 mg->mg_flags |= MGf_DUP;
1822 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1823
1824 av_extend (coro->args, items - 1);
1825 for (i = 1; i < items; i++)
1826 av_push (coro->args, newSVsv (ST (i)));
1827}
1828 OUTPUT:
1829 RETVAL
1830
1831# these not obviously related functions are all rolled into the same xs
1832# function to increase chances that they all will call transfer with the same
1833# stack offset
1834void
1835_set_stacklevel (...)
1836 ALIAS:
1837 Coro::State::transfer = 1
1838 Coro::schedule = 2
1839 Coro::cede = 3
1840 Coro::cede_notself = 4
1841 CODE:
1842{
1843 struct transfer_args ta;
1844
1845 PUTBACK;
1846 switch (ix)
1847 {
1848 case 0:
1849 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1850 ta.next = 0;
1851 break;
1852
1853 case 1:
1854 if (items != 2)
1855 croak ("Coro::State::transfer (prev, next) expects two arguments, not %d", items);
1856
1857 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
1858 break;
1859
1860 case 2:
1861 prepare_schedule (aTHX_ &ta);
1862 break;
1863
1864 case 3:
1865 prepare_cede (aTHX_ &ta);
1866 break;
1867
1868 case 4:
1869 if (!prepare_cede_notself (aTHX_ &ta))
1870 XSRETURN_EMPTY;
1871
1872 break;
1873 }
1874 SPAGAIN;
1875
1876 BARRIER;
1877 PUTBACK;
1878 TRANSFER (ta, 0);
1879 SPAGAIN; /* might be the sp of a different coroutine now */
1880 /* be extra careful not to ever do anything after TRANSFER */
1881}
1882
1883bool
1884_destroy (SV *coro_sv)
1885 CODE:
1886 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1887 OUTPUT:
1888 RETVAL
1889
1890void
1891_exit (int code)
1892 PROTOTYPE: $
1893 CODE:
1894 _exit (code);
1895
1896int
1897cctx_stacksize (int new_stacksize = 0)
1898 CODE:
1899 RETVAL = cctx_stacksize;
1900 if (new_stacksize)
1901 {
1902 cctx_stacksize = new_stacksize;
1903 ++cctx_gen;
1904 }
1905 OUTPUT:
1906 RETVAL
1907
1908int
1909cctx_max_idle (int max_idle = 0)
1910 CODE:
1911 RETVAL = cctx_max_idle;
1912 if (max_idle > 1)
1913 cctx_max_idle = max_idle;
1914 OUTPUT:
1915 RETVAL
1916
1917int
1918cctx_count ()
1919 CODE:
1920 RETVAL = cctx_count;
1921 OUTPUT:
1922 RETVAL
1923
1924int
1925cctx_idle ()
1926 CODE:
1927 RETVAL = cctx_idle;
1928 OUTPUT:
1929 RETVAL
1930
1931void
1932list ()
1933 PPCODE:
1934{
1935 struct coro *coro;
1936 for (coro = coro_first; coro; coro = coro->next)
1937 if (coro->hv)
1938 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1939}
1940
1941void
1942call (Coro::State coro, SV *coderef)
1943 ALIAS:
1944 eval = 1
1945 CODE:
1946{
1947 if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
1948 {
1949 struct coro temp;
1950
1951 if (!(coro->flags & CF_RUNNING))
215 { 1952 {
216 /* I never used formats, so how should I know how these are implemented? */ 1953 PUTBACK;
217 /* my bold guess is as a simple, plain sub... */ 1954 save_perl (aTHX_ &temp);
218 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 1955 load_perl (aTHX_ coro);
1956 }
1957
1958 {
1959 dSP;
1960 ENTER;
1961 SAVETMPS;
1962 PUTBACK;
1963 PUSHSTACK;
1964 PUSHMARK (SP);
1965
1966 if (ix)
1967 eval_sv (coderef, 0);
1968 else
1969 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1970
1971 POPSTACK;
1972 SPAGAIN;
1973 FREETMPS;
1974 LEAVE;
1975 PUTBACK;
1976 }
1977
1978 if (!(coro->flags & CF_RUNNING))
1979 {
1980 save_perl (aTHX_ coro);
1981 load_perl (aTHX_ &temp);
1982 SPAGAIN;
219 } 1983 }
220 } 1984 }
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} 1985}
261 1986
262static void 1987SV *
263LOAD(pTHX_ Coro__State c) 1988is_ready (Coro::State coro)
264{ 1989 PROTOTYPE: $
265 PL_dowarn = c->dowarn; 1990 ALIAS:
266 GvAV (PL_defgv) = c->defav; 1991 is_ready = CF_READY
267 PL_curstackinfo = c->curstackinfo; 1992 is_running = CF_RUNNING
268 PL_curstack = c->curstack; 1993 is_new = CF_NEW
269 PL_mainstack = c->mainstack; 1994 is_destroyed = CF_DESTROYED
270 PL_stack_sp = c->stack_sp; 1995 CODE:
271 PL_op = c->op; 1996 RETVAL = boolSV (coro->flags & ix);
272 PL_curpad = c->curpad; 1997 OUTPUT:
273 PL_stack_base = c->stack_base; 1998 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 1999
2000void
2001api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
2002
2003SV *
2004has_cctx (Coro::State coro)
2005 PROTOTYPE: $
2006 CODE:
2007 RETVAL = boolSV (!!coro->cctx);
2008 OUTPUT:
2009 RETVAL
2010
2011int
2012is_traced (Coro::State coro)
2013 PROTOTYPE: $
2014 CODE:
2015 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
2016 OUTPUT:
2017 RETVAL
2018
2019UV
2020rss (Coro::State coro)
2021 PROTOTYPE: $
2022 ALIAS:
2023 usecount = 1
2024 CODE:
2025 switch (ix)
293 { 2026 {
294 dSP; 2027 case 0: RETVAL = coro_rss (aTHX_ coro); break;
295 CV *cv; 2028 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 } 2029 }
2030 OUTPUT:
2031 RETVAL
311 2032
312 PUTBACK; 2033void
313 } 2034force_cctx ()
314} 2035 CODE:
2036 struct coro *coro = SvSTATE (coro_current);
2037 coro->cctx->idle_sp = 0;
315 2038
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 2039void
317STATIC void 2040swap_defsv (Coro::State self)
318S_nuke_stacks(pTHX) 2041 PROTOTYPE: $
319{ 2042 ALIAS:
320 while (PL_curstackinfo->si_next) 2043 swap_defav = 1
321 PL_curstackinfo = PL_curstackinfo->si_next; 2044 CODE:
322 while (PL_curstackinfo) { 2045 if (!self->slot)
323 PERL_SI *p = PL_curstackinfo->si_prev; 2046 croak ("cannot swap state with coroutine that has no saved state");
324 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 2047 else
325 Safefree(PL_curstackinfo->si_cxstack); 2048 {
326 Safefree(PL_curstackinfo); 2049 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
327 PL_curstackinfo = p; 2050 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 2051
336#define SUB_INIT "Coro::State::_newcoro" 2052 SV *tmp = *src; *src = *dst; *dst = tmp;
2053 }
337 2054
338MODULE = Coro::State PACKAGE = Coro::State 2055MODULE = Coro::State PACKAGE = Coro
339
340PROTOTYPES: ENABLE
341 2056
342BOOT: 2057BOOT:
343 if (!padlist_cache) 2058{
344 padlist_cache = newHV (); 2059 int i;
345 2060
346Coro::State 2061 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
347_newprocess(args) 2062 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
348 SV * args 2063 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
2064
2065 coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
2066 SvREADONLY_on (coro_current);
2067
2068 coro_stash = gv_stashpv ("Coro", TRUE);
2069
2070 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
2071 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
2072 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
2073 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
2074 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
2075 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
2076
2077 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
2078 coro_ready[i] = newAV ();
2079
2080 {
2081 SV *sv = perl_get_sv ("Coro::API", TRUE);
2082 perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
2083
2084 coroapi.schedule = api_schedule;
2085 coroapi.cede = api_cede;
2086 coroapi.cede_notself = api_cede_notself;
2087 coroapi.ready = api_ready;
2088 coroapi.is_ready = api_is_ready;
2089 coroapi.nready = &coro_nready;
2090 coroapi.current = coro_current;
2091
2092 GCoroAPI = &coroapi;
2093 sv_setiv (sv, (IV)&coroapi);
2094 SvREADONLY_on (sv);
2095 }
2096}
2097
2098void
2099_set_current (SV *current)
349 PROTOTYPE: $ 2100 PROTOTYPE: $
2101 CODE:
2102 SvREFCNT_dec (SvRV (coro_current));
2103 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
2104
2105void
2106_set_readyhook (SV *hook)
2107 PROTOTYPE: $
350 CODE: 2108 CODE:
351 Coro__State coro;
352
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
354 croak ("Coro::State::newprocess expects an arrayref");
355 2109 LOCK;
356 New (0, coro, 1, struct coro); 2110 SvREFCNT_dec (coro_readyhook);
2111 coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
2112 UNLOCK;
357 2113
358 coro->mainstack = 0; /* actual work is done inside transfer */ 2114int
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 2115prio (Coro::State coro, int newprio = 0)
360 2116 ALIAS:
2117 nice = 1
2118 CODE:
2119{
361 RETVAL = coro; 2120 RETVAL = coro->prio;
362 OUTPUT: 2121
2122 if (items > 1)
2123 {
2124 if (ix)
2125 newprio = coro->prio - newprio;
2126
2127 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
2128 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
2129
2130 coro->prio = newprio;
2131 }
2132}
2133 OUTPUT:
363 RETVAL 2134 RETVAL
364 2135
2136SV *
2137ready (SV *self)
2138 PROTOTYPE: $
2139 CODE:
2140 RETVAL = boolSV (api_ready (self));
2141 OUTPUT:
2142 RETVAL
2143
2144int
2145nready (...)
2146 PROTOTYPE:
2147 CODE:
2148 RETVAL = coro_nready;
2149 OUTPUT:
2150 RETVAL
2151
365void 2152void
366transfer(prev,next) 2153throw (Coro::State self, SV *throw = &PL_sv_undef)
367 Coro::State_or_hashref prev 2154 PROTOTYPE: $;$
368 Coro::State_or_hashref next
369 CODE: 2155 CODE:
2156 SvREFCNT_dec (self->throw);
2157 self->throw = SvOK (throw) ? newSVsv (throw) : 0;
370 2158
371 if (prev != next) 2159# for async_pool speedup
2160void
2161_pool_1 (SV *cb)
2162 CODE:
2163{
2164 struct coro *coro = SvSTATE (coro_current);
2165 HV *hv = (HV *)SvRV (coro_current);
2166 AV *defav = GvAV (PL_defgv);
2167 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
2168 AV *invoke_av;
2169 int i, len;
2170
2171 if (!invoke)
372 { 2172 {
2173 SV *old = PL_diehook;
2174 PL_diehook = 0;
2175 SvREFCNT_dec (old);
2176 croak ("\3async_pool terminate\2\n");
2177 }
2178
2179 SvREFCNT_dec (coro->saved_deffh);
2180 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
2181
2182 hv_store (hv, "desc", sizeof ("desc") - 1,
2183 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
2184
2185 invoke_av = (AV *)SvRV (invoke);
2186 len = av_len (invoke_av);
2187
2188 sv_setsv (cb, AvARRAY (invoke_av)[0]);
2189
2190 if (len > 0)
2191 {
2192 av_fill (defav, len - 1);
2193 for (i = 0; i < len; ++i)
2194 av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
2195 }
2196
2197 SvREFCNT_dec (invoke);
2198}
2199
2200void
2201_pool_2 (SV *cb)
2202 CODE:
2203{
2204 struct coro *coro = SvSTATE (coro_current);
2205
2206 sv_setsv (cb, &PL_sv_undef);
2207
2208 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
2209 coro->saved_deffh = 0;
2210
2211 if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
2212 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2213 {
2214 SV *old = PL_diehook;
2215 PL_diehook = 0;
2216 SvREFCNT_dec (old);
2217 croak ("\3async_pool terminate\2\n");
2218 }
2219
2220 av_clear (GvAV (PL_defgv));
2221 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
2222 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
2223
2224 coro->prio = 0;
2225
2226 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
2227 api_trace (coro_current, 0);
2228
2229 av_push (av_async_pool, newSVsv (coro_current));
2230}
2231
2232#if 0
2233
2234void
2235_generator_call (...)
2236 PROTOTYPE: @
2237 PPCODE:
2238 fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
2239 xxxx
2240 abort ();
2241
2242SV *
2243gensub (SV *sub, ...)
2244 PROTOTYPE: &;@
2245 CODE:
2246{
2247 struct coro *coro;
2248 MAGIC *mg;
2249 CV *xcv;
2250 CV *ncv = (CV *)newSV_type (SVt_PVCV);
2251 int i;
2252
2253 CvGV (ncv) = CvGV (cv);
2254 CvFILE (ncv) = CvFILE (cv);
2255
2256 Newz (0, coro, 1, struct coro);
2257 coro->args = newAV ();
2258 coro->flags = CF_NEW;
2259
2260 av_extend (coro->args, items - 1);
2261 for (i = 1; i < items; i++)
2262 av_push (coro->args, newSVsv (ST (i)));
2263
2264 CvISXSUB_on (ncv);
2265 CvXSUBANY (ncv).any_ptr = (void *)coro;
2266
2267 xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
2268
2269 CvXSUB (ncv) = CvXSUB (xcv);
2270 CvANON_on (ncv);
2271
2272 mg = sv_magicext ((SV *)ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char *)coro, 0);
2273 RETVAL = newRV_noinc ((SV *)ncv);
2274}
2275 OUTPUT:
2276 RETVAL
2277
2278#endif
2279
2280
2281MODULE = Coro::State PACKAGE = Coro::AIO
2282
2283void
2284_get_state (SV *self)
2285 PPCODE:
2286{
2287 AV *defav = GvAV (PL_defgv);
2288 AV *av = newAV ();
2289 int i;
2290 SV *data_sv = newSV (sizeof (struct io_state));
2291 struct io_state *data = (struct io_state *)SvPVX (data_sv);
2292 SvCUR_set (data_sv, sizeof (struct io_state));
2293 SvPOK_only (data_sv);
2294
2295 data->errorno = errno;
2296 data->laststype = PL_laststype;
2297 data->laststatval = PL_laststatval;
2298 data->statcache = PL_statcache;
2299
2300 av_extend (av, AvFILLp (defav) + 1 + 1);
2301
2302 for (i = 0; i <= AvFILLp (defav); ++i)
2303 av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
2304
2305 av_push (av, data_sv);
2306
2307 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
2308
2309 api_ready (self);
2310}
2311
2312void
2313_set_state (SV *state)
2314 PROTOTYPE: $
2315 PPCODE:
2316{
2317 AV *av = (AV *)SvRV (state);
2318 struct io_state *data = (struct io_state *)SvPVX (AvARRAY (av)[AvFILLp (av)]);
2319 int i;
2320
2321 errno = data->errorno;
2322 PL_laststype = data->laststype;
2323 PL_laststatval = data->laststatval;
2324 PL_statcache = data->statcache;
2325
2326 EXTEND (SP, AvFILLp (av));
2327 for (i = 0; i < AvFILLp (av); ++i)
2328 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
2329}
2330
2331
2332MODULE = Coro::State PACKAGE = Coro::AnyEvent
2333
2334BOOT:
2335 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
2336
2337SV *
2338_schedule (...)
2339 PROTOTYPE: @
2340 CODE:
2341{
2342 static int incede;
2343
2344 api_cede_notself ();
2345
2346 ++incede;
2347 while (coro_nready >= incede && api_cede ())
2348 ;
2349
2350 sv_setsv (sv_activity, &PL_sv_undef);
2351 if (coro_nready >= incede)
2352 {
2353 PUSHMARK (SP);
373 PUTBACK; 2354 PUTBACK;
374 SAVE (aTHX_ prev); 2355 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; 2356 SPAGAIN;
439 } 2357 }
440 2358
441 SvREFCNT_dec (coro->args); 2359 --incede;
442 Safefree (coro); 2360}
443 2361
444 2362
2363MODULE = Coro::State PACKAGE = PerlIO::cede
2364
2365BOOT:
2366 PerlIO_define_layer (aTHX_ &PerlIO_cede);

Diff Legend

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