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

Diff Legend

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