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

Diff Legend

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