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

Diff Legend

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