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

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

Diff Legend

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