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.190 by root, Fri Oct 5 20:39:39 2007 UTC

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

Diff Legend

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