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

Diff Legend

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