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.6 by root, Tue Jul 17 15:42:28 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
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_state(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(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);
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
282#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0) 469 New(50,PL_tmps_stack,128,SV*);
283#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0) 470 PL_tmps_floor = -1;
471 PL_tmps_ix = -1;
472 PL_tmps_max = 128;
284 473
285static void 474 New(54,PL_markstack,32,I32);
286load_state(pTHX_ Coro__State c)
287{
288 PL_dowarn = c->dowarn;
289 GvAV (PL_defgv) = c->defav;
290 PL_curstackinfo = c->curstackinfo;
291 PL_curstack = c->curstack;
292 PL_mainstack = c->mainstack;
293 PL_stack_sp = c->stack_sp;
294 PL_op = c->op;
295 PL_curpad = c->curpad;
296 PL_stack_base = c->stack_base;
297 PL_stack_max = c->stack_max;
298 PL_tmps_stack = c->tmps_stack;
299 PL_tmps_floor = c->tmps_floor;
300 PL_tmps_ix = c->tmps_ix;
301 PL_tmps_max = c->tmps_max;
302 PL_markstack = c->markstack;
303 PL_markstack_ptr = c->markstack_ptr; 475 PL_markstack_ptr = PL_markstack;
304 PL_markstack_max = c->markstack_max; 476 PL_markstack_max = PL_markstack + 32;
305 PL_scopestack = c->scopestack; 477
306 PL_scopestack_ix = c->scopestack_ix; 478#ifdef SET_MARK_OFFSET
307 PL_scopestack_max = c->scopestack_max; 479 SET_MARK_OFFSET;
308 PL_savestack = c->savestack; 480#endif
309 PL_savestack_ix = c->savestack_ix; 481
310 PL_savestack_max = c->savestack_max; 482 New(54,PL_scopestack,32,I32);
311 PL_retstack = c->retstack; 483 PL_scopestack_ix = 0;
312 PL_retstack_ix = c->retstack_ix; 484 PL_scopestack_max = 32;
313 PL_retstack_max = c->retstack_max; 485
314 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;
315 562
316 { 563 {
317 dSP; 564 dSP;
318 CV *cv; 565 LOGOP myop;
319 566
320 /* now do the ugly restore mess */ 567 SvREFCNT_dec (GvAV (PL_defgv));
321 while ((cv = (CV *)POPs)) 568 GvAV (PL_defgv) = coro->args; coro->args = 0;
322 {
323 AV *padlist = (AV *)POPs;
324 569
325 put_padlist (cv); 570 Zero (&myop, 1, LOGOP);
326 CvPADLIST(cv) = padlist; 571 myop.op_next = Nullop;
327 CvDEPTH(cv) = (I32)POPs; 572 myop.op_flags = OPf_WANT_VOID;
328 573
329#ifdef USE_THREADS 574 PUSHMARK (SP);
330 CvOWNER(cv) = (struct perl_thread *)POPs; 575 XPUSHs (av_shift (GvAV (PL_defgv)));
331 error does not work either
332#endif
333 }
334
335 PUTBACK; 576 PUTBACK;
577 PL_op = (OP *)&myop;
578 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
579 SPAGAIN;
336 } 580 }
337}
338 581
339/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 582 ENTER; /* necessary e.g. for dounwind */
340STATIC void 583}
341destroy_stacks(pTHX)
342{
343 /* die does this while calling POPSTACK, but I just don't see why. */
344 /* OTOH, die does not have a memleak, but we do... */
345 dounwind(-1);
346 584
347 /* is this ugly, I ask? */ 585static void
348 while (PL_scopestack_ix) 586free_coro_mortal (pTHX)
349 LEAVE; 587{
350 588 if (coro_mortal)
351 while (PL_curstackinfo->si_next) 589 {
352 PL_curstackinfo = PL_curstackinfo->si_next; 590 SvREFCNT_dec (coro_mortal);
353 591 coro_mortal = 0;
354 while (PL_curstackinfo)
355 { 592 }
356 PERL_SI *p = PL_curstackinfo->si_prev; 593}
357 594
358 SvREFCNT_dec(PL_curstackinfo->si_stack); 595/* inject a fake call to Coro::State::_cctx_init into the execution */
359 Safefree(PL_curstackinfo->si_cxstack); 596/* _cctx_init should be careful, as it could be called at almost any time */
360 Safefree(PL_curstackinfo); 597/* during execution of a perl program */
361 PL_curstackinfo = p; 598static void NOINLINE
362 } 599prepare_cctx (pTHX_ coro_cctx *cctx)
600{
601 dSP;
602 LOGOP myop;
363 603
364 if (PL_scopestack_ix != 0) 604 Zero (&myop, 1, LOGOP);
365 Perl_warner(aTHX_ WARN_INTERNAL, 605 myop.op_next = PL_op;
366 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 606 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
367 (long)PL_scopestack_ix); 607
368 if (PL_savestack_ix != 0) 608 PUSHMARK (SP);
369 Perl_warner(aTHX_ WARN_INTERNAL, 609 EXTEND (SP, 2);
370 "Unbalanced saves: %ld more saves than restores\n", 610 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
371 (long)PL_savestack_ix); 611 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
372 if (PL_tmps_floor != -1) 612 PUTBACK;
373 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 613 PL_op = (OP *)&myop;
374 (long)PL_tmps_floor + 1); 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
375 /* 638 /*
376 */ 639 * If perl-run returns we assume exit() was being called or the coro
377 Safefree(PL_tmps_stack); 640 * fell off the end, which seems to be the only valid (non-bug)
378 Safefree(PL_markstack); 641 * reason for perl_run to return. We try to exit by jumping to the
379 Safefree(PL_scopestack); 642 * bootstrap-time "top" top_env, as we cannot restore the "main"
380 Safefree(PL_savestack); 643 * coroutine as Coro has no such concept
381 Safefree(PL_retstack); 644 */
645 PL_top_env = main_top_env;
646 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
382} 647}
383 648
384#define SUB_INIT "Coro::State::_newcoro" 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}
385 1176
386MODULE = Coro::State PACKAGE = Coro::State 1177MODULE = Coro::State PACKAGE = Coro::State
387 1178
388PROTOTYPES: ENABLE 1179PROTOTYPES: DISABLE
389 1180
390BOOT: 1181BOOT:
391 if (!padlist_cache) 1182{
392 padlist_cache = newHV (); 1183#ifdef USE_ITHREADS
1184 MUTEX_INIT (&coro_mutex);
1185#endif
1186 BOOT_PAGESIZE;
393 1187
394Coro::State 1188 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
395_newprocess(args) 1189
396 SV * args 1190 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
397 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, ...)
398 CODE: 1212 CODE:
399 Coro__State coro; 1213{
1214 struct coro *coro;
1215 HV *hv;
1216 int i;
400 1217
401 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
402 croak ("Coro::State::newprocess expects an arrayref");
403
404 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;
405 1222
406 coro->mainstack = 0; /* actual work is done inside transfer */ 1223 if (first) first->prev = coro;
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1224 coro->next = first;
1225 first = coro;
408 1226
409 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}
410 OUTPUT: 1234 OUTPUT:
411 RETVAL 1235 RETVAL
412 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
413void 1255void
414transfer(prev,next) 1256_set_stacklevel (...)
415 Coro::State_or_hashref prev 1257 ALIAS:
416 Coro::State_or_hashref next 1258 Coro::State::transfer = 1
1259 Coro::schedule = 2
1260 Coro::cede = 3
1261 Coro::cede_notself = 4
417 CODE: 1262 CODE:
1263{
1264 struct transfer_args ta;
418 1265
419 if (prev != next) 1266 switch (ix)
420 { 1267 {
421 /*
422 * this could be done in newprocess which would lead to
423 * extremely elegant and fast (just SAVE/LOAD)
424 * code here, but lazy allocation of stacks has also
425 * some virtues and the overhead of the if() is nil.
426 */
427 if (next->mainstack)
428 {
429 SAVE (prev);
430 LOAD (next);
431 /* mark this state as in-use */
432 next->mainstack = 0;
433 next->tmps_ix = -2;
434 }
435 else if (next->tmps_ix == -2)
436 {
437 croak ("tried to transfer to running coroutine");
438 }
439 else 1268 case 0:
1269 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1270 ta.next = 0;
440 { 1271 break;
441 SAVE (prev);
442 1272
443 /* 1273 case 1:
444 * emulate part of the perl startup here. 1274 if (items != 2)
445 */ 1275 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446 UNOP myop;
447 1276
448 init_stacks (); /* from perl.c */ 1277 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
449 PL_op = (OP *)&myop;
450 /*PL_curcop = 0;*/
451 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452
453 SPAGAIN;
454 Zero(&myop, 1, UNOP);
455 myop.op_next = Nullop;
456 myop.op_flags = OPf_WANT_VOID;
457
458 PUSHMARK(SP);
459 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460 PUTBACK;
461 /*
462 * the next line is slightly wrong, as PL_op->op_next
463 * is actually being executed so we skip the first op.
464 * that doesn't matter, though, since it is only
465 * pp_nextstate and we never return...
466 */
467 PL_op = Perl_pp_entersub(aTHX);
468 SPAGAIN;
469
470 ENTER;
471 } 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;
472 } 1293 }
473 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
474void 1309void
475DESTROY(coro) 1310_exit (code)
476 Coro::State coro 1311 int code
477 CODE: 1312 PROTOTYPE: $
1313 CODE:
1314 _exit (code);
478 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);
479 if (coro->mainstack) 1354 if (coro->mainstack)
480 { 1355 {
481 struct coro temp; 1356 struct coro temp;
1357 Zero (&temp, 1, struct coro);
1358 temp.save = CORO_SAVE_ALL;
482 1359
483 SAVE(aTHX_ (&temp)); 1360 if (!(coro->flags & CF_RUNNING))
484 LOAD(aTHX_ coro); 1361 {
1362 save_perl (aTHX_ &temp);
1363 load_perl (aTHX_ coro);
1364 }
485 1365
486 destroy_stacks (); 1366 {
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 1367 dSP;
1368 ENTER;
1369 SAVETMPS;
1370 PUSHMARK (SP);
1371 PUTBACK;
1372 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1373 SPAGAIN;
1374 FREETMPS;
1375 LEAVE;
1376 PUTBACK;
1377 }
488 1378
489 LOAD((&temp)); 1379 if (!(coro->flags & CF_RUNNING))
1380 {
1381 save_perl (aTHX_ coro);
1382 load_perl (aTHX_ &temp);
1383 }
490 } 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
491 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:
492 SvREFCNT_dec (coro->args); 1445 SvREFCNT_dec (SvRV (coro_current));
493 Safefree (coro); 1446 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
494 1447
1448int
1449prio (Coro::State coro, int newprio = 0)
1450 ALIAS:
1451 nice = 1
1452 CODE:
1453{
1454 RETVAL = coro->prio;
495 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