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

Diff Legend

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