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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.139 by root, Sun Jan 14 21:13:41 2007 UTC

1#include "libcoro/coro.c"
2
1#include "EXTERN.h" 3#include "EXTERN.h"
2#include "perl.h" 4#include "perl.h"
3#include "XSUB.h" 5#include "XSUB.h"
4 6
5#if 0 7#include "patchlevel.h"
6# define CHK(x) (void *)0 8
9#include <stdio.h>
10#include <errno.h>
11#include <assert.h>
12
13#ifdef HAVE_MMAP
14# include <unistd.h>
15# include <sys/mman.h>
16# ifndef MAP_ANONYMOUS
17# ifdef MAP_ANON
18# define MAP_ANONYMOUS MAP_ANON
19# else
20# undef HAVE_MMAP
21# endif
22# endif
23# include <limits.h>
24# ifndef PAGESIZE
25# define PAGESIZE pagesize
26# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
27static long pagesize;
28# else
29# define BOOT_PAGESIZE (void)0
30# endif
7#else 31#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 32# define PAGESIZE 0
33# define BOOT_PAGESIZE (void)0
34#endif
35
36#if USE_VALGRIND
37# include <valgrind/valgrind.h>
38#endif
39
40/* the maximum number of idle cctx that will be pooled */
41#define MAX_IDLE_CCTX 8
42
43#define PERL_VERSION_ATLEAST(a,b,c) \
44 (PERL_REVISION > (a) \
45 || (PERL_REVISION == (a) \
46 && (PERL_VERSION > (b) \
47 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
48
49#if !PERL_VERSION_ATLEAST (5,6,0)
50# ifndef PL_ppaddr
51# define PL_ppaddr ppaddr
9#endif 52# endif
53# ifndef call_sv
54# define call_sv perl_call_sv
55# endif
56# ifndef get_sv
57# define get_sv perl_get_sv
58# endif
59# ifndef get_cv
60# define get_cv perl_get_cv
61# endif
62# ifndef IS_PADGV
63# define IS_PADGV(v) 0
64# endif
65# ifndef IS_PADCONST
66# define IS_PADCONST(v) 0
67# endif
68#endif
10 69
70/* 5.8.7 */
71#ifndef SvRV_set
72# define SvRV_set(s,v) SvRV(s) = (v)
73#endif
74
75#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
76# undef STACKGUARD
77#endif
78
79#ifndef STACKGUARD
80# define STACKGUARD 0
81#endif
82
83/* prefer perl internal functions over our own? */
84#ifndef PREFER_PERL_FUNCTIONS
85# define PREFER_PERL_FUNCTIONS 0
86#endif
87
88/* The next macro should declare a variable stacklevel that contains and approximation
89 * to the current C stack pointer. Its property is that it changes with each call
90 * and should be unique. */
91#define dSTACKLEVEL int stacklevel
92#define STACKLEVEL ((void *)&stacklevel)
93
94#define IN_DESTRUCT (PL_main_cv == Nullcv)
95
96#if __GNUC__ >= 3
97# define attribute(x) __attribute__(x)
98# define BARRIER __asm__ __volatile__ ("" : : : "memory")
99#else
100# define attribute(x)
101# define BARRIER
102#endif
103
104#define NOINLINE attribute ((noinline))
105
106#include "CoroAPI.h"
107
108#ifdef USE_ITHREADS
109static perl_mutex coro_mutex;
110# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
111# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
112#else
113# define LOCK (void)0
114# define UNLOCK (void)0
115#endif
116
117/* helper storage struct for Coro::AIO */
118struct io_state
119{
120 int errorno;
121 I32 laststype;
122 int laststatval;
123 Stat_t statcache;
124};
125
126static struct CoroAPI coroapi;
127static AV *main_mainstack; /* used to differentiate between $main and others */
128static HV *coro_state_stash, *coro_stash;
129static SV *coro_mortal; /* will be freed after next transfer */
130
131static struct coro_cctx *cctx_first;
132static int cctx_count, cctx_idle;
133
134/* this is a structure representing a c-level coroutine */
135typedef struct coro_cctx {
136 struct coro_cctx *next;
137
138 /* the stack */
139 void *sptr;
140 long ssize; /* positive == mmap, otherwise malloc */
141
142 /* cpu state */
143 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
144 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
145 JMPENV *top_env;
146 coro_context cctx;
147
148 int inuse;
149
150#if USE_VALGRIND
151 int valgrind_id;
152#endif
153} coro_cctx;
154
155enum {
156 CF_RUNNING = 0x0001, /* coroutine is running */
157 CF_READY = 0x0002, /* coroutine is ready */
158 CF_NEW = 0x0004, /* has never been switched to */
159 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
160};
161
162/* this is a structure representing a perl-level coroutine */
11struct coro { 163struct coro {
12 U8 dowarn; 164 /* the c coroutine allocated to this perl coroutine, if any */
13 AV *defav; 165 coro_cctx *cctx;
166
167 /* data associated with this coroutine (initial args) */
168 AV *args;
169 int refcnt;
170 int save; /* CORO_SAVE flags */
171 int flags; /* CF_ flags */
172
173 /* optionally saved, might be zero */
174 AV *defav; /* @_ */
175 SV *defsv; /* $_ */
176 SV *errsv; /* $@ */
177 SV *irssv; /* $/ */
178 SV *irssv_sv; /* real $/ cache */
14 179
15 PERL_SI *curstackinfo; 180#define VAR(name,type) type name;
16 AV *curstack; 181# include "state.h"
17 AV *mainstack; 182#undef VAR
18 SV **stack_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 183
41 AV *args; 184 /* coro process data */
185 int prio;
42}; 186};
43 187
44typedef struct coro *Coro__State; 188typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 189typedef struct coro *Coro__State_or_hashref;
46 190
47static HV *padlist_cache; 191/** Coro ********************************************************************/
48 192
49/* mostly copied from op.c:cv_clone2 */ 193#define PRIO_MAX 3
50STATIC AV * 194#define PRIO_HIGH 1
51clone_padlist (AV *protopadlist) 195#define PRIO_NORMAL 0
196#define PRIO_LOW -1
197#define PRIO_IDLE -3
198#define PRIO_MIN -4
199
200/* for Coro.pm */
201static SV *coro_current;
202static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
203static int coro_nready;
204
205/** lowlevel stuff **********************************************************/
206
207static AV *
208coro_clone_padlist (CV *cv)
52{ 209{
53 AV *av; 210 AV *padlist = CvPADLIST (cv);
54 I32 ix;
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
57 SV **pname = AvARRAY (protopad_name);
58 SV **ppad = AvARRAY (protopad);
59 I32 fname = AvFILLp (protopad_name);
60 I32 fpad = AvFILLp (protopad);
61 AV *newpadlist, *newpad_name, *newpad; 211 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 212
72 newpadlist = newAV (); 213 newpadlist = newAV ();
73 AvREAL_off (newpadlist); 214 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 215#if PERL_VERSION_ATLEAST (5,9,0)
216 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
217#else
218 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
219#endif
220 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
221 --AvFILLp (padlist);
222
223 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75 av_store (newpadlist, 1, (SV *) newpad); 224 av_store (newpadlist, 1, (SV *)newpad);
76 225
77 av = newAV (); /* will be @_ */ 226 return newpadlist;
78 av_extend (av, 0); 227}
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 228
82 for (ix = fpad; ix > 0; ix--) 229static void
230free_padlist (AV *padlist)
231{
232 /* may be during global destruction */
233 if (SvREFCNT (padlist))
83 { 234 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 235 I32 i = AvFILLp (padlist);
85 if (namesv && namesv != &PL_sv_undef) 236 while (i >= 0)
86 { 237 {
87 char *name = SvPVX (namesv); /* XXX */ 238 SV **svp = av_fetch (padlist, i--, FALSE);
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 239 if (svp)
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 } 240 {
92 else
93 { /* our own lexical */
94 SV *sv; 241 SV *sv;
95 if (*name == '&') 242 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96 sv = SvREFCNT_inc (ppad[ix]); 243 SvREFCNT_dec (sv);
97 else if (*name == '@') 244
98 sv = (SV *) newAV (); 245 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 } 246 }
107 } 247 }
108 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix])) 248
109 { 249 SvREFCNT_dec ((SV*)padlist);
110 npad[ix] = SvREFCNT_inc (ppad[ix]); 250 }
111 } 251}
252
253static int
254coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
255{
256 AV *padlist;
257 AV *av = (AV *)mg->mg_obj;
258
259 /* casting is fun. */
260 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
261 free_padlist (padlist);
262
263 SvREFCNT_dec (av);
264
265 return 0;
266}
267
268#define PERL_MAGIC_coro PERL_MAGIC_ext
269
270static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
271
272#define CORO_MAGIC(cv) \
273 SvMAGIC (cv) \
274 ? SvMAGIC (cv)->mg_type == PERL_MAGIC_coro \
275 ? SvMAGIC (cv) \
276 : mg_find ((SV *)cv, PERL_MAGIC_coro) \
277 : 0
278
279/* the next two functions merely cache the padlists */
280static void
281get_padlist (CV *cv)
282{
283 MAGIC *mg = CORO_MAGIC (cv);
284 AV *av;
285
286 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
287 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
288 else
289 {
290#if PREFER_PERL_FUNCTIONS
291 /* this is probably cleaner, but also slower? */
292 CV *cp = Perl_cv_clone (cv);
293 CvPADLIST (cv) = CvPADLIST (cp);
294 CvPADLIST (cp) = 0;
295 SvREFCNT_dec (cp);
296#else
297 CvPADLIST (cv) = coro_clone_padlist (cv);
298#endif
299 }
300}
301
302static void
303put_padlist (CV *cv)
304{
305 MAGIC *mg = CORO_MAGIC (cv);
306 AV *av;
307
308 if (!mg)
309 {
310 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
311 mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
312 mg->mg_virtual = &vtbl_coro;
313 mg->mg_obj = (SV *)newAV ();
314 }
315
316 av = (AV *)mg->mg_obj;
317
318 if (AvFILLp (av) >= AvMAX (av))
319 av_extend (av, AvMAX (av) + 1);
320
321 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
322}
323
324/** load & save, init *******************************************************/
325
326#define SB do {
327#define SE } while (0)
328
329#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
330
331static void
332load_perl (Coro__State c)
333{
334#define VAR(name,type) PL_ ## name = c->name;
335# include "state.h"
336#undef VAR
337
338 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
339 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
340 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
341 if (c->irssv)
342 {
343 if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
344 SvREFCNT_dec (c->irssv);
112 else 345 else
113 { 346 {
114 SV *sv = NEWSV (0, 0); 347 REPLACE_SV (PL_rs, c->irssv);
115 SvPADTMP_on (sv); 348 if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
116 npad[ix] = sv; 349 sv_setsv (c->irssv_sv, PL_rs);
117 } 350 }
118 } 351 }
119 352
120#if 0 /* NONOTUNDERSTOOD */ 353 {
121 /* Now that vars are all in place, clone nested closures. */ 354 dSP;
355 CV *cv;
122 356
123 for (ix = fpad; ix > 0; ix--) { 357 /* now do the ugly restore mess */
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 358 while ((cv = (CV *)POPs))
125 if (namesv
126 && namesv != &PL_sv_undef
127 && !(SvFLAGS(namesv) & SVf_FAKE)
128 && *SvPVX(namesv) == '&'
129 && CvCLONE(ppad[ix]))
130 { 359 {
131 CV *kid = cv_clone((CV*)ppad[ix]); 360 put_padlist (cv); /* mark this padlist as available */
132 SvREFCNT_dec(ppad[ix]); 361 CvDEPTH (cv) = PTR2IV (POPs);
133 CvCLONE_on(kid); 362 CvPADLIST (cv) = (AV *)POPs;
134 SvPADMY_on(kid);
135 npad[ix] = (SV*)kid;
136 } 363 }
137 }
138#endif
139 364
140 return newpadlist; 365 PUTBACK;
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);
159 } 366 }
160} 367}
161 368
162STATIC AV *
163unuse_padlist (AV *padlist)
164{
165 free_padlist (padlist);
166}
167
168static void 369static void
169SAVE(pTHX_ Coro__State c) 370save_perl (Coro__State c)
170{ 371{
171 { 372 {
172 dSP; 373 dSP;
173 I32 cxix = cxstack_ix; 374 I32 cxix = cxstack_ix;
375 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 376 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 377
177 /* 378 /*
178 * the worst thing you can imagine happens first - we have to save 379 * the worst thing you can imagine happens first - we have to save
179 * (and reinitialize) all cv's in the whole callchain :( 380 * (and reinitialize) all cv's in the whole callchain :(
180 */ 381 */
181 382
383 EXTEND (SP, 3 + 1);
182 PUSHs (Nullsv); 384 PUSHs (Nullsv);
183 /* this loop was inspired by pp_caller */ 385 /* this loop was inspired by pp_caller */
184 for (;;) 386 for (;;)
185 { 387 {
186 while (cxix >= 0) 388 while (cxix >= 0)
187 { 389 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 390 PERL_CONTEXT *cx = &ccstk[cxix--];
189 391
190 if (CxTYPE(cx) == CXt_SUB) 392 if (CxTYPE (cx) == CXt_SUB)
191 { 393 {
192 CV *cv = cx->blk_sub.cv; 394 CV *cv = cx->blk_sub.cv;
395
193 if (CvDEPTH(cv)) 396 if (CvDEPTH (cv))
194 { 397 {
195#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv));
197#endif
198 EXTEND (SP, 3); 398 EXTEND (SP, 3);
199 PUSHs ((SV *)CvDEPTH(cv));
200 PUSHs ((SV *)CvPADLIST(cv)); 399 PUSHs ((SV *)CvPADLIST (cv));
400 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
201 PUSHs ((SV *)cv); 401 PUSHs ((SV *)cv);
202 402
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));
204
205 CvDEPTH(cv) = 0; 403 CvDEPTH (cv) = 0;
206#ifdef USE_THREADS 404 get_padlist (cv);
207 CvOWNER(cv) = 0;
208 error must unlock this cv etc.. etc...
209 if you are here wondering about this error message then
210 the reason is that it will not work as advertised yet
211#endif
212 } 405 }
213 }
214 else if (CxTYPE(cx) == CXt_FORMAT)
215 {
216 /* I never used formats, so how should I know how these are implemented? */
217 /* my bold guess is as a simple, plain sub... */
218 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
219 } 406 }
220 } 407 }
221 408
222 if (top_si->si_type == PERLSI_MAIN) 409 if (top_si->si_type == PERLSI_MAIN)
223 break; 410 break;
… …
228 } 415 }
229 416
230 PUTBACK; 417 PUTBACK;
231 } 418 }
232 419
233 c->dowarn = PL_dowarn; 420 c->defav = c->save & CORO_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
234 c->defav = GvAV (PL_defgv); 421 c->defsv = c->save & CORO_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
235 c->curstackinfo = PL_curstackinfo; 422 c->errsv = c->save & CORO_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
236 c->curstack = PL_curstack; 423 c->irssv = c->save & CORO_SAVE_IRSSV ? SvREFCNT_inc (PL_rs) : 0;
237 c->mainstack = PL_mainstack; 424
238 c->stack_sp = PL_stack_sp; 425#define VAR(name,type)c->name = PL_ ## name;
239 c->op = PL_op; 426# include "state.h"
240 c->curpad = PL_curpad; 427#undef VAR
428}
429
430/*
431 * allocate various perl stacks. This is an exact copy
432 * of perl.c:init_stacks, except that it uses less memory
433 * on the (sometimes correct) assumption that coroutines do
434 * not usually need a lot of stackspace.
435 */
436#if PREFER_PERL_FUNCTIONS
437# define coro_init_stacks init_stacks
438#else
439static void
440coro_init_stacks ()
441{
442 PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT));
443 PL_curstackinfo->si_type = PERLSI_MAIN;
444 PL_curstack = PL_curstackinfo->si_stack;
445 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
446
447 PL_stack_base = AvARRAY(PL_curstack);
241 c->stack_base = PL_stack_base; 448 PL_stack_sp = PL_stack_base;
242 c->stack_max = PL_stack_max; 449 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
243 c->tmps_stack = PL_tmps_stack;
244 c->tmps_floor = PL_tmps_floor;
245 c->tmps_ix = PL_tmps_ix;
246 c->tmps_max = PL_tmps_max;
247 c->markstack = PL_markstack;
248 c->markstack_ptr = PL_markstack_ptr;
249 c->markstack_max = PL_markstack_max;
250 c->scopestack = PL_scopestack;
251 c->scopestack_ix = PL_scopestack_ix;
252 c->scopestack_max = PL_scopestack_max;
253 c->savestack = PL_savestack;
254 c->savestack_ix = PL_savestack_ix;
255 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop;
260}
261 450
262static void 451 New(50,PL_tmps_stack,128,SV*);
263LOAD(pTHX_ Coro__State c) 452 PL_tmps_floor = -1;
264{ 453 PL_tmps_ix = -1;
265 PL_dowarn = c->dowarn; 454 PL_tmps_max = 128;
266 GvAV (PL_defgv) = c->defav; 455
267 PL_curstackinfo = c->curstackinfo; 456 New(54,PL_markstack,32,I32);
268 PL_curstack = c->curstack;
269 PL_mainstack = c->mainstack;
270 PL_stack_sp = c->stack_sp;
271 PL_op = c->op;
272 PL_curpad = c->curpad;
273 PL_stack_base = c->stack_base;
274 PL_stack_max = c->stack_max;
275 PL_tmps_stack = c->tmps_stack;
276 PL_tmps_floor = c->tmps_floor;
277 PL_tmps_ix = c->tmps_ix;
278 PL_tmps_max = c->tmps_max;
279 PL_markstack = c->markstack;
280 PL_markstack_ptr = c->markstack_ptr; 457 PL_markstack_ptr = PL_markstack;
281 PL_markstack_max = c->markstack_max; 458 PL_markstack_max = PL_markstack + 32;
282 PL_scopestack = c->scopestack; 459
283 PL_scopestack_ix = c->scopestack_ix; 460#ifdef SET_MARK_OFFSET
284 PL_scopestack_max = c->scopestack_max; 461 SET_MARK_OFFSET;
285 PL_savestack = c->savestack; 462#endif
286 PL_savestack_ix = c->savestack_ix; 463
287 PL_savestack_max = c->savestack_max; 464 New(54,PL_scopestack,32,I32);
288 PL_retstack = c->retstack; 465 PL_scopestack_ix = 0;
289 PL_retstack_ix = c->retstack_ix; 466 PL_scopestack_max = 32;
290 PL_retstack_max = c->retstack_max; 467
291 PL_curcop = c->curcop; 468 New(54,PL_savestack,64,ANY);
469 PL_savestack_ix = 0;
470 PL_savestack_max = 64;
471
472#if !PERL_VERSION_ATLEAST (5,9,0)
473 New(54,PL_retstack,16,OP*);
474 PL_retstack_ix = 0;
475 PL_retstack_max = 16;
476#endif
477}
478#endif
479
480/*
481 * destroy the stacks, the callchain etc...
482 */
483static void
484coro_destroy_stacks ()
485{
486 if (!IN_DESTRUCT)
487 {
488 /* restore all saved variables and stuff */
489 LEAVE_SCOPE (0);
490 assert (PL_tmps_floor == -1);
491
492 /* free all temporaries */
493 FREETMPS;
494 assert (PL_tmps_ix == -1);
495
496 /* unwind all extra stacks */
497 POPSTACK_TO (PL_mainstack);
498
499 /* unwind main stack */
500 dounwind (-1);
501 }
502
503 while (PL_curstackinfo->si_next)
504 PL_curstackinfo = PL_curstackinfo->si_next;
505
506 while (PL_curstackinfo)
507 {
508 PERL_SI *p = PL_curstackinfo->si_prev;
509
510 if (!IN_DESTRUCT)
511 SvREFCNT_dec (PL_curstackinfo->si_stack);
512
513 Safefree (PL_curstackinfo->si_cxstack);
514 Safefree (PL_curstackinfo);
515 PL_curstackinfo = p;
516 }
517
518 Safefree (PL_tmps_stack);
519 Safefree (PL_markstack);
520 Safefree (PL_scopestack);
521 Safefree (PL_savestack);
522#if !PERL_VERSION_ATLEAST (5,9,0)
523 Safefree (PL_retstack);
524#endif
525}
526
527/** coroutine stack handling ************************************************/
528
529static void
530setup_coro (struct coro *coro)
531{
532 /*
533 * emulate part of the perl startup here.
534 */
535
536 coro_init_stacks ();
537
538 PL_curcop = &PL_compiling;
539 PL_in_eval = EVAL_NULL;
540 PL_curpm = 0;
541 PL_localizing = 0;
542 PL_dirty = 0;
543 PL_restartop = 0;
292 544
293 { 545 {
294 dSP; 546 dSP;
295 CV *cv; 547 LOGOP myop;
296 548
297 /* now do the ugly restore mess */ 549 SvREFCNT_dec (GvAV (PL_defgv));
298 while ((cv = (CV *)POPs)) 550 GvAV (PL_defgv) = coro->args; coro->args = 0;
299 {
300 AV *padlist = (AV *)POPs;
301 551
302 unuse_padlist (CvPADLIST(cv)); 552 Zero (&myop, 1, LOGOP);
303 CvPADLIST(cv) = padlist; 553 myop.op_next = Nullop;
304 CvDEPTH(cv) = (I32)POPs; 554 myop.op_flags = OPf_WANT_VOID;
305 555
306#ifdef USE_THREADS 556 PUSHMARK (SP);
307 CvOWNER(cv) = (struct perl_thread *)POPs; 557 XPUSHs ((SV *)get_cv ("Coro::State::_coro_init", FALSE));
308 error does not work either
309#endif
310 }
311
312 PUTBACK; 558 PUTBACK;
559 PL_op = (OP *)&myop;
560 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
561 SPAGAIN;
313 } 562 }
314}
315 563
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 564 ENTER; /* necessary e.g. for dounwind */
317STATIC void 565}
318S_nuke_stacks(pTHX) 566
567static void
568free_coro_mortal ()
319{ 569{
320 while (PL_curstackinfo->si_next) 570 if (coro_mortal)
321 PL_curstackinfo = PL_curstackinfo->si_next; 571 {
322 while (PL_curstackinfo) { 572 SvREFCNT_dec (coro_mortal);
323 PERL_SI *p = PL_curstackinfo->si_prev; 573 coro_mortal = 0;
324 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 574 }
325 Safefree(PL_curstackinfo->si_cxstack); 575}
326 Safefree(PL_curstackinfo); 576
327 PL_curstackinfo = p; 577/* inject a fake call to Coro::State::_cctx_init into the execution */
578static void NOINLINE
579prepare_cctx (coro_cctx *cctx)
580{
581 dSP;
582 LOGOP myop;
583
584 Zero (&myop, 1, LOGOP);
585 myop.op_next = PL_op;
586 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
587
588 PUSHMARK (SP);
589 EXTEND (SP, 2);
590 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
591 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
592 PUTBACK;
593 PL_op = (OP *)&myop;
594 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
595 SPAGAIN;
596}
597
598static void
599coro_run (void *arg)
600{
601 /* coro_run is the alternative tail of transfer(), so unlock here. */
602 UNLOCK;
603
604 /*
605 * this is a _very_ stripped down perl interpreter ;)
606 */
607 PL_top_env = &PL_start_env;
608
609 /* inject call to cctx_init */
610 prepare_cctx ((coro_cctx *)arg);
611
612 /* somebody will hit me for both perl_run and PL_restartop */
613 PL_restartop = PL_op;
614 perl_run (PL_curinterp);
615
616 fputs ("FATAL: C coroutine fell over the edge of the world, aborting. Did you call exit in a coroutine?\n", stderr);
617 abort ();
618}
619
620static coro_cctx *
621cctx_new ()
622{
623 coro_cctx *cctx;
624
625 ++cctx_count;
626
627 Newz (0, cctx, 1, coro_cctx);
628
629#if HAVE_MMAP
630
631 cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
632 /* mmap supposedly does allocate-on-write for us */
633 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
634
635 if (cctx->sptr == (void *)-1)
636 {
637 perror ("FATAL: unable to mmap stack for coroutine");
638 _exit (EXIT_FAILURE);
639 }
640
641# if STACKGUARD
642 mprotect (cctx->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
643# endif
644
645#else
646
647 cctx->ssize = STACKSIZE * (long)sizeof (long);
648 New (0, cctx->sptr, STACKSIZE, long);
649
650 if (!cctx->sptr)
651 {
652 perror ("FATAL: unable to malloc stack for coroutine");
653 _exit (EXIT_FAILURE);
654 }
655
656#endif
657
658#if USE_VALGRIND
659 cctx->valgrind_id = VALGRIND_STACK_REGISTER (
660 STACKGUARD * PAGESIZE + (char *)cctx->sptr,
661 cctx->ssize + (char *)cctx->sptr
662 );
663#endif
664
665 coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, cctx->ssize);
666
667 return cctx;
668}
669
670static void
671cctx_destroy (coro_cctx *cctx)
672{
673 if (!cctx)
674 return;
675
676 --cctx_count;
677
678#if USE_VALGRIND
679 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
680#endif
681
682#if HAVE_MMAP
683 munmap (cctx->sptr, cctx->ssize);
684#else
685 Safefree (cctx->sptr);
686#endif
687
688 Safefree (cctx);
689}
690
691static coro_cctx *
692cctx_get ()
693{
694 coro_cctx *cctx;
695
696 if (cctx_first)
697 {
698 cctx = cctx_first;
699 cctx_first = cctx->next;
700 --cctx_idle;
701 }
702 else
703 {
704 cctx = cctx_new ();
705 PL_op = PL_op->op_next;
328 } 706 }
329 Safefree(PL_tmps_stack);
330 Safefree(PL_markstack);
331 Safefree(PL_scopestack);
332 Safefree(PL_savestack);
333 Safefree(PL_retstack);
334}
335 707
336#define SUB_INIT "Coro::State::_newcoro" 708 return cctx;
709}
710
711static void
712cctx_put (coro_cctx *cctx)
713{
714 /* free another cctx if overlimit */
715 if (cctx_idle >= MAX_IDLE_CCTX)
716 {
717 coro_cctx *first = cctx_first;
718 cctx_first = first->next;
719 --cctx_idle;
720
721 assert (!first->inuse);
722 cctx_destroy (first);
723 }
724
725 ++cctx_idle;
726 cctx->next = cctx_first;
727 cctx_first = cctx;
728}
729
730/** coroutine switching *****************************************************/
731
732/* never call directly, always through the coro_state_transfer global variable */
733static void NOINLINE
734transfer (struct coro *prev, struct coro *next)
735{
736 dSTACKLEVEL;
737
738 /* sometimes transfer is only called to set idle_sp */
739 if (!next)
740 {
741 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
742 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
743 }
744 else if (prev != next)
745 {
746 coro_cctx *prev__cctx;
747
748 if (prev->flags & CF_NEW)
749 {
750 /* create a new empty context */
751 Newz (0, prev->cctx, 1, coro_cctx);
752 prev->cctx->inuse = 1;
753 prev->flags &= ~CF_NEW;
754 prev->flags |= CF_RUNNING;
755 }
756
757 /*TODO: must not croak here */
758 if (!prev->flags & CF_RUNNING)
759 croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
760
761 if (next->flags & CF_RUNNING)
762 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
763
764 if (next->flags & CF_DESTROYED)
765 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
766
767 prev->flags &= ~CF_RUNNING;
768 next->flags |= CF_RUNNING;
769
770 LOCK;
771
772 if (next->flags & CF_NEW)
773 {
774 /* need to start coroutine */
775 next->flags &= ~CF_NEW;
776 /* first get rid of the old state */
777 save_perl (prev);
778 /* setup coroutine call */
779 setup_coro (next);
780 /* need a new stack */
781 assert (!next->cctx);
782 }
783 else
784 {
785 /* coroutine already started */
786 save_perl (prev);
787 load_perl (next);
788 }
789
790 prev__cctx = prev->cctx;
791
792 /* possibly "free" the cctx */
793 if (prev__cctx->idle_sp == STACKLEVEL)
794 {
795 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
796 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
797
798 prev->cctx = 0;
799
800 cctx_put (prev__cctx);
801 prev__cctx->inuse = 0;
802 }
803
804 if (!next->cctx)
805 {
806 next->cctx = cctx_get ();
807 assert (!next->cctx->inuse);
808 next->cctx->inuse = 1;
809 }
810
811 if (prev__cctx != next->cctx)
812 {
813 prev__cctx->top_env = PL_top_env;
814 PL_top_env = next->cctx->top_env;
815 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
816 }
817
818 free_coro_mortal ();
819 UNLOCK;
820 }
821}
822
823struct transfer_args
824{
825 struct coro *prev, *next;
826};
827
828#define TRANSFER(ta) transfer ((ta).prev, (ta).next)
829
830/** high level stuff ********************************************************/
831
832static int
833coro_state_destroy (struct coro *coro)
834{
835 if (coro->flags & CF_DESTROYED)
836 return 0;
837
838 coro->flags |= CF_DESTROYED;
839
840 if (coro->flags & CF_READY)
841 {
842 /* reduce nready, as destroying a ready coro effectively unreadies it */
843 /* alternative: look through all ready queues and remove the coro */
844 LOCK;
845 --coro_nready;
846 UNLOCK;
847 }
848 else
849 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
850
851 if (coro->mainstack && coro->mainstack != main_mainstack)
852 {
853 assert (!(coro->flags & CF_RUNNING));
854
855 struct coro temp;
856 Zero (&temp, 1, struct coro);
857 temp.save = CORO_SAVE_ALL;
858
859 if (coro->flags & CF_RUNNING)
860 croak ("FATAL: tried to destroy currently running coroutine");
861
862 save_perl (&temp);
863 load_perl (coro);
864
865 coro_destroy_stacks ();
866
867 load_perl (&temp); /* this will get rid of defsv etc.. */
868
869 coro->mainstack = 0;
870 }
871
872 cctx_destroy (coro->cctx);
873 SvREFCNT_dec (coro->args);
874
875 return 1;
876}
877
878static int
879coro_state_free (pTHX_ SV *sv, MAGIC *mg)
880{
881 struct coro *coro = (struct coro *)mg->mg_ptr;
882 mg->mg_ptr = 0;
883
884 if (--coro->refcnt < 0)
885 {
886 coro_state_destroy (coro);
887 Safefree (coro);
888 }
889
890 return 0;
891}
892
893static int
894coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
895{
896 struct coro *coro = (struct coro *)mg->mg_ptr;
897
898 ++coro->refcnt;
899
900 return 0;
901}
902
903static MGVTBL coro_state_vtbl = {
904 0, 0, 0, 0,
905 coro_state_free,
906 0,
907#ifdef MGf_DUP
908 coro_state_dup,
909#else
910# define MGf_DUP 0
911#endif
912};
913
914static struct coro *
915SvSTATE (SV *coro)
916{
917 HV *stash;
918 MAGIC *mg;
919
920 if (SvROK (coro))
921 coro = SvRV (coro);
922
923 stash = SvSTASH (coro);
924 if (stash != coro_stash && stash != coro_state_stash)
925 {
926 /* very slow, but rare, check */
927 if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
928 croak ("Coro::State object required");
929 }
930
931 mg = SvMAGIC (coro);
932 assert (mg->mg_type == PERL_MAGIC_ext);
933 return (struct coro *)mg->mg_ptr;
934}
935
936static void
937prepare_transfer (struct transfer_args *ta, SV *prev_sv, SV *next_sv)
938{
939 ta->prev = SvSTATE (prev_sv);
940 ta->next = SvSTATE (next_sv);
941}
942
943static void
944api_transfer (SV *prev_sv, SV *next_sv)
945{
946 struct transfer_args ta;
947
948 prepare_transfer (&ta, prev_sv, next_sv);
949 TRANSFER (ta);
950}
951
952static int
953api_save (SV *coro_sv, int new_save)
954{
955 struct coro *coro = SvSTATE (coro_sv);
956 int old_save = coro->save;
957
958 if (new_save >= 0)
959 coro->save = new_save;
960
961 return old_save;
962}
963
964/** Coro ********************************************************************/
965
966static void
967coro_enq (SV *coro_sv)
968{
969 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
970}
971
972static SV *
973coro_deq (int min_prio)
974{
975 int prio = PRIO_MAX - PRIO_MIN;
976
977 min_prio -= PRIO_MIN;
978 if (min_prio < 0)
979 min_prio = 0;
980
981 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
982 if (AvFILLp (coro_ready [prio]) >= 0)
983 return av_shift (coro_ready [prio]);
984
985 return 0;
986}
987
988static int
989api_ready (SV *coro_sv)
990{
991 struct coro *coro;
992
993 if (SvROK (coro_sv))
994 coro_sv = SvRV (coro_sv);
995
996 coro = SvSTATE (coro_sv);
997
998 if (coro->flags & CF_READY)
999 return 0;
1000
1001 coro->flags |= CF_READY;
1002
1003 LOCK;
1004 coro_enq (SvREFCNT_inc (coro_sv));
1005 ++coro_nready;
1006 UNLOCK;
1007
1008 return 1;
1009}
1010
1011static int
1012api_is_ready (SV *coro_sv)
1013{
1014 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1015}
1016
1017static void
1018prepare_schedule (struct transfer_args *ta)
1019{
1020 SV *prev_sv, *next_sv;
1021
1022 for (;;)
1023 {
1024 LOCK;
1025 next_sv = coro_deq (PRIO_MIN);
1026
1027 /* nothing to schedule: call the idle handler */
1028 if (!next_sv)
1029 {
1030 UNLOCK;
1031 dSP;
1032
1033 ENTER;
1034 SAVETMPS;
1035
1036 PUSHMARK (SP);
1037 PUTBACK;
1038 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1039
1040 FREETMPS;
1041 LEAVE;
1042 continue;
1043 }
1044
1045 ta->next = SvSTATE (next_sv);
1046
1047 /* cannot transfer to destroyed coros, skip and look for next */
1048 if (ta->next->flags & CF_DESTROYED)
1049 {
1050 UNLOCK;
1051 SvREFCNT_dec (next_sv);
1052 /* coro_nready is already taken care of by destroy */
1053 continue;
1054 }
1055
1056 --coro_nready;
1057 UNLOCK;
1058 break;
1059 }
1060
1061 /* free this only after the transfer */
1062 prev_sv = SvRV (coro_current);
1063 SvRV_set (coro_current, next_sv);
1064 ta->prev = SvSTATE (prev_sv);
1065
1066 assert (ta->next->flags & CF_READY);
1067 ta->next->flags &= ~CF_READY;
1068
1069 LOCK;
1070 free_coro_mortal ();
1071 coro_mortal = prev_sv;
1072 UNLOCK;
1073}
1074
1075static void
1076prepare_cede (struct transfer_args *ta)
1077{
1078 api_ready (coro_current);
1079 prepare_schedule (ta);
1080}
1081
1082static int
1083prepare_cede_notself (struct transfer_args *ta)
1084{
1085 if (coro_nready)
1086 {
1087 SV *prev = SvRV (coro_current);
1088 prepare_schedule (ta);
1089 api_ready (prev);
1090 return 1;
1091 }
1092 else
1093 return 0;
1094}
1095
1096static void
1097api_schedule (void)
1098{
1099 struct transfer_args ta;
1100
1101 prepare_schedule (&ta);
1102 TRANSFER (ta);
1103}
1104
1105static int
1106api_cede (void)
1107{
1108 struct transfer_args ta;
1109
1110 prepare_cede (&ta);
1111
1112 if (ta.prev != ta.next)
1113 {
1114 TRANSFER (ta);
1115 return 1;
1116 }
1117 else
1118 return 0;
1119}
1120
1121static int
1122api_cede_notself (void)
1123{
1124 struct transfer_args ta;
1125
1126 if (prepare_cede_notself (&ta))
1127 {
1128 TRANSFER (ta);
1129 return 1;
1130 }
1131 else
1132 return 0;
1133}
337 1134
338MODULE = Coro::State PACKAGE = Coro::State 1135MODULE = Coro::State PACKAGE = Coro::State
339 1136
340PROTOTYPES: ENABLE 1137PROTOTYPES: DISABLE
341 1138
342BOOT: 1139BOOT:
343 if (!padlist_cache) 1140{
344 padlist_cache = newHV (); 1141#ifdef USE_ITHREADS
1142 MUTEX_INIT (&coro_mutex);
1143#endif
1144 BOOT_PAGESIZE;
345 1145
346Coro::State 1146 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
347_newprocess(args) 1147
348 SV * args 1148 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
349 PROTOTYPE: $ 1149 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
1150 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
1151 newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
1152 newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
1153
1154 main_mainstack = PL_mainstack;
1155
1156 coroapi.ver = CORO_API_VERSION;
1157 coroapi.transfer = api_transfer;
1158
1159 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1160}
1161
1162SV *
1163new (char *klass, ...)
350 CODE: 1164 CODE:
351 Coro__State coro; 1165{
1166 struct coro *coro;
1167 HV *hv;
1168 int i;
352 1169
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
354 croak ("Coro::State::newprocess expects an arrayref");
355
356 New (0, coro, 1, struct coro); 1170 Newz (0, coro, 1, struct coro);
1171 coro->args = newAV ();
1172 coro->save = CORO_SAVE_ALL;
1173 coro->flags = CF_NEW;
357 1174
358 coro->mainstack = 0; /* actual work is done inside transfer */ 1175 hv = newHV ();
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1176 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1177 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
360 1178
361 RETVAL = coro; 1179 for (i = 1; i < items; i++)
1180 av_push (coro->args, newSVsv (ST (i)));
1181}
362 OUTPUT: 1182 OUTPUT:
363 RETVAL 1183 RETVAL
364 1184
1185int
1186save (SV *coro, int new_save = -1)
1187 CODE:
1188 RETVAL = api_save (coro, new_save);
1189 OUTPUT:
1190 RETVAL
1191
365void 1192void
366transfer(prev,next) 1193_set_stacklevel (...)
367 Coro::State_or_hashref prev 1194 ALIAS:
368 Coro::State_or_hashref next 1195 Coro::State::transfer = 1
1196 Coro::schedule = 2
1197 Coro::cede = 3
1198 Coro::cede_notself = 4
369 CODE: 1199 CODE:
1200{
1201 struct transfer_args ta;
370 1202
371 if (prev != next) 1203 switch (ix)
372 { 1204 {
373 PUTBACK;
374 SAVE (aTHX_ prev);
375
376 /*
377 * this could be done in newprocess which would lead to
378 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
379 * code here, but lazy allocation of stacks has also
380 * some virtues and the overhead of the if() is nil.
381 */
382 if (next->mainstack)
383 {
384 LOAD (aTHX_ next);
385 next->mainstack = 0; /* unnecessary but much cleaner */
386 SPAGAIN;
387 }
388 else 1205 case 0:
1206 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1207 ta.next = 0;
389 { 1208 break;
390 /*
391 * emulate part of the perl startup here.
392 */
393 UNOP myop;
394 1209
395 init_stacks (); 1210 case 1:
396 PL_op = (OP *)&myop; 1211 if (items != 2)
397 /*PL_curcop = 0;*/ 1212 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
398 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399 1213
400 SPAGAIN; 1214 prepare_transfer (&ta, ST (0), ST (1));
401 Zero(&myop, 1, UNOP);
402 myop.op_next = Nullop;
403 myop.op_flags = OPf_WANT_VOID;
404
405 PUSHMARK(SP);
406 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
407 PUTBACK;
408 /*
409 * the next line is slightly wrong, as PL_op->op_next
410 * is actually being executed so we skip the first op.
411 * that doesn't matter, though, since it is only
412 * pp_nextstate and we never return...
413 */
414 PL_op = Perl_pp_entersub(aTHX);
415 SPAGAIN;
416
417 ENTER;
418 } 1215 break;
1216
1217 case 2:
1218 prepare_schedule (&ta);
1219 break;
1220
1221 case 3:
1222 prepare_cede (&ta);
1223 break;
1224
1225 case 4:
1226 if (!prepare_cede_notself (&ta))
1227 XSRETURN_EMPTY;
1228
1229 break;
419 } 1230 }
420 1231
1232 BARRIER;
1233 TRANSFER (ta);
1234
1235 if (GIMME_V != G_VOID && ta.next != ta.prev)
1236 XSRETURN_YES;
1237}
1238
1239bool
1240_destroy (SV *coro_sv)
1241 CODE:
1242 RETVAL = coro_state_destroy (SvSTATE (coro_sv));
1243 OUTPUT:
1244 RETVAL
1245
421void 1246void
422DESTROY(coro) 1247_exit (code)
423 Coro::State coro 1248 int code
1249 PROTOTYPE: $
1250 CODE:
1251 _exit (code);
1252
1253int
1254cctx_count ()
1255 CODE:
1256 RETVAL = cctx_count;
1257 OUTPUT:
1258 RETVAL
1259
1260int
1261cctx_idle ()
1262 CODE:
1263 RETVAL = cctx_idle;
1264 OUTPUT:
1265 RETVAL
1266
1267MODULE = Coro::State PACKAGE = Coro
1268
1269BOOT:
1270{
1271 int i;
1272
1273 coro_stash = gv_stashpv ("Coro", TRUE);
1274
1275 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1276 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1277 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1278 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1279 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1280 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1281
1282 coro_current = get_sv ("Coro::current", FALSE);
1283 SvREADONLY_on (coro_current);
1284
1285 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1286 coro_ready[i] = newAV ();
1287
1288 {
1289 SV *sv = perl_get_sv("Coro::API", 1);
1290
1291 coroapi.schedule = api_schedule;
1292 coroapi.save = api_save;
1293 coroapi.cede = api_cede;
1294 coroapi.cede_notself = api_cede_notself;
1295 coroapi.ready = api_ready;
1296 coroapi.is_ready = api_is_ready;
1297 coroapi.nready = &coro_nready;
1298 coroapi.current = coro_current;
1299
1300 GCoroAPI = &coroapi;
1301 sv_setiv (sv, (IV)&coroapi);
1302 SvREADONLY_on (sv);
1303 }
1304}
1305
1306void
1307_set_current (SV *current)
1308 PROTOTYPE: $
1309 CODE:
1310 SvREFCNT_dec (SvRV (coro_current));
1311 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1312
1313int
1314prio (Coro::State coro, int newprio = 0)
1315 ALIAS:
1316 nice = 1
424 CODE: 1317 CODE:
1318{
1319 RETVAL = coro->prio;
425 1320
426 if (coro->mainstack) 1321 if (items > 1)
427 { 1322 {
428 struct coro temp; 1323 if (ix)
1324 newprio = coro->prio - newprio;
429 1325
430 PUTBACK; 1326 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
431 SAVE(aTHX_ (&temp)); 1327 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
432 LOAD(aTHX_ coro);
433 1328
434 S_nuke_stacks (); 1329 coro->prio = newprio;
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437 LOAD((&temp));
438 SPAGAIN;
439 } 1330 }
1331}
1332 OUTPUT:
1333 RETVAL
440 1334
441 SvREFCNT_dec (coro->args); 1335SV *
442 Safefree (coro); 1336ready (SV *self)
1337 PROTOTYPE: $
1338 CODE:
1339 RETVAL = boolSV (api_ready (self));
1340 OUTPUT:
1341 RETVAL
443 1342
1343SV *
1344is_ready (SV *self)
1345 PROTOTYPE: $
1346 CODE:
1347 RETVAL = boolSV (api_is_ready (self));
1348 OUTPUT:
1349 RETVAL
444 1350
1351int
1352nready (...)
1353 PROTOTYPE:
1354 CODE:
1355 RETVAL = coro_nready;
1356 OUTPUT:
1357 RETVAL
1358
1359MODULE = Coro::State PACKAGE = Coro::AIO
1360
1361SV *
1362_get_state ()
1363 CODE:
1364{
1365 struct io_state *data;
1366
1367 RETVAL = newSV (sizeof (struct io_state));
1368 data = (struct io_state *)SvPVX (RETVAL);
1369 SvCUR_set (RETVAL, sizeof (struct io_state));
1370 SvPOK_only (RETVAL);
1371
1372 data->errorno = errno;
1373 data->laststype = PL_laststype;
1374 data->laststatval = PL_laststatval;
1375 data->statcache = PL_statcache;
1376}
1377 OUTPUT:
1378 RETVAL
1379
1380void
1381_set_state (char *data_)
1382 PROTOTYPE: $
1383 CODE:
1384{
1385 struct io_state *data = (void *)data_;
1386
1387 errno = data->errorno;
1388 PL_laststype = data->laststype;
1389 PL_laststatval = data->laststatval;
1390 PL_statcache = data->statcache;
1391}
1392

Diff Legend

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