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

Diff Legend

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