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

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

Diff Legend

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