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

Diff Legend

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