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

Diff Legend

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