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

Diff Legend

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