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.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.106 by root, Mon Nov 27 02:08:55 2006 UTC

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

Diff Legend

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