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.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.178 by root, Wed Oct 3 01:48:06 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 GvIOp(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_state(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 = GvIOp (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
282#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0) 494 New(50,PL_tmps_stack,64,SV*);
283#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0) 495 PL_tmps_floor = -1;
496 PL_tmps_ix = -1;
497 PL_tmps_max = 64;
284 498
285static void 499 New(54,PL_markstack,16,I32);
286load_state(pTHX_ Coro__State c)
287{
288 PL_dowarn = c->dowarn;
289 GvAV (PL_defgv) = c->defav;
290 PL_curstackinfo = c->curstackinfo;
291 PL_curstack = c->curstack;
292 PL_mainstack = c->mainstack;
293 PL_stack_sp = c->stack_sp;
294 PL_op = c->op;
295 PL_curpad = c->curpad;
296 PL_stack_base = c->stack_base;
297 PL_stack_max = c->stack_max;
298 PL_tmps_stack = c->tmps_stack;
299 PL_tmps_floor = c->tmps_floor;
300 PL_tmps_ix = c->tmps_ix;
301 PL_tmps_max = c->tmps_max;
302 PL_markstack = c->markstack;
303 PL_markstack_ptr = c->markstack_ptr; 500 PL_markstack_ptr = PL_markstack;
304 PL_markstack_max = c->markstack_max; 501 PL_markstack_max = PL_markstack + 16;
305 PL_scopestack = c->scopestack; 502
306 PL_scopestack_ix = c->scopestack_ix; 503#ifdef SET_MARK_OFFSET
307 PL_scopestack_max = c->scopestack_max; 504 SET_MARK_OFFSET;
308 PL_savestack = c->savestack; 505#endif
309 PL_savestack_ix = c->savestack_ix; 506
310 PL_savestack_max = c->savestack_max; 507 New(54,PL_scopestack,16,I32);
311 PL_retstack = c->retstack; 508 PL_scopestack_ix = 0;
312 PL_retstack_ix = c->retstack_ix; 509 PL_scopestack_max = 16;
313 PL_retstack_max = c->retstack_max; 510
314 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
587setup_coro (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) = newSVsv (PL_rs);
607 PL_rs = newSVpvn ("\n", 1);
608
609 {
610 IO *io = newIO ();
611 GvIOp(PL_defoutgv) = io;
612 IoTYPE (io) = IoTYPE_WRONLY;
613 IoOFP (io) = IoIFP (io) = PerlIO_stdout ();
614 IoFLAGS (io) |= IOf_FLUSH;
615 }
315 616
316 { 617 {
317 dSP; 618 dSP;
318 CV *cv; 619 LOGOP myop;
319 620
320 /* now do the ugly restore mess */ 621 Zero (&myop, 1, LOGOP);
321 while ((cv = (CV *)POPs)) 622 myop.op_next = Nullop;
322 { 623 myop.op_flags = OPf_WANT_VOID;
323 AV *padlist = (AV *)POPs;
324 624
325 put_padlist (cv); 625 PUSHMARK (SP);
326 CvPADLIST(cv) = padlist; 626 XPUSHs (av_shift (GvAV (PL_defgv)));
327 CvDEPTH(cv) = (I32)POPs;
328
329#ifdef USE_THREADS
330 CvOWNER(cv) = (struct perl_thread *)POPs;
331 error does not work either
332#endif
333 }
334
335 PUTBACK; 627 PUTBACK;
628 PL_op = (OP *)&myop;
629 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
630 SPAGAIN;
336 } 631 }
337}
338 632
339/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 633 ENTER; /* necessary e.g. for dounwind */
340STATIC void 634}
341destroy_stacks(pTHX) 635
636static void
637destroy_coro (pTHX_ struct coro *coro)
342{ 638{
343 /* die does this while calling POPSTACK, but I just don't see why. */ 639 if (!IN_DESTRUCT)
344 /* OTOH, die does not have a memleak, but we do... */ 640 {
641 /* restore all saved variables and stuff */
642 LEAVE_SCOPE (0);
643 assert (PL_tmps_floor == -1);
644
645 /* free all temporaries */
646 FREETMPS;
647 assert (PL_tmps_ix == -1);
648
649 /* unwind all extra stacks */
650 POPSTACK_TO (PL_mainstack);
651
652 /* unwind main stack */
345 dounwind(-1); 653 dounwind (-1);
346
347 /* is this ugly, I ask? */
348 while (PL_scopestack_ix)
349 LEAVE;
350
351 while (PL_curstackinfo->si_next)
352 PL_curstackinfo = PL_curstackinfo->si_next;
353
354 while (PL_curstackinfo)
355 { 654 }
356 PERL_SI *p = PL_curstackinfo->si_prev;
357 655
358 SvREFCNT_dec(PL_curstackinfo->si_stack); 656 SvREFCNT_dec (GvSV (PL_defgv));
359 Safefree(PL_curstackinfo->si_cxstack); 657 SvREFCNT_dec (GvAV (PL_defgv));
360 Safefree(PL_curstackinfo); 658 SvREFCNT_dec (GvSV (PL_errgv));
361 PL_curstackinfo = p; 659 SvREFCNT_dec (GvIOp(PL_defoutgv));
660 SvREFCNT_dec (PL_rs);
661 SvREFCNT_dec (GvSV (irsgv));
662
663 coro_destroy_stacks (aTHX);
664}
665
666static void
667free_coro_mortal (pTHX)
668{
669 if (coro_mortal)
670 {
671 SvREFCNT_dec (coro_mortal);
672 coro_mortal = 0;
362 } 673 }
674}
363 675
364 if (PL_scopestack_ix != 0) 676static int
365 Perl_warner(aTHX_ WARN_INTERNAL, 677runops_trace (pTHX)
366 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 678{
367 (long)PL_scopestack_ix); 679 COP *oldcop = 0;
368 if (PL_savestack_ix != 0) 680 int oldcxix = -2;
369 Perl_warner(aTHX_ WARN_INTERNAL, 681 struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
370 "Unbalanced saves: %ld more saves than restores\n", 682 coro_cctx *cctx = coro->cctx;
371 (long)PL_savestack_ix); 683
372 if (PL_tmps_floor != -1) 684 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
373 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 685 {
374 (long)PL_tmps_floor + 1); 686 PERL_ASYNC_CHECK ();
687
688 if (cctx->flags & CC_TRACE_ALL)
689 {
690 if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
691 {
692 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
693 SV **bot, **top;
694 AV *av = newAV (); /* return values */
695 SV **cb;
696 dSP;
697
698 GV *gv = CvGV (cx->blk_sub.cv);
699 SV *fullname = sv_2mortal (newSV (0));
700 if (isGV (gv))
701 gv_efullname3 (fullname, gv, 0);
702
703 bot = PL_stack_base + cx->blk_oldsp + 1;
704 top = cx->blk_gimme == G_ARRAY ? SP + 1
705 : cx->blk_gimme == G_SCALAR ? bot + 1
706 : bot;
707
708 while (bot < top)
709 av_push (av, SvREFCNT_inc (*bot++));
710
711 PL_runops = RUNOPS_DEFAULT;
712 ENTER;
713 SAVETMPS;
714 EXTEND (SP, 3);
715 PUSHMARK (SP);
716 PUSHs (&PL_sv_no);
717 PUSHs (fullname);
718 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
719 PUTBACK;
720 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
721 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
722 SPAGAIN;
723 FREETMPS;
724 LEAVE;
725 PL_runops = runops_trace;
726 }
727
728 if (oldcop != PL_curcop)
729 {
730 oldcop = PL_curcop;
731
732 if (PL_curcop != &PL_compiling)
733 {
734 SV **cb;
735
736 if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
737 {
738 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
739
740 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
741 {
742 runops_proc_t old_runops = PL_runops;
743 dSP;
744 GV *gv = CvGV (cx->blk_sub.cv);
745 SV *fullname = sv_2mortal (newSV (0));
746
747 if (isGV (gv))
748 gv_efullname3 (fullname, gv, 0);
749
750 PL_runops = RUNOPS_DEFAULT;
751 ENTER;
752 SAVETMPS;
753 EXTEND (SP, 3);
754 PUSHMARK (SP);
755 PUSHs (&PL_sv_yes);
756 PUSHs (fullname);
757 PUSHs (cx->blk_sub.hasargs ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
758 PUTBACK;
759 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
760 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
761 SPAGAIN;
762 FREETMPS;
763 LEAVE;
764 PL_runops = runops_trace;
765 }
766
767 oldcxix = cxstack_ix;
768 }
769
770 if (cctx->flags & CC_TRACE_LINE)
771 {
772 dSP;
773
774 PL_runops = RUNOPS_DEFAULT;
775 ENTER;
776 SAVETMPS;
777 EXTEND (SP, 3);
778 PL_runops = RUNOPS_DEFAULT;
779 PUSHMARK (SP);
780 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
781 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
782 PUTBACK;
783 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
784 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
785 SPAGAIN;
786 FREETMPS;
787 LEAVE;
788 PL_runops = runops_trace;
789 }
790 }
791 }
792 }
793 }
794
795 TAINT_NOT;
796 return 0;
797}
798
799/* inject a fake call to Coro::State::_cctx_init into the execution */
800/* _cctx_init should be careful, as it could be called at almost any time */
801/* during execution of a perl program */
802static void NOINLINE
803prepare_cctx (pTHX_ coro_cctx *cctx)
804{
805 dSP;
806 LOGOP myop;
807
808 PL_top_env = &PL_start_env;
809
810 if (cctx->flags & CC_TRACE)
811 PL_runops = runops_trace;
812
813 Zero (&myop, 1, LOGOP);
814 myop.op_next = PL_op;
815 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
816
817 PUSHMARK (SP);
818 EXTEND (SP, 2);
819 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
820 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
821 PUTBACK;
822 PL_op = (OP *)&myop;
823 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
824 SPAGAIN;
825}
826
827/*
828 * this is a _very_ stripped down perl interpreter ;)
829 */
830static void
831coro_run (void *arg)
832{
833 dTHX;
834
835 /* coro_run is the alternative tail of transfer(), so unlock here. */
836 UNLOCK;
837
838 /* we now skip the entersub that lead to transfer() */
839 PL_op = PL_op->op_next;
840
841 /* inject a fake subroutine call to cctx_init */
842 prepare_cctx (aTHX_ (coro_cctx *)arg);
843
844 /* somebody or something will hit me for both perl_run and PL_restartop */
845 PL_restartop = PL_op;
846 perl_run (PL_curinterp);
847
375 /* 848 /*
376 */ 849 * If perl-run returns we assume exit() was being called or the coro
377 Safefree(PL_tmps_stack); 850 * fell off the end, which seems to be the only valid (non-bug)
378 Safefree(PL_markstack); 851 * reason for perl_run to return. We try to exit by jumping to the
379 Safefree(PL_scopestack); 852 * bootstrap-time "top" top_env, as we cannot restore the "main"
380 Safefree(PL_savestack); 853 * coroutine as Coro has no such concept
381 Safefree(PL_retstack); 854 */
855 PL_top_env = main_top_env;
856 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
382} 857}
383 858
384#define SUB_INIT "Coro::State::_newcoro" 859static coro_cctx *
860cctx_new ()
861{
862 coro_cctx *cctx;
863 void *stack_start;
864 size_t stack_size;
385 865
866 ++cctx_count;
867
868 Newz (0, cctx, 1, coro_cctx);
869
870#if HAVE_MMAP
871
872 cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
873 /* mmap supposedly does allocate-on-write for us */
874 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
875
876 if (cctx->sptr != (void *)-1)
877 {
878# if CORO_STACKGUARD
879 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
880# endif
881 stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
882 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
883 cctx->flags |= CC_MAPPED;
884 }
885 else
886#endif
887 {
888 cctx->ssize = coro_stacksize * (long)sizeof (long);
889 New (0, cctx->sptr, coro_stacksize, long);
890
891 if (!cctx->sptr)
892 {
893 perror ("FATAL: unable to allocate stack for coroutine");
894 _exit (EXIT_FAILURE);
895 }
896
897 stack_start = cctx->sptr;
898 stack_size = cctx->ssize;
899 }
900
901 REGISTER_STACK (cctx, (char *)stack_start, (char *)stack_start + stack_size);
902 coro_create (&cctx->cctx, coro_run, (void *)cctx, stack_start, stack_size);
903
904 return cctx;
905}
906
907static void
908cctx_destroy (coro_cctx *cctx)
909{
910 if (!cctx)
911 return;
912
913 --cctx_count;
914
915#if CORO_USE_VALGRIND
916 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
917#endif
918
919#if HAVE_MMAP
920 if (cctx->flags & CC_MAPPED)
921 munmap (cctx->sptr, cctx->ssize);
922 else
923#endif
924 Safefree (cctx->sptr);
925
926 Safefree (cctx);
927}
928
929static coro_cctx *
930cctx_get (pTHX)
931{
932 while (cctx_first)
933 {
934 coro_cctx *cctx = cctx_first;
935 cctx_first = cctx->next;
936 --cctx_idle;
937
938 if (cctx->ssize >= coro_stacksize && !(cctx->flags & CC_NOREUSE))
939 return cctx;
940
941 cctx_destroy (cctx);
942 }
943
944 return cctx_new ();
945}
946
947static void
948cctx_put (coro_cctx *cctx)
949{
950 /* free another cctx if overlimit */
951 if (cctx_idle >= MAX_IDLE_CCTX)
952 {
953 coro_cctx *first = cctx_first;
954 cctx_first = first->next;
955 --cctx_idle;
956
957 cctx_destroy (first);
958 }
959
960 ++cctx_idle;
961 cctx->next = cctx_first;
962 cctx_first = cctx;
963}
964
965/** coroutine switching *****************************************************/
966
967static void NOINLINE
968transfer_check (pTHX_ struct coro *prev, struct coro *next)
969{
970 if (prev != next)
971 {
972 if (!(prev->flags & (CF_RUNNING | CF_NEW)))
973 croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
974
975 if (next->flags & CF_RUNNING)
976 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
977
978 if (next->flags & CF_DESTROYED)
979 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
980
981 if (PL_lex_state != LEX_NOTPARSING)
982 croak ("Coro::State::transfer called while parsing, but this is not supported");
983 }
984}
985
986/* always use the TRANSFER macro */
987static void NOINLINE
988transfer (pTHX_ struct coro *prev, struct coro *next)
989{
990 dSTACKLEVEL;
991
992 /* sometimes transfer is only called to set idle_sp */
993 if (!next)
994 {
995 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
996 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
997 }
998 else if (prev != next)
999 {
1000 coro_cctx *prev__cctx;
1001
1002 if (prev->flags & CF_NEW)
1003 {
1004 /* create a new empty context */
1005 Newz (0, prev->cctx, 1, coro_cctx);
1006 prev->flags &= ~CF_NEW;
1007 prev->flags |= CF_RUNNING;
1008 }
1009
1010 prev->flags &= ~CF_RUNNING;
1011 next->flags |= CF_RUNNING;
1012
1013 LOCK;
1014
1015 if (next->flags & CF_NEW)
1016 {
1017 /* need to start coroutine */
1018 next->flags &= ~CF_NEW;
1019 /* first get rid of the old state */
1020 save_perl (aTHX_ prev);
1021 /* setup coroutine call */
1022 setup_coro (aTHX_ next);
1023 }
1024 else
1025 {
1026 /* coroutine already started */
1027 save_perl (aTHX_ prev);
1028 load_perl (aTHX_ next);
1029 }
1030
1031 prev__cctx = prev->cctx;
1032
1033 /* possibly "free" the cctx */
1034 if (prev__cctx->idle_sp == STACKLEVEL && !(prev__cctx->flags & CC_TRACE))
1035 {
1036 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
1037 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
1038
1039 prev->cctx = 0;
1040
1041 cctx_put (prev__cctx);
1042 }
1043
1044 ++next->usecount;
1045
1046 if (!next->cctx)
1047 next->cctx = cctx_get (aTHX);
1048
1049 if (prev__cctx != next->cctx)
1050 {
1051 prev__cctx->top_env = PL_top_env;
1052 PL_top_env = next->cctx->top_env;
1053 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
1054 }
1055
1056 free_coro_mortal (aTHX);
1057 UNLOCK;
1058 }
1059}
1060
1061struct transfer_args
1062{
1063 struct coro *prev, *next;
1064};
1065
1066#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next)
1067#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1068
1069/** high level stuff ********************************************************/
1070
1071static int
1072coro_state_destroy (pTHX_ struct coro *coro)
1073{
1074 if (coro->flags & CF_DESTROYED)
1075 return 0;
1076
1077 coro->flags |= CF_DESTROYED;
1078
1079 if (coro->flags & CF_READY)
1080 {
1081 /* reduce nready, as destroying a ready coro effectively unreadies it */
1082 /* alternative: look through all ready queues and remove the coro */
1083 LOCK;
1084 --coro_nready;
1085 UNLOCK;
1086 }
1087 else
1088 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1089
1090 if (coro->mainstack && coro->mainstack != main_mainstack)
1091 {
1092 struct coro temp;
1093
1094 if (coro->flags & CF_RUNNING)
1095 croak ("FATAL: tried to destroy currently running coroutine");
1096
1097 save_perl (aTHX_ &temp);
1098 load_perl (aTHX_ coro);
1099
1100 destroy_coro (aTHX_ coro);
1101
1102 load_perl (aTHX_ &temp); /* this will get rid of defsv etc.. */
1103
1104 coro->mainstack = 0;
1105 }
1106
1107 cctx_destroy (coro->cctx);
1108 SvREFCNT_dec (coro->args);
1109
1110 if (coro->next) coro->next->prev = coro->prev;
1111 if (coro->prev) coro->prev->next = coro->next;
1112 if (coro == coro_first) coro_first = coro->next;
1113
1114 return 1;
1115}
1116
1117static int
1118coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1119{
1120 struct coro *coro = (struct coro *)mg->mg_ptr;
1121 mg->mg_ptr = 0;
1122
1123 coro->hv = 0;
1124
1125 if (--coro->refcnt < 0)
1126 {
1127 coro_state_destroy (aTHX_ coro);
1128 Safefree (coro);
1129 }
1130
1131 return 0;
1132}
1133
1134static int
1135coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1136{
1137 struct coro *coro = (struct coro *)mg->mg_ptr;
1138
1139 ++coro->refcnt;
1140
1141 return 0;
1142}
1143
1144static MGVTBL coro_state_vtbl = {
1145 0, 0, 0, 0,
1146 coro_state_free,
1147 0,
1148#ifdef MGf_DUP
1149 coro_state_dup,
1150#else
1151# define MGf_DUP 0
1152#endif
1153};
1154
1155static void
1156prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
1157{
1158 ta->prev = SvSTATE (prev_sv);
1159 ta->next = SvSTATE (next_sv);
1160 TRANSFER_CHECK (*ta);
1161}
1162
1163static void
1164api_transfer (SV *prev_sv, SV *next_sv)
1165{
1166 dTHX;
1167 struct transfer_args ta;
1168
1169 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1170 TRANSFER (ta);
1171}
1172
1173/** Coro ********************************************************************/
1174
1175static void
1176coro_enq (pTHX_ SV *coro_sv)
1177{
1178 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1179}
1180
1181static SV *
1182coro_deq (pTHX_ int min_prio)
1183{
1184 int prio = PRIO_MAX - PRIO_MIN;
1185
1186 min_prio -= PRIO_MIN;
1187 if (min_prio < 0)
1188 min_prio = 0;
1189
1190 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
1191 if (AvFILLp (coro_ready [prio]) >= 0)
1192 return av_shift (coro_ready [prio]);
1193
1194 return 0;
1195}
1196
1197static int
1198api_ready (SV *coro_sv)
1199{
1200 dTHX;
1201 struct coro *coro;
1202
1203 if (SvROK (coro_sv))
1204 coro_sv = SvRV (coro_sv);
1205
1206 coro = SvSTATE (coro_sv);
1207
1208 if (coro->flags & CF_READY)
1209 return 0;
1210
1211 coro->flags |= CF_READY;
1212
1213 LOCK;
1214 coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
1215 ++coro_nready;
1216 UNLOCK;
1217
1218 return 1;
1219}
1220
1221static int
1222api_is_ready (SV *coro_sv)
1223{
1224 dTHX;
1225 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1226}
1227
1228static void
1229prepare_schedule (pTHX_ struct transfer_args *ta)
1230{
1231 SV *prev_sv, *next_sv;
1232
1233 for (;;)
1234 {
1235 LOCK;
1236 next_sv = coro_deq (aTHX_ PRIO_MIN);
1237
1238 /* nothing to schedule: call the idle handler */
1239 if (!next_sv)
1240 {
1241 dSP;
1242 UNLOCK;
1243
1244 ENTER;
1245 SAVETMPS;
1246
1247 PUSHMARK (SP);
1248 PUTBACK;
1249 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1250
1251 FREETMPS;
1252 LEAVE;
1253 continue;
1254 }
1255
1256 ta->next = SvSTATE (next_sv);
1257
1258 /* cannot transfer to destroyed coros, skip and look for next */
1259 if (ta->next->flags & CF_DESTROYED)
1260 {
1261 UNLOCK;
1262 SvREFCNT_dec (next_sv);
1263 /* coro_nready is already taken care of by destroy */
1264 continue;
1265 }
1266
1267 --coro_nready;
1268 UNLOCK;
1269 break;
1270 }
1271
1272 /* free this only after the transfer */
1273 prev_sv = SvRV (coro_current);
1274 ta->prev = SvSTATE (prev_sv);
1275 TRANSFER_CHECK (*ta);
1276 assert (ta->next->flags & CF_READY);
1277 ta->next->flags &= ~CF_READY;
1278 SvRV_set (coro_current, next_sv);
1279
1280 LOCK;
1281 free_coro_mortal (aTHX);
1282 coro_mortal = prev_sv;
1283 UNLOCK;
1284}
1285
1286static void
1287prepare_cede (pTHX_ struct transfer_args *ta)
1288{
1289 api_ready (coro_current);
1290 prepare_schedule (aTHX_ ta);
1291}
1292
1293static int
1294prepare_cede_notself (pTHX_ struct transfer_args *ta)
1295{
1296 if (coro_nready)
1297 {
1298 SV *prev = SvRV (coro_current);
1299 prepare_schedule (aTHX_ ta);
1300 api_ready (prev);
1301 return 1;
1302 }
1303 else
1304 return 0;
1305}
1306
1307static void
1308api_schedule (void)
1309{
1310 dTHX;
1311 struct transfer_args ta;
1312
1313 prepare_schedule (aTHX_ &ta);
1314 TRANSFER (ta);
1315}
1316
1317static int
1318api_cede (void)
1319{
1320 dTHX;
1321 struct transfer_args ta;
1322
1323 prepare_cede (aTHX_ &ta);
1324
1325 if (ta.prev != ta.next)
1326 {
1327 TRANSFER (ta);
1328 return 1;
1329 }
1330 else
1331 return 0;
1332}
1333
1334static int
1335api_cede_notself (void)
1336{
1337 dTHX;
1338 struct transfer_args ta;
1339
1340 if (prepare_cede_notself (aTHX_ &ta))
1341 {
1342 TRANSFER (ta);
1343 return 1;
1344 }
1345 else
1346 return 0;
1347}
1348
1349static void
1350api_trace (SV *coro_sv, int flags)
1351{
1352 dTHX;
1353 struct coro *coro = SvSTATE (coro_sv);
1354
1355 if (flags & CC_TRACE)
1356 {
1357 if (!coro->cctx)
1358 coro->cctx = cctx_new ();
1359 else if (!(coro->cctx->flags & CC_TRACE))
1360 croak ("cannot enable tracing on coroutine with custom stack");
1361
1362 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1363 }
1364 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1365 {
1366 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1367
1368 if (coro->flags & CF_RUNNING)
1369 PL_runops = RUNOPS_DEFAULT;
1370 else
1371 coro->runops = RUNOPS_DEFAULT;
1372 }
1373}
1374
386MODULE = Coro::State PACKAGE = Coro::State 1375MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
387 1376
388PROTOTYPES: ENABLE 1377PROTOTYPES: DISABLE
389 1378
390BOOT: 1379BOOT:
391 if (!padlist_cache) 1380{
392 padlist_cache = newHV (); 1381#ifdef USE_ITHREADS
1382 MUTEX_INIT (&coro_mutex);
1383#endif
1384 BOOT_PAGESIZE;
393 1385
394Coro::State 1386 irsgv = gv_fetchpv ("/", 1, SVt_PV);
395_newprocess(args) 1387
396 SV * args 1388 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
397 PROTOTYPE: $ 1389
1390 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1391 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1392 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1393 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1394
1395 main_mainstack = PL_mainstack;
1396 main_top_env = PL_top_env;
1397
1398 while (main_top_env->je_prev)
1399 main_top_env = main_top_env->je_prev;
1400
1401 coroapi.ver = CORO_API_VERSION;
1402 coroapi.transfer = api_transfer;
1403
1404 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1405}
1406
1407SV *
1408new (char *klass, ...)
398 CODE: 1409 CODE:
399 Coro__State coro; 1410{
1411 struct coro *coro;
1412 HV *hv;
1413 int i;
400 1414
401 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
402 croak ("Coro::State::newprocess expects an arrayref");
403
404 New (0, coro, 1, struct coro); 1415 Newz (0, coro, 1, struct coro);
1416 coro->args = newAV ();
1417 coro->flags = CF_NEW;
405 1418
406 coro->mainstack = 0; /* actual work is done inside transfer */ 1419 if (coro_first) coro_first->prev = coro;
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1420 coro->next = coro_first;
1421 coro_first = coro;
408 1422
409 RETVAL = coro; 1423 coro->hv = hv = newHV ();
1424 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1425 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1426
1427 for (i = 1; i < items; i++)
1428 av_push (coro->args, newSVsv (ST (i)));
1429}
410 OUTPUT: 1430 OUTPUT:
411 RETVAL 1431 RETVAL
412 1432
1433# these not obviously related functions are all rolled into the same xs
1434# function to increase chances that they all will call transfer with the same
1435# stack offset
413void 1436void
414transfer(prev,next) 1437_set_stacklevel (...)
415 Coro::State_or_hashref prev 1438 ALIAS:
416 Coro::State_or_hashref next 1439 Coro::State::transfer = 1
1440 Coro::schedule = 2
1441 Coro::cede = 3
1442 Coro::cede_notself = 4
417 CODE: 1443 CODE:
1444{
1445 struct transfer_args ta;
418 1446
419 if (prev != next) 1447 switch (ix)
420 { 1448 {
421 /*
422 * this could be done in newprocess which would lead to
423 * extremely elegant and fast (just SAVE/LOAD)
424 * code here, but lazy allocation of stacks has also
425 * some virtues and the overhead of the if() is nil.
426 */
427 if (next->mainstack)
428 {
429 SAVE (prev);
430 LOAD (next);
431 /* mark this state as in-use */
432 next->mainstack = 0;
433 next->tmps_ix = -2;
434 }
435 else if (next->tmps_ix == -2)
436 {
437 croak ("tried to transfer to running coroutine");
438 }
439 else 1449 case 0:
1450 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1451 ta.next = 0;
440 { 1452 break;
441 SAVE (prev);
442 1453
443 /* 1454 case 1:
444 * emulate part of the perl startup here. 1455 if (items != 2)
445 */ 1456 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446 UNOP myop;
447 1457
448 init_stacks (); /* from perl.c */ 1458 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
449 PL_op = (OP *)&myop;
450 /*PL_curcop = 0;*/
451 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452
453 SPAGAIN;
454 Zero(&myop, 1, UNOP);
455 myop.op_next = Nullop;
456 myop.op_flags = OPf_WANT_VOID;
457
458 PUSHMARK(SP);
459 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460 PUTBACK;
461 /*
462 * the next line is slightly wrong, as PL_op->op_next
463 * is actually being executed so we skip the first op.
464 * that doesn't matter, though, since it is only
465 * pp_nextstate and we never return...
466 */
467 PL_op = Perl_pp_entersub(aTHX);
468 SPAGAIN;
469
470 ENTER;
471 } 1459 break;
1460
1461 case 2:
1462 prepare_schedule (aTHX_ &ta);
1463 break;
1464
1465 case 3:
1466 prepare_cede (aTHX_ &ta);
1467 break;
1468
1469 case 4:
1470 if (!prepare_cede_notself (aTHX_ &ta))
1471 XSRETURN_EMPTY;
1472
1473 break;
472 } 1474 }
473 1475
1476 BARRIER;
1477 TRANSFER (ta);
1478
1479 if (GIMME_V != G_VOID && ta.next != ta.prev)
1480 XSRETURN_YES;
1481}
1482
1483bool
1484_destroy (SV *coro_sv)
1485 CODE:
1486 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1487 OUTPUT:
1488 RETVAL
1489
474void 1490void
475DESTROY(coro) 1491_exit (code)
476 Coro::State coro 1492 int code
477 CODE: 1493 PROTOTYPE: $
1494 CODE:
1495 _exit (code);
478 1496
1497int
1498cctx_stacksize (int new_stacksize = 0)
1499 CODE:
1500 RETVAL = coro_stacksize;
1501 if (new_stacksize)
1502 coro_stacksize = new_stacksize;
1503 OUTPUT:
1504 RETVAL
1505
1506int
1507cctx_count ()
1508 CODE:
1509 RETVAL = cctx_count;
1510 OUTPUT:
1511 RETVAL
1512
1513int
1514cctx_idle ()
1515 CODE:
1516 RETVAL = cctx_idle;
1517 OUTPUT:
1518 RETVAL
1519
1520void
1521list ()
1522 PPCODE:
1523{
1524 struct coro *coro;
1525 for (coro = coro_first; coro; coro = coro->next)
1526 if (coro->hv)
1527 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1528}
1529
1530void
1531call (Coro::State coro, SV *coderef)
1532 ALIAS:
1533 eval = 1
1534 CODE:
1535{
479 if (coro->mainstack) 1536 if (coro->mainstack)
480 { 1537 {
481 struct coro temp; 1538 struct coro temp;
1539 Zero (&temp, 1, struct coro);
482 1540
483 SAVE(aTHX_ (&temp)); 1541 if (!(coro->flags & CF_RUNNING))
484 LOAD(aTHX_ coro); 1542 {
1543 save_perl (aTHX_ &temp);
1544 load_perl (aTHX_ coro);
1545 }
485 1546
486 destroy_stacks (); 1547 {
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 1548 dSP;
1549 ENTER;
1550 SAVETMPS;
1551 PUSHMARK (SP);
1552 PUTBACK;
1553 if (ix)
1554 eval_sv (coderef, 0);
1555 else
1556 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1557 SPAGAIN;
1558 FREETMPS;
1559 LEAVE;
1560 PUTBACK;
1561 }
488 1562
489 LOAD((&temp)); 1563 if (!(coro->flags & CF_RUNNING))
1564 {
1565 save_perl (aTHX_ coro);
1566 load_perl (aTHX_ &temp);
1567 }
490 } 1568 }
1569}
491 1570
1571SV *
1572is_ready (Coro::State coro)
1573 PROTOTYPE: $
1574 ALIAS:
1575 is_ready = CF_READY
1576 is_running = CF_RUNNING
1577 is_new = CF_NEW
1578 is_destroyed = CF_DESTROYED
1579 CODE:
1580 RETVAL = boolSV (coro->flags & ix);
1581 OUTPUT:
1582 RETVAL
1583
1584void
1585api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1586
1587SV *
1588has_stack (Coro::State coro)
1589 PROTOTYPE: $
1590 CODE:
1591 RETVAL = boolSV (!!coro->cctx);
1592 OUTPUT:
1593 RETVAL
1594
1595int
1596is_traced (Coro::State coro)
1597 PROTOTYPE: $
1598 CODE:
1599 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1600 OUTPUT:
1601 RETVAL
1602
1603IV
1604rss (Coro::State coro)
1605 PROTOTYPE: $
1606 ALIAS:
1607 usecount = 1
1608 CODE:
1609 switch (ix)
1610 {
1611 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1612 case 1: RETVAL = coro->usecount; break;
1613 }
1614 OUTPUT:
1615 RETVAL
1616
1617
1618MODULE = Coro::State PACKAGE = Coro
1619
1620BOOT:
1621{
1622 int i;
1623
1624 sv_pool_rss = get_sv ("Coro::POOL_RSS" , TRUE);
1625 sv_pool_size = get_sv ("Coro::POOL_SIZE" , TRUE);
1626 av_async_pool = get_av ("Coro::async_pool", TRUE);
1627
1628 coro_current = get_sv ("Coro::current", FALSE);
1629 SvREADONLY_on (coro_current);
1630
1631 coro_stash = gv_stashpv ("Coro", TRUE);
1632
1633 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1634 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1635 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1636 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1637 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1638 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1639
1640 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1641 coro_ready[i] = newAV ();
1642
1643 {
1644 SV *sv = perl_get_sv("Coro::API", 1);
1645
1646 coroapi.schedule = api_schedule;
1647 coroapi.cede = api_cede;
1648 coroapi.cede_notself = api_cede_notself;
1649 coroapi.ready = api_ready;
1650 coroapi.is_ready = api_is_ready;
1651 coroapi.nready = &coro_nready;
1652 coroapi.current = coro_current;
1653
1654 GCoroAPI = &coroapi;
1655 sv_setiv (sv, (IV)&coroapi);
1656 SvREADONLY_on (sv);
1657 }
1658}
1659
1660void
1661_set_current (SV *current)
1662 PROTOTYPE: $
1663 CODE:
1664 SvREFCNT_dec (SvRV (coro_current));
1665 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1666
1667int
1668prio (Coro::State coro, int newprio = 0)
1669 ALIAS:
1670 nice = 1
1671 CODE:
1672{
1673 RETVAL = coro->prio;
1674
1675 if (items > 1)
1676 {
1677 if (ix)
1678 newprio = coro->prio - newprio;
1679
1680 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1681 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1682
1683 coro->prio = newprio;
1684 }
1685}
1686 OUTPUT:
1687 RETVAL
1688
1689SV *
1690ready (SV *self)
1691 PROTOTYPE: $
1692 CODE:
1693 RETVAL = boolSV (api_ready (self));
1694 OUTPUT:
1695 RETVAL
1696
1697int
1698nready (...)
1699 PROTOTYPE:
1700 CODE:
1701 RETVAL = coro_nready;
1702 OUTPUT:
1703 RETVAL
1704
1705# for async_pool speedup
1706void
1707_pool_1 (SV *cb)
1708 CODE:
1709{
1710 int i, len;
1711 HV *hv = (HV *)SvRV (coro_current);
1712 AV *defav = GvAV (PL_defgv);
1713 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
1714 AV *invoke_av;
1715
1716 if (!invoke)
1717 croak ("\3terminate\2\n");
1718
1719 hv_store (hv, "desc", sizeof ("desc") - 1,
1720 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
1721
1722 invoke_av = (AV *)SvRV (invoke);
1723 len = av_len (invoke_av);
1724
1725 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1726
1727 if (len > 0)
1728 {
1729 av_fill (defav, len - 1);
1730 for (i = 0; i < len; ++i)
1731 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1732 }
1733
492 SvREFCNT_dec (coro->args); 1734 SvREFCNT_dec (invoke);
493 Safefree (coro); 1735}
494 1736
1737void
1738_pool_2 (SV *cb)
1739 CODE:
1740{
1741 struct coro *coro = SvSTATE (coro_current);
495 1742
1743 sv_setsv (cb, &PL_sv_undef);
1744
1745 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1746 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1747 croak ("\3terminate\2\n");
1748
1749 av_clear (GvAV (PL_defgv));
1750 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
1751 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
1752
1753 coro->prio = 0;
1754
1755 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1756 api_trace (coro_current, 0);
1757
1758 av_push (av_async_pool, newSVsv (coro_current));
1759}
1760
1761
1762MODULE = Coro::State PACKAGE = Coro::AIO
1763
1764SV *
1765_get_state ()
1766 CODE:
1767{
1768 struct io_state *data;
1769
1770 RETVAL = newSV (sizeof (struct io_state));
1771 data = (struct io_state *)SvPVX (RETVAL);
1772 SvCUR_set (RETVAL, sizeof (struct io_state));
1773 SvPOK_only (RETVAL);
1774
1775 data->errorno = errno;
1776 data->laststype = PL_laststype;
1777 data->laststatval = PL_laststatval;
1778 data->statcache = PL_statcache;
1779}
1780 OUTPUT:
1781 RETVAL
1782
1783void
1784_set_state (char *data_)
1785 PROTOTYPE: $
1786 CODE:
1787{
1788 struct io_state *data = (void *)data_;
1789
1790 errno = data->errorno;
1791 PL_laststype = data->laststype;
1792 PL_laststatval = data->laststatval;
1793 PL_statcache = data->statcache;
1794}
1795

Diff Legend

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