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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.180 by root, Wed Oct 3 17:12:20 2007 UTC

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

Diff Legend

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