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

Diff Legend

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