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

Diff Legend

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