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

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

Diff Legend

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