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.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.180 by root, Wed Oct 3 17:12:20 2007 UTC

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

Diff Legend

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