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

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

Diff Legend

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