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

Diff Legend

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