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

Diff Legend

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