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.196 by root, Sat Oct 6 01:11:01 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 = 0;
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 = (GV *)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 /*
861 * If perl-run returns we assume exit() was being called or the coro
862 * fell off the end, which seems to be the only valid (non-bug)
863 * reason for perl_run to return. We try to exit by jumping to the
864 * bootstrap-time "top" top_env, as we cannot restore the "main"
865 * coroutine as Coro has no such concept
866 */
867 PL_top_env = main_top_env;
868 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
869}
870
871static coro_cctx *
872cctx_new ()
873{
874 coro_cctx *cctx;
875 void *stack_start;
876 size_t stack_size;
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 if (expect_false (prev->throw || next->throw))
1080 {
1081 struct coro *coro = SvSTATE (coro_current);
1082
1083 if (coro->throw)
376 */ 1084 {
377 Safefree(PL_tmps_stack); 1085 SV *exception = coro->throw;
378 Safefree(PL_markstack); 1086 coro->throw = 0;
379 Safefree(PL_scopestack); 1087 sv_setsv (ERRSV, exception);
380 Safefree(PL_savestack); 1088 croak (0);
381 Safefree(PL_retstack); 1089 }
1090 }
1091 }
382} 1092}
383 1093
384#define SUB_INIT "Coro::State::_newcoro" 1094struct transfer_args
1095{
1096 struct coro *prev, *next;
1097};
385 1098
1099#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next)
1100#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1101
1102/** high level stuff ********************************************************/
1103
1104static int
1105coro_state_destroy (pTHX_ struct coro *coro)
1106{
1107 if (coro->flags & CF_DESTROYED)
1108 return 0;
1109
1110 coro->flags |= CF_DESTROYED;
1111
1112 if (coro->flags & CF_READY)
1113 {
1114 /* reduce nready, as destroying a ready coro effectively unreadies it */
1115 /* alternative: look through all ready queues and remove the coro */
1116 LOCK;
1117 --coro_nready;
1118 UNLOCK;
1119 }
1120 else
1121 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1122
1123 if (coro->mainstack && coro->mainstack != main_mainstack)
1124 {
1125 struct coro temp;
1126
1127 if (coro->flags & CF_RUNNING)
1128 croak ("FATAL: tried to destroy currently running coroutine");
1129
1130 save_perl (aTHX_ &temp);
1131 load_perl (aTHX_ coro);
1132
1133 coro_destroy (aTHX_ coro);
1134
1135 load_perl (aTHX_ &temp); /* this will get rid of defsv etc.. */
1136
1137 coro->mainstack = 0;
1138 }
1139
1140 cctx_destroy (coro->cctx);
1141 SvREFCNT_dec (coro->args);
1142
1143 if (coro->next) coro->next->prev = coro->prev;
1144 if (coro->prev) coro->prev->next = coro->next;
1145 if (coro == coro_first) coro_first = coro->next;
1146
1147 return 1;
1148}
1149
1150static int
1151coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1152{
1153 struct coro *coro = (struct coro *)mg->mg_ptr;
1154 mg->mg_ptr = 0;
1155
1156 coro->hv = 0;
1157
1158 if (--coro->refcnt < 0)
1159 {
1160 coro_state_destroy (aTHX_ coro);
1161 Safefree (coro);
1162 }
1163
1164 return 0;
1165}
1166
1167static int
1168coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1169{
1170 struct coro *coro = (struct coro *)mg->mg_ptr;
1171
1172 ++coro->refcnt;
1173
1174 return 0;
1175}
1176
1177static MGVTBL coro_state_vtbl = {
1178 0, 0, 0, 0,
1179 coro_state_free,
1180 0,
1181#ifdef MGf_DUP
1182 coro_state_dup,
1183#else
1184# define MGf_DUP 0
1185#endif
1186};
1187
1188static void
1189prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
1190{
1191 ta->prev = SvSTATE (prev_sv);
1192 ta->next = SvSTATE (next_sv);
1193 TRANSFER_CHECK (*ta);
1194}
1195
1196static void
1197api_transfer (SV *prev_sv, SV *next_sv)
1198{
1199 dTHX;
1200 struct transfer_args ta;
1201
1202 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1203 TRANSFER (ta);
1204}
1205
1206/** Coro ********************************************************************/
1207
1208static void
1209coro_enq (pTHX_ SV *coro_sv)
1210{
1211 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1212}
1213
1214static SV *
1215coro_deq (pTHX_ int min_prio)
1216{
1217 int prio = PRIO_MAX - PRIO_MIN;
1218
1219 min_prio -= PRIO_MIN;
1220 if (min_prio < 0)
1221 min_prio = 0;
1222
1223 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
1224 if (AvFILLp (coro_ready [prio]) >= 0)
1225 return av_shift (coro_ready [prio]);
1226
1227 return 0;
1228}
1229
1230static int
1231api_ready (SV *coro_sv)
1232{
1233 dTHX;
1234 struct coro *coro;
1235
1236 if (SvROK (coro_sv))
1237 coro_sv = SvRV (coro_sv);
1238
1239 coro = SvSTATE (coro_sv);
1240
1241 if (coro->flags & CF_READY)
1242 return 0;
1243
1244 coro->flags |= CF_READY;
1245
1246 LOCK;
1247 coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
1248 ++coro_nready;
1249 UNLOCK;
1250
1251 return 1;
1252}
1253
1254static int
1255api_is_ready (SV *coro_sv)
1256{
1257 dTHX;
1258 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1259}
1260
1261static void
1262prepare_schedule (pTHX_ struct transfer_args *ta)
1263{
1264 SV *prev_sv, *next_sv;
1265
1266 for (;;)
1267 {
1268 LOCK;
1269 next_sv = coro_deq (aTHX_ PRIO_MIN);
1270
1271 /* nothing to schedule: call the idle handler */
1272 if (expect_false (!next_sv))
1273 {
1274 dSP;
1275 UNLOCK;
1276
1277 ENTER;
1278 SAVETMPS;
1279
1280 PUSHMARK (SP);
1281 PUTBACK;
1282 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1283
1284 FREETMPS;
1285 LEAVE;
1286 continue;
1287 }
1288
1289 ta->next = SvSTATE (next_sv);
1290
1291 /* cannot transfer to destroyed coros, skip and look for next */
1292 if (expect_false (ta->next->flags & CF_DESTROYED))
1293 {
1294 UNLOCK;
1295 SvREFCNT_dec (next_sv);
1296 /* coro_nready is already taken care of by destroy */
1297 continue;
1298 }
1299
1300 --coro_nready;
1301 UNLOCK;
1302 break;
1303 }
1304
1305 /* free this only after the transfer */
1306 prev_sv = SvRV (coro_current);
1307 ta->prev = SvSTATE (prev_sv);
1308 TRANSFER_CHECK (*ta);
1309 assert (ta->next->flags & CF_READY);
1310 ta->next->flags &= ~CF_READY;
1311 SvRV_set (coro_current, next_sv);
1312
1313 LOCK;
1314 free_coro_mortal (aTHX);
1315 coro_mortal = prev_sv;
1316 UNLOCK;
1317}
1318
1319static void
1320prepare_cede (pTHX_ struct transfer_args *ta)
1321{
1322 api_ready (coro_current);
1323 prepare_schedule (aTHX_ ta);
1324}
1325
1326static int
1327prepare_cede_notself (pTHX_ struct transfer_args *ta)
1328{
1329 if (coro_nready)
1330 {
1331 SV *prev = SvRV (coro_current);
1332 prepare_schedule (aTHX_ ta);
1333 api_ready (prev);
1334 return 1;
1335 }
1336 else
1337 return 0;
1338}
1339
1340static void
1341api_schedule (void)
1342{
1343 dTHX;
1344 struct transfer_args ta;
1345
1346 prepare_schedule (aTHX_ &ta);
1347 TRANSFER (ta);
1348}
1349
1350static int
1351api_cede (void)
1352{
1353 dTHX;
1354 struct transfer_args ta;
1355
1356 prepare_cede (aTHX_ &ta);
1357
1358 if (expect_true (ta.prev != ta.next))
1359 {
1360 TRANSFER (ta);
1361 return 1;
1362 }
1363 else
1364 return 0;
1365}
1366
1367static int
1368api_cede_notself (void)
1369{
1370 dTHX;
1371 struct transfer_args ta;
1372
1373 if (prepare_cede_notself (aTHX_ &ta))
1374 {
1375 TRANSFER (ta);
1376 return 1;
1377 }
1378 else
1379 return 0;
1380}
1381
1382static void
1383api_trace (SV *coro_sv, int flags)
1384{
1385 dTHX;
1386 struct coro *coro = SvSTATE (coro_sv);
1387
1388 if (flags & CC_TRACE)
1389 {
1390 if (!coro->cctx)
1391 coro->cctx = cctx_new ();
1392 else if (!(coro->cctx->flags & CC_TRACE))
1393 croak ("cannot enable tracing on coroutine with custom stack");
1394
1395 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1396 }
1397 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1398 {
1399 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1400
1401 if (coro->flags & CF_RUNNING)
1402 PL_runops = RUNOPS_DEFAULT;
1403 else
1404 coro->runops = RUNOPS_DEFAULT;
1405 }
1406}
1407
386MODULE = Coro::State PACKAGE = Coro::State 1408MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
387 1409
388PROTOTYPES: ENABLE 1410PROTOTYPES: DISABLE
389 1411
390BOOT: 1412BOOT:
391 if (!padlist_cache) 1413{
392 padlist_cache = newHV (); 1414#ifdef USE_ITHREADS
1415 MUTEX_INIT (&coro_mutex);
1416#endif
1417 BOOT_PAGESIZE;
393 1418
394Coro::State 1419 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
395_newprocess(args) 1420 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
396 SV * args 1421
397 PROTOTYPE: $ 1422 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1423
1424 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1425 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1426 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1427 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1428
1429 main_mainstack = PL_mainstack;
1430 main_top_env = PL_top_env;
1431
1432 while (main_top_env->je_prev)
1433 main_top_env = main_top_env->je_prev;
1434
1435 coroapi.ver = CORO_API_VERSION;
1436 coroapi.transfer = api_transfer;
1437
1438 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1439}
1440
1441SV *
1442new (char *klass, ...)
398 CODE: 1443 CODE:
399 Coro__State coro; 1444{
1445 struct coro *coro;
1446 HV *hv;
1447 int i;
400 1448
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); 1449 Newz (0, coro, 1, struct coro);
1450 coro->args = newAV ();
1451 coro->flags = CF_NEW;
405 1452
406 coro->mainstack = 0; /* actual work is done inside transfer */ 1453 if (coro_first) coro_first->prev = coro;
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1454 coro->next = coro_first;
1455 coro_first = coro;
408 1456
409 RETVAL = coro; 1457 coro->hv = hv = newHV ();
1458 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1459 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1460
1461 av_extend (coro->args, items - 1);
1462 for (i = 1; i < items; i++)
1463 av_push (coro->args, newSVsv (ST (i)));
1464}
410 OUTPUT: 1465 OUTPUT:
411 RETVAL 1466 RETVAL
412 1467
1468# these not obviously related functions are all rolled into the same xs
1469# function to increase chances that they all will call transfer with the same
1470# stack offset
413void 1471void
414transfer(prev,next) 1472_set_stacklevel (...)
415 Coro::State_or_hashref prev 1473 ALIAS:
416 Coro::State_or_hashref next 1474 Coro::State::transfer = 1
1475 Coro::schedule = 2
1476 Coro::cede = 3
1477 Coro::cede_notself = 4
417 CODE: 1478 CODE:
1479{
1480 struct transfer_args ta;
418 1481
419 if (prev != next) 1482 switch (ix)
420 { 1483 {
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 1484 case 0:
1485 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1486 ta.next = 0;
440 { 1487 break;
441 SAVE (prev);
442 1488
443 /* 1489 case 1:
444 * emulate part of the perl startup here. 1490 if (items != 2)
445 */ 1491 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446 UNOP myop;
447 1492
448 init_stacks (); /* from perl.c */ 1493 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 } 1494 break;
1495
1496 case 2:
1497 prepare_schedule (aTHX_ &ta);
1498 break;
1499
1500 case 3:
1501 prepare_cede (aTHX_ &ta);
1502 break;
1503
1504 case 4:
1505 if (!prepare_cede_notself (aTHX_ &ta))
1506 XSRETURN_EMPTY;
1507
1508 break;
472 } 1509 }
473 1510
1511 BARRIER;
1512 TRANSFER (ta);
1513
1514 if (expect_false (GIMME_V != G_VOID && ta.next != ta.prev))
1515 XSRETURN_YES;
1516}
1517
1518bool
1519_destroy (SV *coro_sv)
1520 CODE:
1521 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1522 OUTPUT:
1523 RETVAL
1524
474void 1525void
475DESTROY(coro) 1526_exit (code)
476 Coro::State coro 1527 int code
477 CODE: 1528 PROTOTYPE: $
1529 CODE:
1530 _exit (code);
478 1531
1532int
1533cctx_stacksize (int new_stacksize = 0)
1534 CODE:
1535 RETVAL = coro_stacksize;
1536 if (new_stacksize)
1537 coro_stacksize = new_stacksize;
1538 OUTPUT:
1539 RETVAL
1540
1541int
1542cctx_count ()
1543 CODE:
1544 RETVAL = cctx_count;
1545 OUTPUT:
1546 RETVAL
1547
1548int
1549cctx_idle ()
1550 CODE:
1551 RETVAL = cctx_idle;
1552 OUTPUT:
1553 RETVAL
1554
1555void
1556list ()
1557 PPCODE:
1558{
1559 struct coro *coro;
1560 for (coro = coro_first; coro; coro = coro->next)
1561 if (coro->hv)
1562 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1563}
1564
1565void
1566call (Coro::State coro, SV *coderef)
1567 ALIAS:
1568 eval = 1
1569 CODE:
1570{
479 if (coro->mainstack) 1571 if (coro->mainstack)
480 { 1572 {
481 struct coro temp; 1573 struct coro temp;
1574 Zero (&temp, 1, struct coro);
482 1575
483 SAVE(aTHX_ (&temp)); 1576 if (!(coro->flags & CF_RUNNING))
484 LOAD(aTHX_ coro); 1577 {
1578 save_perl (aTHX_ &temp);
1579 load_perl (aTHX_ coro);
1580 }
485 1581
486 destroy_stacks (); 1582 {
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 1583 dSP;
1584 ENTER;
1585 SAVETMPS;
1586 PUSHMARK (SP);
1587 PUTBACK;
1588 if (ix)
1589 eval_sv (coderef, 0);
1590 else
1591 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1592 SPAGAIN;
1593 FREETMPS;
1594 LEAVE;
1595 PUTBACK;
1596 }
488 1597
489 LOAD((&temp)); 1598 if (!(coro->flags & CF_RUNNING))
1599 {
1600 save_perl (aTHX_ coro);
1601 load_perl (aTHX_ &temp);
1602 }
490 } 1603 }
1604}
491 1605
1606SV *
1607is_ready (Coro::State coro)
1608 PROTOTYPE: $
1609 ALIAS:
1610 is_ready = CF_READY
1611 is_running = CF_RUNNING
1612 is_new = CF_NEW
1613 is_destroyed = CF_DESTROYED
1614 CODE:
1615 RETVAL = boolSV (coro->flags & ix);
1616 OUTPUT:
1617 RETVAL
1618
1619void
1620api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1621
1622SV *
1623has_stack (Coro::State coro)
1624 PROTOTYPE: $
1625 CODE:
1626 RETVAL = boolSV (!!coro->cctx);
1627 OUTPUT:
1628 RETVAL
1629
1630int
1631is_traced (Coro::State coro)
1632 PROTOTYPE: $
1633 CODE:
1634 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1635 OUTPUT:
1636 RETVAL
1637
1638IV
1639rss (Coro::State coro)
1640 PROTOTYPE: $
1641 ALIAS:
1642 usecount = 1
1643 CODE:
1644 switch (ix)
1645 {
1646 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1647 case 1: RETVAL = coro->usecount; break;
1648 }
1649 OUTPUT:
1650 RETVAL
1651
1652
1653MODULE = Coro::State PACKAGE = Coro
1654
1655BOOT:
1656{
1657 int i;
1658
1659 sv_pool_rss = get_sv ("Coro::POOL_RSS" , TRUE);
1660 sv_pool_size = get_sv ("Coro::POOL_SIZE" , TRUE);
1661 av_async_pool = get_av ("Coro::async_pool", TRUE);
1662
1663 coro_current = get_sv ("Coro::current", FALSE);
1664 SvREADONLY_on (coro_current);
1665
1666 coro_stash = gv_stashpv ("Coro", TRUE);
1667
1668 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1669 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1670 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1671 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1672 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1673 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1674
1675 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1676 coro_ready[i] = newAV ();
1677
1678 {
1679 SV *sv = perl_get_sv("Coro::API", 1);
1680
1681 coroapi.schedule = api_schedule;
1682 coroapi.cede = api_cede;
1683 coroapi.cede_notself = api_cede_notself;
1684 coroapi.ready = api_ready;
1685 coroapi.is_ready = api_is_ready;
1686 coroapi.nready = &coro_nready;
1687 coroapi.current = coro_current;
1688
1689 GCoroAPI = &coroapi;
1690 sv_setiv (sv, (IV)&coroapi);
1691 SvREADONLY_on (sv);
1692 }
1693}
1694
1695void
1696_set_current (SV *current)
1697 PROTOTYPE: $
1698 CODE:
1699 SvREFCNT_dec (SvRV (coro_current));
1700 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1701
1702int
1703prio (Coro::State coro, int newprio = 0)
1704 ALIAS:
1705 nice = 1
1706 CODE:
1707{
1708 RETVAL = coro->prio;
1709
1710 if (items > 1)
1711 {
1712 if (ix)
1713 newprio = coro->prio - newprio;
1714
1715 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1716 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1717
1718 coro->prio = newprio;
1719 }
1720}
1721 OUTPUT:
1722 RETVAL
1723
1724SV *
1725ready (SV *self)
1726 PROTOTYPE: $
1727 CODE:
1728 RETVAL = boolSV (api_ready (self));
1729 OUTPUT:
1730 RETVAL
1731
1732int
1733nready (...)
1734 PROTOTYPE:
1735 CODE:
1736 RETVAL = coro_nready;
1737 OUTPUT:
1738 RETVAL
1739
1740void
1741throw (Coro::State self, SV *throw = &PL_sv_undef)
1742 PROTOTYPE: $;$
1743 CODE:
1744 SvREFCNT_dec (self->throw);
1745 self->throw = SvOK (throw) ? newSVsv (throw) : 0;
1746
1747# for async_pool speedup
1748void
1749_pool_1 (SV *cb)
1750 CODE:
1751{
1752 struct coro *coro = SvSTATE (coro_current);
1753 HV *hv = (HV *)SvRV (coro_current);
1754 AV *defav = GvAV (PL_defgv);
1755 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
1756 AV *invoke_av;
1757 int i, len;
1758
1759 if (!invoke)
1760 croak ("\3terminate\2\n");
1761
492 SvREFCNT_dec (coro->args); 1762 SvREFCNT_dec (coro->saved_deffh);
493 Safefree (coro); 1763 coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
494 1764
1765 hv_store (hv, "desc", sizeof ("desc") - 1,
1766 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
495 1767
1768 invoke_av = (AV *)SvRV (invoke);
1769 len = av_len (invoke_av);
1770
1771 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1772
1773 if (len > 0)
1774 {
1775 av_fill (defav, len - 1);
1776 for (i = 0; i < len; ++i)
1777 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1778 }
1779
1780 SvREFCNT_dec (invoke);
1781}
1782
1783void
1784_pool_2 (SV *cb)
1785 CODE:
1786{
1787 struct coro *coro = SvSTATE (coro_current);
1788
1789 sv_setsv (cb, &PL_sv_undef);
1790
1791 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1792 coro->saved_deffh = 0;
1793
1794 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1795 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1796 croak ("\3terminate\2\n");
1797
1798 av_clear (GvAV (PL_defgv));
1799 hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
1800 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
1801
1802 coro->prio = 0;
1803
1804 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1805 api_trace (coro_current, 0);
1806
1807 av_push (av_async_pool, newSVsv (coro_current));
1808}
1809
1810
1811MODULE = Coro::State PACKAGE = Coro::AIO
1812
1813SV *
1814_get_state ()
1815 CODE:
1816{
1817 struct io_state *data;
1818
1819 RETVAL = newSV (sizeof (struct io_state));
1820 data = (struct io_state *)SvPVX (RETVAL);
1821 SvCUR_set (RETVAL, sizeof (struct io_state));
1822 SvPOK_only (RETVAL);
1823
1824 data->errorno = errno;
1825 data->laststype = PL_laststype;
1826 data->laststatval = PL_laststatval;
1827 data->statcache = PL_statcache;
1828}
1829 OUTPUT:
1830 RETVAL
1831
1832void
1833_set_state (char *data_)
1834 PROTOTYPE: $
1835 CODE:
1836{
1837 struct io_state *data = (void *)data_;
1838
1839 errno = data->errorno;
1840 PL_laststype = data->laststype;
1841 PL_laststatval = data->laststatval;
1842 PL_statcache = data->statcache;
1843}
1844

Diff Legend

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