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

Diff Legend

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