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

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

Diff Legend

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