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.187 by root, Fri Oct 5 20:31:18 2007 UTC

1#include "libcoro/coro.c"
2
3#define PERL_NO_GET_CONTEXT
4
1#include "EXTERN.h" 5#include "EXTERN.h"
2#include "perl.h" 6#include "perl.h"
3#include "XSUB.h" 7#include "XSUB.h"
4 8
5#if 0 9#include "patchlevel.h"
6# define CHK(x) (void *)0 10
11#include <stdio.h>
12#include <errno.h>
13#include <assert.h>
14
15#ifdef HAVE_MMAP
16# include <unistd.h>
17# include <sys/mman.h>
18# ifndef MAP_ANONYMOUS
19# ifdef MAP_ANON
20# define MAP_ANONYMOUS MAP_ANON
21# else
22# undef HAVE_MMAP
23# endif
24# endif
25# include <limits.h>
26# ifndef PAGESIZE
27# define PAGESIZE pagesize
28# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
29static long pagesize;
30# else
31# define BOOT_PAGESIZE (void)0
32# endif
7#else 33#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 34# define PAGESIZE 0
35# define BOOT_PAGESIZE (void)0
36#endif
37
38#if CORO_USE_VALGRIND
39# include <valgrind/valgrind.h>
40# define REGISTER_STACK(cctx,start,end) (cctx)->valgrind_id = VALGRIND_STACK_REGISTER ((start), (end))
41#else
42# define REGISTER_STACK(cctx,start,end)
43#endif
44
45/* the maximum number of idle cctx that will be pooled */
46#define MAX_IDLE_CCTX 8
47
48#define PERL_VERSION_ATLEAST(a,b,c) \
49 (PERL_REVISION > (a) \
50 || (PERL_REVISION == (a) \
51 && (PERL_VERSION > (b) \
52 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
53
54#if !PERL_VERSION_ATLEAST (5,6,0)
55# ifndef PL_ppaddr
56# define PL_ppaddr ppaddr
9#endif 57# endif
58# ifndef call_sv
59# define call_sv perl_call_sv
60# endif
61# ifndef get_sv
62# define get_sv perl_get_sv
63# endif
64# ifndef get_cv
65# define get_cv perl_get_cv
66# endif
67# ifndef IS_PADGV
68# define IS_PADGV(v) 0
69# endif
70# ifndef IS_PADCONST
71# define IS_PADCONST(v) 0
72# endif
73#endif
10 74
75/* 5.8.7 */
76#ifndef SvRV_set
77# define SvRV_set(s,v) SvRV(s) = (v)
78#endif
79
80#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
81# undef CORO_STACKGUARD
82#endif
83
84#ifndef CORO_STACKGUARD
85# define CORO_STACKGUARD 0
86#endif
87
88/* prefer perl internal functions over our own? */
89#ifndef CORO_PREFER_PERL_FUNCTIONS
90# define CORO_PREFER_PERL_FUNCTIONS 0
91#endif
92
93/* The next macros try to return the current stack pointer, in an as
94 * portable way as possible. */
95#define dSTACKLEVEL volatile char stacklevel
96#define STACKLEVEL ((void *)&stacklevel)
97
98#define IN_DESTRUCT (PL_main_cv == Nullcv)
99
100#if __GNUC__ >= 3
101# define attribute(x) __attribute__(x)
102# define BARRIER __asm__ __volatile__ ("" : : : "memory")
103#else
104# define attribute(x)
105# define BARRIER
106#endif
107
108#define NOINLINE attribute ((noinline))
109
110#include "CoroAPI.h"
111
112#ifdef USE_ITHREADS
113static perl_mutex coro_mutex;
114# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
115# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
116#else
117# define LOCK (void)0
118# define UNLOCK (void)0
119#endif
120
121/* helper storage struct for Coro::AIO */
122struct io_state
123{
124 int errorno;
125 I32 laststype;
126 int laststatval;
127 Stat_t statcache;
128};
129
130static size_t coro_stacksize = CORO_STACKSIZE;
131static struct CoroAPI coroapi;
132static AV *main_mainstack; /* used to differentiate between $main and others */
133static JMPENV *main_top_env;
134static HV *coro_state_stash, *coro_stash;
135static SV *coro_mortal; /* will be freed after next transfer */
136
137static GV *irsgv; /* $/ */
138
139/* async_pool helper stuff */
140static SV *sv_pool_rss;
141static SV *sv_pool_size;
142static AV *av_async_pool;
143
144static struct coro_cctx *cctx_first;
145static int cctx_count, cctx_idle;
146
147enum {
148 CC_MAPPED = 0x01,
149 CC_NOREUSE = 0x02, /* throw this away after tracing */
150 CC_TRACE = 0x04,
151 CC_TRACE_SUB = 0x08, /* trace sub calls */
152 CC_TRACE_LINE = 0x10, /* trace each statement */
153 CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
154};
155
156/* this is a structure representing a c-level coroutine */
157typedef struct coro_cctx {
158 struct coro_cctx *next;
159
160 /* the stack */
161 void *sptr;
162 size_t ssize;
163
164 /* cpu state */
165 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
166 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
167 JMPENV *top_env;
168 coro_context cctx;
169
170#if CORO_USE_VALGRIND
171 int valgrind_id;
172#endif
173 unsigned char flags;
174} coro_cctx;
175
176enum {
177 CF_RUNNING = 0x0001, /* coroutine is running */
178 CF_READY = 0x0002, /* coroutine is ready */
179 CF_NEW = 0x0004, /* has never been switched to */
180 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
181};
182
183/* this is a structure representing a perl-level coroutine */
11struct coro { 184struct coro {
12 U8 dowarn; 185 /* the c coroutine allocated to this perl coroutine, if any */
13 AV *defav; 186 coro_cctx *cctx;
187
188 /* data associated with this coroutine (initial args) */
189 AV *args;
190 int refcnt;
191 int flags; /* CF_ flags */
192
193 /* optionally saved, might be zero */
194 AV *defav; /* @_ */
195 SV *defsv; /* $_ */
196 SV *errsv; /* $@ */
197 SV *deffh; /* default filehandle */
198 SV *irssv; /* $/ */
199 SV *irssv_sv; /* real $/ cache */
14 200
15 PERL_SI *curstackinfo; 201#define VAR(name,type) type name;
16 AV *curstack; 202# include "state.h"
17 AV *mainstack; 203#undef VAR
18 SV **stack_sp;
19 OP *op;
20 SV **curpad;
21 SV **stack_base;
22 SV **stack_max;
23 SV **tmps_stack;
24 I32 tmps_floor;
25 I32 tmps_ix;
26 I32 tmps_max;
27 I32 *markstack;
28 I32 *markstack_ptr;
29 I32 *markstack_max;
30 I32 *scopestack;
31 I32 scopestack_ix;
32 I32 scopestack_max;
33 ANY *savestack;
34 I32 savestack_ix;
35 I32 savestack_max;
36 OP **retstack;
37 I32 retstack_ix;
38 I32 retstack_max;
39 COP *curcop;
40 204
41 AV *args; 205 /* statistics */
206 int usecount; /* number of transfers to this coro */
207
208 /* coro process data */
209 int prio;
210 //SV *throw;
211
212 /* async_pool */
213 SV *saved_deffh;
214
215 /* linked list */
216 struct coro *next, *prev;
217 HV *hv; /* the perl hash associated with this coro, if any */
42}; 218};
43 219
44typedef struct coro *Coro__State; 220typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 221typedef struct coro *Coro__State_or_hashref;
46 222
47static HV *padlist_cache; 223/** Coro ********************************************************************/
48 224
49/* mostly copied from op.c:cv_clone2 */ 225#define PRIO_MAX 3
50STATIC AV * 226#define PRIO_HIGH 1
51clone_padlist (AV *protopadlist) 227#define PRIO_NORMAL 0
228#define PRIO_LOW -1
229#define PRIO_IDLE -3
230#define PRIO_MIN -4
231
232/* for Coro.pm */
233static SV *coro_current;
234static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
235static int coro_nready;
236static struct coro *coro_first;
237
238/** lowlevel stuff **********************************************************/
239
240static AV *
241coro_clone_padlist (pTHX_ CV *cv)
52{ 242{
53 AV *av; 243 AV *padlist = CvPADLIST (cv);
54 I32 ix;
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
57 SV **pname = AvARRAY (protopad_name);
58 SV **ppad = AvARRAY (protopad);
59 I32 fname = AvFILLp (protopad_name);
60 I32 fpad = AvFILLp (protopad);
61 AV *newpadlist, *newpad_name, *newpad; 244 AV *newpadlist, *newpad;
62 SV **npad;
63
64 newpad_name = newAV ();
65 for (ix = fname; ix >= 0; ix--)
66 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
67
68 newpad = newAV ();
69 av_fill (newpad, AvFILLp (protopad));
70 npad = AvARRAY (newpad);
71 245
72 newpadlist = newAV (); 246 newpadlist = newAV ();
73 AvREAL_off (newpadlist); 247 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 248#if PERL_VERSION_ATLEAST (5,9,0)
249 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
250#else
251 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
252#endif
253 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
254 --AvFILLp (padlist);
255
256 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75 av_store (newpadlist, 1, (SV *) newpad); 257 av_store (newpadlist, 1, (SV *)newpad);
76 258
77 av = newAV (); /* will be @_ */ 259 return newpadlist;
78 av_extend (av, 0); 260}
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 261
82 for (ix = fpad; ix > 0; ix--) 262static void
263free_padlist (pTHX_ AV *padlist)
264{
265 /* may be during global destruction */
266 if (SvREFCNT (padlist))
83 { 267 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 268 I32 i = AvFILLp (padlist);
85 if (namesv && namesv != &PL_sv_undef) 269 while (i >= 0)
86 { 270 {
87 char *name = SvPVX (namesv); /* XXX */ 271 SV **svp = av_fetch (padlist, i--, FALSE);
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 272 if (svp)
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 } 273 {
92 else
93 { /* our own lexical */
94 SV *sv; 274 SV *sv;
95 if (*name == '&') 275 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96 sv = SvREFCNT_inc (ppad[ix]); 276 SvREFCNT_dec (sv);
97 else if (*name == '@') 277
98 sv = (SV *) newAV (); 278 SvREFCNT_dec (*svp);
99 else if (*name == '%')
100 sv = (SV *) newHV ();
101 else
102 sv = NEWSV (0, 0);
103 if (!SvPADBUSY (sv))
104 SvPADMY_on (sv);
105 npad[ix] = sv;
106 } 279 }
107 } 280 }
108 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
109 {
110 npad[ix] = SvREFCNT_inc (ppad[ix]);
111 }
112 else
113 {
114 SV *sv = NEWSV (0, 0);
115 SvPADTMP_on (sv);
116 npad[ix] = sv;
117 }
118 }
119 281
120#if 0 /* NONOTUNDERSTOOD */
121 /* Now that vars are all in place, clone nested closures. */
122
123 for (ix = fpad; ix > 0; ix--) {
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125 if (namesv
126 && namesv != &PL_sv_undef
127 && !(SvFLAGS(namesv) & SVf_FAKE)
128 && *SvPVX(namesv) == '&'
129 && CvCLONE(ppad[ix]))
130 {
131 CV *kid = cv_clone((CV*)ppad[ix]);
132 SvREFCNT_dec(ppad[ix]);
133 CvCLONE_on(kid);
134 SvPADMY_on(kid);
135 npad[ix] = (SV*)kid;
136 }
137 }
138#endif
139
140 return newpadlist;
141}
142
143STATIC AV *
144free_padlist (AV *padlist)
145{
146 /* may be during global destruction */
147 if (SvREFCNT(padlist))
148 {
149 I32 i = AvFILLp(padlist);
150 while (i >= 0)
151 {
152 SV **svp = av_fetch(padlist, i--, FALSE);
153 SV *sv = svp ? *svp : Nullsv;
154 if (sv)
155 SvREFCNT_dec(sv);
156 }
157
158 SvREFCNT_dec((SV*)padlist); 282 SvREFCNT_dec ((SV*)padlist);
283 }
284}
285
286static int
287coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
288{
289 AV *padlist;
290 AV *av = (AV *)mg->mg_obj;
291
292 /* casting is fun. */
293 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
294 free_padlist (aTHX_ padlist);
295
296 SvREFCNT_dec (av);
297
298 return 0;
299}
300
301#define PERL_MAGIC_coro PERL_MAGIC_ext
302
303static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
304
305#define CORO_MAGIC(cv) \
306 SvMAGIC (cv) \
307 ? SvMAGIC (cv)->mg_type == PERL_MAGIC_coro \
308 ? SvMAGIC (cv) \
309 : mg_find ((SV *)cv, PERL_MAGIC_coro) \
310 : 0
311
312static struct coro *
313SvSTATE_ (pTHX_ SV *coro)
314{
315 HV *stash;
316 MAGIC *mg;
317
318 if (SvROK (coro))
319 coro = SvRV (coro);
320
321 if (SvTYPE (coro) != SVt_PVHV)
322 croak ("Coro::State object required");
323
324 stash = SvSTASH (coro);
325 if (stash != coro_stash && stash != coro_state_stash)
326 {
327 /* very slow, but rare, check */
328 if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
329 croak ("Coro::State object required");
330 }
331
332 mg = CORO_MAGIC (coro);
333 return (struct coro *)mg->mg_ptr;
334}
335
336#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
337
338/* the next two functions merely cache the padlists */
339static void
340get_padlist (pTHX_ CV *cv)
341{
342 MAGIC *mg = CORO_MAGIC (cv);
343 AV *av;
344
345 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
346 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
347 else
348 {
349#if CORO_PREFER_PERL_FUNCTIONS
350 /* this is probably cleaner, but also slower? */
351 CV *cp = Perl_cv_clone (cv);
352 CvPADLIST (cv) = CvPADLIST (cp);
353 CvPADLIST (cp) = 0;
354 SvREFCNT_dec (cp);
355#else
356 CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
357#endif
358 }
359}
360
361static void
362put_padlist (pTHX_ CV *cv)
363{
364 MAGIC *mg = CORO_MAGIC (cv);
365 AV *av;
366
367 if (!mg)
368 {
369 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
370 mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
371 mg->mg_virtual = &vtbl_coro;
372 mg->mg_obj = (SV *)newAV ();
373 }
374
375 av = (AV *)mg->mg_obj;
376
377 if (AvFILLp (av) >= AvMAX (av))
378 av_extend (av, AvMAX (av) + 1);
379
380 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
381}
382
383/** load & save, init *******************************************************/
384
385static void
386load_perl (pTHX_ Coro__State c)
387{
388#define VAR(name,type) PL_ ## name = c->name;
389# include "state.h"
390#undef VAR
391
392 GvSV (PL_defgv) = c->defsv;
393 GvAV (PL_defgv) = c->defav;
394 GvSV (PL_errgv) = c->errsv;
395 GvSV (irsgv) = c->irssv_sv;
396
397 {
398 dSP;
399 CV *cv;
400
401 /* now do the ugly restore mess */
402 while ((cv = (CV *)POPs))
403 {
404 put_padlist (aTHX_ cv); /* mark this padlist as available */
405 CvDEPTH (cv) = PTR2IV (POPs);
406 CvPADLIST (cv) = (AV *)POPs;
407 }
408
409 PUTBACK;
159 } 410 }
160} 411}
161 412
162STATIC AV *
163unuse_padlist (AV *padlist)
164{
165 free_padlist (padlist);
166}
167
168static void 413static void
169SAVE(pTHX_ Coro__State c) 414save_perl (pTHX_ Coro__State c)
170{ 415{
171 { 416 {
172 dSP; 417 dSP;
173 I32 cxix = cxstack_ix; 418 I32 cxix = cxstack_ix;
419 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 420 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 421
177 /* 422 /*
178 * the worst thing you can imagine happens first - we have to save 423 * the worst thing you can imagine happens first - we have to save
179 * (and reinitialize) all cv's in the whole callchain :( 424 * (and reinitialize) all cv's in the whole callchain :(
180 */ 425 */
181 426
182 PUSHs (Nullsv); 427 XPUSHs (Nullsv);
183 /* this loop was inspired by pp_caller */ 428 /* this loop was inspired by pp_caller */
184 for (;;) 429 for (;;)
185 { 430 {
186 while (cxix >= 0) 431 while (cxix >= 0)
187 { 432 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 433 PERL_CONTEXT *cx = &ccstk[cxix--];
189 434
190 if (CxTYPE(cx) == CXt_SUB) 435 if (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT)
191 { 436 {
192 CV *cv = cx->blk_sub.cv; 437 CV *cv = cx->blk_sub.cv;
438
193 if (CvDEPTH(cv)) 439 if (CvDEPTH (cv))
194 { 440 {
195#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv));
197#endif
198 EXTEND (SP, 3); 441 EXTEND (SP, 3);
199 PUSHs ((SV *)CvDEPTH(cv));
200 PUSHs ((SV *)CvPADLIST(cv)); 442 PUSHs ((SV *)CvPADLIST (cv));
443 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
201 PUSHs ((SV *)cv); 444 PUSHs ((SV *)cv);
202 445
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));
204
205 CvDEPTH(cv) = 0; 446 CvDEPTH (cv) = 0;
206#ifdef USE_THREADS 447 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 } 448 }
213 } 449 }
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 } 450 }
221 451
222 if (top_si->si_type == PERLSI_MAIN) 452 if (top_si->si_type == PERLSI_MAIN)
223 break; 453 break;
224 454
225 top_si = top_si->si_prev; 455 top_si = top_si->si_prev;
226 ccstk = top_si->si_cxstack; 456 ccstk = top_si->si_cxstack;
227 cxix = top_si->si_cxix; 457 cxix = top_si->si_cxix;
228 } 458 }
229 459
230 PUTBACK; 460 PUTBACK;
231 } 461 }
232 462
233 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv); 463 c->defav = GvAV (PL_defgv);
235 c->curstackinfo = PL_curstackinfo; 464 c->defsv = DEFSV;
236 c->curstack = PL_curstack; 465 c->errsv = ERRSV;
237 c->mainstack = PL_mainstack; 466 c->irssv_sv = GvSV (irsgv);
238 c->stack_sp = PL_stack_sp; 467
239 c->op = PL_op; 468#define VAR(name,type)c->name = PL_ ## name;
240 c->curpad = PL_curpad; 469# include "state.h"
470#undef VAR
471}
472
473/*
474 * allocate various perl stacks. This is an exact copy
475 * of perl.c:init_stacks, except that it uses less memory
476 * on the (sometimes correct) assumption that coroutines do
477 * not usually need a lot of stackspace.
478 */
479#if CORO_PREFER_PERL_FUNCTIONS
480# define coro_init_stacks init_stacks
481#else
482static void
483coro_init_stacks (pTHX)
484{
485 PL_curstackinfo = new_stackinfo(64, 6);
486 PL_curstackinfo->si_type = PERLSI_MAIN;
487 PL_curstack = PL_curstackinfo->si_stack;
488 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
489
490 PL_stack_base = AvARRAY(PL_curstack);
241 c->stack_base = PL_stack_base; 491 PL_stack_sp = PL_stack_base;
242 c->stack_max = PL_stack_max; 492 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
243 c->tmps_stack = PL_tmps_stack;
244 c->tmps_floor = PL_tmps_floor;
245 c->tmps_ix = PL_tmps_ix;
246 c->tmps_max = PL_tmps_max;
247 c->markstack = PL_markstack;
248 c->markstack_ptr = PL_markstack_ptr;
249 c->markstack_max = PL_markstack_max;
250 c->scopestack = PL_scopestack;
251 c->scopestack_ix = PL_scopestack_ix;
252 c->scopestack_max = PL_scopestack_max;
253 c->savestack = PL_savestack;
254 c->savestack_ix = PL_savestack_ix;
255 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop;
260}
261 493
262static void 494 New(50,PL_tmps_stack,64,SV*);
263LOAD(pTHX_ Coro__State c) 495 PL_tmps_floor = -1;
264{ 496 PL_tmps_ix = -1;
265 PL_dowarn = c->dowarn; 497 PL_tmps_max = 64;
266 GvAV (PL_defgv) = c->defav; 498
267 PL_curstackinfo = c->curstackinfo; 499 New(54,PL_markstack,16,I32);
268 PL_curstack = c->curstack;
269 PL_mainstack = c->mainstack;
270 PL_stack_sp = c->stack_sp;
271 PL_op = c->op;
272 PL_curpad = c->curpad;
273 PL_stack_base = c->stack_base;
274 PL_stack_max = c->stack_max;
275 PL_tmps_stack = c->tmps_stack;
276 PL_tmps_floor = c->tmps_floor;
277 PL_tmps_ix = c->tmps_ix;
278 PL_tmps_max = c->tmps_max;
279 PL_markstack = c->markstack;
280 PL_markstack_ptr = c->markstack_ptr; 500 PL_markstack_ptr = PL_markstack;
281 PL_markstack_max = c->markstack_max; 501 PL_markstack_max = PL_markstack + 16;
282 PL_scopestack = c->scopestack; 502
283 PL_scopestack_ix = c->scopestack_ix; 503#ifdef SET_MARK_OFFSET
284 PL_scopestack_max = c->scopestack_max; 504 SET_MARK_OFFSET;
285 PL_savestack = c->savestack; 505#endif
286 PL_savestack_ix = c->savestack_ix; 506
287 PL_savestack_max = c->savestack_max; 507 New(54,PL_scopestack,16,I32);
288 PL_retstack = c->retstack; 508 PL_scopestack_ix = 0;
289 PL_retstack_ix = c->retstack_ix; 509 PL_scopestack_max = 16;
290 PL_retstack_max = c->retstack_max; 510
291 PL_curcop = c->curcop; 511 New(54,PL_savestack,64,ANY);
512 PL_savestack_ix = 0;
513 PL_savestack_max = 64;
514
515#if !PERL_VERSION_ATLEAST (5,9,0)
516 New(54,PL_retstack,4,OP*);
517 PL_retstack_ix = 0;
518 PL_retstack_max = 4;
519#endif
520}
521#endif
522
523/*
524 * destroy the stacks, the callchain etc...
525 */
526static void
527coro_destroy_stacks (pTHX)
528{
529 while (PL_curstackinfo->si_next)
530 PL_curstackinfo = PL_curstackinfo->si_next;
531
532 while (PL_curstackinfo)
533 {
534 PERL_SI *p = PL_curstackinfo->si_prev;
535
536 if (!IN_DESTRUCT)
537 SvREFCNT_dec (PL_curstackinfo->si_stack);
538
539 Safefree (PL_curstackinfo->si_cxstack);
540 Safefree (PL_curstackinfo);
541 PL_curstackinfo = p;
542 }
543
544 Safefree (PL_tmps_stack);
545 Safefree (PL_markstack);
546 Safefree (PL_scopestack);
547 Safefree (PL_savestack);
548#if !PERL_VERSION_ATLEAST (5,9,0)
549 Safefree (PL_retstack);
550#endif
551}
552
553static size_t
554coro_rss (pTHX_ struct coro *coro)
555{
556 size_t rss = sizeof (*coro);
557
558 if (coro->mainstack)
559 {
560 if (coro->flags & CF_RUNNING)
561 {
562 #define VAR(name,type)coro->name = PL_ ## name;
563 # include "state.h"
564 #undef VAR
565 }
566
567 rss += sizeof (coro->curstackinfo);
568 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvFILL (coro->curstackinfo->si_stack)) * sizeof (SV *);
569 rss += (coro->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
570 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvFILL (coro->curstack)) * sizeof (SV *);
571 rss += coro->tmps_max * sizeof (SV *);
572 rss += (coro->markstack_max - coro->markstack_ptr) * sizeof (I32);
573 rss += coro->scopestack_max * sizeof (I32);
574 rss += coro->savestack_max * sizeof (ANY);
575
576#if !PERL_VERSION_ATLEAST (5,9,0)
577 rss += coro->retstack_max * sizeof (OP *);
578#endif
579 }
580
581 return rss;
582}
583
584/** coroutine stack handling ************************************************/
585
586static void
587coro_setup (pTHX_ struct coro *coro)
588{
589 /*
590 * emulate part of the perl startup here.
591 */
592 coro_init_stacks (aTHX);
593
594 PL_runops = RUNOPS_DEFAULT;
595 PL_curcop = &PL_compiling;
596 PL_in_eval = EVAL_NULL;
597 PL_comppad = 0;
598 PL_curpm = 0;
599 PL_localizing = 0;
600 PL_dirty = 0;
601 PL_restartop = 0;
602
603 GvSV (PL_defgv) = NEWSV (0, 0);
604 GvAV (PL_defgv) = coro->args; coro->args = 0;
605 GvSV (PL_errgv) = NEWSV (0, 0);
606 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
607 PL_rs = newSVsv (GvSV (irsgv));
608
609 SvREFCNT_inc (PL_defoutgv);
292 610
293 { 611 {
294 dSP; 612 dSP;
295 CV *cv; 613 LOGOP myop;
296 614
297 /* now do the ugly restore mess */ 615 Zero (&myop, 1, LOGOP);
298 while ((cv = (CV *)POPs)) 616 myop.op_next = Nullop;
299 { 617 myop.op_flags = OPf_WANT_VOID;
300 AV *padlist = (AV *)POPs;
301 618
302 unuse_padlist (CvPADLIST(cv)); 619 PUSHMARK (SP);
303 CvPADLIST(cv) = padlist; 620 XPUSHs (av_shift (GvAV (PL_defgv)));
304 CvDEPTH(cv) = (I32)POPs;
305
306#ifdef USE_THREADS
307 CvOWNER(cv) = (struct perl_thread *)POPs;
308 error does not work either
309#endif
310 }
311
312 PUTBACK; 621 PUTBACK;
622 PL_op = (OP *)&myop;
623 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
624 SPAGAIN;
313 } 625 }
314}
315 626
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 627 ENTER; /* necessary e.g. for dounwind */
317STATIC void 628}
318S_nuke_stacks(pTHX) 629
630static void
631coro_destroy (pTHX_ struct coro *coro)
319{ 632{
320 while (PL_curstackinfo->si_next) 633 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 } 634 {
329 Safefree(PL_tmps_stack); 635 /* restore all saved variables and stuff */
330 Safefree(PL_markstack); 636 LEAVE_SCOPE (0);
331 Safefree(PL_scopestack); 637 assert (PL_tmps_floor == -1);
332 Safefree(PL_savestack);
333 Safefree(PL_retstack);
334}
335 638
336#define SUB_INIT "Coro::State::_newcoro" 639 /* free all temporaries */
640 FREETMPS;
641 assert (PL_tmps_ix == -1);
337 642
643 /* unwind all extra stacks */
644 POPSTACK_TO (PL_mainstack);
645
646 /* unwind main stack */
647 dounwind (-1);
648 }
649
650 SvREFCNT_dec (GvSV (PL_defgv));
651 SvREFCNT_dec (GvAV (PL_defgv));
652 SvREFCNT_dec (GvSV (PL_errgv));
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;
670 }
671}
672
673static int
674runops_trace (pTHX)
675{
676 COP *oldcop = 0;
677 int oldcxix = -2;
678 struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
679 coro_cctx *cctx = coro->cctx;
680
681 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
682 {
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
845 /*
846 * If perl-run returns we assume exit() was being called or the coro
847 * fell off the end, which seems to be the only valid (non-bug)
848 * reason for perl_run to return. We try to exit by jumping to the
849 * bootstrap-time "top" top_env, as we cannot restore the "main"
850 * coroutine as Coro has no such concept
851 */
852 PL_top_env = main_top_env;
853 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
854}
855
856static coro_cctx *
857cctx_new ()
858{
859 coro_cctx *cctx;
860 void *stack_start;
861 size_t stack_size;
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
338MODULE = Coro::State PACKAGE = Coro::State 1372MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
339 1373
340PROTOTYPES: ENABLE 1374PROTOTYPES: DISABLE
341 1375
342BOOT: 1376BOOT:
343 if (!padlist_cache) 1377{
344 padlist_cache = newHV (); 1378#ifdef USE_ITHREADS
1379 MUTEX_INIT (&coro_mutex);
1380#endif
1381 BOOT_PAGESIZE;
345 1382
346Coro::State 1383 irsgv = gv_fetchpv ("/", 1, SVt_PV);
347_newprocess(args) 1384
348 SV * args 1385 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
349 PROTOTYPE: $ 1386
1387 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1388 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1389 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1390 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1391
1392 main_mainstack = PL_mainstack;
1393 main_top_env = PL_top_env;
1394
1395 while (main_top_env->je_prev)
1396 main_top_env = main_top_env->je_prev;
1397
1398 coroapi.ver = CORO_API_VERSION;
1399 coroapi.transfer = api_transfer;
1400
1401 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1402}
1403
1404SV *
1405new (char *klass, ...)
350 CODE: 1406 CODE:
351 Coro__State coro; 1407{
1408 struct coro *coro;
1409 HV *hv;
1410 int i;
352 1411
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); 1412 Newz (0, coro, 1, struct coro);
1413 coro->args = newAV ();
1414 coro->flags = CF_NEW;
357 1415
358 coro->mainstack = 0; /* actual work is done inside transfer */ 1416 if (coro_first) coro_first->prev = coro;
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1417 coro->next = coro_first;
1418 coro_first = coro;
360 1419
361 RETVAL = coro; 1420 coro->hv = hv = newHV ();
1421 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1422 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1423
1424 for (i = 1; i < items; i++)
1425 av_push (coro->args, newSVsv (ST (i)));
1426}
362 OUTPUT: 1427 OUTPUT:
363 RETVAL 1428 RETVAL
364 1429
1430# these not obviously related functions are all rolled into the same xs
1431# function to increase chances that they all will call transfer with the same
1432# stack offset
365void 1433void
366transfer(prev,next) 1434_set_stacklevel (...)
367 Coro::State_or_hashref prev 1435 ALIAS:
368 Coro::State_or_hashref next 1436 Coro::State::transfer = 1
1437 Coro::schedule = 2
1438 Coro::cede = 3
1439 Coro::cede_notself = 4
369 CODE: 1440 CODE:
1441{
1442 struct transfer_args ta;
370 1443
371 if (prev != next) 1444 switch (ix)
372 { 1445 {
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 1446 case 0:
1447 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1448 ta.next = 0;
389 { 1449 break;
390 /*
391 * emulate part of the perl startup here.
392 */
393 UNOP myop;
394 1450
395 init_stacks (); 1451 case 1:
396 PL_op = (OP *)&myop; 1452 if (items != 2)
397 /*PL_curcop = 0;*/ 1453 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
398 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399 1454
400 SPAGAIN; 1455 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 } 1456 break;
1457
1458 case 2:
1459 prepare_schedule (aTHX_ &ta);
1460 break;
1461
1462 case 3:
1463 prepare_cede (aTHX_ &ta);
1464 break;
1465
1466 case 4:
1467 if (!prepare_cede_notself (aTHX_ &ta))
1468 XSRETURN_EMPTY;
1469
1470 break;
419 } 1471 }
420 1472
1473 BARRIER;
1474 TRANSFER (ta);
1475
1476 if (GIMME_V != G_VOID && ta.next != ta.prev)
1477 XSRETURN_YES;
1478}
1479
1480bool
1481_destroy (SV *coro_sv)
1482 CODE:
1483 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1484 OUTPUT:
1485 RETVAL
1486
421void 1487void
422DESTROY(coro) 1488_exit (code)
423 Coro::State coro 1489 int code
424 CODE: 1490 PROTOTYPE: $
1491 CODE:
1492 _exit (code);
425 1493
1494int
1495cctx_stacksize (int new_stacksize = 0)
1496 CODE:
1497 RETVAL = coro_stacksize;
1498 if (new_stacksize)
1499 coro_stacksize = new_stacksize;
1500 OUTPUT:
1501 RETVAL
1502
1503int
1504cctx_count ()
1505 CODE:
1506 RETVAL = cctx_count;
1507 OUTPUT:
1508 RETVAL
1509
1510int
1511cctx_idle ()
1512 CODE:
1513 RETVAL = cctx_idle;
1514 OUTPUT:
1515 RETVAL
1516
1517void
1518list ()
1519 PPCODE:
1520{
1521 struct coro *coro;
1522 for (coro = coro_first; coro; coro = coro->next)
1523 if (coro->hv)
1524 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1525}
1526
1527void
1528call (Coro::State coro, SV *coderef)
1529 ALIAS:
1530 eval = 1
1531 CODE:
1532{
426 if (coro->mainstack) 1533 if (coro->mainstack)
427 { 1534 {
428 struct coro temp; 1535 struct coro temp;
1536 Zero (&temp, 1, struct coro);
429 1537
1538 if (!(coro->flags & CF_RUNNING))
1539 {
1540 save_perl (aTHX_ &temp);
1541 load_perl (aTHX_ coro);
1542 }
1543
1544 {
1545 dSP;
1546 ENTER;
1547 SAVETMPS;
1548 PUSHMARK (SP);
430 PUTBACK; 1549 PUTBACK;
431 SAVE(aTHX_ (&temp)); 1550 if (ix)
432 LOAD(aTHX_ coro); 1551 eval_sv (coderef, 0);
433 1552 else
434 S_nuke_stacks (); 1553 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437 LOAD((&temp));
438 SPAGAIN; 1554 SPAGAIN;
1555 FREETMPS;
1556 LEAVE;
1557 PUTBACK;
1558 }
1559
1560 if (!(coro->flags & CF_RUNNING))
1561 {
1562 save_perl (aTHX_ coro);
1563 load_perl (aTHX_ &temp);
1564 }
439 } 1565 }
1566}
440 1567
1568SV *
1569is_ready (Coro::State coro)
1570 PROTOTYPE: $
1571 ALIAS:
1572 is_ready = CF_READY
1573 is_running = CF_RUNNING
1574 is_new = CF_NEW
1575 is_destroyed = CF_DESTROYED
1576 CODE:
1577 RETVAL = boolSV (coro->flags & ix);
1578 OUTPUT:
1579 RETVAL
1580
1581void
1582api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1583
1584SV *
1585has_stack (Coro::State coro)
1586 PROTOTYPE: $
1587 CODE:
1588 RETVAL = boolSV (!!coro->cctx);
1589 OUTPUT:
1590 RETVAL
1591
1592int
1593is_traced (Coro::State coro)
1594 PROTOTYPE: $
1595 CODE:
1596 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1597 OUTPUT:
1598 RETVAL
1599
1600IV
1601rss (Coro::State coro)
1602 PROTOTYPE: $
1603 ALIAS:
1604 usecount = 1
1605 CODE:
1606 switch (ix)
1607 {
1608 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1609 case 1: RETVAL = coro->usecount; break;
1610 }
1611 OUTPUT:
1612 RETVAL
1613
1614
1615MODULE = Coro::State PACKAGE = Coro
1616
1617BOOT:
1618{
1619 int i;
1620
1621 sv_pool_rss = get_sv ("Coro::POOL_RSS" , TRUE);
1622 sv_pool_size = get_sv ("Coro::POOL_SIZE" , TRUE);
1623 av_async_pool = get_av ("Coro::async_pool", TRUE);
1624
1625 coro_current = get_sv ("Coro::current", FALSE);
1626 SvREADONLY_on (coro_current);
1627
1628 coro_stash = gv_stashpv ("Coro", TRUE);
1629
1630 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1631 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1632 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1633 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1634 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1635 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1636
1637 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1638 coro_ready[i] = newAV ();
1639
1640 {
1641 SV *sv = perl_get_sv("Coro::API", 1);
1642
1643 coroapi.schedule = api_schedule;
1644 coroapi.cede = api_cede;
1645 coroapi.cede_notself = api_cede_notself;
1646 coroapi.ready = api_ready;
1647 coroapi.is_ready = api_is_ready;
1648 coroapi.nready = &coro_nready;
1649 coroapi.current = coro_current;
1650
1651 GCoroAPI = &coroapi;
1652 sv_setiv (sv, (IV)&coroapi);
1653 SvREADONLY_on (sv);
1654 }
1655}
1656
1657void
1658_set_current (SV *current)
1659 PROTOTYPE: $
1660 CODE:
1661 SvREFCNT_dec (SvRV (coro_current));
1662 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1663
1664int
1665prio (Coro::State coro, int newprio = 0)
1666 ALIAS:
1667 nice = 1
1668 CODE:
1669{
1670 RETVAL = coro->prio;
1671
1672 if (items > 1)
1673 {
1674 if (ix)
1675 newprio = coro->prio - newprio;
1676
1677 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1678 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1679
1680 coro->prio = newprio;
1681 }
1682}
1683 OUTPUT:
1684 RETVAL
1685
1686SV *
1687ready (SV *self)
1688 PROTOTYPE: $
1689 CODE:
1690 RETVAL = boolSV (api_ready (self));
1691 OUTPUT:
1692 RETVAL
1693
1694int
1695nready (...)
1696 PROTOTYPE:
1697 CODE:
1698 RETVAL = coro_nready;
1699 OUTPUT:
1700 RETVAL
1701
1702# for async_pool speedup
1703void
1704_pool_1 (SV *cb)
1705 CODE:
1706{
1707 struct coro *coro = SvSTATE (coro_current);
1708 HV *hv = (HV *)SvRV (coro_current);
1709 AV *defav = GvAV (PL_defgv);
1710 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
1711 AV *invoke_av;
1712 int i, len;
1713
1714 if (!invoke)
1715 croak ("\3terminate\2\n");
1716
441 SvREFCNT_dec (coro->args); 1717 SvREFCNT_dec (coro->saved_deffh);
442 Safefree (coro); 1718 coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
443 1719
1720 hv_store (hv, "desc", sizeof ("desc") - 1,
1721 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
444 1722
1723 invoke_av = (AV *)SvRV (invoke);
1724 len = av_len (invoke_av);
1725
1726 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1727
1728 if (len > 0)
1729 {
1730 av_fill (defav, len - 1);
1731 for (i = 0; i < len; ++i)
1732 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1733 }
1734
1735 SvREFCNT_dec (invoke);
1736}
1737
1738void
1739_pool_2 (SV *cb)
1740 CODE:
1741{
1742 struct coro *coro = SvSTATE (coro_current);
1743
1744 sv_setsv (cb, &PL_sv_undef);
1745
1746 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1747 coro->saved_deffh = 0;
1748
1749 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1750 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1751 croak ("\3terminate\2\n");
1752
1753 av_clear (GvAV (PL_defgv));
1754 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
1755 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
1756
1757 coro->prio = 0;
1758
1759 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1760 api_trace (coro_current, 0);
1761
1762 av_push (av_async_pool, newSVsv (coro_current));
1763}
1764
1765
1766MODULE = Coro::State PACKAGE = Coro::AIO
1767
1768SV *
1769_get_state ()
1770 CODE:
1771{
1772 struct io_state *data;
1773
1774 RETVAL = newSV (sizeof (struct io_state));
1775 data = (struct io_state *)SvPVX (RETVAL);
1776 SvCUR_set (RETVAL, sizeof (struct io_state));
1777 SvPOK_only (RETVAL);
1778
1779 data->errorno = errno;
1780 data->laststype = PL_laststype;
1781 data->laststatval = PL_laststatval;
1782 data->statcache = PL_statcache;
1783}
1784 OUTPUT:
1785 RETVAL
1786
1787void
1788_set_state (char *data_)
1789 PROTOTYPE: $
1790 CODE:
1791{
1792 struct io_state *data = (void *)data_;
1793
1794 errno = data->errorno;
1795 PL_laststype = data->laststype;
1796 PL_laststatval = data->laststatval;
1797 PL_statcache = data->statcache;
1798}
1799

Diff Legend

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