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

Diff Legend

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