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

Diff Legend

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