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

Diff Legend

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