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.216 by root, Wed Nov 14 10:24:14 2007 UTC

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

Diff Legend

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