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

Diff Legend

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