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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.106 by root, Mon Nov 27 02:08:55 2006 UTC

1#include "libcoro/coro.c"
2
1#include "EXTERN.h" 3#include "EXTERN.h"
2#include "perl.h" 4#include "perl.h"
3#include "XSUB.h" 5#include "XSUB.h"
4 6
5#if 0 7#include "patchlevel.h"
6# define CHK(x) (void *)0 8
9#if USE_VALGRIND
10# include <valgrind/valgrind.h>
11#endif
12
13#define PERL_VERSION_ATLEAST(a,b,c) \
14 (PERL_REVISION > (a) \
15 || (PERL_REVISION == (a) \
16 && (PERL_VERSION > (b) \
17 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
18
19#if !PERL_VERSION_ATLEAST (5,6,0)
20# ifndef PL_ppaddr
21# define PL_ppaddr ppaddr
22# endif
23# ifndef call_sv
24# define call_sv perl_call_sv
25# endif
26# ifndef get_sv
27# define get_sv perl_get_sv
28# endif
29# ifndef get_cv
30# define get_cv perl_get_cv
31# endif
32# ifndef IS_PADGV
33# define IS_PADGV(v) 0
34# endif
35# ifndef IS_PADCONST
36# define IS_PADCONST(v) 0
37# endif
38#endif
39
40#include <stdio.h>
41#include <errno.h>
42
43#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
44# undef STACKGUARD
45#endif
46
47#ifndef STACKGUARD
48# define STACKGUARD 0
49#endif
50
51#ifdef HAVE_MMAP
52# include <unistd.h>
53# include <sys/mman.h>
54# ifndef MAP_ANONYMOUS
55# ifdef MAP_ANON
56# define MAP_ANONYMOUS MAP_ANON
57# else
58# undef HAVE_MMAP
59# endif
60# endif
61# include <limits.h>
62# ifndef PAGESIZE
63# define PAGESIZE pagesize
64# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
65static long pagesize;
66# else
67# define BOOT_PAGESIZE (void)0
68# endif
7#else 69#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 70# define PAGESIZE 0
71# define BOOT_PAGESIZE (void)0
9#endif 72#endif
10 73
74/* The next macro should declare a variable stacklevel that contains and approximation
75 * to the current C stack pointer. Its property is that it changes with each call
76 * and should be unique. */
77#define dSTACKLEVEL int stacklevel
78#define STACKLEVEL ((void *)&stacklevel)
79
80#define IN_DESTRUCT (PL_main_cv == Nullcv)
81
82#if __GNUC__ >= 3
83# define attribute(x) __attribute__(x)
84#else
85# define attribute(x)
86#endif
87
88#define NOINLINE attribute ((noinline))
89
90#include "CoroAPI.h"
91
92#define TRANSFER_SET_STACKLEVEL 0x8bfbfbfb /* magic cookie */
93
94#ifdef USE_ITHREADS
95static perl_mutex coro_mutex;
96# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
97# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
98#else
99# define LOCK (void)0
100# define UNLOCK (void)0
101#endif
102
103static struct CoroAPI coroapi;
104static AV *main_mainstack; /* used to differentiate between $main and others */
105static HV *coro_state_stash, *coro_stash;
106static SV *coro_mortal; /* will be freed after next transfer */
107
108/* this is a structure representing a c-level coroutine */
109typedef struct coro_cctx {
110 struct coro_cctx *next;
111
112 /* the stack */
113 void *sptr;
114 long ssize; /* positive == mmap, otherwise malloc */
115
116 /* cpu state */
117 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
118 JMPENV *top_env;
119 coro_context cctx;
120
121#if USE_VALGRIND
122 int valgrind_id;
123#endif
124} coro_cctx;
125
126/* this is a structure representing a perl-level coroutine */
11struct coro { 127struct coro {
128 /* the c coroutine allocated to this perl coroutine, if any */
129 coro_cctx *cctx;
130
131 /* data associated with this coroutine (initial args) */
132 AV *args;
133 int refcnt;
134
135 /* optionally saved, might be zero */
136 AV *defav;
137 SV *defsv;
138 SV *errsv;
139
140 /* saved global state not related to stacks */
12 U8 dowarn; 141 U8 dowarn;
13 AV *defav; 142 I32 in_eval;
14 143
144 /* the stacks and related info (callchain etc..) */
15 PERL_SI *curstackinfo; 145 PERL_SI *curstackinfo;
16 AV *curstack; 146 AV *curstack;
17 AV *mainstack; 147 AV *mainstack;
18 SV **stack_sp; 148 SV **stack_sp;
19 OP *op; 149 OP *op;
20 SV **curpad; 150 SV **curpad;
151 AV *comppad;
152 CV *compcv;
21 SV **stack_base; 153 SV **stack_base;
22 SV **stack_max; 154 SV **stack_max;
23 SV **tmps_stack; 155 SV **tmps_stack;
24 I32 tmps_floor; 156 I32 tmps_floor;
25 I32 tmps_ix; 157 I32 tmps_ix;
… …
34 I32 savestack_ix; 166 I32 savestack_ix;
35 I32 savestack_max; 167 I32 savestack_max;
36 OP **retstack; 168 OP **retstack;
37 I32 retstack_ix; 169 I32 retstack_ix;
38 I32 retstack_max; 170 I32 retstack_max;
171 PMOP *curpm;
39 COP *curcop; 172 COP *curcop;
40 173
41 AV *args; 174 /* coro process data */
175 int prio;
42}; 176};
43 177
44typedef struct coro *Coro__State; 178typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 179typedef struct coro *Coro__State_or_hashref;
46 180
47static HV *padlist_cache; 181static AV *
48 182coro_clone_padlist (CV *cv)
49/* mostly copied from op.c:cv_clone2 */
50STATIC AV *
51clone_padlist (AV *protopadlist)
52{ 183{
53 AV *av; 184 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; 185 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 186
72 newpadlist = newAV (); 187 newpadlist = newAV ();
73 AvREAL_off (newpadlist); 188 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 189#if PERL_VERSION_ATLEAST (5,9,0)
190 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
191#else
192 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
193#endif
194 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
195 --AvFILLp (padlist);
196
197 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75 av_store (newpadlist, 1, (SV *) newpad); 198 av_store (newpadlist, 1, (SV *)newpad);
76 199
77 av = newAV (); /* will be @_ */ 200 return newpadlist;
78 av_extend (av, 0); 201}
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 202
82 for (ix = fpad; ix > 0; ix--) 203static void
204free_padlist (AV *padlist)
205{
206 /* may be during global destruction */
207 if (SvREFCNT (padlist))
83 { 208 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 209 I32 i = AvFILLp (padlist);
85 if (namesv && namesv != &PL_sv_undef) 210 while (i >= 0)
86 { 211 {
87 char *name = SvPVX (namesv); /* XXX */ 212 SV **svp = av_fetch (padlist, i--, FALSE);
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 213 if (svp)
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 } 214 {
92 else
93 { /* our own lexical */
94 SV *sv; 215 SV *sv;
95 if (*name == '&') 216 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96 sv = SvREFCNT_inc (ppad[ix]); 217 SvREFCNT_dec (sv);
97 else if (*name == '@') 218
98 sv = (SV *) newAV (); 219 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 } 220 }
107 } 221 }
108 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix])) 222
109 { 223 SvREFCNT_dec ((SV*)padlist);
110 npad[ix] = SvREFCNT_inc (ppad[ix]);
111 }
112 else
113 {
114 SV *sv = NEWSV (0, 0);
115 SvPADTMP_on (sv);
116 npad[ix] = sv;
117 }
118 } 224 }
225}
119 226
120#if 0 /* NONOTUNDERSTOOD */ 227static int
121 /* Now that vars are all in place, clone nested closures. */ 228coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
229{
230 AV *padlist;
231 AV *av = (AV *)mg->mg_obj;
122 232
123 for (ix = fpad; ix > 0; ix--) { 233 /* casting is fun. */
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 234 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
125 if (namesv 235 free_padlist (padlist);
126 && namesv != &PL_sv_undef 236
127 && !(SvFLAGS(namesv) & SVf_FAKE) 237 SvREFCNT_dec (av);
128 && *SvPVX(namesv) == '&' 238
129 && CvCLONE(ppad[ix])) 239 return 0;
130 { 240}
131 CV *kid = cv_clone((CV*)ppad[ix]); 241
132 SvREFCNT_dec(ppad[ix]); 242#define PERL_MAGIC_coro PERL_MAGIC_ext
133 CvCLONE_on(kid); 243
134 SvPADMY_on(kid); 244static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
135 npad[ix] = (SV*)kid; 245
136 } 246/* the next two functions merely cache the padlists */
247static void
248get_padlist (CV *cv)
249{
250 MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
251
252 if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0)
253 CvPADLIST (cv) = (AV *)av_pop ((AV *)mg->mg_obj);
254 else
255 {
256#if 0
257 /* this is probably cleaner, but also slower? */
258 CV *cp = Perl_cv_clone (cv);
259 CvPADLIST (cv) = CvPADLIST (cp);
260 CvPADLIST (cp) = 0;
261 SvREFCNT_dec (cp);
262#else
263 CvPADLIST (cv) = coro_clone_padlist (cv);
264#endif
265 }
266}
267
268static void
269put_padlist (CV *cv)
270{
271 MAGIC *mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
272
273 if (!mg)
274 {
275 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
276 mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
277 mg->mg_virtual = &vtbl_coro;
278 mg->mg_obj = (SV *)newAV ();
137 } 279 }
138#endif
139 280
140 return newpadlist; 281 av_push ((AV *)mg->mg_obj, (SV *)CvPADLIST (cv));
141} 282}
142 283
143STATIC AV * 284#define SB do {
144free_padlist (AV *padlist) 285#define SE } while (0)
286
287#define LOAD(state) load_state((state));
288#define SAVE(state,flags) save_state((state),(flags));
289
290#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE
291
292static void
293load_state(Coro__State c)
145{ 294{
146 /* may be during global destruction */ 295 PL_dowarn = c->dowarn;
147 if (SvREFCNT(padlist)) 296 PL_in_eval = c->in_eval;
297
298 PL_curstackinfo = c->curstackinfo;
299 PL_curstack = c->curstack;
300 PL_mainstack = c->mainstack;
301 PL_stack_sp = c->stack_sp;
302 PL_op = c->op;
303 PL_curpad = c->curpad;
304 PL_comppad = c->comppad;
305 PL_compcv = c->compcv;
306 PL_stack_base = c->stack_base;
307 PL_stack_max = c->stack_max;
308 PL_tmps_stack = c->tmps_stack;
309 PL_tmps_floor = c->tmps_floor;
310 PL_tmps_ix = c->tmps_ix;
311 PL_tmps_max = c->tmps_max;
312 PL_markstack = c->markstack;
313 PL_markstack_ptr = c->markstack_ptr;
314 PL_markstack_max = c->markstack_max;
315 PL_scopestack = c->scopestack;
316 PL_scopestack_ix = c->scopestack_ix;
317 PL_scopestack_max = c->scopestack_max;
318 PL_savestack = c->savestack;
319 PL_savestack_ix = c->savestack_ix;
320 PL_savestack_max = c->savestack_max;
321#if !PERL_VERSION_ATLEAST (5,9,0)
322 PL_retstack = c->retstack;
323 PL_retstack_ix = c->retstack_ix;
324 PL_retstack_max = c->retstack_max;
325#endif
326 PL_curpm = c->curpm;
327 PL_curcop = c->curcop;
328
329 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
330 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
331 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
332
333 {
334 dSP;
335 CV *cv;
336
337 /* now do the ugly restore mess */
338 while ((cv = (CV *)POPs))
148 { 339 {
149 I32 i = AvFILLp(padlist); 340 AV *padlist = (AV *)POPs;
150 while (i >= 0) 341
342 if (padlist)
151 { 343 {
152 SV **svp = av_fetch(padlist, i--, FALSE); 344 put_padlist (cv); /* mark this padlist as available */
153 SV *sv = svp ? *svp : Nullsv; 345 CvPADLIST(cv) = padlist;
154 if (sv)
155 SvREFCNT_dec(sv);
156 } 346 }
157 347
158 SvREFCNT_dec((SV*)padlist); 348 ++CvDEPTH(cv);
349 }
350
351 PUTBACK;
159 } 352 }
160} 353}
161 354
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 355static void
189SAVE(pTHX_ Coro__State c) 356save_state(Coro__State c, int flags)
190{ 357{
191 { 358 {
192 dSP; 359 dSP;
193 I32 cxix = cxstack_ix; 360 I32 cxix = cxstack_ix;
361 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 362 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 363
197 /* 364 /*
198 * the worst thing you can imagine happens first - we have to save 365 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 366 * (and reinitialize) all cv's in the whole callchain :(
200 */ 367 */
… …
210 if (CxTYPE(cx) == CXt_SUB) 377 if (CxTYPE(cx) == CXt_SUB)
211 { 378 {
212 CV *cv = cx->blk_sub.cv; 379 CV *cv = cx->blk_sub.cv;
213 if (CvDEPTH(cv)) 380 if (CvDEPTH(cv))
214 { 381 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3); 382 EXTEND (SP, CvDEPTH(cv)*2);
383
384 while (--CvDEPTH(cv))
385 {
386 /* this tells the restore code to increment CvDEPTH */
387 PUSHs (Nullsv);
219 PUSHs ((SV *)CvDEPTH(cv)); 388 PUSHs ((SV *)cv);
389 }
390
220 PUSHs ((SV *)CvPADLIST(cv)); 391 PUSHs ((SV *)CvPADLIST(cv));
221 PUSHs ((SV *)cv); 392 PUSHs ((SV *)cv);
222 393
223 get_padlist (cv); 394 get_padlist (cv);
224
225 CvDEPTH(cv) = 0;
226#ifdef USE_THREADS
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 } 395 }
233 } 396 }
397#ifdef CXt_FORMAT
234 else if (CxTYPE(cx) == CXt_FORMAT) 398 else if (CxTYPE(cx) == CXt_FORMAT)
235 { 399 {
236 /* I never used formats, so how should I know how these are implemented? */ 400 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */ 401 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 402 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 } 403 }
404#endif
240 } 405 }
241 406
242 if (top_si->si_type == PERLSI_MAIN) 407 if (top_si->si_type == PERLSI_MAIN)
243 break; 408 break;
244 409
… …
248 } 413 }
249 414
250 PUTBACK; 415 PUTBACK;
251 } 416 }
252 417
418 c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
419 c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
420 c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
421
253 c->dowarn = PL_dowarn; 422 c->dowarn = PL_dowarn;
254 c->defav = GvAV (PL_defgv); 423 c->in_eval = PL_in_eval;
424
255 c->curstackinfo = PL_curstackinfo; 425 c->curstackinfo = PL_curstackinfo;
256 c->curstack = PL_curstack; 426 c->curstack = PL_curstack;
257 c->mainstack = PL_mainstack; 427 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp; 428 c->stack_sp = PL_stack_sp;
259 c->op = PL_op; 429 c->op = PL_op;
260 c->curpad = PL_curpad; 430 c->curpad = PL_curpad;
431 c->comppad = PL_comppad;
432 c->compcv = PL_compcv;
261 c->stack_base = PL_stack_base; 433 c->stack_base = PL_stack_base;
262 c->stack_max = PL_stack_max; 434 c->stack_max = PL_stack_max;
263 c->tmps_stack = PL_tmps_stack; 435 c->tmps_stack = PL_tmps_stack;
264 c->tmps_floor = PL_tmps_floor; 436 c->tmps_floor = PL_tmps_floor;
265 c->tmps_ix = PL_tmps_ix; 437 c->tmps_ix = PL_tmps_ix;
… …
271 c->scopestack_ix = PL_scopestack_ix; 443 c->scopestack_ix = PL_scopestack_ix;
272 c->scopestack_max = PL_scopestack_max; 444 c->scopestack_max = PL_scopestack_max;
273 c->savestack = PL_savestack; 445 c->savestack = PL_savestack;
274 c->savestack_ix = PL_savestack_ix; 446 c->savestack_ix = PL_savestack_ix;
275 c->savestack_max = PL_savestack_max; 447 c->savestack_max = PL_savestack_max;
448#if !PERL_VERSION_ATLEAST (5,9,0)
276 c->retstack = PL_retstack; 449 c->retstack = PL_retstack;
277 c->retstack_ix = PL_retstack_ix; 450 c->retstack_ix = PL_retstack_ix;
278 c->retstack_max = PL_retstack_max; 451 c->retstack_max = PL_retstack_max;
452#endif
453 c->curpm = PL_curpm;
279 c->curcop = PL_curcop; 454 c->curcop = PL_curcop;
280} 455}
281 456
457/*
458 * allocate various perl stacks. This is an exact copy
459 * of perl.c:init_stacks, except that it uses less memory
460 * on the (sometimes correct) assumption that coroutines do
461 * not usually need a lot of stackspace.
462 */
282static void 463static void
283LOAD(pTHX_ Coro__State c) 464coro_init_stacks ()
284{ 465{
285 PL_dowarn = c->dowarn; 466 PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286 GvAV (PL_defgv) = c->defav; 467 PL_curstackinfo->si_type = PERLSI_MAIN;
287 PL_curstackinfo = c->curstackinfo; 468 PL_curstack = PL_curstackinfo->si_stack;
288 PL_curstack = c->curstack; 469 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289 PL_mainstack = c->mainstack; 470
471 PL_stack_base = AvARRAY(PL_curstack);
290 PL_stack_sp = c->stack_sp; 472 PL_stack_sp = PL_stack_base;
291 PL_op = c->op; 473 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292 PL_curpad = c->curpad; 474
293 PL_stack_base = c->stack_base; 475 New(50,PL_tmps_stack,96,SV*);
294 PL_stack_max = c->stack_max; 476 PL_tmps_floor = -1;
295 PL_tmps_stack = c->tmps_stack; 477 PL_tmps_ix = -1;
296 PL_tmps_floor = c->tmps_floor; 478 PL_tmps_max = 96;
297 PL_tmps_ix = c->tmps_ix; 479
298 PL_tmps_max = c->tmps_max; 480 New(54,PL_markstack,16,I32);
299 PL_markstack = c->markstack;
300 PL_markstack_ptr = c->markstack_ptr; 481 PL_markstack_ptr = PL_markstack;
301 PL_markstack_max = c->markstack_max; 482 PL_markstack_max = PL_markstack + 16;
302 PL_scopestack = c->scopestack;
303 PL_scopestack_ix = c->scopestack_ix;
304 PL_scopestack_max = c->scopestack_max;
305 PL_savestack = c->savestack;
306 PL_savestack_ix = c->savestack_ix;
307 PL_savestack_max = c->savestack_max;
308 PL_retstack = c->retstack;
309 PL_retstack_ix = c->retstack_ix;
310 PL_retstack_max = c->retstack_max;
311 PL_curcop = c->curcop;
312 483
313 { 484#ifdef SET_MARK_OFFSET
314 dSP; 485 SET_MARK_OFFSET;
315 CV *cv; 486#endif
316 487
317 /* now do the ugly restore mess */ 488 New(54,PL_scopestack,16,I32);
318 while ((cv = (CV *)POPs)) 489 PL_scopestack_ix = 0;
490 PL_scopestack_max = 16;
491
492 New(54,PL_savestack,96,ANY);
493 PL_savestack_ix = 0;
494 PL_savestack_max = 96;
495
496#if !PERL_VERSION_ATLEAST (5,9,0)
497 New(54,PL_retstack,8,OP*);
498 PL_retstack_ix = 0;
499 PL_retstack_max = 8;
500#endif
501}
502
503/*
504 * destroy the stacks, the callchain etc...
505 */
506static void
507coro_destroy_stacks ()
508{
509 if (!IN_DESTRUCT)
319 { 510 {
320 AV *padlist = (AV *)POPs;
321
322 put_padlist (cv);
323 CvPADLIST(cv) = padlist;
324 CvDEPTH(cv) = (I32)POPs;
325
326#ifdef USE_THREADS
327 CvOWNER(cv) = (struct perl_thread *)POPs;
328 error does not work either
329#endif
330 }
331
332 PUTBACK;
333 }
334}
335
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
337STATIC void
338destroy_stacks(pTHX)
339{
340 /* die does this while calling POPSTACK, but I just don't see why. */
341 dounwind(-1);
342
343 /* is this ugly, I ask? */ 511 /* is this ugly, I ask? */
344 while (PL_scopestack_ix) 512 LEAVE_SCOPE (0);
345 LEAVE; 513
514 /* sure it is, but more important: is it correct?? :/ */
515 FREETMPS;
516
517 /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/
518 }
346 519
347 while (PL_curstackinfo->si_next) 520 while (PL_curstackinfo->si_next)
348 PL_curstackinfo = PL_curstackinfo->si_next; 521 PL_curstackinfo = PL_curstackinfo->si_next;
349 522
350 while (PL_curstackinfo) 523 while (PL_curstackinfo)
351 { 524 {
352 PERL_SI *p = PL_curstackinfo->si_prev; 525 PERL_SI *p = PL_curstackinfo->si_prev;
353 526
527 { /*D*//*remove*/
528 dSP;
529 SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
530 PUTBACK; /* possibly superfluous */
531 }
532
533 if (!IN_DESTRUCT)
534 {
535 dounwind (-1);/*D*//*remove*/
354 SvREFCNT_dec(PL_curstackinfo->si_stack); 536 SvREFCNT_dec (PL_curstackinfo->si_stack);
537 }
538
355 Safefree(PL_curstackinfo->si_cxstack); 539 Safefree (PL_curstackinfo->si_cxstack);
356 Safefree(PL_curstackinfo); 540 Safefree (PL_curstackinfo);
357 PL_curstackinfo = p; 541 PL_curstackinfo = p;
358 } 542 }
359 543
360 if (PL_scopestack_ix != 0) 544 Safefree (PL_tmps_stack);
361 Perl_warner(aTHX_ WARN_INTERNAL, 545 Safefree (PL_markstack);
362 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 546 Safefree (PL_scopestack);
363 (long)PL_scopestack_ix); 547 Safefree (PL_savestack);
364 if (PL_savestack_ix != 0) 548#if !PERL_VERSION_ATLEAST (5,9,0)
365 Perl_warner(aTHX_ WARN_INTERNAL, 549 Safefree (PL_retstack);
366 "Unbalanced saves: %ld more saves than restores\n", 550#endif
367 (long)PL_savestack_ix); 551}
368 if (PL_tmps_floor != -1) 552
369 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 553static void
370 (long)PL_tmps_floor + 1); 554setup_coro (struct coro *coro)
555{
371 /* 556 /*
372 */ 557 * emulate part of the perl startup here.
373 Safefree(PL_tmps_stack); 558 */
374 Safefree(PL_markstack);
375 Safefree(PL_scopestack);
376 Safefree(PL_savestack);
377 Safefree(PL_retstack);
378}
379 559
380#define SUB_INIT "Coro::State::_newcoro" 560 coro_init_stacks ();
561
562 PL_curcop = 0;
563 PL_in_eval = 0;
564 PL_curpm = 0;
565
566 {
567 dSP;
568 LOGOP myop;
569
570 /* I have no idea why this is needed, but it is */
571 PUSHMARK (SP);
572
573 SvREFCNT_dec (GvAV (PL_defgv));
574 GvAV (PL_defgv) = coro->args; coro->args = 0;
575
576 Zero (&myop, 1, LOGOP);
577 myop.op_next = Nullop;
578 myop.op_flags = OPf_WANT_VOID;
579
580 PL_op = (OP *)&myop;
581
582 PUSHMARK (SP);
583 XPUSHs ((SV *)get_cv ("Coro::State::coro_init", FALSE));
584 PUTBACK;
585 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
586 SPAGAIN;
587
588 ENTER; /* necessary e.g. for dounwind */
589 }
590}
591
592static void
593free_coro_mortal ()
594{
595 if (coro_mortal)
596 {
597 SvREFCNT_dec (coro_mortal);
598 coro_mortal = 0;
599 }
600}
601
602static void NOINLINE
603prepare_cctx (coro_cctx *cctx)
604{
605 dSP;
606 LOGOP myop;
607
608 Zero (&myop, 1, LOGOP);
609 myop.op_next = PL_op;
610 myop.op_flags = OPf_WANT_VOID;
611
612 sv_setiv (get_sv ("Coro::State::cctx", FALSE), PTR2IV (cctx));
613
614 PUSHMARK (SP);
615 XPUSHs ((SV *)get_cv ("Coro::State::cctx_init", FALSE));
616 PUTBACK;
617 PL_restartop = PL_ppaddr[OP_ENTERSUB](aTHX);
618 SPAGAIN;
619}
620
621static void
622coro_run (void *arg)
623{
624 /* coro_run is the alternative epilogue of transfer() */
625 UNLOCK;
626
627 /*
628 * this is a _very_ stripped down perl interpreter ;)
629 */
630 PL_top_env = &PL_start_env;
631 /* inject call to cctx_init */
632 prepare_cctx ((coro_cctx *)arg);
633
634 /* somebody will hit me for both perl_run and PL_restartop */
635 perl_run (PL_curinterp);
636
637 fputs ("FATAL: C coroutine fell over the edge of the world, aborting. Did you call exit in a coroutine?\n", stderr);
638 abort ();
639}
640
641static coro_cctx *
642cctx_new ()
643{
644 coro_cctx *cctx;
645
646 New (0, cctx, 1, coro_cctx);
647
648#if HAVE_MMAP
649
650 cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
651 /* mmap suppsedly does allocate-on-write for us */
652 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
653
654 if (cctx->sptr == (void *)-1)
655 {
656 perror ("FATAL: unable to mmap stack for coroutine");
657 _exit (EXIT_FAILURE);
658 }
659
660# if STACKGUARD
661 mprotect (cctx->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
662# endif
663
664#else
665
666 cctx->ssize = STACKSIZE * (long)sizeof (long);
667 New (0, cctx->sptr, STACKSIZE, long);
668
669 if (!cctx->sptr)
670 {
671 perror ("FATAL: unable to malloc stack for coroutine");
672 _exit (EXIT_FAILURE);
673 }
674
675#endif
676
677#if USE_VALGRIND
678 cctx->valgrind_id = VALGRIND_STACK_REGISTER (
679 STACKGUARD * PAGESIZE + (char *)cctx->sptr,
680 cctx->ssize + (char *)cctx->sptr
681 );
682#endif
683
684 coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, cctx->ssize);
685
686 return cctx;
687}
688
689static void
690cctx_free (coro_cctx *cctx)
691{
692 if (!cctx)
693 return;
694
695#if USE_VALGRIND
696 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
697#endif
698
699#if HAVE_MMAP
700 munmap (cctx->sptr, cctx->ssize);
701#else
702 Safefree (cctx->sptr);
703#endif
704
705 Safefree (cctx);
706}
707
708static coro_cctx *cctx_first;
709static int cctx_count, cctx_idle;
710
711static coro_cctx *
712cctx_get ()
713{
714 coro_cctx *cctx;
715
716 if (cctx_first)
717 {
718 --cctx_idle;
719 cctx = cctx_first;
720 cctx_first = cctx->next;
721 }
722 else
723 {
724 ++cctx_count;
725 cctx = cctx_new ();
726 PL_op = PL_op->op_next;
727 }
728
729 return cctx;
730}
731
732static void
733cctx_put (coro_cctx *cctx)
734{
735 ++cctx_idle;
736 cctx->next = cctx_first;
737 cctx_first = cctx;
738}
739
740/* never call directly, always through the coro_state_transfer global variable */
741static void NOINLINE
742transfer (struct coro *prev, struct coro *next, int flags)
743{
744 dSTACKLEVEL;
745
746 /* sometimes transfer is only called to set idle_sp */
747 if (flags == TRANSFER_SET_STACKLEVEL)
748 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
749 else if (prev != next)
750 {
751 coro_cctx *prev__cctx;
752
753 LOCK;
754
755 if (next->mainstack)
756 {
757 /* coroutine already started */
758 SAVE (prev, flags);
759 LOAD (next);
760 }
761 else
762 {
763 /* need to start coroutine */
764 /* first get rid of the old state */
765 SAVE (prev, -1);
766 /* setup coroutine call */
767 setup_coro (next);
768 /* need a stack */
769 next->cctx = 0;
770 }
771
772 if (!prev->cctx)
773 /* create a new empty context */
774 Newz (0, prev->cctx, 1, coro_cctx);
775
776 prev__cctx = prev->cctx;
777
778 /* possibly "free" the cctx */
779 if (prev__cctx->idle_sp == STACKLEVEL)
780 {
781 cctx_put (prev__cctx);
782 prev->cctx = 0;
783 }
784
785 if (!next->cctx)
786 next->cctx = cctx_get ();
787
788 if (prev__cctx != next->cctx)
789 {
790 prev__cctx->top_env = PL_top_env;
791 PL_top_env = next->cctx->top_env;
792 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
793 }
794
795 free_coro_mortal ();
796
797 UNLOCK;
798 }
799}
800
801struct transfer_args
802{
803 struct coro *prev, *next;
804 int flags;
805};
806
807#define TRANSFER(ta) transfer ((ta).prev, (ta).next, (ta).flags)
808
809static void
810coro_state_destroy (struct coro *coro)
811{
812 if (coro->refcnt--)
813 return;
814
815 if (coro->mainstack && coro->mainstack != main_mainstack)
816 {
817 struct coro temp;
818
819 SAVE ((&temp), TRANSFER_SAVE_ALL);
820 LOAD (coro);
821
822 coro_destroy_stacks ();
823
824 LOAD ((&temp)); /* this will get rid of defsv etc.. */
825
826 coro->mainstack = 0;
827 }
828
829 cctx_free (coro->cctx);
830 SvREFCNT_dec (coro->args);
831 Safefree (coro);
832}
833
834static int
835coro_state_clear (pTHX_ SV *sv, MAGIC *mg)
836{
837 struct coro *coro = (struct coro *)mg->mg_ptr;
838 mg->mg_ptr = 0;
839
840 coro_state_destroy (coro);
841
842 return 0;
843}
844
845static int
846coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
847{
848 struct coro *coro = (struct coro *)mg->mg_ptr;
849
850 ++coro->refcnt;
851
852 return 0;
853}
854
855static MGVTBL coro_state_vtbl = {
856 0, 0, 0, 0,
857 coro_state_clear,
858 0,
859#ifdef MGf_DUP
860 coro_state_dup,
861#else
862# define MGf_DUP 0
863#endif
864};
865
866static struct coro *
867SvSTATE (SV *coro)
868{
869 HV *stash;
870 MAGIC *mg;
871
872 if (SvROK (coro))
873 coro = SvRV (coro);
874
875 stash = SvSTASH (coro);
876 if (stash != coro_stash && stash != coro_state_stash)
877 {
878 /* very slow, but rare, check */
879 if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
880 croak ("Coro::State object required");
881 }
882
883 mg = SvMAGIC (coro);
884 assert (mg->mg_type == PERL_MAGIC_ext);
885 return (struct coro *)mg->mg_ptr;
886}
887
888static void
889prepare_transfer (struct transfer_args *ta, SV *prev, SV *next, int flags)
890{
891 ta->prev = SvSTATE (prev);
892 ta->next = SvSTATE (next);
893 ta->flags = flags;
894}
895
896static void
897api_transfer (SV *prev, SV *next, int flags)
898{
899 dTHX;
900 struct transfer_args ta;
901
902 prepare_transfer (&ta, prev, next, flags);
903 TRANSFER (ta);
904}
905
906/** Coro ********************************************************************/
907
908#define PRIO_MAX 3
909#define PRIO_HIGH 1
910#define PRIO_NORMAL 0
911#define PRIO_LOW -1
912#define PRIO_IDLE -3
913#define PRIO_MIN -4
914
915/* for Coro.pm */
916static GV *coro_current, *coro_idle;
917static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
918static int coro_nready;
919
920static void
921coro_enq (SV *sv)
922{
923 int prio;
924
925 if (SvTYPE (sv) != SVt_PVHV)
926 croak ("Coro::ready tried to enqueue something that is not a coroutine");
927
928 prio = SvSTATE (sv)->prio;
929
930 av_push (coro_ready [prio - PRIO_MIN], sv);
931 coro_nready++;
932}
933
934static SV *
935coro_deq (int min_prio)
936{
937 int prio = PRIO_MAX - PRIO_MIN;
938
939 min_prio -= PRIO_MIN;
940 if (min_prio < 0)
941 min_prio = 0;
942
943 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
944 if (AvFILLp (coro_ready [prio]) >= 0)
945 {
946 coro_nready--;
947 return av_shift (coro_ready [prio]);
948 }
949
950 return 0;
951}
952
953static void
954api_ready (SV *coro)
955{
956 dTHX;
957
958 if (SvROK (coro))
959 coro = SvRV (coro);
960
961 LOCK;
962 coro_enq (SvREFCNT_inc (coro));
963 UNLOCK;
964}
965
966static void
967prepare_schedule (struct transfer_args *ta)
968{
969 SV *current, *prev, *next;
970
971 current = GvSV (coro_current);
972
973 for (;;)
974 {
975 LOCK;
976 next = coro_deq (PRIO_MIN);
977 UNLOCK;
978
979 if (next)
980 break;
981
982 {
983 dSP;
984
985 ENTER;
986 SAVETMPS;
987
988 PUSHMARK (SP);
989 PUTBACK;
990 call_sv (GvSV (coro_idle), G_DISCARD);
991
992 FREETMPS;
993 LEAVE;
994 }
995 }
996
997 prev = SvRV (current);
998 SvRV (current) = next;
999
1000 /* free this only after the transfer */
1001 LOCK;
1002 free_coro_mortal ();
1003 UNLOCK;
1004 coro_mortal = prev;
1005
1006 ta->prev = SvSTATE (prev);
1007 ta->next = SvSTATE (next);
1008 ta->flags = TRANSFER_SAVE_ALL;
1009}
1010
1011static void
1012prepare_cede (struct transfer_args *ta)
1013{
1014 LOCK;
1015 coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
1016 UNLOCK;
1017
1018 prepare_schedule (ta);
1019}
1020
1021static void
1022api_schedule (void)
1023{
1024 dTHX;
1025 struct transfer_args ta;
1026
1027 prepare_schedule (&ta);
1028 TRANSFER (ta);
1029}
1030
1031static void
1032api_cede (void)
1033{
1034 dTHX;
1035 struct transfer_args ta;
1036
1037 prepare_cede (&ta);
1038 TRANSFER (ta);
1039}
381 1040
382MODULE = Coro::State PACKAGE = Coro::State 1041MODULE = Coro::State PACKAGE = Coro::State
383 1042
384PROTOTYPES: ENABLE 1043PROTOTYPES: DISABLE
385 1044
386BOOT: 1045BOOT:
387 if (!padlist_cache) 1046{
388 padlist_cache = newHV (); 1047#ifdef USE_ITHREADS
1048 MUTEX_INIT (&coro_mutex);
1049#endif
1050 BOOT_PAGESIZE;
389 1051
390Coro::State 1052 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
391_newprocess(args) 1053
392 SV * args 1054 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
393 PROTOTYPE: $ 1055 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
1056 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
1057
1058 main_mainstack = PL_mainstack;
1059
1060 coroapi.ver = CORO_API_VERSION;
1061 coroapi.transfer = api_transfer;
1062
1063 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1064}
1065
1066SV *
1067new (char *klass, ...)
394 CODE: 1068 CODE:
395 Coro__State coro; 1069{
1070 struct coro *coro;
1071 HV *hv;
1072 int i;
396 1073
397 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398 croak ("Coro::State::newprocess expects an arrayref");
399
400 New (0, coro, 1, struct coro); 1074 Newz (0, coro, 1, struct coro);
1075 coro->args = newAV ();
401 1076
402 coro->mainstack = 0; /* actual work is done inside transfer */ 1077 hv = newHV ();
403 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1078 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1079 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
404 1080
405 RETVAL = coro; 1081 for (i = 1; i < items; i++)
1082 av_push (coro->args, newSVsv (ST (i)));
1083}
406 OUTPUT: 1084 OUTPUT:
407 RETVAL 1085 RETVAL
408 1086
409void 1087void
410transfer(prev,next) 1088_set_stacklevel (...)
411 Coro::State_or_hashref prev 1089 ALIAS:
412 Coro::State_or_hashref next 1090 Coro::State::transfer = 1
1091 Coro::schedule = 2
1092 Coro::cede = 3
1093 Coro::Cont::yield = 4
413 CODE: 1094 CODE:
1095{
1096 struct transfer_args ta;
414 1097
415 if (prev != next) 1098 switch (ix)
416 { 1099 {
417 PUTBACK; 1100 case 0:
418 SAVE (aTHX_ prev); 1101 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1102 ta.next = 0;
1103 ta.flags = TRANSFER_SET_STACKLEVEL;
1104 break;
419 1105
420 /* 1106 case 1:
421 * this could be done in newprocess which would lead to 1107 if (items != 3)
422 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN) 1108 croak ("Coro::State::transfer(prev,next,flags) expects three arguments, not %d", items);
423 * code here, but lazy allocation of stacks has also 1109
424 * some virtues and the overhead of the if() is nil. 1110 prepare_transfer (&ta, ST (0), ST (1), SvIV (ST (2)));
425 */ 1111 break;
426 if (next->mainstack) 1112
1113 case 2:
1114 prepare_schedule (&ta);
1115 break;
1116
1117 case 3:
1118 prepare_cede (&ta);
1119 break;
1120
1121 case 4:
427 { 1122 {
428 LOAD (aTHX_ next); 1123 SV *yieldstack;
429 next->mainstack = 0; /* unnecessary but much cleaner */ 1124 SV *sv;
1125 AV *defav = GvAV (PL_defgv);
1126
1127 yieldstack = *hv_fetch (
1128 (HV *)SvRV (GvSV (coro_current)),
1129 "yieldstack", sizeof ("yieldstack") - 1,
1130 0
430 SPAGAIN; 1131 );
1132
1133 /* set up @_ -- ugly */
1134 av_clear (defav);
1135 av_fill (defav, items - 1);
1136 while (items--)
1137 av_store (defav, items, SvREFCNT_inc (ST(items)));
1138
1139 sv = av_pop ((AV *)SvRV (yieldstack));
1140 ta.prev = SvSTATE (*av_fetch ((AV *)SvRV (sv), 0, 0));
1141 ta.next = SvSTATE (*av_fetch ((AV *)SvRV (sv), 1, 0));
1142 ta.flags = 0;
1143 SvREFCNT_dec (sv);
431 } 1144 }
432 else 1145 break;
433 {
434 /*
435 * emulate part of the perl startup here.
436 */
437 UNOP myop;
438 1146
439 init_stacks (); /* from perl.c */
440 PL_op = (OP *)&myop;
441 /*PL_curcop = 0;*/
442 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
443
444 SPAGAIN;
445 Zero(&myop, 1, UNOP);
446 myop.op_next = Nullop;
447 myop.op_flags = OPf_WANT_VOID;
448
449 PUSHMARK(SP);
450 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451 PUTBACK;
452 /*
453 * the next line is slightly wrong, as PL_op->op_next
454 * is actually being executed so we skip the first op.
455 * that doesn't matter, though, since it is only
456 * pp_nextstate and we never return...
457 */
458 PL_op = Perl_pp_entersub(aTHX);
459 SPAGAIN;
460
461 ENTER;
462 }
463 } 1147 }
464 1148
1149 TRANSFER (ta);
1150}
1151
465void 1152void
466DESTROY(coro) 1153_clone_state_from (SV *dst, SV *src)
467 Coro::State coro 1154 CODE:
1155{
1156 struct coro *coro_src = SvSTATE (src);
1157
1158 sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
1159
1160 ++coro_src->refcnt;
1161 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1162}
1163
1164void
1165_exit (code)
1166 int code
1167 PROTOTYPE: $
1168 CODE:
1169 _exit (code);
1170
1171int
1172cctx_count ()
1173 CODE:
1174 RETVAL = cctx_count;
1175 OUTPUT:
1176 RETVAL
1177
1178int
1179cctx_idle ()
1180 CODE:
1181 RETVAL = cctx_idle;
1182 OUTPUT:
1183 RETVAL
1184
1185MODULE = Coro::State PACKAGE = Coro
1186
1187BOOT:
1188{
1189 int i;
1190
1191 coro_stash = gv_stashpv ("Coro", TRUE);
1192
1193 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1194 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1195 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1196 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1197 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1198 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1199
1200 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
1201 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
1202
1203 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1204 coro_ready[i] = newAV ();
1205
1206 {
1207 SV *sv = perl_get_sv("Coro::API", 1);
1208
1209 coroapi.schedule = api_schedule;
1210 coroapi.cede = api_cede;
1211 coroapi.ready = api_ready;
1212 coroapi.nready = &coro_nready;
1213 coroapi.current = coro_current;
1214
1215 GCoroAPI = &coroapi;
1216 sv_setiv (sv, (IV)&coroapi);
1217 SvREADONLY_on (sv);
1218 }
1219}
1220
1221int
1222prio (Coro::State coro, int newprio = 0)
1223 ALIAS:
1224 nice = 1
468 CODE: 1225 CODE:
1226{
1227 RETVAL = coro->prio;
469 1228
470 if (coro->mainstack) 1229 if (items > 1)
471 { 1230 {
472 struct coro temp; 1231 if (ix)
1232 newprio += coro->prio;
473 1233
474 PUTBACK; 1234 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
475 SAVE(aTHX_ (&temp)); 1235 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
476 LOAD(aTHX_ coro);
477 1236
478 destroy_stacks (); 1237 coro->prio = newprio;
479 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481 LOAD((&temp));
482 SPAGAIN;
483 } 1238 }
1239}
484 1240
485 SvREFCNT_dec (coro->args); 1241void
486 Safefree (coro); 1242ready (SV *self)
1243 PROTOTYPE: $
1244 CODE:
1245 api_ready (self);
487 1246
1247int
1248nready (...)
1249 PROTOTYPE:
1250 CODE:
1251 RETVAL = coro_nready;
1252 OUTPUT:
1253 RETVAL
488 1254
1255MODULE = Coro::State PACKAGE = Coro::AIO
1256
1257SV *
1258_get_state ()
1259 CODE:
1260{
1261 struct {
1262 int errorno;
1263 int laststype;
1264 int laststatval;
1265 Stat_t statcache;
1266 } data;
1267
1268 data.errorno = errno;
1269 data.laststype = PL_laststype;
1270 data.laststatval = PL_laststatval;
1271 data.statcache = PL_statcache;
1272
1273 RETVAL = newSVpvn ((char *)&data, sizeof data);
1274}
1275 OUTPUT:
1276 RETVAL
1277
1278void
1279_set_state (char *data_)
1280 PROTOTYPE: $
1281 CODE:
1282{
1283 struct {
1284 int errorno;
1285 int laststype;
1286 int laststatval;
1287 Stat_t statcache;
1288 } *data = (void *)data_;
1289
1290 errno = data->errorno;
1291 PL_laststype = data->laststype;
1292 PL_laststatval = data->laststatval;
1293 PL_statcache = data->statcache;
1294}

Diff Legend

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