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.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.95 by root, Sun Nov 26 17:35:42 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/* 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 should work - but it doesn't :( */
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 /* die does this while calling POPSTACK, but I just don't see why. */ 490 if (!IN_DESTRUCT)
341 dounwind(-1); 491 {
342
343 /* is this ugly, I ask? */ 492 /* is this ugly, I ask? */
344 while (PL_scopestack_ix) 493 LEAVE_SCOPE (0);
345 LEAVE; 494
495 /* sure it is, but more important: is it correct?? :/ */
496 FREETMPS;
497
498 /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/
499 }
346 500
347 while (PL_curstackinfo->si_next) 501 while (PL_curstackinfo->si_next)
348 PL_curstackinfo = PL_curstackinfo->si_next; 502 PL_curstackinfo = PL_curstackinfo->si_next;
349 503
350 while (PL_curstackinfo) 504 while (PL_curstackinfo)
351 { 505 {
352 PERL_SI *p = PL_curstackinfo->si_prev; 506 PERL_SI *p = PL_curstackinfo->si_prev;
353 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*/
354 SvREFCNT_dec(PL_curstackinfo->si_stack); 517 SvREFCNT_dec (PL_curstackinfo->si_stack);
518 }
519
355 Safefree(PL_curstackinfo->si_cxstack); 520 Safefree (PL_curstackinfo->si_cxstack);
356 Safefree(PL_curstackinfo); 521 Safefree (PL_curstackinfo);
357 PL_curstackinfo = p; 522 PL_curstackinfo = p;
358 } 523 }
359 524
360 if (PL_scopestack_ix != 0) 525 Safefree (PL_tmps_stack);
361 Perl_warner(aTHX_ WARN_INTERNAL, 526 Safefree (PL_markstack);
362 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 527 Safefree (PL_scopestack);
363 (long)PL_scopestack_ix); 528 Safefree (PL_savestack);
364 if (PL_savestack_ix != 0) 529#if PERL_VERSION < 9
365 Perl_warner(aTHX_ WARN_INTERNAL, 530 Safefree (PL_retstack);
366 "Unbalanced saves: %ld more saves than restores\n", 531#endif
367 (long)PL_savestack_ix); 532}
368 if (PL_tmps_floor != -1) 533
369 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 534static void
370 (long)PL_tmps_floor + 1); 535setup_coro (struct coro *coro)
536{
371 /* 537 /*
372 */ 538 * emulate part of the perl startup here.
373 Safefree(PL_tmps_stack); 539 */
374 Safefree(PL_markstack); 540 dTHX;
375 Safefree(PL_scopestack); 541 dSP;
376 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 SvREFCNT_dec (coro_mortal);
574 coro_mortal = 0;
575 }
576}
577
578static void
579coro_run (void *arg)
580{
581 /*
582 * this is a _very_ stripped down perl interpreter ;)
583 */
584 dTHX;
585 int ret;
586
587 UNLOCK;
588
589 PL_top_env = &PL_start_env;
590
591 sv_setiv (get_sv ("Coro::State::cctx_stack", FALSE), PTR2IV ((coro_stack *)arg));
592 sv_setiv (get_sv ("Coro::State::cctx_restartop", FALSE), PTR2IV (PL_op));
593
594 /* continue at cctx_init, without entersub */
595 PL_restartop = CvSTART (get_cv ("Coro::State::cctx_init", FALSE));
596
597 /* somebody will hit me for both perl_run and PL_restartop */
598 ret = perl_run (aTHX_ PERL_GET_CONTEXT);
599 printf ("ret %d\n", ret);//D
600
601 fputs ("FATAL: C coroutine fell over the edge of the world, aborting.\n", stderr);
602 abort ();
603}
604
605static coro_stack *
606stack_new ()
607{
608 coro_stack *stack;
609
610 New (0, stack, 1, coro_stack);
611
612#if HAVE_MMAP
613
614 stack->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
615 /* mmap suppsedly does allocate-on-write for us */
616 stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
617
618 if (stack->sptr == (void *)-1)
619 {
620 perror ("FATAL: unable to mmap stack for coroutine");
621 _exit (EXIT_FAILURE);
622 }
623
624# if STACKGUARD
625 mprotect (stack->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
626# endif
627
628#else
629
630 stack->ssize = STACKSIZE * (long)sizeof (long);
631 New (0, stack->sptr, STACKSIZE, long);
632
633 if (!stack->sptr)
634 {
635 perror (stderr, "FATAL: unable to malloc stack for coroutine");
636 _exit (EXIT_FAILURE);
637 }
638
639#endif
640
641 coro_create (&stack->cctx, coro_run, (void *)stack, stack->sptr, stack->ssize);
642
643 return stack;
644}
645
646static void
647stack_free (coro_stack *stack)
648{
649 if (!stack)
650 return;
651
652#if HAVE_MMAP
653 munmap (stack->sptr, stack->ssize);
654#else
655 Safefree (stack->sptr);
656#endif
657
377 Safefree(PL_retstack); 658 Safefree (stack);
378} 659}
379 660
380#define SUB_INIT "Coro::State::_newcoro" 661static coro_stack *stack_first;
662
663static coro_stack *
664stack_get ()
665{
666 coro_stack *stack;
667
668 if (stack_first)
669 {
670 stack = stack_first;
671 stack_first = stack->next;
672 }
673 else
674 {
675 stack = stack_new ();
676 PL_op = PL_op->op_next;
677 }
678
679 return stack;
680}
681
682static void
683stack_put (coro_stack *stack)
684{
685 stack->next = stack_first;
686 stack_first = stack;
687}
688
689/* never call directly, always through the coro_state_transfer global variable */
690static void
691transfer_impl (pTHX_ struct coro *prev, struct coro *next, int flags)
692{
693 dSTACKLEVEL;
694
695 /* sometimes transfer is only called to set idle_sp */
696 if (flags == TRANSFER_SET_STACKLEVEL)
697 ((coro_stack *)prev)->idle_sp = STACKLEVEL;
698 else if (prev != next)
699 {
700 coro_stack *prev__stack;
701
702 LOCK;
703
704 if (next->mainstack)
705 {
706 /* coroutine already started */
707 SAVE (prev, flags);
708 LOAD (next);
709 }
710 else
711 {
712 /* need to start coroutine */
713 /* first get rid of the old state */
714 SAVE (prev, -1);
715 /* setup coroutine call */
716 setup_coro (next);
717 /* need a stack */
718 next->stack = 0;
719 }
720
721 if (!prev->stack)
722 /* create a new empty context */
723 Newz (0, prev->stack, 1, coro_stack);
724
725 prev__stack = prev->stack;
726
727 /* possibly "free" the stack */
728 if (prev__stack->idle_sp == STACKLEVEL)
729 {
730 stack_put (prev__stack);
731 prev->stack = 0;
732 }
733
734 if (!next->stack)
735 next->stack = stack_get ();
736
737 if (prev__stack != next->stack)
738 {
739 prev__stack->top_env = PL_top_env;
740 PL_top_env = next->stack->top_env;
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}
381 989
382MODULE = Coro::State PACKAGE = Coro::State 990MODULE = Coro::State PACKAGE = Coro::State
383 991
384PROTOTYPES: ENABLE 992PROTOTYPES: DISABLE
385 993
386BOOT: 994BOOT:
387 if (!padlist_cache) 995{
388 padlist_cache = newHV (); 996#ifdef USE_ITHREADS
997 MUTEX_INIT (&coro_mutex);
998#endif
999 BOOT_PAGESIZE;
389 1000
390Coro::State 1001 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
391_newprocess(args) 1002
392 SV * args 1003 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
393 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 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1013}
1014
1015SV *
1016new (char *klass, ...)
394 CODE: 1017 CODE:
395 Coro__State coro; 1018{
1019 struct coro *coro;
1020 HV *hv;
1021 int i;
396 1022
397 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398 croak ("Coro::State::newprocess expects an arrayref");
399
400 New (0, coro, 1, struct coro); 1023 Newz (0, coro, 1, struct coro);
1024 coro->args = newAV ();
401 1025
1026 hv = newHV ();
1027 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1028 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1029
1030 for (i = 1; i < items; i++)
1031 av_push (coro->args, newSVsv (ST (i)));
1032
402 coro->mainstack = 0; /* actual work is done inside transfer */ 1033 /*coro->mainstack = 0; *//*actual work is done inside transfer */
403 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1034 /*coro->stack = 0;*/
404 1035}
405 RETVAL = coro;
406 OUTPUT: 1036 OUTPUT:
407 RETVAL 1037 RETVAL
408 1038
409void 1039void
410transfer(prev,next) 1040_set_stacklevel (...)
411 Coro::State_or_hashref prev 1041 ALIAS:
412 Coro::State_or_hashref next 1042 Coro::State::transfer = 1
1043 Coro::schedule = 2
1044 Coro::cede = 3
1045 Coro::Cont::yield = 4
413 CODE: 1046 CODE:
1047{
1048 struct transfer_args ta;
414 1049
415 if (prev != next) 1050 switch (ix)
416 { 1051 {
417 PUTBACK; 1052 case 0:
418 SAVE (aTHX_ prev); 1053 ta.prev = (struct coro *)INT2PTR (coro_stack *, SvIV (ST (0)));
1054 ta.next = 0;
1055 ta.flags = TRANSFER_SET_STACKLEVEL;
1056 break;
419 1057
420 /* 1058 case 1:
421 * this could be done in newprocess which would lead to 1059 if (items != 3)
422 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN) 1060 croak ("Coro::State::transfer(prev,next,flags) expects three arguments, not %d", items);
423 * code here, but lazy allocation of stacks has also 1061
424 * some virtues and the overhead of the if() is nil. 1062 prepare_transfer (&ta, ST (0), ST (1), SvIV (ST (2)));
425 */ 1063 break;
426 if (next->mainstack) 1064
1065 case 2:
1066 prepare_schedule (&ta);
1067 break;
1068
1069 case 3:
1070 prepare_cede (&ta);
1071 break;
1072
1073 case 4:
427 { 1074 {
428 LOAD (aTHX_ next); 1075 SV *yieldstack;
429 next->mainstack = 0; /* unnecessary but much cleaner */ 1076 SV *sv;
1077 AV *defav = GvAV (PL_defgv);
1078
1079 yieldstack = *hv_fetch (
1080 (HV *)SvRV (GvSV (coro_current)),
1081 "yieldstack", sizeof ("yieldstack") - 1,
1082 0
430 SPAGAIN; 1083 );
1084
1085 /* set up @_ -- ugly */
1086 av_clear (defav);
1087 av_fill (defav, items - 1);
1088 while (items--)
1089 av_store (defav, items, SvREFCNT_inc (ST(items)));
1090
1091 sv = av_pop ((AV *)SvRV (yieldstack));
1092 ta.prev = SvSTATE (*av_fetch ((AV *)SvRV (sv), 0, 0));
1093 ta.next = SvSTATE (*av_fetch ((AV *)SvRV (sv), 1, 0));
1094 ta.flags = 0;
1095 SvREFCNT_dec (sv);
431 } 1096 }
432 else 1097 break;
433 {
434 /*
435 * emulate part of the perl startup here.
436 */
437 UNOP myop;
438 1098
439 init_stacks (); /* from perl.c */
440 PL_op = (OP *)&myop;
441 /*PL_curcop = 0;*/
442 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
443
444 SPAGAIN;
445 Zero(&myop, 1, UNOP);
446 myop.op_next = Nullop;
447 myop.op_flags = OPf_WANT_VOID;
448
449 PUSHMARK(SP);
450 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451 PUTBACK;
452 /*
453 * the next line is slightly wrong, as PL_op->op_next
454 * is actually being executed so we skip the first op.
455 * that doesn't matter, though, since it is only
456 * pp_nextstate and we never return...
457 */
458 PL_op = Perl_pp_entersub(aTHX);
459 SPAGAIN;
460
461 ENTER;
462 }
463 } 1099 }
464 1100
1101 TRANSFER (ta);
1102}
1103
465void 1104void
466DESTROY(coro) 1105_clone_state_from (SV *dst, SV *src)
467 Coro::State coro 1106 CODE:
1107{
1108 struct coro *coro_src = SvSTATE (src);
1109
1110 sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
1111
1112 ++coro_src->refcnt;
1113 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1114}
1115
1116void
1117_nonlocal_goto (IV nextop)
1118 CODE:
1119 /* uuh, somebody will kill me again for this */
1120 PL_op->op_next = INT2PTR (OP *, nextop);
1121
1122void
1123_exit (code)
1124 int code
1125 PROTOTYPE: $
1126 CODE:
1127 _exit (code);
1128
1129MODULE = Coro::State PACKAGE = Coro
1130
1131BOOT:
1132{
1133 int i;
1134
1135 coro_stash = gv_stashpv ("Coro", TRUE);
1136
1137 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1138 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1139 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1140 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1141 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1142 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1143
1144 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
1145 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
1146
1147 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1148 coro_ready[i] = newAV ();
1149
1150 {
1151 SV *sv = perl_get_sv("Coro::API", 1);
1152
1153 coroapi.schedule = api_schedule;
1154 coroapi.cede = api_cede;
1155 coroapi.ready = api_ready;
1156 coroapi.nready = &coro_nready;
1157 coroapi.current = coro_current;
1158
1159 GCoroAPI = &coroapi;
1160 sv_setiv (sv, (IV)&coroapi);
1161 SvREADONLY_on (sv);
1162 }
1163}
1164
1165int
1166prio (Coro::State coro, int newprio = 0)
1167 ALIAS:
1168 nice = 1
468 CODE: 1169 CODE:
1170{
1171 RETVAL = coro->prio;
469 1172
470 if (coro->mainstack) 1173 if (items > 1)
471 { 1174 {
472 struct coro temp; 1175 if (ix)
1176 newprio += coro->prio;
473 1177
474 PUTBACK; 1178 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
475 SAVE(aTHX_ (&temp)); 1179 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
476 LOAD(aTHX_ coro);
477 1180
478 destroy_stacks (); 1181 coro->prio = newprio;
479 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481 LOAD((&temp));
482 SPAGAIN;
483 } 1182 }
1183}
484 1184
485 SvREFCNT_dec (coro->args); 1185void
486 Safefree (coro); 1186ready (SV *self)
1187 PROTOTYPE: $
1188 CODE:
1189 api_ready (self);
487 1190
1191int
1192nready (...)
1193 PROTOTYPE:
1194 CODE:
1195 RETVAL = coro_nready;
1196 OUTPUT:
1197 RETVAL
488 1198
1199MODULE = Coro::State PACKAGE = Coro::AIO
1200
1201SV *
1202_get_state ()
1203 CODE:
1204{
1205 struct {
1206 int errorno;
1207 int laststype;
1208 int laststatval;
1209 Stat_t statcache;
1210 } data;
1211
1212 data.errorno = errno;
1213 data.laststype = PL_laststype;
1214 data.laststatval = PL_laststatval;
1215 data.statcache = PL_statcache;
1216
1217 RETVAL = newSVpvn ((char *)&data, sizeof data);
1218}
1219 OUTPUT:
1220 RETVAL
1221
1222void
1223_set_state (char *data_)
1224 PROTOTYPE: $
1225 CODE:
1226{
1227 struct {
1228 int errorno;
1229 int laststype;
1230 int laststatval;
1231 Stat_t statcache;
1232 } *data = (void *)data_;
1233
1234 errno = data->errorno;
1235 PL_laststype = data->laststype;
1236 PL_laststatval = data->laststatval;
1237 PL_statcache = data->statcache;
1238}

Diff Legend

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