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

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

Diff Legend

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