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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.158 by root, Fri Sep 21 02:23:48 2007 UTC

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

Diff Legend

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