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

Diff Legend

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