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

Diff Legend

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