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.194 by root, Sat Oct 6 00:08:04 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_localizing = 0;
614 PL_dirty = 0;
615 PL_restartop = 0;
616
617 GvSV (PL_defgv) = newSV (0);
618 GvAV (PL_defgv) = coro->args; coro->args = 0;
619 GvSV (PL_errgv) = newSV (0);
620 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
621 PL_rs = newSVsv (GvSV (irsgv));
622 PL_defoutgv = SvREFCNT_inc (stdoutgv);
623
624 ENTER; /* necessary e.g. for dounwind */
315 625
316 { 626 {
317 dSP; 627 dSP;
318 CV *cv; 628 LOGOP myop;
319 629
320 /* now do the ugly restore mess */ 630 Zero (&myop, 1, LOGOP);
321 while ((cv = (CV *)POPs)) 631 myop.op_next = Nullop;
322 { 632 myop.op_flags = OPf_WANT_VOID;
323 AV *padlist = (AV *)POPs;
324 633
325 put_padlist (cv); 634 PUSHMARK (SP);
326 CvPADLIST(cv) = padlist; 635 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; 636 PUTBACK;
637 PL_op = (OP *)&myop;
638 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
639 SPAGAIN;
336 } 640 }
337} 641}
338 642
339/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 643static void
340STATIC void 644coro_destroy (pTHX_ struct coro *coro)
341destroy_stacks(pTHX)
342{ 645{
343 /* die does this while calling POPSTACK, but I just don't see why. */ 646 if (!IN_DESTRUCT)
344 /* OTOH, die does not have a memleak, but we do... */ 647 {
648 /* restore all saved variables and stuff */
649 LEAVE_SCOPE (0);
650 assert (PL_tmps_floor == -1);
651
652 /* free all temporaries */
653 FREETMPS;
654 assert (PL_tmps_ix == -1);
655
656 /* unwind all extra stacks */
657 POPSTACK_TO (PL_mainstack);
658
659 /* unwind main stack */
345 dounwind(-1); 660 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 { 661 }
356 PERL_SI *p = PL_curstackinfo->si_prev;
357 662
358 SvREFCNT_dec(PL_curstackinfo->si_stack); 663 SvREFCNT_dec (GvSV (PL_defgv));
359 Safefree(PL_curstackinfo->si_cxstack); 664 SvREFCNT_dec (GvAV (PL_defgv));
360 Safefree(PL_curstackinfo); 665 SvREFCNT_dec (GvSV (PL_errgv));
361 PL_curstackinfo = p; 666 SvREFCNT_dec (PL_defoutgv);
667 SvREFCNT_dec (PL_rs);
668 SvREFCNT_dec (GvSV (irsgv));
669
670 SvREFCNT_dec (coro->saved_deffh);
671 //SvREFCNT_dec (coro->throw);
672
673 coro_destroy_stacks (aTHX);
674}
675
676static void
677free_coro_mortal (pTHX)
678{
679 if (expect_true (coro_mortal))
680 {
681 SvREFCNT_dec (coro_mortal);
682 coro_mortal = 0;
362 } 683 }
684}
363 685
364 if (PL_scopestack_ix != 0) 686static int
365 Perl_warner(aTHX_ WARN_INTERNAL, 687runops_trace (pTHX)
366 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 688{
367 (long)PL_scopestack_ix); 689 COP *oldcop = 0;
368 if (PL_savestack_ix != 0) 690 int oldcxix = -2;
369 Perl_warner(aTHX_ WARN_INTERNAL, 691 struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
370 "Unbalanced saves: %ld more saves than restores\n", 692 coro_cctx *cctx = coro->cctx;
371 (long)PL_savestack_ix); 693
372 if (PL_tmps_floor != -1) 694 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
373 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 695 {
374 (long)PL_tmps_floor + 1); 696 PERL_ASYNC_CHECK ();
697
698 if (cctx->flags & CC_TRACE_ALL)
699 {
700 if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
701 {
702 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
703 SV **bot, **top;
704 AV *av = newAV (); /* return values */
705 SV **cb;
706 dSP;
707
708 GV *gv = CvGV (cx->blk_sub.cv);
709 SV *fullname = sv_2mortal (newSV (0));
710 if (isGV (gv))
711 gv_efullname3 (fullname, gv, 0);
712
713 bot = PL_stack_base + cx->blk_oldsp + 1;
714 top = cx->blk_gimme == G_ARRAY ? SP + 1
715 : cx->blk_gimme == G_SCALAR ? bot + 1
716 : bot;
717
718 av_extend (av, top - bot);
719 while (bot < top)
720 av_push (av, SvREFCNT_inc (*bot++));
721
722 PL_runops = RUNOPS_DEFAULT;
723 ENTER;
724 SAVETMPS;
725 EXTEND (SP, 3);
726 PUSHMARK (SP);
727 PUSHs (&PL_sv_no);
728 PUSHs (fullname);
729 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
730 PUTBACK;
731 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
732 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
733 SPAGAIN;
734 FREETMPS;
735 LEAVE;
736 PL_runops = runops_trace;
737 }
738
739 if (oldcop != PL_curcop)
740 {
741 oldcop = PL_curcop;
742
743 if (PL_curcop != &PL_compiling)
744 {
745 SV **cb;
746
747 if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
748 {
749 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
750
751 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
752 {
753 runops_proc_t old_runops = PL_runops;
754 dSP;
755 GV *gv = CvGV (cx->blk_sub.cv);
756 SV *fullname = sv_2mortal (newSV (0));
757
758 if (isGV (gv))
759 gv_efullname3 (fullname, gv, 0);
760
761 PL_runops = RUNOPS_DEFAULT;
762 ENTER;
763 SAVETMPS;
764 EXTEND (SP, 3);
765 PUSHMARK (SP);
766 PUSHs (&PL_sv_yes);
767 PUSHs (fullname);
768 PUSHs (cx->blk_sub.hasargs ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
769 PUTBACK;
770 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
771 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
772 SPAGAIN;
773 FREETMPS;
774 LEAVE;
775 PL_runops = runops_trace;
776 }
777
778 oldcxix = cxstack_ix;
779 }
780
781 if (cctx->flags & CC_TRACE_LINE)
782 {
783 dSP;
784
785 PL_runops = RUNOPS_DEFAULT;
786 ENTER;
787 SAVETMPS;
788 EXTEND (SP, 3);
789 PL_runops = RUNOPS_DEFAULT;
790 PUSHMARK (SP);
791 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
792 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
793 PUTBACK;
794 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
795 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
796 SPAGAIN;
797 FREETMPS;
798 LEAVE;
799 PL_runops = runops_trace;
800 }
801 }
802 }
803 }
804 }
805
806 TAINT_NOT;
807 return 0;
808}
809
810/* inject a fake call to Coro::State::_cctx_init into the execution */
811/* _cctx_init should be careful, as it could be called at almost any time */
812/* during execution of a perl program */
813static void NOINLINE
814prepare_cctx (pTHX_ coro_cctx *cctx)
815{
816 dSP;
817 LOGOP myop;
818
819 PL_top_env = &PL_start_env;
820
821 if (cctx->flags & CC_TRACE)
822 PL_runops = runops_trace;
823
824 Zero (&myop, 1, LOGOP);
825 myop.op_next = PL_op;
826 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
827
828 PUSHMARK (SP);
829 EXTEND (SP, 2);
830 PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
831 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
832 PUTBACK;
833 PL_op = (OP *)&myop;
834 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
835 SPAGAIN;
836}
837
838/*
839 * this is a _very_ stripped down perl interpreter ;)
840 */
841static void
842coro_run (void *arg)
843{
844 dTHX;
845
846 /* coro_run is the alternative tail of transfer(), so unlock here. */
847 UNLOCK;
848
849 /* we now skip the entersub that lead to transfer() */
850 PL_op = PL_op->op_next;
851
852 /* inject a fake subroutine call to cctx_init */
853 prepare_cctx (aTHX_ (coro_cctx *)arg);
854
855 /* somebody or something will hit me for both perl_run and PL_restartop */
856 PL_restartop = PL_op;
857 perl_run (PL_curinterp);
858
375 /* 859 /*
376 */ 860 * If perl-run returns we assume exit() was being called or the coro
377 Safefree(PL_tmps_stack); 861 * fell off the end, which seems to be the only valid (non-bug)
378 Safefree(PL_markstack); 862 * reason for perl_run to return. We try to exit by jumping to the
379 Safefree(PL_scopestack); 863 * bootstrap-time "top" top_env, as we cannot restore the "main"
380 Safefree(PL_savestack); 864 * coroutine as Coro has no such concept
381 Safefree(PL_retstack); 865 */
866 PL_top_env = main_top_env;
867 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
382} 868}
383 869
384#define SUB_INIT "Coro::State::_newcoro" 870static coro_cctx *
871cctx_new ()
872{
873 coro_cctx *cctx;
874 void *stack_start;
875 size_t stack_size;
385 876
877 ++cctx_count;
878
879 Newz (0, cctx, 1, coro_cctx);
880
881#if HAVE_MMAP
882
883 cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
884 /* mmap supposedly does allocate-on-write for us */
885 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
886
887 if (cctx->sptr != (void *)-1)
888 {
889# if CORO_STACKGUARD
890 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
891# endif
892 stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
893 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
894 cctx->flags |= CC_MAPPED;
895 }
896 else
897#endif
898 {
899 cctx->ssize = coro_stacksize * (long)sizeof (long);
900 New (0, cctx->sptr, coro_stacksize, long);
901
902 if (!cctx->sptr)
903 {
904 perror ("FATAL: unable to allocate stack for coroutine");
905 _exit (EXIT_FAILURE);
906 }
907
908 stack_start = cctx->sptr;
909 stack_size = cctx->ssize;
910 }
911
912 REGISTER_STACK (cctx, (char *)stack_start, (char *)stack_start + stack_size);
913 coro_create (&cctx->cctx, coro_run, (void *)cctx, stack_start, stack_size);
914
915 return cctx;
916}
917
918static void
919cctx_destroy (coro_cctx *cctx)
920{
921 if (!cctx)
922 return;
923
924 --cctx_count;
925
926#if CORO_USE_VALGRIND
927 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
928#endif
929
930#if HAVE_MMAP
931 if (cctx->flags & CC_MAPPED)
932 munmap (cctx->sptr, cctx->ssize);
933 else
934#endif
935 Safefree (cctx->sptr);
936
937 Safefree (cctx);
938}
939
940/* wether this cctx should be destructed */
941#define CCTX_EXPIRED(cctx) ((cctx)->ssize < coro_stacksize || ((cctx)->flags & CC_NOREUSE))
942
943static coro_cctx *
944cctx_get (pTHX)
945{
946 while (expect_true (cctx_first))
947 {
948 coro_cctx *cctx = cctx_first;
949 cctx_first = cctx->next;
950 --cctx_idle;
951
952 if (expect_true (!CCTX_EXPIRED (cctx)))
953 return cctx;
954
955 cctx_destroy (cctx);
956 }
957
958 return cctx_new ();
959}
960
961static void
962cctx_put (coro_cctx *cctx)
963{
964 /* free another cctx if overlimit */
965 if (expect_false (cctx_idle >= MAX_IDLE_CCTX))
966 {
967 coro_cctx *first = cctx_first;
968 cctx_first = first->next;
969 --cctx_idle;
970
971 cctx_destroy (first);
972 }
973
974 ++cctx_idle;
975 cctx->next = cctx_first;
976 cctx_first = cctx;
977}
978
979/** coroutine switching *****************************************************/
980
981static void
982transfer_check (pTHX_ struct coro *prev, struct coro *next)
983{
984 if (expect_true (prev != next))
985 {
986 if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
987 croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
988
989 if (expect_false (next->flags & CF_RUNNING))
990 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
991
992 if (expect_false (next->flags & CF_DESTROYED))
993 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
994
995 if (expect_false (PL_lex_state != LEX_NOTPARSING))
996 croak ("Coro::State::transfer called while parsing, but this is not supported");
997 }
998}
999
1000/* always use the TRANSFER macro */
1001static void NOINLINE
1002transfer (pTHX_ struct coro *prev, struct coro *next)
1003{
1004 dSTACKLEVEL;
1005
1006 /* sometimes transfer is only called to set idle_sp */
1007 if (expect_false (!next))
1008 {
1009 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
1010 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1011 }
1012 else if (expect_true (prev != next))
1013 {
1014 coro_cctx *prev__cctx;
1015
1016 if (expect_false (prev->flags & CF_NEW))
1017 {
1018 /* create a new empty context */
1019 Newz (0, prev->cctx, 1, coro_cctx);
1020 prev->flags &= ~CF_NEW;
1021 prev->flags |= CF_RUNNING;
1022 }
1023
1024 prev->flags &= ~CF_RUNNING;
1025 next->flags |= CF_RUNNING;
1026
1027 LOCK;
1028
1029 if (expect_false (next->flags & CF_NEW))
1030 {
1031 /* need to start coroutine */
1032 next->flags &= ~CF_NEW;
1033 /* first get rid of the old state */
1034 save_perl (aTHX_ prev);
1035 /* setup coroutine call */
1036 coro_setup (aTHX_ next);
1037 }
1038 else
1039 {
1040 /* coroutine already started */
1041 save_perl (aTHX_ prev);
1042 load_perl (aTHX_ next);
1043 }
1044
1045 prev__cctx = prev->cctx;
1046
1047 /* possibly "free" the cctx */
1048 if (expect_true (prev__cctx->idle_sp == STACKLEVEL && !(prev__cctx->flags & CC_TRACE)))
1049 {
1050 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
1051 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
1052
1053 prev->cctx = 0;
1054
1055 /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
1056 /* without this the next cctx_get might destroy the prev__cctx while still in use */
1057 if (expect_false (CCTX_EXPIRED (prev__cctx)))
1058 next->cctx = cctx_get (aTHX);
1059
1060 cctx_put (prev__cctx);
1061 }
1062
1063 ++next->usecount;
1064
1065 if (expect_true (!next->cctx))
1066 next->cctx = cctx_get (aTHX);
1067
1068 if (expect_false (prev__cctx != next->cctx))
1069 {
1070 prev__cctx->top_env = PL_top_env;
1071 PL_top_env = next->cctx->top_env;
1072 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
1073 }
1074
1075 free_coro_mortal (aTHX);
1076 UNLOCK;
1077 }
1078}
1079
1080struct transfer_args
1081{
1082 struct coro *prev, *next;
1083};
1084
1085#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next)
1086#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1087
1088/** high level stuff ********************************************************/
1089
1090static int
1091coro_state_destroy (pTHX_ struct coro *coro)
1092{
1093 if (coro->flags & CF_DESTROYED)
1094 return 0;
1095
1096 coro->flags |= CF_DESTROYED;
1097
1098 if (coro->flags & CF_READY)
1099 {
1100 /* reduce nready, as destroying a ready coro effectively unreadies it */
1101 /* alternative: look through all ready queues and remove the coro */
1102 LOCK;
1103 --coro_nready;
1104 UNLOCK;
1105 }
1106 else
1107 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1108
1109 if (coro->mainstack && coro->mainstack != main_mainstack)
1110 {
1111 struct coro temp;
1112
1113 if (coro->flags & CF_RUNNING)
1114 croak ("FATAL: tried to destroy currently running coroutine");
1115
1116 save_perl (aTHX_ &temp);
1117 load_perl (aTHX_ coro);
1118
1119 coro_destroy (aTHX_ coro);
1120
1121 load_perl (aTHX_ &temp); /* this will get rid of defsv etc.. */
1122
1123 coro->mainstack = 0;
1124 }
1125
1126 cctx_destroy (coro->cctx);
1127 SvREFCNT_dec (coro->args);
1128
1129 if (coro->next) coro->next->prev = coro->prev;
1130 if (coro->prev) coro->prev->next = coro->next;
1131 if (coro == coro_first) coro_first = coro->next;
1132
1133 return 1;
1134}
1135
1136static int
1137coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1138{
1139 struct coro *coro = (struct coro *)mg->mg_ptr;
1140 mg->mg_ptr = 0;
1141
1142 coro->hv = 0;
1143
1144 if (--coro->refcnt < 0)
1145 {
1146 coro_state_destroy (aTHX_ coro);
1147 Safefree (coro);
1148 }
1149
1150 return 0;
1151}
1152
1153static int
1154coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1155{
1156 struct coro *coro = (struct coro *)mg->mg_ptr;
1157
1158 ++coro->refcnt;
1159
1160 return 0;
1161}
1162
1163static MGVTBL coro_state_vtbl = {
1164 0, 0, 0, 0,
1165 coro_state_free,
1166 0,
1167#ifdef MGf_DUP
1168 coro_state_dup,
1169#else
1170# define MGf_DUP 0
1171#endif
1172};
1173
1174static void
1175prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
1176{
1177 ta->prev = SvSTATE (prev_sv);
1178 ta->next = SvSTATE (next_sv);
1179 TRANSFER_CHECK (*ta);
1180}
1181
1182static void
1183api_transfer (SV *prev_sv, SV *next_sv)
1184{
1185 dTHX;
1186 struct transfer_args ta;
1187
1188 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1189 TRANSFER (ta);
1190}
1191
1192/** Coro ********************************************************************/
1193
1194static void
1195coro_enq (pTHX_ SV *coro_sv)
1196{
1197 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1198}
1199
1200static SV *
1201coro_deq (pTHX_ int min_prio)
1202{
1203 int prio = PRIO_MAX - PRIO_MIN;
1204
1205 min_prio -= PRIO_MIN;
1206 if (min_prio < 0)
1207 min_prio = 0;
1208
1209 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
1210 if (AvFILLp (coro_ready [prio]) >= 0)
1211 return av_shift (coro_ready [prio]);
1212
1213 return 0;
1214}
1215
1216static int
1217api_ready (SV *coro_sv)
1218{
1219 dTHX;
1220 struct coro *coro;
1221
1222 if (SvROK (coro_sv))
1223 coro_sv = SvRV (coro_sv);
1224
1225 coro = SvSTATE (coro_sv);
1226
1227 if (coro->flags & CF_READY)
1228 return 0;
1229
1230 coro->flags |= CF_READY;
1231
1232 LOCK;
1233 coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
1234 ++coro_nready;
1235 UNLOCK;
1236
1237 return 1;
1238}
1239
1240static int
1241api_is_ready (SV *coro_sv)
1242{
1243 dTHX;
1244 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1245}
1246
1247static void
1248prepare_schedule (pTHX_ struct transfer_args *ta)
1249{
1250 SV *prev_sv, *next_sv;
1251
1252 for (;;)
1253 {
1254 LOCK;
1255 next_sv = coro_deq (aTHX_ PRIO_MIN);
1256
1257 /* nothing to schedule: call the idle handler */
1258 if (expect_false (!next_sv))
1259 {
1260 dSP;
1261 UNLOCK;
1262
1263 ENTER;
1264 SAVETMPS;
1265
1266 PUSHMARK (SP);
1267 PUTBACK;
1268 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1269
1270 FREETMPS;
1271 LEAVE;
1272 continue;
1273 }
1274
1275 ta->next = SvSTATE (next_sv);
1276
1277 /* cannot transfer to destroyed coros, skip and look for next */
1278 if (expect_false (ta->next->flags & CF_DESTROYED))
1279 {
1280 UNLOCK;
1281 SvREFCNT_dec (next_sv);
1282 /* coro_nready is already taken care of by destroy */
1283 continue;
1284 }
1285
1286 --coro_nready;
1287 UNLOCK;
1288 break;
1289 }
1290
1291 /* free this only after the transfer */
1292 prev_sv = SvRV (coro_current);
1293 ta->prev = SvSTATE (prev_sv);
1294 TRANSFER_CHECK (*ta);
1295 assert (ta->next->flags & CF_READY);
1296 ta->next->flags &= ~CF_READY;
1297 SvRV_set (coro_current, next_sv);
1298
1299 LOCK;
1300 free_coro_mortal (aTHX);
1301 coro_mortal = prev_sv;
1302 UNLOCK;
1303}
1304
1305static void
1306prepare_cede (pTHX_ struct transfer_args *ta)
1307{
1308 api_ready (coro_current);
1309 prepare_schedule (aTHX_ ta);
1310}
1311
1312static int
1313prepare_cede_notself (pTHX_ struct transfer_args *ta)
1314{
1315 if (coro_nready)
1316 {
1317 SV *prev = SvRV (coro_current);
1318 prepare_schedule (aTHX_ ta);
1319 api_ready (prev);
1320 return 1;
1321 }
1322 else
1323 return 0;
1324}
1325
1326static void
1327api_schedule (void)
1328{
1329 dTHX;
1330 struct transfer_args ta;
1331
1332 prepare_schedule (aTHX_ &ta);
1333 TRANSFER (ta);
1334}
1335
1336static int
1337api_cede (void)
1338{
1339 dTHX;
1340 struct transfer_args ta;
1341
1342 prepare_cede (aTHX_ &ta);
1343
1344 if (expect_true (ta.prev != ta.next))
1345 {
1346 TRANSFER (ta);
1347 return 1;
1348 }
1349 else
1350 return 0;
1351}
1352
1353static int
1354api_cede_notself (void)
1355{
1356 dTHX;
1357 struct transfer_args ta;
1358
1359 if (prepare_cede_notself (aTHX_ &ta))
1360 {
1361 TRANSFER (ta);
1362 return 1;
1363 }
1364 else
1365 return 0;
1366}
1367
1368static void
1369api_trace (SV *coro_sv, int flags)
1370{
1371 dTHX;
1372 struct coro *coro = SvSTATE (coro_sv);
1373
1374 if (flags & CC_TRACE)
1375 {
1376 if (!coro->cctx)
1377 coro->cctx = cctx_new ();
1378 else if (!(coro->cctx->flags & CC_TRACE))
1379 croak ("cannot enable tracing on coroutine with custom stack");
1380
1381 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1382 }
1383 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1384 {
1385 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1386
1387 if (coro->flags & CF_RUNNING)
1388 PL_runops = RUNOPS_DEFAULT;
1389 else
1390 coro->runops = RUNOPS_DEFAULT;
1391 }
1392}
1393
386MODULE = Coro::State PACKAGE = Coro::State 1394MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
387 1395
388PROTOTYPES: ENABLE 1396PROTOTYPES: DISABLE
389 1397
390BOOT: 1398BOOT:
391 if (!padlist_cache) 1399{
392 padlist_cache = newHV (); 1400#ifdef USE_ITHREADS
1401 MUTEX_INIT (&coro_mutex);
1402#endif
1403 BOOT_PAGESIZE;
393 1404
394Coro::State 1405 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
395_newprocess(args) 1406 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
396 SV * args 1407
397 PROTOTYPE: $ 1408 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1409
1410 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1411 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1412 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1413 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1414
1415 main_mainstack = PL_mainstack;
1416 main_top_env = PL_top_env;
1417
1418 while (main_top_env->je_prev)
1419 main_top_env = main_top_env->je_prev;
1420
1421 coroapi.ver = CORO_API_VERSION;
1422 coroapi.transfer = api_transfer;
1423
1424 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1425}
1426
1427SV *
1428new (char *klass, ...)
398 CODE: 1429 CODE:
399 Coro__State coro; 1430{
1431 struct coro *coro;
1432 HV *hv;
1433 int i;
400 1434
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); 1435 Newz (0, coro, 1, struct coro);
1436 coro->args = newAV ();
1437 coro->flags = CF_NEW;
405 1438
406 coro->mainstack = 0; /* actual work is done inside transfer */ 1439 if (coro_first) coro_first->prev = coro;
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1440 coro->next = coro_first;
1441 coro_first = coro;
408 1442
409 RETVAL = coro; 1443 coro->hv = hv = newHV ();
1444 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1445 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1446
1447 av_extend (coro->args, items - 1);
1448 for (i = 1; i < items; i++)
1449 av_push (coro->args, newSVsv (ST (i)));
1450}
410 OUTPUT: 1451 OUTPUT:
411 RETVAL 1452 RETVAL
412 1453
1454# these not obviously related functions are all rolled into the same xs
1455# function to increase chances that they all will call transfer with the same
1456# stack offset
413void 1457void
414transfer(prev,next) 1458_set_stacklevel (...)
415 Coro::State_or_hashref prev 1459 ALIAS:
416 Coro::State_or_hashref next 1460 Coro::State::transfer = 1
1461 Coro::schedule = 2
1462 Coro::cede = 3
1463 Coro::cede_notself = 4
417 CODE: 1464 CODE:
1465{
1466 struct transfer_args ta;
418 1467
419 if (prev != next) 1468 switch (ix)
420 { 1469 {
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 1470 case 0:
1471 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1472 ta.next = 0;
440 { 1473 break;
441 SAVE (prev);
442 1474
443 /* 1475 case 1:
444 * emulate part of the perl startup here. 1476 if (items != 2)
445 */ 1477 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446 UNOP myop;
447 1478
448 init_stacks (); /* from perl.c */ 1479 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 } 1480 break;
1481
1482 case 2:
1483 prepare_schedule (aTHX_ &ta);
1484 break;
1485
1486 case 3:
1487 prepare_cede (aTHX_ &ta);
1488 break;
1489
1490 case 4:
1491 if (!prepare_cede_notself (aTHX_ &ta))
1492 XSRETURN_EMPTY;
1493
1494 break;
472 } 1495 }
473 1496
1497 BARRIER;
1498 TRANSFER (ta);
1499
1500 if (expect_false (GIMME_V != G_VOID && ta.next != ta.prev))
1501 XSRETURN_YES;
1502}
1503
1504bool
1505_destroy (SV *coro_sv)
1506 CODE:
1507 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1508 OUTPUT:
1509 RETVAL
1510
474void 1511void
475DESTROY(coro) 1512_exit (code)
476 Coro::State coro 1513 int code
477 CODE: 1514 PROTOTYPE: $
1515 CODE:
1516 _exit (code);
478 1517
1518int
1519cctx_stacksize (int new_stacksize = 0)
1520 CODE:
1521 RETVAL = coro_stacksize;
1522 if (new_stacksize)
1523 coro_stacksize = new_stacksize;
1524 OUTPUT:
1525 RETVAL
1526
1527int
1528cctx_count ()
1529 CODE:
1530 RETVAL = cctx_count;
1531 OUTPUT:
1532 RETVAL
1533
1534int
1535cctx_idle ()
1536 CODE:
1537 RETVAL = cctx_idle;
1538 OUTPUT:
1539 RETVAL
1540
1541void
1542list ()
1543 PPCODE:
1544{
1545 struct coro *coro;
1546 for (coro = coro_first; coro; coro = coro->next)
1547 if (coro->hv)
1548 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1549}
1550
1551void
1552call (Coro::State coro, SV *coderef)
1553 ALIAS:
1554 eval = 1
1555 CODE:
1556{
479 if (coro->mainstack) 1557 if (coro->mainstack)
480 { 1558 {
481 struct coro temp; 1559 struct coro temp;
1560 Zero (&temp, 1, struct coro);
482 1561
483 SAVE(aTHX_ (&temp)); 1562 if (!(coro->flags & CF_RUNNING))
484 LOAD(aTHX_ coro); 1563 {
1564 save_perl (aTHX_ &temp);
1565 load_perl (aTHX_ coro);
1566 }
485 1567
486 destroy_stacks (); 1568 {
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 1569 dSP;
1570 ENTER;
1571 SAVETMPS;
1572 PUSHMARK (SP);
1573 PUTBACK;
1574 if (ix)
1575 eval_sv (coderef, 0);
1576 else
1577 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1578 SPAGAIN;
1579 FREETMPS;
1580 LEAVE;
1581 PUTBACK;
1582 }
488 1583
489 LOAD((&temp)); 1584 if (!(coro->flags & CF_RUNNING))
1585 {
1586 save_perl (aTHX_ coro);
1587 load_perl (aTHX_ &temp);
1588 }
490 } 1589 }
1590}
491 1591
1592SV *
1593is_ready (Coro::State coro)
1594 PROTOTYPE: $
1595 ALIAS:
1596 is_ready = CF_READY
1597 is_running = CF_RUNNING
1598 is_new = CF_NEW
1599 is_destroyed = CF_DESTROYED
1600 CODE:
1601 RETVAL = boolSV (coro->flags & ix);
1602 OUTPUT:
1603 RETVAL
1604
1605void
1606api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1607
1608SV *
1609has_stack (Coro::State coro)
1610 PROTOTYPE: $
1611 CODE:
1612 RETVAL = boolSV (!!coro->cctx);
1613 OUTPUT:
1614 RETVAL
1615
1616int
1617is_traced (Coro::State coro)
1618 PROTOTYPE: $
1619 CODE:
1620 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1621 OUTPUT:
1622 RETVAL
1623
1624IV
1625rss (Coro::State coro)
1626 PROTOTYPE: $
1627 ALIAS:
1628 usecount = 1
1629 CODE:
1630 switch (ix)
1631 {
1632 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1633 case 1: RETVAL = coro->usecount; break;
1634 }
1635 OUTPUT:
1636 RETVAL
1637
1638
1639MODULE = Coro::State PACKAGE = Coro
1640
1641BOOT:
1642{
1643 int i;
1644
1645 sv_pool_rss = get_sv ("Coro::POOL_RSS" , TRUE);
1646 sv_pool_size = get_sv ("Coro::POOL_SIZE" , TRUE);
1647 av_async_pool = get_av ("Coro::async_pool", TRUE);
1648
1649 coro_current = get_sv ("Coro::current", FALSE);
1650 SvREADONLY_on (coro_current);
1651
1652 coro_stash = gv_stashpv ("Coro", TRUE);
1653
1654 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1655 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1656 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1657 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1658 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1659 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1660
1661 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1662 coro_ready[i] = newAV ();
1663
1664 {
1665 SV *sv = perl_get_sv("Coro::API", 1);
1666
1667 coroapi.schedule = api_schedule;
1668 coroapi.cede = api_cede;
1669 coroapi.cede_notself = api_cede_notself;
1670 coroapi.ready = api_ready;
1671 coroapi.is_ready = api_is_ready;
1672 coroapi.nready = &coro_nready;
1673 coroapi.current = coro_current;
1674
1675 GCoroAPI = &coroapi;
1676 sv_setiv (sv, (IV)&coroapi);
1677 SvREADONLY_on (sv);
1678 }
1679}
1680
1681void
1682_set_current (SV *current)
1683 PROTOTYPE: $
1684 CODE:
1685 SvREFCNT_dec (SvRV (coro_current));
1686 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1687
1688int
1689prio (Coro::State coro, int newprio = 0)
1690 ALIAS:
1691 nice = 1
1692 CODE:
1693{
1694 RETVAL = coro->prio;
1695
1696 if (items > 1)
1697 {
1698 if (ix)
1699 newprio = coro->prio - newprio;
1700
1701 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1702 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1703
1704 coro->prio = newprio;
1705 }
1706}
1707 OUTPUT:
1708 RETVAL
1709
1710SV *
1711ready (SV *self)
1712 PROTOTYPE: $
1713 CODE:
1714 RETVAL = boolSV (api_ready (self));
1715 OUTPUT:
1716 RETVAL
1717
1718int
1719nready (...)
1720 PROTOTYPE:
1721 CODE:
1722 RETVAL = coro_nready;
1723 OUTPUT:
1724 RETVAL
1725
1726# for async_pool speedup
1727void
1728_pool_1 (SV *cb)
1729 CODE:
1730{
1731 struct coro *coro = SvSTATE (coro_current);
1732 HV *hv = (HV *)SvRV (coro_current);
1733 AV *defav = GvAV (PL_defgv);
1734 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
1735 AV *invoke_av;
1736 int i, len;
1737
1738 if (!invoke)
1739 croak ("\3terminate\2\n");
1740
492 SvREFCNT_dec (coro->args); 1741 SvREFCNT_dec (coro->saved_deffh);
493 Safefree (coro); 1742 coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
494 1743
1744 hv_store (hv, "desc", sizeof ("desc") - 1,
1745 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
495 1746
1747 invoke_av = (AV *)SvRV (invoke);
1748 len = av_len (invoke_av);
1749
1750 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1751
1752 if (len > 0)
1753 {
1754 av_fill (defav, len - 1);
1755 for (i = 0; i < len; ++i)
1756 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1757 }
1758
1759 SvREFCNT_dec (invoke);
1760}
1761
1762void
1763_pool_2 (SV *cb)
1764 CODE:
1765{
1766 struct coro *coro = SvSTATE (coro_current);
1767
1768 sv_setsv (cb, &PL_sv_undef);
1769
1770 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1771 coro->saved_deffh = 0;
1772
1773 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1774 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1775 croak ("\3terminate\2\n");
1776
1777 av_clear (GvAV (PL_defgv));
1778 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
1779 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
1780
1781 coro->prio = 0;
1782
1783 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1784 api_trace (coro_current, 0);
1785
1786 av_push (av_async_pool, newSVsv (coro_current));
1787}
1788
1789
1790MODULE = Coro::State PACKAGE = Coro::AIO
1791
1792SV *
1793_get_state ()
1794 CODE:
1795{
1796 struct io_state *data;
1797
1798 RETVAL = newSV (sizeof (struct io_state));
1799 data = (struct io_state *)SvPVX (RETVAL);
1800 SvCUR_set (RETVAL, sizeof (struct io_state));
1801 SvPOK_only (RETVAL);
1802
1803 data->errorno = errno;
1804 data->laststype = PL_laststype;
1805 data->laststatval = PL_laststatval;
1806 data->statcache = PL_statcache;
1807}
1808 OUTPUT:
1809 RETVAL
1810
1811void
1812_set_state (char *data_)
1813 PROTOTYPE: $
1814 CODE:
1815{
1816 struct io_state *data = (void *)data_;
1817
1818 errno = data->errorno;
1819 PL_laststype = data->laststype;
1820 PL_laststatval = data->laststatval;
1821 PL_statcache = data->statcache;
1822}
1823

Diff Legend

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