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.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.202 by root, Mon Oct 8 02:50:23 2007 UTC

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

Diff Legend

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