ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro/Coro/State.xs
(Generate patch)

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

Diff Legend

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