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

Diff Legend

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