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

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

Diff Legend

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