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.177 by root, Tue Oct 2 10:24:44 2007 UTC

1#include "libcoro/coro.c"
2
3#define PERL_NO_GET_CONTEXT
4
1#include "EXTERN.h" 5#include "EXTERN.h"
2#include "perl.h" 6#include "perl.h"
3#include "XSUB.h" 7#include "XSUB.h"
4 8
5#if 0 9#include "patchlevel.h"
6# define CHK(x) (void *)0 10
11#include <stdio.h>
12#include <errno.h>
13#include <assert.h>
14
15#ifdef HAVE_MMAP
16# include <unistd.h>
17# include <sys/mman.h>
18# ifndef MAP_ANONYMOUS
19# ifdef MAP_ANON
20# define MAP_ANONYMOUS MAP_ANON
21# else
22# undef HAVE_MMAP
23# endif
24# endif
25# include <limits.h>
26# ifndef PAGESIZE
27# define PAGESIZE pagesize
28# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
29static long pagesize;
30# else
31# define BOOT_PAGESIZE (void)0
32# endif
7#else 33#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 34# define PAGESIZE 0
35# define BOOT_PAGESIZE (void)0
36#endif
37
38#if CORO_USE_VALGRIND
39# include <valgrind/valgrind.h>
40# define REGISTER_STACK(cctx,start,end) (cctx)->valgrind_id = VALGRIND_STACK_REGISTER ((start), (end))
41#else
42# define REGISTER_STACK(cctx,start,end)
43#endif
44
45/* the maximum number of idle cctx that will be pooled */
46#define MAX_IDLE_CCTX 8
47
48#define PERL_VERSION_ATLEAST(a,b,c) \
49 (PERL_REVISION > (a) \
50 || (PERL_REVISION == (a) \
51 && (PERL_VERSION > (b) \
52 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
53
54#if !PERL_VERSION_ATLEAST (5,6,0)
55# ifndef PL_ppaddr
56# define PL_ppaddr ppaddr
9#endif 57# endif
58# ifndef call_sv
59# define call_sv perl_call_sv
60# endif
61# ifndef get_sv
62# define get_sv perl_get_sv
63# endif
64# ifndef get_cv
65# define get_cv perl_get_cv
66# endif
67# ifndef IS_PADGV
68# define IS_PADGV(v) 0
69# endif
70# ifndef IS_PADCONST
71# define IS_PADCONST(v) 0
72# endif
73#endif
10 74
75/* 5.8.7 */
76#ifndef SvRV_set
77# define SvRV_set(s,v) SvRV(s) = (v)
78#endif
79
80#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
81# undef CORO_STACKGUARD
82#endif
83
84#ifndef CORO_STACKGUARD
85# define CORO_STACKGUARD 0
86#endif
87
88/* prefer perl internal functions over our own? */
89#ifndef CORO_PREFER_PERL_FUNCTIONS
90# define CORO_PREFER_PERL_FUNCTIONS 0
91#endif
92
93/* The next macros try to return the current stack pointer, in an as
94 * portable way as possible. */
95#define dSTACKLEVEL volatile char stacklevel
96#define STACKLEVEL ((void *)&stacklevel)
97
98#define IN_DESTRUCT (PL_main_cv == Nullcv)
99
100#if __GNUC__ >= 3
101# define attribute(x) __attribute__(x)
102# define BARRIER __asm__ __volatile__ ("" : : : "memory")
103#else
104# define attribute(x)
105# define BARRIER
106#endif
107
108#define NOINLINE attribute ((noinline))
109
110#include "CoroAPI.h"
111
112#ifdef USE_ITHREADS
113static perl_mutex coro_mutex;
114# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
115# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
116#else
117# define LOCK (void)0
118# define UNLOCK (void)0
119#endif
120
121/* helper storage struct for Coro::AIO */
122struct io_state
123{
124 int errorno;
125 I32 laststype;
126 int laststatval;
127 Stat_t statcache;
128};
129
130static size_t coro_stacksize = CORO_STACKSIZE;
131static struct CoroAPI coroapi;
132static AV *main_mainstack; /* used to differentiate between $main and others */
133static JMPENV *main_top_env;
134static HV *coro_state_stash, *coro_stash;
135static SV *coro_mortal; /* will be freed after next transfer */
136
137/* async_pool helper stuff */
138static SV *sv_pool_rss;
139static SV *sv_pool_size;
140static AV *av_async_pool;
141
142static struct coro_cctx *cctx_first;
143static int cctx_count, cctx_idle;
144
145enum {
146 CC_MAPPED = 0x01,
147 CC_NOREUSE = 0x02, /* throw this away after tracing */
148 CC_TRACE = 0x04,
149 CC_TRACE_SUB = 0x08, /* trace sub calls */
150 CC_TRACE_LINE = 0x10, /* trace each statement */
151 CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
152};
153
154/* this is a structure representing a c-level coroutine */
155typedef struct coro_cctx {
156 struct coro_cctx *next;
157
158 /* the stack */
159 void *sptr;
160 size_t ssize;
161
162 /* cpu state */
163 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
164 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
165 JMPENV *top_env;
166 coro_context cctx;
167
168#if CORO_USE_VALGRIND
169 int valgrind_id;
170#endif
171 unsigned char flags;
172} coro_cctx;
173
174enum {
175 CF_RUNNING = 0x0001, /* coroutine is running */
176 CF_READY = 0x0002, /* coroutine is ready */
177 CF_NEW = 0x0004, /* has never been switched to */
178 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
179};
180
181/* this is a structure representing a perl-level coroutine */
11struct coro { 182struct coro {
12 U8 dowarn; 183 /* the c coroutine allocated to this perl coroutine, if any */
13 AV *defav; 184 coro_cctx *cctx;
185
186 /* data associated with this coroutine (initial args) */
187 AV *args;
188 int refcnt;
189 int save; /* CORO_SAVE flags */
190 int flags; /* CF_ flags */
191
192 /* optionally saved, might be zero */
193 AV *defav; /* @_ */
194 SV *defsv; /* $_ */
195 SV *errsv; /* $@ */
196 GV *deffh; /* default filehandle */
197 SV *irssv; /* $/ */
198 SV *irssv_sv; /* real $/ cache */
14 199
15 PERL_SI *curstackinfo; 200#define VAR(name,type) type name;
16 AV *curstack; 201# include "state.h"
17 AV *mainstack; 202#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 203
41 AV *args; 204 /* statistics */
205 int usecount; /* number of switches to this coro */
206
207 /* coro process data */
208 int prio;
209
210 /* linked list */
211 struct coro *next, *prev;
212 HV *hv; /* the perl hash associated with this coro, if any */
42}; 213};
43 214
44typedef struct coro *Coro__State; 215typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 216typedef struct coro *Coro__State_or_hashref;
46 217
47static HV *padlist_cache; 218/** Coro ********************************************************************/
48 219
49/* mostly copied from op.c:cv_clone2 */ 220#define PRIO_MAX 3
50STATIC AV * 221#define PRIO_HIGH 1
51clone_padlist (AV *protopadlist) 222#define PRIO_NORMAL 0
223#define PRIO_LOW -1
224#define PRIO_IDLE -3
225#define PRIO_MIN -4
226
227/* for Coro.pm */
228static SV *coro_current;
229static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
230static int coro_nready;
231static struct coro *coro_first;
232
233/** lowlevel stuff **********************************************************/
234
235static AV *
236coro_clone_padlist (pTHX_ CV *cv)
52{ 237{
53 AV *av; 238 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; 239 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 240
72 newpadlist = newAV (); 241 newpadlist = newAV ();
73 AvREAL_off (newpadlist); 242 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 243#if PERL_VERSION_ATLEAST (5,9,0)
244 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
245#else
246 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
247#endif
248 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
249 --AvFILLp (padlist);
250
251 av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75 av_store (newpadlist, 1, (SV *) newpad); 252 av_store (newpadlist, 1, (SV *)newpad);
76 253
77 av = newAV (); /* will be @_ */ 254 return newpadlist;
78 av_extend (av, 0); 255}
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 256
82 for (ix = fpad; ix > 0; ix--) 257static void
258free_padlist (pTHX_ AV *padlist)
259{
260 /* may be during global destruction */
261 if (SvREFCNT (padlist))
83 { 262 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 263 I32 i = AvFILLp (padlist);
85 if (namesv && namesv != &PL_sv_undef) 264 while (i >= 0)
86 { 265 {
87 char *name = SvPVX (namesv); /* XXX */ 266 SV **svp = av_fetch (padlist, i--, FALSE);
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 267 if (svp)
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 } 268 {
92 else
93 { /* our own lexical */
94 SV *sv; 269 SV *sv;
95 if (*name == '&') 270 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96 sv = SvREFCNT_inc (ppad[ix]); 271 SvREFCNT_dec (sv);
97 else if (*name == '@') 272
98 sv = (SV *) newAV (); 273 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 } 274 }
107 } 275 }
108 else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix])) 276
277 SvREFCNT_dec ((SV*)padlist);
278 }
279}
280
281static int
282coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
283{
284 AV *padlist;
285 AV *av = (AV *)mg->mg_obj;
286
287 /* casting is fun. */
288 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
289 free_padlist (aTHX_ padlist);
290
291 SvREFCNT_dec (av);
292
293 return 0;
294}
295
296#define PERL_MAGIC_coro PERL_MAGIC_ext
297
298static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
299
300#define CORO_MAGIC(cv) \
301 SvMAGIC (cv) \
302 ? SvMAGIC (cv)->mg_type == PERL_MAGIC_coro \
303 ? SvMAGIC (cv) \
304 : mg_find ((SV *)cv, PERL_MAGIC_coro) \
305 : 0
306
307static struct coro *
308SvSTATE_ (pTHX_ SV *coro)
309{
310 HV *stash;
311 MAGIC *mg;
312
313 if (SvROK (coro))
314 coro = SvRV (coro);
315
316 if (SvTYPE (coro) != SVt_PVHV)
317 croak ("Coro::State object required");
318
319 stash = SvSTASH (coro);
320 if (stash != coro_stash && stash != coro_state_stash)
321 {
322 /* very slow, but rare, check */
323 if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
324 croak ("Coro::State object required");
325 }
326
327 mg = CORO_MAGIC (coro);
328 return (struct coro *)mg->mg_ptr;
329}
330
331#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
332
333/* the next two functions merely cache the padlists */
334static void
335get_padlist (pTHX_ CV *cv)
336{
337 MAGIC *mg = CORO_MAGIC (cv);
338 AV *av;
339
340 if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
341 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
342 else
343 {
344#if CORO_PREFER_PERL_FUNCTIONS
345 /* this is probably cleaner, but also slower? */
346 CV *cp = Perl_cv_clone (cv);
347 CvPADLIST (cv) = CvPADLIST (cp);
348 CvPADLIST (cp) = 0;
349 SvREFCNT_dec (cp);
350#else
351 CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
352#endif
353 }
354}
355
356static void
357put_padlist (pTHX_ CV *cv)
358{
359 MAGIC *mg = CORO_MAGIC (cv);
360 AV *av;
361
362 if (!mg)
363 {
364 sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
365 mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
366 mg->mg_virtual = &vtbl_coro;
367 mg->mg_obj = (SV *)newAV ();
368 }
369
370 av = (AV *)mg->mg_obj;
371
372 if (AvFILLp (av) >= AvMAX (av))
373 av_extend (av, AvMAX (av) + 1);
374
375 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
376}
377
378/** load & save, init *******************************************************/
379
380#define SB do {
381#define SE } while (0)
382
383#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
384
385static void
386load_perl (pTHX_ Coro__State c)
387{
388#define VAR(name,type) PL_ ## name = c->name;
389# include "state.h"
390#undef VAR
391
392 if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
393 if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
394 if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
395 if (c->deffh) REPLACE_SV (PL_defoutgv , c->deffh);
396
397 if (c->irssv)
398 {
399 if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
109 { 400 {
110 npad[ix] = SvREFCNT_inc (ppad[ix]); 401 SvREFCNT_dec (c->irssv);
402 c->irssv = 0;
111 } 403 }
112 else 404 else
113 { 405 {
114 SV *sv = NEWSV (0, 0); 406 REPLACE_SV (PL_rs, c->irssv);
115 SvPADTMP_on (sv); 407 if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
116 npad[ix] = sv; 408 sv_setsv (c->irssv_sv, PL_rs);
117 } 409 }
118 } 410 }
119 411
120#if 0 /* NONOTUNDERSTOOD */ 412 {
121 /* Now that vars are all in place, clone nested closures. */ 413 dSP;
414 CV *cv;
122 415
123 for (ix = fpad; ix > 0; ix--) { 416 /* now do the ugly restore mess */
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 417 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 { 418 {
131 CV *kid = cv_clone((CV*)ppad[ix]); 419 put_padlist (aTHX_ cv); /* mark this padlist as available */
132 SvREFCNT_dec(ppad[ix]); 420 CvDEPTH (cv) = PTR2IV (POPs);
133 CvCLONE_on(kid); 421 CvPADLIST (cv) = (AV *)POPs;
134 SvPADMY_on(kid);
135 npad[ix] = (SV*)kid;
136 } 422 }
137 }
138#endif
139 423
140 return newpadlist; 424 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 } 425 }
160} 426}
161 427
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 428static void
189save_state(pTHX_ Coro__State c) 429save_perl (pTHX_ Coro__State c)
190{ 430{
191 { 431 {
192 dSP; 432 dSP;
193 I32 cxix = cxstack_ix; 433 I32 cxix = cxstack_ix;
434 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 435 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 436
197 /* 437 /*
198 * the worst thing you can imagine happens first - we have to save 438 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 439 * (and reinitialize) all cv's in the whole callchain :(
200 */ 440 */
201 441
202 PUSHs (Nullsv); 442 XPUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 443 /* this loop was inspired by pp_caller */
204 for (;;) 444 for (;;)
205 { 445 {
206 while (cxix >= 0) 446 while (cxix >= 0)
207 { 447 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 448 PERL_CONTEXT *cx = &ccstk[cxix--];
209 449
210 if (CxTYPE(cx) == CXt_SUB) 450 if (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT)
211 { 451 {
212 CV *cv = cx->blk_sub.cv; 452 CV *cv = cx->blk_sub.cv;
453
213 if (CvDEPTH(cv)) 454 if (CvDEPTH (cv))
214 { 455 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3); 456 EXTEND (SP, 3);
219 PUSHs ((SV *)CvDEPTH(cv));
220 PUSHs ((SV *)CvPADLIST(cv)); 457 PUSHs ((SV *)CvPADLIST (cv));
458 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
221 PUSHs ((SV *)cv); 459 PUSHs ((SV *)cv);
222 460
223 get_padlist (cv);
224
225 CvDEPTH(cv) = 0; 461 CvDEPTH (cv) = 0;
226#ifdef USE_THREADS 462 get_padlist (aTHX_ cv);
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 } 463 }
233 } 464 }
234 else if (CxTYPE(cx) == CXt_FORMAT)
235 {
236 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 }
240 } 465 }
241 466
242 if (top_si->si_type == PERLSI_MAIN) 467 if (top_si->si_type == PERLSI_MAIN)
243 break; 468 break;
244 469
245 top_si = top_si->si_prev; 470 top_si = top_si->si_prev;
246 ccstk = top_si->si_cxstack; 471 ccstk = top_si->si_cxstack;
247 cxix = top_si->si_cxix; 472 cxix = top_si->si_cxix;
248 } 473 }
249 474
250 PUTBACK; 475 PUTBACK;
251 } 476 }
252 477
253 c->dowarn = PL_dowarn; 478 c->defav = c->save & CORO_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
254 c->defav = GvAV (PL_defgv); 479 c->defsv = c->save & CORO_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
255 c->curstackinfo = PL_curstackinfo; 480 c->errsv = c->save & CORO_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
256 c->curstack = PL_curstack; 481 c->deffh = c->save & CORO_SAVE_DEFFH ? (GV *)SvREFCNT_inc (PL_defoutgv) : 0;
257 c->mainstack = PL_mainstack; 482 c->irssv = c->save & CORO_SAVE_IRSSV ? SvREFCNT_inc (PL_rs) : 0;
258 c->stack_sp = PL_stack_sp;
259 c->op = PL_op;
260 c->curpad = PL_curpad;
261 c->stack_base = PL_stack_base;
262 c->stack_max = PL_stack_max;
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 483
282#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0) 484#define VAR(name,type)c->name = PL_ ## name;
283#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0) 485# include "state.h"
486#undef VAR
487}
284 488
489/*
490 * allocate various perl stacks. This is an exact copy
491 * of perl.c:init_stacks, except that it uses less memory
492 * on the (sometimes correct) assumption that coroutines do
493 * not usually need a lot of stackspace.
494 */
495#if CORO_PREFER_PERL_FUNCTIONS
496# define coro_init_stacks init_stacks
497#else
285static void 498static void
286load_state(pTHX_ Coro__State c) 499coro_init_stacks (pTHX)
287{ 500{
288 PL_dowarn = c->dowarn;
289 GvAV (PL_defgv) = c->defav;
290 PL_curstackinfo = c->curstackinfo; 501 PL_curstackinfo = new_stackinfo(64, 6);
291 PL_curstack = c->curstack; 502 PL_curstackinfo->si_type = PERLSI_MAIN;
292 PL_mainstack = c->mainstack; 503 PL_curstack = PL_curstackinfo->si_stack;
504 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
505
506 PL_stack_base = AvARRAY(PL_curstack);
293 PL_stack_sp = c->stack_sp; 507 PL_stack_sp = PL_stack_base;
294 PL_op = c->op; 508 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295 PL_curpad = c->curpad; 509
296 PL_stack_base = c->stack_base; 510 New(50,PL_tmps_stack,64,SV*);
297 PL_stack_max = c->stack_max; 511 PL_tmps_floor = -1;
298 PL_tmps_stack = c->tmps_stack; 512 PL_tmps_ix = -1;
299 PL_tmps_floor = c->tmps_floor; 513 PL_tmps_max = 64;
300 PL_tmps_ix = c->tmps_ix; 514
301 PL_tmps_max = c->tmps_max; 515 New(54,PL_markstack,16,I32);
302 PL_markstack = c->markstack;
303 PL_markstack_ptr = c->markstack_ptr; 516 PL_markstack_ptr = PL_markstack;
304 PL_markstack_max = c->markstack_max; 517 PL_markstack_max = PL_markstack + 16;
305 PL_scopestack = c->scopestack; 518
306 PL_scopestack_ix = c->scopestack_ix; 519#ifdef SET_MARK_OFFSET
307 PL_scopestack_max = c->scopestack_max; 520 SET_MARK_OFFSET;
308 PL_savestack = c->savestack; 521#endif
309 PL_savestack_ix = c->savestack_ix; 522
310 PL_savestack_max = c->savestack_max; 523 New(54,PL_scopestack,16,I32);
311 PL_retstack = c->retstack; 524 PL_scopestack_ix = 0;
312 PL_retstack_ix = c->retstack_ix; 525 PL_scopestack_max = 16;
313 PL_retstack_max = c->retstack_max; 526
314 PL_curcop = c->curcop; 527 New(54,PL_savestack,64,ANY);
528 PL_savestack_ix = 0;
529 PL_savestack_max = 64;
530
531#if !PERL_VERSION_ATLEAST (5,9,0)
532 New(54,PL_retstack,4,OP*);
533 PL_retstack_ix = 0;
534 PL_retstack_max = 4;
535#endif
536}
537#endif
538
539/*
540 * destroy the stacks, the callchain etc...
541 */
542static void
543coro_destroy_stacks (pTHX)
544{
545 if (!IN_DESTRUCT)
546 {
547 /* restore all saved variables and stuff */
548 LEAVE_SCOPE (0);
549 assert (PL_tmps_floor == -1);
550
551 /* free all temporaries */
552 FREETMPS;
553 assert (PL_tmps_ix == -1);
554
555 /* unwind all extra stacks */
556 POPSTACK_TO (PL_mainstack);
557
558 /* unwind main stack */
559 dounwind (-1);
560 }
561
562 while (PL_curstackinfo->si_next)
563 PL_curstackinfo = PL_curstackinfo->si_next;
564
565 while (PL_curstackinfo)
566 {
567 PERL_SI *p = PL_curstackinfo->si_prev;
568
569 if (!IN_DESTRUCT)
570 SvREFCNT_dec (PL_curstackinfo->si_stack);
571
572 Safefree (PL_curstackinfo->si_cxstack);
573 Safefree (PL_curstackinfo);
574 PL_curstackinfo = p;
575 }
576
577 Safefree (PL_tmps_stack);
578 Safefree (PL_markstack);
579 Safefree (PL_scopestack);
580 Safefree (PL_savestack);
581#if !PERL_VERSION_ATLEAST (5,9,0)
582 Safefree (PL_retstack);
583#endif
584}
585
586static size_t
587coro_rss (pTHX_ struct coro *coro)
588{
589 size_t rss = sizeof (coro);
590
591 if (coro->mainstack)
592 {
593 if (coro->flags & CF_RUNNING)
594 {
595 #define VAR(name,type)coro->name = PL_ ## name;
596 # include "state.h"
597 #undef VAR
598 }
599
600 rss += sizeof (coro->curstackinfo);
601 rss += sizeof (struct xpvav) + (1 + AvFILL (coro->curstackinfo->si_stack)) * sizeof (SV *);
602 rss += (coro->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
603 rss += sizeof (struct xpvav) + (1 + AvFILL (coro->curstack)) * sizeof (SV *);
604 rss += coro->tmps_max * sizeof (SV *);
605 rss += (coro->markstack_max - coro->markstack_ptr) * sizeof (I32);
606 rss += coro->scopestack_max * sizeof (I32);
607 rss += coro->savestack_max * sizeof (ANY);
608
609#if !PERL_VERSION_ATLEAST (5,9,0)
610 rss += coro->retstack_max * sizeof (OP *);
611#endif
612 }
613
614 return rss;
615}
616
617/** coroutine stack handling ************************************************/
618
619static void
620setup_coro (pTHX_ struct coro *coro)
621{
622 /*
623 * emulate part of the perl startup here.
624 */
625 coro_init_stacks (aTHX);
626
627 PL_runops = RUNOPS_DEFAULT;
628 PL_curcop = &PL_compiling;
629 PL_in_eval = EVAL_NULL;
630 PL_comppad = 0;
631 PL_curpm = 0;
632 PL_localizing = 0;
633 PL_dirty = 0;
634 PL_restartop = 0;
315 635
316 { 636 {
317 dSP; 637 dSP;
318 CV *cv; 638 LOGOP myop;
319 639
320 /* now do the ugly restore mess */ 640 SvREFCNT_dec (GvAV (PL_defgv));
321 while ((cv = (CV *)POPs)) 641 GvAV (PL_defgv) = coro->args; coro->args = 0;
322 {
323 AV *padlist = (AV *)POPs;
324 642
325 put_padlist (cv); 643 Zero (&myop, 1, LOGOP);
326 CvPADLIST(cv) = padlist; 644 myop.op_next = Nullop;
327 CvDEPTH(cv) = (I32)POPs; 645 myop.op_flags = OPf_WANT_VOID;
328 646
329#ifdef USE_THREADS 647 PUSHMARK (SP);
330 CvOWNER(cv) = (struct perl_thread *)POPs; 648 XPUSHs (av_shift (GvAV (PL_defgv)));
331 error does not work either
332#endif
333 }
334
335 PUTBACK; 649 PUTBACK;
650 PL_op = (OP *)&myop;
651 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
652 SPAGAIN;
336 } 653 }
337}
338 654
339/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 655 ENTER; /* necessary e.g. for dounwind */
340STATIC void 656}
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 657
347 /* is this ugly, I ask? */ 658static void
348 while (PL_scopestack_ix) 659free_coro_mortal (pTHX)
349 LEAVE; 660{
350 661 if (coro_mortal)
351 while (PL_curstackinfo->si_next) 662 {
352 PL_curstackinfo = PL_curstackinfo->si_next; 663 SvREFCNT_dec (coro_mortal);
353 664 coro_mortal = 0;
354 while (PL_curstackinfo)
355 { 665 }
356 PERL_SI *p = PL_curstackinfo->si_prev; 666}
357 667
358 SvREFCNT_dec(PL_curstackinfo->si_stack); 668static int
359 Safefree(PL_curstackinfo->si_cxstack); 669runops_trace (pTHX)
360 Safefree(PL_curstackinfo); 670{
361 PL_curstackinfo = p; 671 COP *oldcop = 0;
672 int oldcxix = -2;
673 struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
674 coro_cctx *cctx = coro->cctx;
675
676 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
677 {
678 PERL_ASYNC_CHECK ();
679
680 if (cctx->flags & CC_TRACE_ALL)
681 {
682 if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
683 {
684 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
685 SV **bot, **top;
686 AV *av = newAV (); /* return values */
687 SV **cb;
688 dSP;
689
690 GV *gv = CvGV (cx->blk_sub.cv);
691 SV *fullname = sv_2mortal (newSV (0));
692 if (isGV (gv))
693 gv_efullname3 (fullname, gv, 0);
694
695 bot = PL_stack_base + cx->blk_oldsp + 1;
696 top = cx->blk_gimme == G_ARRAY ? SP + 1
697 : cx->blk_gimme == G_SCALAR ? bot + 1
698 : bot;
699
700 while (bot < top)
701 av_push (av, SvREFCNT_inc (*bot++));
702
703 PL_runops = RUNOPS_DEFAULT;
704 ENTER;
705 SAVETMPS;
706 EXTEND (SP, 3);
707 PUSHMARK (SP);
708 PUSHs (&PL_sv_no);
709 PUSHs (fullname);
710 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
711 PUTBACK;
712 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
713 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
714 SPAGAIN;
715 FREETMPS;
716 LEAVE;
717 PL_runops = runops_trace;
718 }
719
720 if (oldcop != PL_curcop)
721 {
722 oldcop = PL_curcop;
723
724 if (PL_curcop != &PL_compiling)
725 {
726 SV **cb;
727
728 if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
729 {
730 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
731
732 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
733 {
734 runops_proc_t old_runops = PL_runops;
735 dSP;
736 GV *gv = CvGV (cx->blk_sub.cv);
737 SV *fullname = sv_2mortal (newSV (0));
738
739 if (isGV (gv))
740 gv_efullname3 (fullname, gv, 0);
741
742 PL_runops = RUNOPS_DEFAULT;
743 ENTER;
744 SAVETMPS;
745 EXTEND (SP, 3);
746 PUSHMARK (SP);
747 PUSHs (&PL_sv_yes);
748 PUSHs (fullname);
749 PUSHs (cx->blk_sub.hasargs ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
750 PUTBACK;
751 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
752 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
753 SPAGAIN;
754 FREETMPS;
755 LEAVE;
756 PL_runops = runops_trace;
757 }
758
759 oldcxix = cxstack_ix;
760 }
761
762 if (cctx->flags & CC_TRACE_LINE)
763 {
764 dSP;
765
766 PL_runops = RUNOPS_DEFAULT;
767 ENTER;
768 SAVETMPS;
769 EXTEND (SP, 3);
770 PL_runops = RUNOPS_DEFAULT;
771 PUSHMARK (SP);
772 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
773 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
774 PUTBACK;
775 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
776 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
777 SPAGAIN;
778 FREETMPS;
779 LEAVE;
780 PL_runops = runops_trace;
781 }
782 }
783 }
784 }
362 } 785 }
363 786
364 if (PL_scopestack_ix != 0) 787 TAINT_NOT;
365 Perl_warner(aTHX_ WARN_INTERNAL, 788 return 0;
366 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 789}
367 (long)PL_scopestack_ix); 790
368 if (PL_savestack_ix != 0) 791/* inject a fake call to Coro::State::_cctx_init into the execution */
369 Perl_warner(aTHX_ WARN_INTERNAL, 792/* _cctx_init should be careful, as it could be called at almost any time */
370 "Unbalanced saves: %ld more saves than restores\n", 793/* during execution of a perl program */
371 (long)PL_savestack_ix); 794static void NOINLINE
372 if (PL_tmps_floor != -1) 795prepare_cctx (pTHX_ coro_cctx *cctx)
373 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 796{
374 (long)PL_tmps_floor + 1); 797 dSP;
798 LOGOP myop;
799
800 PL_top_env = &PL_start_env;
801
802 if (cctx->flags & CC_TRACE)
803 PL_runops = runops_trace;
804
805 Zero (&myop, 1, LOGOP);
806 myop.op_next = PL_op;
807 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
808
809 PUSHMARK (SP);
810 EXTEND (SP, 2);
811 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
812 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
813 PUTBACK;
814 PL_op = (OP *)&myop;
815 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
816 SPAGAIN;
817}
818
819/*
820 * this is a _very_ stripped down perl interpreter ;)
821 */
822static void
823coro_run (void *arg)
824{
825 dTHX;
826
827 /* coro_run is the alternative tail of transfer(), so unlock here. */
828 UNLOCK;
829
830 /* we now skip the entersub that lead to transfer() */
831 PL_op = PL_op->op_next;
832
833 /* inject a fake subroutine call to cctx_init */
834 prepare_cctx (aTHX_ (coro_cctx *)arg);
835
836 /* somebody or something will hit me for both perl_run and PL_restartop */
837 PL_restartop = PL_op;
838 perl_run (PL_curinterp);
839
375 /* 840 /*
376 */ 841 * If perl-run returns we assume exit() was being called or the coro
377 Safefree(PL_tmps_stack); 842 * fell off the end, which seems to be the only valid (non-bug)
378 Safefree(PL_markstack); 843 * reason for perl_run to return. We try to exit by jumping to the
379 Safefree(PL_scopestack); 844 * bootstrap-time "top" top_env, as we cannot restore the "main"
380 Safefree(PL_savestack); 845 * coroutine as Coro has no such concept
381 Safefree(PL_retstack); 846 */
847 PL_top_env = main_top_env;
848 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
382} 849}
383 850
384#define SUB_INIT "Coro::State::_newcoro" 851static coro_cctx *
852cctx_new ()
853{
854 coro_cctx *cctx;
855 void *stack_start;
856 size_t stack_size;
385 857
858 ++cctx_count;
859
860 Newz (0, cctx, 1, coro_cctx);
861
862#if HAVE_MMAP
863
864 cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
865 /* mmap supposedly does allocate-on-write for us */
866 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
867
868 if (cctx->sptr != (void *)-1)
869 {
870# if CORO_STACKGUARD
871 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
872# endif
873 stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
874 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
875 cctx->flags |= CC_MAPPED;
876 }
877 else
878#endif
879 {
880 cctx->ssize = coro_stacksize * (long)sizeof (long);
881 New (0, cctx->sptr, coro_stacksize, long);
882
883 if (!cctx->sptr)
884 {
885 perror ("FATAL: unable to allocate stack for coroutine");
886 _exit (EXIT_FAILURE);
887 }
888
889 stack_start = cctx->sptr;
890 stack_size = cctx->ssize;
891 }
892
893 REGISTER_STACK (cctx, (char *)stack_start, (char *)stack_start + stack_size);
894 coro_create (&cctx->cctx, coro_run, (void *)cctx, stack_start, stack_size);
895
896 return cctx;
897}
898
899static void
900cctx_destroy (coro_cctx *cctx)
901{
902 if (!cctx)
903 return;
904
905 --cctx_count;
906
907#if CORO_USE_VALGRIND
908 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
909#endif
910
911#if HAVE_MMAP
912 if (cctx->flags & CC_MAPPED)
913 munmap (cctx->sptr, cctx->ssize);
914 else
915#endif
916 Safefree (cctx->sptr);
917
918 Safefree (cctx);
919}
920
921static coro_cctx *
922cctx_get (pTHX)
923{
924 while (cctx_first)
925 {
926 coro_cctx *cctx = cctx_first;
927 cctx_first = cctx->next;
928 --cctx_idle;
929
930 if (cctx->ssize >= coro_stacksize && !(cctx->flags & CC_NOREUSE))
931 return cctx;
932
933 cctx_destroy (cctx);
934 }
935
936 return cctx_new ();
937}
938
939static void
940cctx_put (coro_cctx *cctx)
941{
942 /* free another cctx if overlimit */
943 if (cctx_idle >= MAX_IDLE_CCTX)
944 {
945 coro_cctx *first = cctx_first;
946 cctx_first = first->next;
947 --cctx_idle;
948
949 cctx_destroy (first);
950 }
951
952 ++cctx_idle;
953 cctx->next = cctx_first;
954 cctx_first = cctx;
955}
956
957/** coroutine switching *****************************************************/
958
959static void NOINLINE
960transfer_check (pTHX_ struct coro *prev, struct coro *next)
961{
962 if (prev != next)
963 {
964 if (!(prev->flags & (CF_RUNNING | CF_NEW)))
965 croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
966
967 if (next->flags & CF_RUNNING)
968 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
969
970 if (next->flags & CF_DESTROYED)
971 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
972
973 if (PL_lex_state != LEX_NOTPARSING)
974 croak ("Coro::State::transfer called while parsing, but this is not supported");
975 }
976}
977
978/* always use the TRANSFER macro */
979static void NOINLINE
980transfer (pTHX_ struct coro *prev, struct coro *next)
981{
982 dSTACKLEVEL;
983
984 /* sometimes transfer is only called to set idle_sp */
985 if (!next)
986 {
987 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
988 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
989 }
990 else if (prev != next)
991 {
992 coro_cctx *prev__cctx;
993
994 if (prev->flags & CF_NEW)
995 {
996 /* create a new empty context */
997 Newz (0, prev->cctx, 1, coro_cctx);
998 prev->flags &= ~CF_NEW;
999 prev->flags |= CF_RUNNING;
1000 }
1001
1002 prev->flags &= ~CF_RUNNING;
1003 next->flags |= CF_RUNNING;
1004
1005 LOCK;
1006
1007 if (next->flags & CF_NEW)
1008 {
1009 /* need to start coroutine */
1010 next->flags &= ~CF_NEW;
1011 /* first get rid of the old state */
1012 save_perl (aTHX_ prev);
1013 /* setup coroutine call */
1014 setup_coro (aTHX_ next);
1015 }
1016 else
1017 {
1018 /* coroutine already started */
1019 save_perl (aTHX_ prev);
1020 load_perl (aTHX_ next);
1021 }
1022
1023 prev__cctx = prev->cctx;
1024
1025 /* possibly "free" the cctx */
1026 if (prev__cctx->idle_sp == STACKLEVEL && !(prev__cctx->flags & CC_TRACE))
1027 {
1028 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
1029 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
1030
1031 prev->cctx = 0;
1032
1033 cctx_put (prev__cctx);
1034 }
1035
1036 ++next->usecount;
1037
1038 if (!next->cctx)
1039 next->cctx = cctx_get (aTHX);
1040
1041 if (prev__cctx != next->cctx)
1042 {
1043 prev__cctx->top_env = PL_top_env;
1044 PL_top_env = next->cctx->top_env;
1045 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
1046 }
1047
1048 free_coro_mortal (aTHX);
1049 UNLOCK;
1050 }
1051}
1052
1053struct transfer_args
1054{
1055 struct coro *prev, *next;
1056};
1057
1058#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next)
1059#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1060
1061/** high level stuff ********************************************************/
1062
1063static int
1064coro_state_destroy (pTHX_ struct coro *coro)
1065{
1066 if (coro->flags & CF_DESTROYED)
1067 return 0;
1068
1069 coro->flags |= CF_DESTROYED;
1070
1071 if (coro->flags & CF_READY)
1072 {
1073 /* reduce nready, as destroying a ready coro effectively unreadies it */
1074 /* alternative: look through all ready queues and remove the coro */
1075 LOCK;
1076 --coro_nready;
1077 UNLOCK;
1078 }
1079 else
1080 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1081
1082 if (coro->mainstack && coro->mainstack != main_mainstack)
1083 {
1084 struct coro temp;
1085
1086 if (coro->flags & CF_RUNNING)
1087 croak ("FATAL: tried to destroy currently running coroutine");
1088
1089 Zero (&temp, 1, struct coro);
1090 temp.save = CORO_SAVE_ALL;
1091
1092 save_perl (aTHX_ &temp);
1093 load_perl (aTHX_ coro);
1094
1095 coro_destroy_stacks (aTHX);
1096
1097 load_perl (aTHX_ &temp); /* this will get rid of defsv etc.. */
1098
1099 coro->mainstack = 0;
1100 }
1101
1102 cctx_destroy (coro->cctx);
1103 SvREFCNT_dec (coro->args);
1104
1105 if (coro->next) coro->next->prev = coro->prev;
1106 if (coro->prev) coro->prev->next = coro->next;
1107 if (coro == coro_first) coro_first = coro->next;
1108
1109 return 1;
1110}
1111
1112static int
1113coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1114{
1115 struct coro *coro = (struct coro *)mg->mg_ptr;
1116 mg->mg_ptr = 0;
1117
1118 coro->hv = 0;
1119
1120 if (--coro->refcnt < 0)
1121 {
1122 coro_state_destroy (aTHX_ coro);
1123 Safefree (coro);
1124 }
1125
1126 return 0;
1127}
1128
1129static int
1130coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1131{
1132 struct coro *coro = (struct coro *)mg->mg_ptr;
1133
1134 ++coro->refcnt;
1135
1136 return 0;
1137}
1138
1139static MGVTBL coro_state_vtbl = {
1140 0, 0, 0, 0,
1141 coro_state_free,
1142 0,
1143#ifdef MGf_DUP
1144 coro_state_dup,
1145#else
1146# define MGf_DUP 0
1147#endif
1148};
1149
1150static void
1151prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
1152{
1153 ta->prev = SvSTATE (prev_sv);
1154 ta->next = SvSTATE (next_sv);
1155 TRANSFER_CHECK (*ta);
1156}
1157
1158static void
1159api_transfer (SV *prev_sv, SV *next_sv)
1160{
1161 dTHX;
1162 struct transfer_args ta;
1163
1164 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1165 TRANSFER (ta);
1166}
1167
1168static int
1169api_save (SV *coro_sv, int new_save)
1170{
1171 dTHX;
1172 struct coro *coro = SvSTATE (coro_sv);
1173 int old_save = coro->save;
1174
1175 if (new_save >= 0)
1176 coro->save = new_save;
1177
1178 return old_save;
1179}
1180
1181/** Coro ********************************************************************/
1182
1183static void
1184coro_enq (pTHX_ SV *coro_sv)
1185{
1186 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1187}
1188
1189static SV *
1190coro_deq (pTHX_ int min_prio)
1191{
1192 int prio = PRIO_MAX - PRIO_MIN;
1193
1194 min_prio -= PRIO_MIN;
1195 if (min_prio < 0)
1196 min_prio = 0;
1197
1198 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
1199 if (AvFILLp (coro_ready [prio]) >= 0)
1200 return av_shift (coro_ready [prio]);
1201
1202 return 0;
1203}
1204
1205static int
1206api_ready (SV *coro_sv)
1207{
1208 dTHX;
1209 struct coro *coro;
1210
1211 if (SvROK (coro_sv))
1212 coro_sv = SvRV (coro_sv);
1213
1214 coro = SvSTATE (coro_sv);
1215
1216 if (coro->flags & CF_READY)
1217 return 0;
1218
1219 coro->flags |= CF_READY;
1220
1221 LOCK;
1222 coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
1223 ++coro_nready;
1224 UNLOCK;
1225
1226 return 1;
1227}
1228
1229static int
1230api_is_ready (SV *coro_sv)
1231{
1232 dTHX;
1233 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1234}
1235
1236static void
1237prepare_schedule (pTHX_ struct transfer_args *ta)
1238{
1239 SV *prev_sv, *next_sv;
1240
1241 for (;;)
1242 {
1243 LOCK;
1244 next_sv = coro_deq (aTHX_ PRIO_MIN);
1245
1246 /* nothing to schedule: call the idle handler */
1247 if (!next_sv)
1248 {
1249 dSP;
1250 UNLOCK;
1251
1252 ENTER;
1253 SAVETMPS;
1254
1255 PUSHMARK (SP);
1256 PUTBACK;
1257 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1258
1259 FREETMPS;
1260 LEAVE;
1261 continue;
1262 }
1263
1264 ta->next = SvSTATE (next_sv);
1265
1266 /* cannot transfer to destroyed coros, skip and look for next */
1267 if (ta->next->flags & CF_DESTROYED)
1268 {
1269 UNLOCK;
1270 SvREFCNT_dec (next_sv);
1271 /* coro_nready is already taken care of by destroy */
1272 continue;
1273 }
1274
1275 --coro_nready;
1276 UNLOCK;
1277 break;
1278 }
1279
1280 /* free this only after the transfer */
1281 prev_sv = SvRV (coro_current);
1282 ta->prev = SvSTATE (prev_sv);
1283 TRANSFER_CHECK (*ta);
1284 assert (ta->next->flags & CF_READY);
1285 ta->next->flags &= ~CF_READY;
1286 SvRV_set (coro_current, next_sv);
1287
1288 LOCK;
1289 free_coro_mortal (aTHX);
1290 coro_mortal = prev_sv;
1291 UNLOCK;
1292}
1293
1294static void
1295prepare_cede (pTHX_ struct transfer_args *ta)
1296{
1297 api_ready (coro_current);
1298 prepare_schedule (aTHX_ ta);
1299}
1300
1301static int
1302prepare_cede_notself (pTHX_ struct transfer_args *ta)
1303{
1304 if (coro_nready)
1305 {
1306 SV *prev = SvRV (coro_current);
1307 prepare_schedule (aTHX_ ta);
1308 api_ready (prev);
1309 return 1;
1310 }
1311 else
1312 return 0;
1313}
1314
1315static void
1316api_schedule (void)
1317{
1318 dTHX;
1319 struct transfer_args ta;
1320
1321 prepare_schedule (aTHX_ &ta);
1322 TRANSFER (ta);
1323}
1324
1325static int
1326api_cede (void)
1327{
1328 dTHX;
1329 struct transfer_args ta;
1330
1331 prepare_cede (aTHX_ &ta);
1332
1333 if (ta.prev != ta.next)
1334 {
1335 TRANSFER (ta);
1336 return 1;
1337 }
1338 else
1339 return 0;
1340}
1341
1342static int
1343api_cede_notself (void)
1344{
1345 dTHX;
1346 struct transfer_args ta;
1347
1348 if (prepare_cede_notself (aTHX_ &ta))
1349 {
1350 TRANSFER (ta);
1351 return 1;
1352 }
1353 else
1354 return 0;
1355}
1356
1357static void
1358api_trace (SV *coro_sv, int flags)
1359{
1360 dTHX;
1361 struct coro *coro = SvSTATE (coro_sv);
1362
1363 if (flags & CC_TRACE)
1364 {
1365 if (!coro->cctx)
1366 coro->cctx = cctx_new ();
1367 else if (!(coro->cctx->flags & CC_TRACE))
1368 croak ("cannot enable tracing on coroutine with custom stack");
1369
1370 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1371 }
1372 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1373 {
1374 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1375
1376 if (coro->flags & CF_RUNNING)
1377 PL_runops = RUNOPS_DEFAULT;
1378 else
1379 coro->runops = RUNOPS_DEFAULT;
1380 }
1381}
1382
386MODULE = Coro::State PACKAGE = Coro::State 1383MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
387 1384
388PROTOTYPES: ENABLE 1385PROTOTYPES: DISABLE
389 1386
390BOOT: 1387BOOT:
391 if (!padlist_cache) 1388{
392 padlist_cache = newHV (); 1389#ifdef USE_ITHREADS
1390 MUTEX_INIT (&coro_mutex);
1391#endif
1392 BOOT_PAGESIZE;
393 1393
394Coro::State 1394 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
395_newprocess(args) 1395
396 SV * args 1396 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
397 PROTOTYPE: $ 1397 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1398 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1399 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1400
1401 newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
1402 newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
1403 newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
1404 newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
1405 newCONSTSUB (coro_state_stash, "SAVE_DEFFH", newSViv (CORO_SAVE_DEFFH));
1406 newCONSTSUB (coro_state_stash, "SAVE_DEF", newSViv (CORO_SAVE_DEF));
1407 newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
1408
1409 main_mainstack = PL_mainstack;
1410 main_top_env = PL_top_env;
1411
1412 while (main_top_env->je_prev)
1413 main_top_env = main_top_env->je_prev;
1414
1415 coroapi.ver = CORO_API_VERSION;
1416 coroapi.transfer = api_transfer;
1417
1418 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1419}
1420
1421SV *
1422new (char *klass, ...)
398 CODE: 1423 CODE:
399 Coro__State coro; 1424{
1425 struct coro *coro;
1426 HV *hv;
1427 int i;
400 1428
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); 1429 Newz (0, coro, 1, struct coro);
1430 coro->args = newAV ();
1431 coro->save = CORO_SAVE_DEF;
1432 coro->flags = CF_NEW;
405 1433
406 coro->mainstack = 0; /* actual work is done inside transfer */ 1434 if (coro_first) coro_first->prev = coro;
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1435 coro->next = coro_first;
1436 coro_first = coro;
408 1437
409 RETVAL = coro; 1438 coro->hv = hv = newHV ();
1439 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1440 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1441
1442 for (i = 1; i < items; i++)
1443 av_push (coro->args, newSVsv (ST (i)));
1444}
410 OUTPUT: 1445 OUTPUT:
411 RETVAL 1446 RETVAL
412 1447
1448int
1449save (SV *coro, int new_save = -1)
1450 CODE:
1451 RETVAL = api_save (coro, new_save);
1452 OUTPUT:
1453 RETVAL
1454
1455int
1456save_also (SV *coro_sv, int save_also)
1457 CODE:
1458{
1459 struct coro *coro = SvSTATE (coro_sv);
1460 RETVAL = coro->save;
1461 coro->save |= save_also;
1462}
1463 OUTPUT:
1464 RETVAL
1465
1466# these not obviously related functions are all rolled into the same xs
1467# function to increase chances that they all will call transfer with the same
1468# stack offset
413void 1469void
414transfer(prev,next) 1470_set_stacklevel (...)
415 Coro::State_or_hashref prev 1471 ALIAS:
416 Coro::State_or_hashref next 1472 Coro::State::transfer = 1
1473 Coro::schedule = 2
1474 Coro::cede = 3
1475 Coro::cede_notself = 4
417 CODE: 1476 CODE:
1477{
1478 struct transfer_args ta;
418 1479
419 if (prev != next) 1480 switch (ix)
420 { 1481 {
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 1482 case 0:
1483 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1484 ta.next = 0;
440 { 1485 break;
441 SAVE (prev);
442 1486
443 /* 1487 case 1:
444 * emulate part of the perl startup here. 1488 if (items != 2)
445 */ 1489 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446 UNOP myop;
447 1490
448 init_stacks (); /* from perl.c */ 1491 prepare_transfer (aTHX_ &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 } 1492 break;
1493
1494 case 2:
1495 prepare_schedule (aTHX_ &ta);
1496 break;
1497
1498 case 3:
1499 prepare_cede (aTHX_ &ta);
1500 break;
1501
1502 case 4:
1503 if (!prepare_cede_notself (aTHX_ &ta))
1504 XSRETURN_EMPTY;
1505
1506 break;
472 } 1507 }
473 1508
1509 BARRIER;
1510 TRANSFER (ta);
1511
1512 if (GIMME_V != G_VOID && ta.next != ta.prev)
1513 XSRETURN_YES;
1514}
1515
1516bool
1517_destroy (SV *coro_sv)
1518 CODE:
1519 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1520 OUTPUT:
1521 RETVAL
1522
474void 1523void
475DESTROY(coro) 1524_exit (code)
476 Coro::State coro 1525 int code
477 CODE: 1526 PROTOTYPE: $
1527 CODE:
1528 _exit (code);
478 1529
1530int
1531cctx_stacksize (int new_stacksize = 0)
1532 CODE:
1533 RETVAL = coro_stacksize;
1534 if (new_stacksize)
1535 coro_stacksize = new_stacksize;
1536 OUTPUT:
1537 RETVAL
1538
1539int
1540cctx_count ()
1541 CODE:
1542 RETVAL = cctx_count;
1543 OUTPUT:
1544 RETVAL
1545
1546int
1547cctx_idle ()
1548 CODE:
1549 RETVAL = cctx_idle;
1550 OUTPUT:
1551 RETVAL
1552
1553void
1554list ()
1555 PPCODE:
1556{
1557 struct coro *coro;
1558 for (coro = coro_first; coro; coro = coro->next)
1559 if (coro->hv)
1560 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1561}
1562
1563void
1564call (Coro::State coro, SV *coderef)
1565 ALIAS:
1566 eval = 1
1567 CODE:
1568{
479 if (coro->mainstack) 1569 if (coro->mainstack)
480 { 1570 {
481 struct coro temp; 1571 struct coro temp;
1572 Zero (&temp, 1, struct coro);
1573 temp.save = CORO_SAVE_ALL;
482 1574
483 SAVE(aTHX_ (&temp)); 1575 if (!(coro->flags & CF_RUNNING))
484 LOAD(aTHX_ coro); 1576 {
1577 save_perl (aTHX_ &temp);
1578 load_perl (aTHX_ coro);
1579 }
485 1580
486 destroy_stacks (); 1581 {
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 1582 dSP;
1583 ENTER;
1584 SAVETMPS;
1585 PUSHMARK (SP);
1586 PUTBACK;
1587 if (ix)
1588 eval_sv (coderef, 0);
1589 else
1590 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1591 SPAGAIN;
1592 FREETMPS;
1593 LEAVE;
1594 PUTBACK;
1595 }
488 1596
489 LOAD((&temp)); 1597 if (!(coro->flags & CF_RUNNING))
1598 {
1599 save_perl (aTHX_ coro);
1600 load_perl (aTHX_ &temp);
1601 }
490 } 1602 }
1603}
491 1604
1605SV *
1606is_ready (Coro::State coro)
1607 PROTOTYPE: $
1608 ALIAS:
1609 is_ready = CF_READY
1610 is_running = CF_RUNNING
1611 is_new = CF_NEW
1612 is_destroyed = CF_DESTROYED
1613 CODE:
1614 RETVAL = boolSV (coro->flags & ix);
1615 OUTPUT:
1616 RETVAL
1617
1618void
1619api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1620
1621SV *
1622has_stack (Coro::State coro)
1623 PROTOTYPE: $
1624 CODE:
1625 RETVAL = boolSV (!!coro->cctx);
1626 OUTPUT:
1627 RETVAL
1628
1629int
1630is_traced (Coro::State coro)
1631 PROTOTYPE: $
1632 CODE:
1633 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1634 OUTPUT:
1635 RETVAL
1636
1637IV
1638rss (Coro::State coro)
1639 PROTOTYPE: $
1640 ALIAS:
1641 usecount = 1
1642 CODE:
1643 switch (ix)
1644 {
1645 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1646 case 1: RETVAL = coro->usecount; break;
1647 }
1648 OUTPUT:
1649 RETVAL
1650
1651
1652MODULE = Coro::State PACKAGE = Coro
1653
1654BOOT:
1655{
1656 int i;
1657
1658 sv_pool_rss = get_sv ("Coro::POOL_RSS" , TRUE);
1659 sv_pool_size = get_sv ("Coro::POOL_SIZE" , TRUE);
1660 av_async_pool = get_av ("Coro::async_pool", TRUE);
1661
1662 coro_current = get_sv ("Coro::current", FALSE);
1663 SvREADONLY_on (coro_current);
1664
1665 coro_stash = gv_stashpv ("Coro", TRUE);
1666
1667 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1668 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1669 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1670 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1671 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1672 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1673
1674 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1675 coro_ready[i] = newAV ();
1676
1677 {
1678 SV *sv = perl_get_sv("Coro::API", 1);
1679
1680 coroapi.schedule = api_schedule;
1681 coroapi.save = api_save;
1682 coroapi.cede = api_cede;
1683 coroapi.cede_notself = api_cede_notself;
1684 coroapi.ready = api_ready;
1685 coroapi.is_ready = api_is_ready;
1686 coroapi.nready = &coro_nready;
1687 coroapi.current = coro_current;
1688
1689 GCoroAPI = &coroapi;
1690 sv_setiv (sv, (IV)&coroapi);
1691 SvREADONLY_on (sv);
1692 }
1693}
1694
1695void
1696_set_current (SV *current)
1697 PROTOTYPE: $
1698 CODE:
1699 SvREFCNT_dec (SvRV (coro_current));
1700 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1701
1702int
1703prio (Coro::State coro, int newprio = 0)
1704 ALIAS:
1705 nice = 1
1706 CODE:
1707{
1708 RETVAL = coro->prio;
1709
1710 if (items > 1)
1711 {
1712 if (ix)
1713 newprio = coro->prio - newprio;
1714
1715 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1716 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1717
1718 coro->prio = newprio;
1719 }
1720}
1721 OUTPUT:
1722 RETVAL
1723
1724SV *
1725ready (SV *self)
1726 PROTOTYPE: $
1727 CODE:
1728 RETVAL = boolSV (api_ready (self));
1729 OUTPUT:
1730 RETVAL
1731
1732int
1733nready (...)
1734 PROTOTYPE:
1735 CODE:
1736 RETVAL = coro_nready;
1737 OUTPUT:
1738 RETVAL
1739
1740# for async_pool speedup
1741void
1742_pool_1 (SV *cb)
1743 CODE:
1744{
1745 int i, len;
1746 HV *hv = (HV *)SvRV (coro_current);
1747 AV *defav = GvAV (PL_defgv);
1748 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
1749 AV *invoke_av;
1750
1751 if (!invoke)
1752 croak ("\3terminate\2\n");
1753
1754 hv_store (hv, "desc", sizeof ("desc") - 1,
1755 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
1756
1757 invoke_av = (AV *)SvRV (invoke);
1758 len = av_len (invoke_av);
1759
1760 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1761
1762 if (len > 0)
1763 {
1764 av_fill (defav, len - 1);
1765 for (i = 0; i < len; ++i)
1766 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1767 }
1768
492 SvREFCNT_dec (coro->args); 1769 SvREFCNT_dec (invoke);
493 Safefree (coro); 1770}
494 1771
1772void
1773_pool_2 (SV *cb)
1774 CODE:
1775{
1776 struct coro *coro = SvSTATE (coro_current);
495 1777
1778 sv_setsv (cb, &PL_sv_undef);
1779
1780 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1781 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1782 croak ("\3terminate\2\n");
1783
1784 av_clear (GvAV (PL_defgv));
1785 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
1786 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
1787
1788 coro->save = CORO_SAVE_DEF;
1789 coro->prio = 0;
1790
1791 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1792 api_trace (coro_current, 0);
1793
1794 av_push (av_async_pool, newSVsv (coro_current));
1795}
1796
1797
1798MODULE = Coro::State PACKAGE = Coro::AIO
1799
1800SV *
1801_get_state ()
1802 CODE:
1803{
1804 struct io_state *data;
1805
1806 RETVAL = newSV (sizeof (struct io_state));
1807 data = (struct io_state *)SvPVX (RETVAL);
1808 SvCUR_set (RETVAL, sizeof (struct io_state));
1809 SvPOK_only (RETVAL);
1810
1811 data->errorno = errno;
1812 data->laststype = PL_laststype;
1813 data->laststatval = PL_laststatval;
1814 data->statcache = PL_statcache;
1815}
1816 OUTPUT:
1817 RETVAL
1818
1819void
1820_set_state (char *data_)
1821 PROTOTYPE: $
1822 CODE:
1823{
1824 struct io_state *data = (void *)data_;
1825
1826 errno = data->errorno;
1827 PL_laststype = data->laststype;
1828 PL_laststatval = data->laststatval;
1829 PL_statcache = data->statcache;
1830}
1831

Diff Legend

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