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.114 by root, Thu Nov 30 21:22:45 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(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
282static void 400 New(50,PL_tmps_stack,96,SV*);
283LOAD(pTHX_ Coro__State c) 401 PL_tmps_floor = -1;
284{ 402 PL_tmps_ix = -1;
285 PL_dowarn = c->dowarn; 403 PL_tmps_max = 96;
286 GvAV (PL_defgv) = c->defav; 404
287 PL_curstackinfo = c->curstackinfo; 405 New(54,PL_markstack,16,I32);
288 PL_curstack = c->curstack;
289 PL_mainstack = c->mainstack;
290 PL_stack_sp = c->stack_sp;
291 PL_op = c->op;
292 PL_curpad = c->curpad;
293 PL_stack_base = c->stack_base;
294 PL_stack_max = c->stack_max;
295 PL_tmps_stack = c->tmps_stack;
296 PL_tmps_floor = c->tmps_floor;
297 PL_tmps_ix = c->tmps_ix;
298 PL_tmps_max = c->tmps_max;
299 PL_markstack = c->markstack;
300 PL_markstack_ptr = c->markstack_ptr; 406 PL_markstack_ptr = PL_markstack;
301 PL_markstack_max = c->markstack_max; 407 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 408
313 { 409#ifdef SET_MARK_OFFSET
314 dSP; 410 SET_MARK_OFFSET;
315 CV *cv; 411#endif
316 412
317 /* now do the ugly restore mess */ 413 New(54,PL_scopestack,16,I32);
318 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)
319 { 435 {
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
330 }
331
332 PUTBACK;
333 }
334}
335
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
337STATIC void
338destroy_stacks(pTHX)
339{
340 /* die does this while calling POPSTACK, but I just don't see why. */
341 dounwind(-1);
342
343 /* is this ugly, I ask? */ 436 /* is this ugly, I ask? */
344 while (PL_scopestack_ix) 437 LEAVE_SCOPE (0);
345 LEAVE; 438
439 /* sure it is, but more important: is it correct?? :/ */
440 FREETMPS;
441
442 /*POPSTACK_TO (PL_mainstack);*//*D*//*use*/
443 }
346 444
347 while (PL_curstackinfo->si_next) 445 while (PL_curstackinfo->si_next)
348 PL_curstackinfo = PL_curstackinfo->si_next; 446 PL_curstackinfo = PL_curstackinfo->si_next;
349 447
350 while (PL_curstackinfo) 448 while (PL_curstackinfo)
351 { 449 {
352 PERL_SI *p = PL_curstackinfo->si_prev; 450 PERL_SI *p = PL_curstackinfo->si_prev;
353 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*/
354 SvREFCNT_dec(PL_curstackinfo->si_stack); 461 SvREFCNT_dec (PL_curstackinfo->si_stack);
462 }
463
355 Safefree(PL_curstackinfo->si_cxstack); 464 Safefree (PL_curstackinfo->si_cxstack);
356 Safefree(PL_curstackinfo); 465 Safefree (PL_curstackinfo);
357 PL_curstackinfo = p; 466 PL_curstackinfo = p;
358 } 467 }
359 468
360 if (PL_scopestack_ix != 0) 469 Safefree (PL_tmps_stack);
361 Perl_warner(aTHX_ WARN_INTERNAL, 470 Safefree (PL_markstack);
362 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 471 Safefree (PL_scopestack);
363 (long)PL_scopestack_ix); 472 Safefree (PL_savestack);
364 if (PL_savestack_ix != 0) 473#if !PERL_VERSION_ATLEAST (5,9,0)
365 Perl_warner(aTHX_ WARN_INTERNAL, 474 Safefree (PL_retstack);
366 "Unbalanced saves: %ld more saves than restores\n", 475#endif
367 (long)PL_savestack_ix); 476}
368 if (PL_tmps_floor != -1) 477
369 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 478static void
370 (long)PL_tmps_floor + 1); 479setup_coro (struct coro *coro)
480{
371 /* 481 /*
372 */ 482 * emulate part of the perl startup here.
373 Safefree(PL_tmps_stack); 483 */
374 Safefree(PL_markstack);
375 Safefree(PL_scopestack);
376 Safefree(PL_savestack);
377 Safefree(PL_retstack);
378}
379 484
380#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 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
721 assert (PL_top_env == prev__cctx->top_env);
722
723 cctx_put (prev__cctx);
724 prev->cctx = 0;
725 }
726
727 if (!next->cctx)
728 next->cctx = cctx_get ();
729
730 if (prev__cctx != next->cctx)
731 {
732 assert ( prev__cctx->inuse);
733 assert (!next->cctx->inuse);
734
735 prev__cctx->inuse = 0;
736 next->cctx->inuse = 1;
737
738 prev__cctx->top_env = PL_top_env;
739 PL_top_env = next->cctx->top_env;
740 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
741 }
742
743 free_coro_mortal ();
744
745 UNLOCK;
746 }
747}
748
749struct transfer_args
750{
751 struct coro *prev, *next;
752 int flags;
753};
754
755#define TRANSFER(ta) transfer ((ta).prev, (ta).next, (ta).flags)
756
757static void
758coro_state_destroy (struct coro *coro)
759{
760 if (coro->refcnt--)
761 return;
762
763 if (coro->flags & CF_RUNNING)
764 croak ("FATAL: tried to destroy currently running coroutine");
765
766 if (coro->mainstack && coro->mainstack != main_mainstack)
767 {
768 struct coro temp;
769
770 SAVE ((&temp), TRANSFER_SAVE_ALL);
771 LOAD (coro);
772
773 coro_destroy_stacks ();
774
775 LOAD ((&temp)); /* this will get rid of defsv etc.. */
776
777 coro->mainstack = 0;
778 }
779
780 cctx_free (coro->cctx);
781 SvREFCNT_dec (coro->args);
782 Safefree (coro);
783}
784
785static int
786coro_state_clear (pTHX_ SV *sv, MAGIC *mg)
787{
788 struct coro *coro = (struct coro *)mg->mg_ptr;
789 mg->mg_ptr = 0;
790
791 coro_state_destroy (coro);
792
793 return 0;
794}
795
796static int
797coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
798{
799 struct coro *coro = (struct coro *)mg->mg_ptr;
800
801 ++coro->refcnt;
802
803 return 0;
804}
805
806static MGVTBL coro_state_vtbl = {
807 0, 0, 0, 0,
808 coro_state_clear,
809 0,
810#ifdef MGf_DUP
811 coro_state_dup,
812#else
813# define MGf_DUP 0
814#endif
815};
816
817static struct coro *
818SvSTATE (SV *coro)
819{
820 HV *stash;
821 MAGIC *mg;
822
823 if (SvROK (coro))
824 coro = SvRV (coro);
825
826 stash = SvSTASH (coro);
827 if (stash != coro_stash && stash != coro_state_stash)
828 {
829 /* very slow, but rare, check */
830 if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
831 croak ("Coro::State object required");
832 }
833
834 mg = SvMAGIC (coro);
835 assert (mg->mg_type == PERL_MAGIC_ext);
836 return (struct coro *)mg->mg_ptr;
837}
838
839static void
840prepare_transfer (struct transfer_args *ta, SV *prev, SV *next, int flags)
841{
842 ta->prev = SvSTATE (prev);
843 ta->next = SvSTATE (next);
844 ta->flags = flags;
845}
846
847static void
848api_transfer (SV *prev, SV *next, int flags)
849{
850 dTHX;
851 struct transfer_args ta;
852
853 prepare_transfer (&ta, prev, next, flags);
854 TRANSFER (ta);
855}
856
857/** Coro ********************************************************************/
858
859#define PRIO_MAX 3
860#define PRIO_HIGH 1
861#define PRIO_NORMAL 0
862#define PRIO_LOW -1
863#define PRIO_IDLE -3
864#define PRIO_MIN -4
865
866/* for Coro.pm */
867static GV *coro_current, *coro_idle;
868static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
869static int coro_nready;
870
871static void
872coro_enq (SV *coro_sv)
873{
874 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
875 coro_nready++;
876}
877
878static SV *
879coro_deq (int min_prio)
880{
881 int prio = PRIO_MAX - PRIO_MIN;
882
883 min_prio -= PRIO_MIN;
884 if (min_prio < 0)
885 min_prio = 0;
886
887 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
888 if (AvFILLp (coro_ready [prio]) >= 0)
889 {
890 coro_nready--;
891 return av_shift (coro_ready [prio]);
892 }
893
894 return 0;
895}
896
897static int
898api_ready (SV *coro_sv)
899{
900 struct coro *coro;
901
902 if (SvROK (coro_sv))
903 coro_sv = SvRV (coro_sv);
904
905 coro = SvSTATE (coro_sv);
906
907 if (coro->flags & CF_READY)
908 return 0;
909
910 if (coro->flags & CF_RUNNING)
911 croak ("Coro::ready called on currently running coroutine");
912
913 coro->flags |= CF_READY;
914
915 LOCK;
916 coro_enq (SvREFCNT_inc (coro_sv));
917 UNLOCK;
918
919 return 1;
920}
921
922static int
923api_is_ready (SV *coro_sv)
924{
925 return !!SvSTATE (coro_sv)->flags & CF_READY;
926}
927
928static void
929prepare_schedule (struct transfer_args *ta)
930{
931 SV *current, *prev, *next;
932
933 current = GvSV (coro_current);
934
935 for (;;)
936 {
937 LOCK;
938 next = coro_deq (PRIO_MIN);
939 UNLOCK;
940
941 if (next)
942 break;
943
944 {
945 dSP;
946
947 ENTER;
948 SAVETMPS;
949
950 PUSHMARK (SP);
951 PUTBACK;
952 call_sv (GvSV (coro_idle), G_DISCARD);
953
954 FREETMPS;
955 LEAVE;
956 }
957 }
958
959 prev = SvRV (current);
960 SvRV (current) = next;
961
962 /* free this only after the transfer */
963 LOCK;
964 free_coro_mortal ();
965 UNLOCK;
966 coro_mortal = prev;
967
968 ta->prev = SvSTATE (prev);
969 ta->next = SvSTATE (next);
970 ta->flags = TRANSFER_SAVE_ALL;
971
972 ta->next->flags &= ~CF_READY;
973}
974
975static void
976prepare_cede (struct transfer_args *ta)
977{
978 api_ready (GvSV (coro_current));
979
980 prepare_schedule (ta);
981}
982
983static void
984api_schedule (void)
985{
986 dTHX;
987 struct transfer_args ta;
988
989 prepare_schedule (&ta);
990 TRANSFER (ta);
991}
992
993static void
994api_cede (void)
995{
996 dTHX;
997 struct transfer_args ta;
998
999 prepare_cede (&ta);
1000 TRANSFER (ta);
1001}
381 1002
382MODULE = Coro::State PACKAGE = Coro::State 1003MODULE = Coro::State PACKAGE = Coro::State
383 1004
384PROTOTYPES: ENABLE 1005PROTOTYPES: DISABLE
385 1006
386BOOT: 1007BOOT:
387 if (!padlist_cache) 1008{
388 padlist_cache = newHV (); 1009#ifdef USE_ITHREADS
1010 MUTEX_INIT (&coro_mutex);
1011#endif
1012 BOOT_PAGESIZE;
389 1013
390Coro::State 1014 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
391_newprocess(args) 1015
392 SV * args 1016 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
393 PROTOTYPE: $ 1017 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
1018 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
1019
1020 main_mainstack = PL_mainstack;
1021
1022 coroapi.ver = CORO_API_VERSION;
1023 coroapi.transfer = api_transfer;
1024
1025 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1026}
1027
1028SV *
1029new (char *klass, ...)
394 CODE: 1030 CODE:
395 Coro__State coro; 1031{
1032 struct coro *coro;
1033 HV *hv;
1034 int i;
396 1035
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); 1036 Newz (0, coro, 1, struct coro);
1037 coro->args = newAV ();
401 1038
402 coro->mainstack = 0; /* actual work is done inside transfer */ 1039 hv = newHV ();
403 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1040 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1041 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
404 1042
405 RETVAL = coro; 1043 for (i = 1; i < items; i++)
1044 av_push (coro->args, newSVsv (ST (i)));
1045}
406 OUTPUT: 1046 OUTPUT:
407 RETVAL 1047 RETVAL
408 1048
409void 1049void
410transfer(prev,next) 1050_set_stacklevel (...)
411 Coro::State_or_hashref prev 1051 ALIAS:
412 Coro::State_or_hashref next 1052 Coro::State::transfer = 1
1053 Coro::schedule = 2
1054 Coro::cede = 3
1055 Coro::Cont::yield = 4
413 CODE: 1056 CODE:
1057{
1058 struct transfer_args ta;
414 1059
415 if (prev != next) 1060 switch (ix)
416 { 1061 {
417 PUTBACK; 1062 case 0:
418 SAVE (aTHX_ prev); 1063 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1064 ta.next = 0;
1065 ta.flags = TRANSFER_SET_STACKLEVEL;
1066 break;
419 1067
420 /* 1068 case 1:
421 * this could be done in newprocess which would lead to 1069 if (items != 3)
422 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN) 1070 croak ("Coro::State::transfer(prev,next,flags) expects three arguments, not %d", items);
423 * code here, but lazy allocation of stacks has also 1071
424 * some virtues and the overhead of the if() is nil. 1072 prepare_transfer (&ta, ST (0), ST (1), SvIV (ST (2)));
425 */ 1073 break;
426 if (next->mainstack) 1074
1075 case 2:
1076 prepare_schedule (&ta);
1077 break;
1078
1079 case 3:
1080 prepare_cede (&ta);
1081 break;
1082
1083 case 4:
427 { 1084 {
428 LOAD (aTHX_ next); 1085 SV *yieldstack;
429 next->mainstack = 0; /* unnecessary but much cleaner */ 1086 SV *sv;
1087 AV *defav = GvAV (PL_defgv);
1088
1089 yieldstack = *hv_fetch (
1090 (HV *)SvRV (GvSV (coro_current)),
1091 "yieldstack", sizeof ("yieldstack") - 1,
1092 0
430 SPAGAIN; 1093 );
1094
1095 /* set up @_ -- ugly */
1096 av_clear (defav);
1097 av_fill (defav, items - 1);
1098 while (items--)
1099 av_store (defav, items, SvREFCNT_inc (ST(items)));
1100
1101 sv = av_pop ((AV *)SvRV (yieldstack));
1102 ta.prev = SvSTATE (*av_fetch ((AV *)SvRV (sv), 0, 0));
1103 ta.next = SvSTATE (*av_fetch ((AV *)SvRV (sv), 1, 0));
1104 ta.flags = 0;
1105 SvREFCNT_dec (sv);
431 } 1106 }
432 else 1107 break;
433 {
434 /*
435 * emulate part of the perl startup here.
436 */
437 UNOP myop;
438 1108
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 } 1109 }
464 1110
1111 TRANSFER (ta);
1112}
1113
465void 1114void
466DESTROY(coro) 1115_clone_state_from (SV *dst, SV *src)
467 Coro::State coro 1116 CODE:
1117{
1118 struct coro *coro_src = SvSTATE (src);
1119
1120 sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
1121
1122 ++coro_src->refcnt;
1123 sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
1124}
1125
1126void
1127_exit (code)
1128 int code
1129 PROTOTYPE: $
1130 CODE:
1131 _exit (code);
1132
1133int
1134cctx_count ()
1135 CODE:
1136 RETVAL = cctx_count;
1137 OUTPUT:
1138 RETVAL
1139
1140int
1141cctx_idle ()
1142 CODE:
1143 RETVAL = cctx_idle;
1144 OUTPUT:
1145 RETVAL
1146
1147MODULE = Coro::State PACKAGE = Coro
1148
1149BOOT:
1150{
1151 int i;
1152
1153 coro_stash = gv_stashpv ("Coro", TRUE);
1154
1155 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1156 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1157 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1158 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1159 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1160 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1161
1162 coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
1163 coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
1164
1165 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1166 coro_ready[i] = newAV ();
1167
1168 {
1169 SV *sv = perl_get_sv("Coro::API", 1);
1170
1171 coroapi.schedule = api_schedule;
1172 coroapi.cede = api_cede;
1173 coroapi.ready = api_ready;
1174 coroapi.is_ready = api_is_ready;
1175 coroapi.nready = &coro_nready;
1176 coroapi.current = coro_current;
1177
1178 GCoroAPI = &coroapi;
1179 sv_setiv (sv, (IV)&coroapi);
1180 SvREADONLY_on (sv);
1181 }
1182}
1183
1184int
1185prio (Coro::State coro, int newprio = 0)
1186 ALIAS:
1187 nice = 1
468 CODE: 1188 CODE:
1189{
1190 RETVAL = coro->prio;
469 1191
470 if (coro->mainstack) 1192 if (items > 1)
471 { 1193 {
472 struct coro temp; 1194 if (ix)
1195 newprio += coro->prio;
473 1196
474 PUTBACK; 1197 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
475 SAVE(aTHX_ (&temp)); 1198 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
476 LOAD(aTHX_ coro);
477 1199
478 destroy_stacks (); 1200 coro->prio = newprio;
479 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481 LOAD((&temp));
482 SPAGAIN;
483 } 1201 }
1202}
484 1203
485 SvREFCNT_dec (coro->args); 1204SV *
486 Safefree (coro); 1205ready (SV *self)
1206 PROTOTYPE: $
1207 CODE:
1208 RETVAL = boolSV (api_ready (self));
1209 OUTPUT:
1210 RETVAL
487 1211
1212SV *
1213is_ready (SV *self)
1214 PROTOTYPE: $
1215 CODE:
1216 RETVAL = boolSV (api_is_ready (self));
1217 OUTPUT:
1218 RETVAL
488 1219
1220int
1221nready (...)
1222 PROTOTYPE:
1223 CODE:
1224 RETVAL = coro_nready;
1225 OUTPUT:
1226 RETVAL
1227
1228MODULE = Coro::State PACKAGE = Coro::AIO
1229
1230SV *
1231_get_state ()
1232 CODE:
1233{
1234 struct {
1235 int errorno;
1236 int laststype;
1237 int laststatval;
1238 Stat_t statcache;
1239 } data;
1240
1241 data.errorno = errno;
1242 data.laststype = PL_laststype;
1243 data.laststatval = PL_laststatval;
1244 data.statcache = PL_statcache;
1245
1246 RETVAL = newSVpvn ((char *)&data, sizeof data);
1247}
1248 OUTPUT:
1249 RETVAL
1250
1251void
1252_set_state (char *data_)
1253 PROTOTYPE: $
1254 CODE:
1255{
1256 struct {
1257 int errorno;
1258 int laststype;
1259 int laststatval;
1260 Stat_t statcache;
1261 } *data = (void *)data_;
1262
1263 errno = data->errorno;
1264 PL_laststype = data->laststype;
1265 PL_laststatval = data->laststatval;
1266 PL_statcache = data->statcache;
1267}

Diff Legend

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