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.92 by root, Sun Nov 26 02:16:19 2006 UTC

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

Diff Legend

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