ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro/Coro/State.xs
(Generate patch)

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.204 by root, Mon Oct 8 03:03:39 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
162/* the next tow functions merely cache the padlists */
163STATIC void
164get_padlist (CV *cv)
165{
166 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
167
168 if (he && AvFILLp ((AV *)*he) >= 0)
169 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
170 else
171 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172}
173
174STATIC void
175put_padlist (CV *cv)
176{
177 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
178
179 if (SvTYPE (*he) != SVt_PVAV)
180 {
181 SvREFCNT_dec (*he);
182 *he = (SV *)newAV ();
183 }
184
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186}
187
188static void 477static void
189SAVE(pTHX_ Coro__State c) 478save_perl (pTHX_ Coro__State c)
190{ 479{
191 { 480 {
192 dSP; 481 dSP;
193 I32 cxix = cxstack_ix; 482 I32 cxix = cxstack_ix;
483 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 484 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 485
197 /* 486 /*
198 * the worst thing you can imagine happens first - we have to save 487 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 488 * (and reinitialize) all cv's in the whole callchain :(
200 */ 489 */
201 490
202 PUSHs (Nullsv); 491 XPUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 492 /* this loop was inspired by pp_caller */
204 for (;;) 493 for (;;)
205 { 494 {
206 while (cxix >= 0) 495 while (expect_true (cxix >= 0))
207 { 496 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 497 PERL_CONTEXT *cx = &ccstk[cxix--];
209 498
210 if (CxTYPE(cx) == CXt_SUB) 499 if (expect_true (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT))
211 { 500 {
212 CV *cv = cx->blk_sub.cv; 501 CV *cv = cx->blk_sub.cv;
502
213 if (CvDEPTH(cv)) 503 if (expect_true (CvDEPTH (cv)))
214 { 504 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3); 505 EXTEND (SP, 3);
219 PUSHs ((SV *)CvDEPTH(cv));
220 PUSHs ((SV *)CvPADLIST(cv)); 506 PUSHs ((SV *)CvPADLIST (cv));
507 PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
221 PUSHs ((SV *)cv); 508 PUSHs ((SV *)cv);
222 509
223 get_padlist (cv);
224
225 CvDEPTH(cv) = 0; 510 CvDEPTH (cv) = 0;
226#ifdef USE_THREADS 511 get_padlist (aTHX_ cv);
227 CvOWNER(cv) = 0;
228 error must unlock this cv etc.. etc...
229 if you are here wondering about this error message then
230 the reason is that it will not work as advertised yet
231#endif
232 } 512 }
233 } 513 }
234 else if (CxTYPE(cx) == CXt_FORMAT)
235 {
236 /* I never used formats, so how should I know how these are implemented? */
237 /* my bold guess is as a simple, plain sub... */
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239 }
240 } 514 }
241 515
242 if (top_si->si_type == PERLSI_MAIN) 516 if (expect_true (top_si->si_type == PERLSI_MAIN))
243 break; 517 break;
244 518
245 top_si = top_si->si_prev; 519 top_si = top_si->si_prev;
246 ccstk = top_si->si_cxstack; 520 ccstk = top_si->si_cxstack;
247 cxix = top_si->si_cxix; 521 cxix = top_si->si_cxix;
248 } 522 }
249 523
250 PUTBACK; 524 PUTBACK;
251 } 525 }
252 526
253 c->dowarn = PL_dowarn; 527 /* allocate some space on the context stack for our purposes */
254 c->defav = GvAV (PL_defgv); 528 /* we manually unroll here, as usually 2 slots is enough */
255 c->curstackinfo = PL_curstackinfo; 529 if (SLOT_COUNT >= 1) CXINC;
256 c->curstack = PL_curstack; 530 if (SLOT_COUNT >= 2) CXINC;
531 if (SLOT_COUNT >= 3) CXINC;
532 {
533 int i;
534 for (i = 3; i < SLOT_COUNT; ++i)
535 CXINC;
536 }
537 cxstack_ix -= SLOT_COUNT; /* undo allocation */
538
257 c->mainstack = PL_mainstack; 539 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp; 540
259 c->op = PL_op; 541 {
260 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);
261 c->stack_base = PL_stack_base; 573 PL_stack_sp = PL_stack_base;
262 c->stack_max = PL_stack_max; 574 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 575
282static void 576 New(50,PL_tmps_stack,32,SV*);
283LOAD(pTHX_ Coro__State c) 577 PL_tmps_floor = -1;
284{ 578 PL_tmps_ix = -1;
285 PL_dowarn = c->dowarn; 579 PL_tmps_max = 32;
286 GvAV (PL_defgv) = c->defav; 580
287 PL_curstackinfo = c->curstackinfo; 581 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; 582 PL_markstack_ptr = PL_markstack;
301 PL_markstack_max = c->markstack_max; 583 PL_markstack_max = PL_markstack + 16;
302 PL_scopestack = c->scopestack; 584
303 PL_scopestack_ix = c->scopestack_ix; 585#ifdef SET_MARK_OFFSET
304 PL_scopestack_max = c->scopestack_max; 586 SET_MARK_OFFSET;
305 PL_savestack = c->savestack; 587#endif
306 PL_savestack_ix = c->savestack_ix; 588
307 PL_savestack_max = c->savestack_max; 589 New(54,PL_scopestack,8,I32);
308 PL_retstack = c->retstack; 590 PL_scopestack_ix = 0;
309 PL_retstack_ix = c->retstack_ix; 591 PL_scopestack_max = 8;
310 PL_retstack_max = c->retstack_max; 592
311 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);
312 700
313 { 701 {
314 dSP; 702 dSP;
315 CV *cv; 703 LOGOP myop;
316 704
317 /* now do the ugly restore mess */ 705 Zero (&myop, 1, LOGOP);
318 while ((cv = (CV *)POPs)) 706 myop.op_next = Nullop;
319 { 707 myop.op_flags = OPf_WANT_VOID;
320 AV *padlist = (AV *)POPs;
321 708
322 put_padlist (cv); 709 PUSHMARK (SP);
323 CvPADLIST(cv) = padlist; 710 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; 711 PUTBACK;
712 PL_op = (OP *)&myop;
713 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
714 SPAGAIN;
333 } 715 }
334}
335 716
336/* 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 */
337STATIC void 718}
719
720static void
721coro_destroy (pTHX_ struct coro *coro)
722{
723 if (!IN_DESTRUCT)
724 {
725 /* restore all saved variables and stuff */
726 LEAVE_SCOPE (0);
727 assert (PL_tmps_floor == -1);
728
729 /* free all temporaries */
730 FREETMPS;
731 assert (PL_tmps_ix == -1);
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
338destroy_stacks(pTHX) 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)
339{ 895{
340 dSP; 896 dSP;
897 LOGOP myop;
341 898
342 /* die does this while calling POPSTACK, but I just don't see why. */ 899 PL_top_env = &PL_start_env;
343 dounwind(-1);
344 900
345 /* is this ugly, I ask? */ 901 if (cctx->flags & CC_TRACE)
346 while (PL_scopestack_ix) 902 PL_runops = runops_trace;
347 LEAVE;
348 903
349 while (PL_curstackinfo->si_next) 904 Zero (&myop, 1, LOGOP);
350 PL_curstackinfo = PL_curstackinfo->si_next; 905 myop.op_next = PL_op;
906 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
351 907
352 while (PL_curstackinfo) 908 PUSHMARK (SP);
353 { 909 EXTEND (SP, 2);
354 PERL_SI *p = PL_curstackinfo->si_prev; 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}
355 917
356 SvREFCNT_dec(PL_curstackinfo->si_stack); 918/*
357 Safefree(PL_curstackinfo->si_cxstack); 919 * this is a _very_ stripped down perl interpreter ;)
358 Safefree(PL_curstackinfo); 920 */
359 PL_curstackinfo = p; 921static void
360 } 922cctx_run (void *arg)
923{
924 dTHX;
361 925
362 if (PL_scopestack_ix != 0) 926 /* cctx_run is the alternative tail of transfer(), so unlock here. */
363 Perl_warner(aTHX_ WARN_INTERNAL, 927 UNLOCK;
364 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 928
365 (long)PL_scopestack_ix); 929 /* we now skip the entersub that lead to transfer() */
366 if (PL_savestack_ix != 0) 930 PL_op = PL_op->op_next;
367 Perl_warner(aTHX_ WARN_INTERNAL, 931
368 "Unbalanced saves: %ld more saves than restores\n", 932 /* inject a fake subroutine call to cctx_init */
369 (long)PL_savestack_ix); 933 cctx_prepare (aTHX_ (coro_cctx *)arg);
370 if (PL_tmps_floor != -1) 934
371 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", 935 /* somebody or something will hit me for both perl_run and PL_restartop */
372 (long)PL_tmps_floor + 1); 936 PL_restartop = PL_op;
937 perl_run (PL_curinterp);
938
373 /* 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)
374 */ 1169 {
375 Safefree(PL_tmps_stack); 1170 SV *exception = coro->throw;
376 Safefree(PL_markstack); 1171 coro->throw = 0;
377 Safefree(PL_scopestack); 1172 sv_setsv (ERRSV, exception);
378 Safefree(PL_savestack); 1173 croak (0);
379 Safefree(PL_retstack); 1174 }
1175 }
1176 }
380} 1177}
381 1178
382#define SUB_INIT "Coro::State::_newcoro" 1179struct transfer_args
1180{
1181 struct coro *prev, *next;
1182};
383 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
384MODULE = Coro::State PACKAGE = Coro::State 1493MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
385 1494
386PROTOTYPES: ENABLE 1495PROTOTYPES: DISABLE
387 1496
388BOOT: 1497BOOT:
389 if (!padlist_cache) 1498{
390 padlist_cache = newHV (); 1499#ifdef USE_ITHREADS
1500 MUTEX_INIT (&coro_mutex);
1501#endif
1502 BOOT_PAGESIZE;
391 1503
392Coro::State 1504 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
393_newprocess(args) 1505 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
394 SV * args 1506
395 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, ...)
396 CODE: 1535 CODE:
397 Coro__State coro; 1536{
1537 struct coro *coro;
1538 HV *hv;
1539 int i;
398 1540
399 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
400 croak ("Coro::State::newprocess expects an arrayref");
401
402 New (0, coro, 1, struct coro); 1541 Newz (0, coro, 1, struct coro);
1542 coro->args = newAV ();
1543 coro->flags = CF_NEW;
403 1544
404 coro->mainstack = 0; /* actual work is done inside transfer */ 1545 if (coro_first) coro_first->prev = coro;
405 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1546 coro->next = coro_first;
1547 coro_first = coro;
406 1548
407 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}
408 OUTPUT: 1557 OUTPUT:
409 RETVAL 1558 RETVAL
410 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
411void 1563void
412transfer(prev,next) 1564_set_stacklevel (...)
413 Coro::State_or_hashref prev 1565 ALIAS:
414 Coro::State_or_hashref next 1566 Coro::State::transfer = 1
1567 Coro::schedule = 2
1568 Coro::cede = 3
1569 Coro::cede_notself = 4
415 CODE: 1570 CODE:
1571{
1572 struct transfer_args ta;
416 1573
417 if (prev != next) 1574 switch (ix)
418 { 1575 {
419 PUTBACK;
420 SAVE (aTHX_ prev);
421
422 /*
423 * this could be done in newprocess which would lead to
424 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425 * code here, but lazy allocation of stacks has also
426 * some virtues and the overhead of the if() is nil.
427 */
428 if (next->mainstack)
429 {
430 LOAD (aTHX_ next);
431 next->mainstack = 0; /* unnecessary but much cleaner */
432 SPAGAIN;
433 }
434 else 1576 case 0:
1577 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1578 ta.next = 0;
435 { 1579 break;
436 /*
437 * emulate part of the perl startup here.
438 */
439 UNOP myop;
440 1580
441 init_stacks (); /* from perl.c */ 1581 case 1:
442 PL_op = (OP *)&myop; 1582 if (items != 2)
443 /*PL_curcop = 0;*/ 1583 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
444 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445 1584
446 SPAGAIN; 1585 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
447 Zero(&myop, 1, UNOP);
448 myop.op_next = Nullop;
449 myop.op_flags = OPf_WANT_VOID;
450
451 PUSHMARK(SP);
452 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453 PUTBACK;
454 /*
455 * the next line is slightly wrong, as PL_op->op_next
456 * is actually being executed so we skip the first op.
457 * that doesn't matter, though, since it is only
458 * pp_nextstate and we never return...
459 */
460 PL_op = Perl_pp_entersub(aTHX);
461 SPAGAIN;
462
463 ENTER;
464 } 1586 break;
1587
1588 case 2:
1589 prepare_schedule (aTHX_ &ta);
1590 break;
1591
1592 case 3:
1593 prepare_cede (aTHX_ &ta);
1594 break;
1595
1596 case 4:
1597 if (!prepare_cede_notself (aTHX_ &ta))
1598 XSRETURN_EMPTY;
1599
1600 break;
465 } 1601 }
466 1602
1603 BARRIER;
1604 TRANSFER (ta);
1605
1606 if (expect_false (GIMME_V != G_VOID && ta.next != ta.prev))
1607 XSRETURN_YES;
1608}
1609
1610bool
1611_destroy (SV *coro_sv)
1612 CODE:
1613 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1614 OUTPUT:
1615 RETVAL
1616
467void 1617void
468DESTROY(coro) 1618_exit (code)
469 Coro::State coro 1619 int code
470 CODE: 1620 PROTOTYPE: $
1621 CODE:
1622 _exit (code);
471 1623
1624int
1625cctx_stacksize (int new_stacksize = 0)
1626 CODE:
1627 RETVAL = coro_stacksize;
1628 if (new_stacksize)
1629 coro_stacksize = new_stacksize;
1630 OUTPUT:
1631 RETVAL
1632
1633int
1634cctx_count ()
1635 CODE:
1636 RETVAL = cctx_count;
1637 OUTPUT:
1638 RETVAL
1639
1640int
1641cctx_idle ()
1642 CODE:
1643 RETVAL = cctx_idle;
1644 OUTPUT:
1645 RETVAL
1646
1647void
1648list ()
1649 PPCODE:
1650{
1651 struct coro *coro;
1652 for (coro = coro_first; coro; coro = coro->next)
1653 if (coro->hv)
1654 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1655}
1656
1657void
1658call (Coro::State coro, SV *coderef)
1659 ALIAS:
1660 eval = 1
1661 CODE:
1662{
472 if (coro->mainstack) 1663 if (coro->mainstack)
473 { 1664 {
474 struct coro temp; 1665 struct coro temp;
475 1666
1667 if (!(coro->flags & CF_RUNNING))
1668 {
1669 save_perl (aTHX_ &temp);
1670 load_perl (aTHX_ coro);
1671 }
1672
1673 {
1674 dSP;
1675 ENTER;
1676 SAVETMPS;
1677 PUSHMARK (SP);
476 PUTBACK; 1678 PUTBACK;
477 SAVE(aTHX_ (&temp));
478 LOAD(aTHX_ coro);
479 1679
480 destroy_stacks (); 1680 if (ix)
481 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 1681 eval_sv (coderef, 0);
1682 else
1683 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
482 1684
483 LOAD((&temp));
484 SPAGAIN; 1685 SPAGAIN;
1686 FREETMPS;
1687 LEAVE;
1688 PUTBACK;
1689 }
1690
1691 if (!(coro->flags & CF_RUNNING))
1692 {
1693 save_perl (aTHX_ coro);
1694 load_perl (aTHX_ &temp);
1695 }
485 } 1696 }
1697}
486 1698
1699SV *
1700is_ready (Coro::State coro)
1701 PROTOTYPE: $
1702 ALIAS:
1703 is_ready = CF_READY
1704 is_running = CF_RUNNING
1705 is_new = CF_NEW
1706 is_destroyed = CF_DESTROYED
1707 CODE:
1708 RETVAL = boolSV (coro->flags & ix);
1709 OUTPUT:
1710 RETVAL
1711
1712void
1713api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1714
1715SV *
1716has_stack (Coro::State coro)
1717 PROTOTYPE: $
1718 CODE:
1719 RETVAL = boolSV (!!coro->cctx);
1720 OUTPUT:
1721 RETVAL
1722
1723int
1724is_traced (Coro::State coro)
1725 PROTOTYPE: $
1726 CODE:
1727 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1728 OUTPUT:
1729 RETVAL
1730
1731IV
1732rss (Coro::State coro)
1733 PROTOTYPE: $
1734 ALIAS:
1735 usecount = 1
1736 CODE:
1737 switch (ix)
1738 {
1739 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1740 case 1: RETVAL = coro->usecount; break;
1741 }
1742 OUTPUT:
1743 RETVAL
1744
1745
1746MODULE = Coro::State PACKAGE = Coro
1747
1748BOOT:
1749{
1750 int i;
1751
1752 sv_pool_rss = coro_get_sv ("Coro::POOL_RSS" , TRUE);
1753 sv_pool_size = coro_get_sv ("Coro::POOL_SIZE" , TRUE);
1754 av_async_pool = coro_get_av ("Coro::async_pool", TRUE);
1755
1756 coro_current = coro_get_sv ("Coro::current", FALSE);
1757 SvREADONLY_on (coro_current);
1758
1759 coro_stash = gv_stashpv ("Coro", TRUE);
1760
1761 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1762 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1763 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1764 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1765 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1766 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1767
1768 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1769 coro_ready[i] = newAV ();
1770
1771 {
1772 SV *sv = perl_get_sv ("Coro::API", TRUE);
1773 perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
1774
1775 coroapi.schedule = api_schedule;
1776 coroapi.cede = api_cede;
1777 coroapi.cede_notself = api_cede_notself;
1778 coroapi.ready = api_ready;
1779 coroapi.is_ready = api_is_ready;
1780 coroapi.nready = &coro_nready;
1781 coroapi.current = coro_current;
1782
1783 GCoroAPI = &coroapi;
1784 sv_setiv (sv, (IV)&coroapi);
1785 SvREADONLY_on (sv);
1786 }
1787}
1788
1789void
1790_set_current (SV *current)
1791 PROTOTYPE: $
1792 CODE:
1793 SvREFCNT_dec (SvRV (coro_current));
1794 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1795
1796int
1797prio (Coro::State coro, int newprio = 0)
1798 ALIAS:
1799 nice = 1
1800 CODE:
1801{
1802 RETVAL = coro->prio;
1803
1804 if (items > 1)
1805 {
1806 if (ix)
1807 newprio = coro->prio - newprio;
1808
1809 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1810 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1811
1812 coro->prio = newprio;
1813 }
1814}
1815 OUTPUT:
1816 RETVAL
1817
1818SV *
1819ready (SV *self)
1820 PROTOTYPE: $
1821 CODE:
1822 RETVAL = boolSV (api_ready (self));
1823 OUTPUT:
1824 RETVAL
1825
1826int
1827nready (...)
1828 PROTOTYPE:
1829 CODE:
1830 RETVAL = coro_nready;
1831 OUTPUT:
1832 RETVAL
1833
1834void
1835throw (Coro::State self, SV *throw = &PL_sv_undef)
1836 PROTOTYPE: $;$
1837 CODE:
1838 SvREFCNT_dec (self->throw);
1839 self->throw = SvOK (throw) ? newSVsv (throw) : 0;
1840
1841# for async_pool speedup
1842void
1843_pool_1 (SV *cb)
1844 CODE:
1845{
1846 struct coro *coro = SvSTATE (coro_current);
1847 HV *hv = (HV *)SvRV (coro_current);
1848 AV *defav = GvAV (PL_defgv);
1849 SV *invoke = hv_delete (hv, strpair ("_invoke"), 0);
1850 AV *invoke_av;
1851 int i, len;
1852
1853 if (!invoke)
1854 croak ("\3async_pool terminate\2\n");
1855
487 SvREFCNT_dec (coro->args); 1856 SvREFCNT_dec (coro->saved_deffh);
488 Safefree (coro); 1857 coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
489 1858
1859 hv_store (hv, "desc", sizeof ("desc") - 1,
1860 newSVpvn (strpair ("[async_pool]")), 0);
490 1861
1862 invoke_av = (AV *)SvRV (invoke);
1863 len = av_len (invoke_av);
1864
1865 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1866
1867 if (len > 0)
1868 {
1869 av_fill (defav, len - 1);
1870 for (i = 0; i < len; ++i)
1871 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1872 }
1873
1874 SvREFCNT_dec (invoke);
1875}
1876
1877void
1878_pool_2 (SV *cb)
1879 CODE:
1880{
1881 struct coro *coro = SvSTATE (coro_current);
1882
1883 sv_setsv (cb, &PL_sv_undef);
1884
1885 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1886 coro->saved_deffh = 0;
1887
1888 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1889 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1890 croak ("\3async_pool terminate\2\n");
1891
1892 av_clear (GvAV (PL_defgv));
1893 hv_store ((HV *)SvRV (coro_current), strpair ("desc"),
1894 newSVpvn (strpair ("[async_pool idle]")), 0);
1895
1896 coro->prio = 0;
1897
1898 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1899 api_trace (coro_current, 0);
1900
1901 av_push (av_async_pool, newSVsv (coro_current));
1902}
1903
1904
1905MODULE = Coro::State PACKAGE = Coro::AIO
1906
1907SV *
1908_get_state ()
1909 CODE:
1910{
1911 struct io_state *data;
1912
1913 RETVAL = newSV (sizeof (struct io_state));
1914 data = (struct io_state *)SvPVX (RETVAL);
1915 SvCUR_set (RETVAL, sizeof (struct io_state));
1916 SvPOK_only (RETVAL);
1917
1918 data->errorno = errno;
1919 data->laststype = PL_laststype;
1920 data->laststatval = PL_laststatval;
1921 data->statcache = PL_statcache;
1922}
1923 OUTPUT:
1924 RETVAL
1925
1926void
1927_set_state (char *data_)
1928 PROTOTYPE: $
1929 CODE:
1930{
1931 struct io_state *data = (void *)data_;
1932
1933 errno = data->errorno;
1934 PL_laststype = data->laststype;
1935 PL_laststatval = data->laststatval;
1936 PL_statcache = data->statcache;
1937}
1938

Diff Legend

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