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

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

Diff Legend

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