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.205 by root, Tue Oct 9 14:07:02 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 fprintf (stderr, "bp1\n");//D
959
960 Newz (0, cctx, 1, coro_cctx);
961
962#if HAVE_MMAP
963 cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
964 /* mmap supposedly does allocate-on-write for us */
965 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
966
967 if (cctx->sptr != (void *)-1)
968 {
969# if CORO_STACKGUARD
970 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
971# endif
972 stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
973 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
974 cctx->flags |= CC_MAPPED;
975 }
976 else
977#endif
978 {
979 cctx->ssize = coro_stacksize * (long)sizeof (long);
980 New (0, cctx->sptr, coro_stacksize, long);
981
982 if (!cctx->sptr)
983 {
984 perror ("FATAL: unable to allocate stack for coroutine");
985 _exit (EXIT_FAILURE);
986 }
987
988 stack_start = cctx->sptr;
989 stack_size = cctx->ssize;
990 }
991
992 REGISTER_STACK (cctx, (char *)stack_start, (char *)stack_start + stack_size);
993 coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
994
995 return cctx;
996}
997
998static void
999cctx_destroy (coro_cctx *cctx)
1000{
1001 if (!cctx)
1002 return;
1003
1004 --cctx_count;
1005
1006#if CORO_USE_VALGRIND
1007 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1008#endif
1009
1010#if HAVE_MMAP
1011 if (cctx->flags & CC_MAPPED)
1012 munmap (cctx->sptr, cctx->ssize);
1013 else
1014#endif
1015 Safefree (cctx->sptr);
1016
1017 Safefree (cctx);
1018}
1019
1020/* wether this cctx should be destructed */
1021#define CCTX_EXPIRED(cctx) ((cctx)->ssize < coro_stacksize || ((cctx)->flags & CC_NOREUSE))
1022
1023static coro_cctx *
1024cctx_get (pTHX)
1025{
1026 while (expect_true (cctx_first))
1027 {
1028 coro_cctx *cctx = cctx_first;
1029 cctx_first = cctx->next;
1030 --cctx_idle;
1031
1032 if (expect_true (!CCTX_EXPIRED (cctx)))
1033 return cctx;
1034
1035 cctx_destroy (cctx);
1036 }
1037
1038 return cctx_new ();
1039}
1040
1041static void
1042cctx_put (coro_cctx *cctx)
1043{
1044 /* free another cctx if overlimit */
1045 if (expect_false (cctx_idle >= MAX_IDLE_CCTX))
1046 {
1047 coro_cctx *first = cctx_first;
1048 cctx_first = first->next;
1049 --cctx_idle;
1050
1051 cctx_destroy (first);
1052 }
1053
1054 ++cctx_idle;
1055 cctx->next = cctx_first;
1056 cctx_first = cctx;
1057}
1058
1059/** coroutine switching *****************************************************/
1060
1061static void
1062transfer_check (pTHX_ struct coro *prev, struct coro *next)
1063{
1064 if (expect_true (prev != next))
1065 {
1066 if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1067 croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
1068
1069 if (expect_false (next->flags & CF_RUNNING))
1070 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
1071
1072 if (expect_false (next->flags & CF_DESTROYED))
1073 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
1074
1075 if (
1076#if PERL_VERSION_ATLEAST (5,9,0)
1077 expect_false (PL_parser)
1078#else
1079 expect_false (PL_lex_state != LEX_NOTPARSING)
1080#endif
1081 )
1082 croak ("Coro::State::transfer called while parsing, but this is not supported");
1083 }
1084}
1085
1086/* always use the TRANSFER macro */
1087static void NOINLINE
1088transfer (pTHX_ struct coro *prev, struct coro *next)
1089{
1090 dSTACKLEVEL;
1091
1092 /* sometimes transfer is only called to set idle_sp */
1093 if (expect_false (!next))
1094 {
1095 ((coro_cctx *)prev)->idle_sp = STACKLEVEL;
1096 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1097 }
1098 else if (expect_true (prev != next))
1099 {
1100 coro_cctx *prev__cctx;
1101
1102 if (expect_false (prev->flags & CF_NEW))
1103 {
1104 /* create a new empty context */
1105 Newz (0, prev->cctx, 1, coro_cctx);
1106 prev->flags &= ~CF_NEW;
1107 prev->flags |= CF_RUNNING;
1108 }
1109
1110 prev->flags &= ~CF_RUNNING;
1111 next->flags |= CF_RUNNING;
1112
1113 LOCK;
1114
1115 if (expect_false (next->flags & CF_NEW))
1116 {
1117 /* need to start coroutine */
1118 next->flags &= ~CF_NEW;
1119 /* first get rid of the old state */
1120 save_perl (aTHX_ prev);
1121 /* setup coroutine call */
1122 coro_setup (aTHX_ next);
1123 }
1124 else
1125 {
1126 /* coroutine already started */
1127 save_perl (aTHX_ prev);
1128 load_perl (aTHX_ next);
1129 }
1130
1131 prev__cctx = prev->cctx;
1132
1133 /* possibly "free" the cctx */
1134 if (expect_true (prev__cctx->idle_sp == STACKLEVEL && !(prev__cctx->flags & CC_TRACE)))
1135 {
1136 /* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
1137 assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
1138
1139 prev->cctx = 0;
1140
1141 /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
1142 /* without this the next cctx_get might destroy the prev__cctx while still in use */
1143 if (expect_false (CCTX_EXPIRED (prev__cctx)))
1144 if (!next->cctx)
1145 next->cctx = cctx_get (aTHX);
1146
1147 cctx_put (prev__cctx);
1148 }
1149
1150 ++next->usecount;
1151
1152 if (expect_true (!next->cctx))
1153 next->cctx = cctx_get (aTHX);
1154
1155 if (expect_false (prev__cctx != next->cctx))
1156 {
1157 prev__cctx->top_env = PL_top_env;
1158 PL_top_env = next->cctx->top_env;
1159 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
1160 }
1161
1162 free_coro_mortal (aTHX);
1163 UNLOCK;
1164
1165 if (expect_false (prev->throw || next->throw))
1166 {
1167 struct coro *coro = SvSTATE (coro_current);
1168
1169 if (coro->throw)
1170 {
1171 SV *exception = coro->throw;
1172 coro->throw = 0;
1173 sv_setsv (ERRSV, exception);
1174 croak (0);
1175 }
1176 }
1177 }
1178}
1179
1180struct transfer_args
1181{
1182 struct coro *prev, *next;
1183};
1184
1185#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next)
1186#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1187
1188/** high level stuff ********************************************************/
1189
1190static int
1191coro_state_destroy (pTHX_ struct coro *coro)
1192{
1193 if (coro->flags & CF_DESTROYED)
1194 return 0;
1195
1196 coro->flags |= CF_DESTROYED;
1197
1198 if (coro->flags & CF_READY)
1199 {
1200 /* reduce nready, as destroying a ready coro effectively unreadies it */
1201 /* alternative: look through all ready queues and remove the coro */
1202 LOCK;
1203 --coro_nready;
1204 UNLOCK;
1205 }
1206 else
1207 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1208
1209 if (coro->mainstack && coro->mainstack != main_mainstack)
1210 {
1211 struct coro temp;
1212
1213 if (coro->flags & CF_RUNNING)
1214 croak ("FATAL: tried to destroy currently running coroutine");
1215
1216 save_perl (aTHX_ &temp);
1217 load_perl (aTHX_ coro);
1218
1219 coro_destroy (aTHX_ coro);
1220
1221 load_perl (aTHX_ &temp);
1222
1223 coro->slot = 0;
1224 }
1225
1226 cctx_destroy (coro->cctx);
1227 SvREFCNT_dec (coro->args);
1228
1229 if (coro->next) coro->next->prev = coro->prev;
1230 if (coro->prev) coro->prev->next = coro->next;
1231 if (coro == coro_first) coro_first = coro->next;
1232
1233 return 1;
1234}
1235
1236static int
1237coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1238{
1239 struct coro *coro = (struct coro *)mg->mg_ptr;
1240 mg->mg_ptr = 0;
1241
1242 coro->hv = 0;
1243
1244 if (--coro->refcnt < 0)
1245 {
1246 coro_state_destroy (aTHX_ coro);
1247 Safefree (coro);
1248 }
1249
1250 return 0;
1251}
1252
1253static int
1254coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1255{
1256 struct coro *coro = (struct coro *)mg->mg_ptr;
1257
1258 ++coro->refcnt;
1259
1260 return 0;
1261}
1262
1263static MGVTBL coro_state_vtbl = {
1264 0, 0, 0, 0,
1265 coro_state_free,
1266 0,
1267#ifdef MGf_DUP
1268 coro_state_dup,
1269#else
1270# define MGf_DUP 0
1271#endif
1272};
1273
1274static void
1275prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
1276{
1277 ta->prev = SvSTATE (prev_sv);
1278 ta->next = SvSTATE (next_sv);
1279 TRANSFER_CHECK (*ta);
1280}
1281
1282static void
1283api_transfer (SV *prev_sv, SV *next_sv)
1284{
1285 dTHX;
1286 struct transfer_args ta;
1287
1288 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1289 TRANSFER (ta);
1290}
1291
1292/** Coro ********************************************************************/
1293
1294static void
1295coro_enq (pTHX_ SV *coro_sv)
1296{
1297 av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
1298}
1299
1300static SV *
1301coro_deq (pTHX_ int min_prio)
1302{
1303 int prio = PRIO_MAX - PRIO_MIN;
1304
1305 min_prio -= PRIO_MIN;
1306 if (min_prio < 0)
1307 min_prio = 0;
1308
1309 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
1310 if (AvFILLp (coro_ready [prio]) >= 0)
1311 return av_shift (coro_ready [prio]);
1312
1313 return 0;
1314}
1315
1316static int
1317api_ready (SV *coro_sv)
1318{
1319 dTHX;
1320 struct coro *coro;
1321
1322 if (SvROK (coro_sv))
1323 coro_sv = SvRV (coro_sv);
1324
1325 coro = SvSTATE (coro_sv);
1326
1327 if (coro->flags & CF_READY)
1328 return 0;
1329
1330 coro->flags |= CF_READY;
1331
1332 LOCK;
1333 coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
1334 ++coro_nready;
1335 UNLOCK;
1336
1337 return 1;
1338}
1339
1340static int
1341api_is_ready (SV *coro_sv)
1342{
1343 dTHX;
1344 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1345}
1346
1347static void
1348prepare_schedule (pTHX_ struct transfer_args *ta)
1349{
1350 SV *prev_sv, *next_sv;
1351
1352 for (;;)
1353 {
1354 LOCK;
1355 next_sv = coro_deq (aTHX_ PRIO_MIN);
1356
1357 /* nothing to schedule: call the idle handler */
1358 if (expect_false (!next_sv))
1359 {
1360 dSP;
1361 UNLOCK;
1362
1363 ENTER;
1364 SAVETMPS;
1365
1366 PUSHMARK (SP);
1367 PUTBACK;
1368 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1369
1370 FREETMPS;
1371 LEAVE;
1372 continue;
1373 }
1374
1375 ta->next = SvSTATE (next_sv);
1376
1377 /* cannot transfer to destroyed coros, skip and look for next */
1378 if (expect_false (ta->next->flags & CF_DESTROYED))
1379 {
1380 UNLOCK;
1381 SvREFCNT_dec (next_sv);
1382 /* coro_nready is already taken care of by destroy */
1383 continue;
1384 }
1385
1386 --coro_nready;
1387 UNLOCK;
1388 break;
1389 }
1390
1391 /* free this only after the transfer */
1392 prev_sv = SvRV (coro_current);
1393 ta->prev = SvSTATE (prev_sv);
1394 TRANSFER_CHECK (*ta);
1395 assert (ta->next->flags & CF_READY);
1396 ta->next->flags &= ~CF_READY;
1397 SvRV_set (coro_current, next_sv);
1398
1399 LOCK;
1400 free_coro_mortal (aTHX);
1401 coro_mortal = prev_sv;
1402 UNLOCK;
1403}
1404
1405static void
1406prepare_cede (pTHX_ struct transfer_args *ta)
1407{
1408 api_ready (coro_current);
1409 prepare_schedule (aTHX_ ta);
1410}
1411
1412static int
1413prepare_cede_notself (pTHX_ struct transfer_args *ta)
1414{
1415 if (coro_nready)
1416 {
1417 SV *prev = SvRV (coro_current);
1418 prepare_schedule (aTHX_ ta);
1419 api_ready (prev);
1420 return 1;
1421 }
1422 else
1423 return 0;
1424}
1425
1426static void
1427api_schedule (void)
1428{
1429 dTHX;
1430 struct transfer_args ta;
1431
1432 prepare_schedule (aTHX_ &ta);
1433 TRANSFER (ta);
1434}
1435
1436static int
1437api_cede (void)
1438{
1439 dTHX;
1440 struct transfer_args ta;
1441
1442 prepare_cede (aTHX_ &ta);
1443
1444 if (expect_true (ta.prev != ta.next))
1445 {
1446 TRANSFER (ta);
1447 return 1;
1448 }
1449 else
1450 return 0;
1451}
1452
1453static int
1454api_cede_notself (void)
1455{
1456 dTHX;
1457 struct transfer_args ta;
1458
1459 if (prepare_cede_notself (aTHX_ &ta))
1460 {
1461 TRANSFER (ta);
1462 return 1;
1463 }
1464 else
1465 return 0;
1466}
1467
1468static void
1469api_trace (SV *coro_sv, int flags)
1470{
1471 dTHX;
1472 struct coro *coro = SvSTATE (coro_sv);
1473
1474 if (flags & CC_TRACE)
1475 {
1476 if (!coro->cctx)
1477 coro->cctx = cctx_new ();
1478 else if (!(coro->cctx->flags & CC_TRACE))
1479 croak ("cannot enable tracing on coroutine with custom stack");
1480
1481 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1482 }
1483 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1484 {
1485 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1486
1487 if (coro->flags & CF_RUNNING)
1488 PL_runops = RUNOPS_DEFAULT;
1489 else
1490 coro->slot->runops = RUNOPS_DEFAULT;
1491 }
1492}
1493
338MODULE = Coro::State PACKAGE = Coro::State 1494MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
339 1495
340PROTOTYPES: ENABLE 1496PROTOTYPES: DISABLE
341 1497
342BOOT: 1498BOOT:
343 if (!padlist_cache) 1499{
344 padlist_cache = newHV (); 1500#ifdef USE_ITHREADS
1501 MUTEX_INIT (&coro_mutex);
1502#endif
1503 BOOT_PAGESIZE;
345 1504
346Coro::State 1505 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
347_newprocess(args) 1506 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
348 SV * args 1507
349 PROTOTYPE: $ 1508 hv_sig = coro_get_hv ("SIG", TRUE);
1509 sv_diehook = coro_get_sv ("Coro::State::DIEHOOK" , TRUE);
1510 sv_warnhook = coro_get_sv ("Coro::State::WARNHOOK", TRUE);
1511
1512 if (!PL_diehook ) hv_store (hv_sig, strpair ("__DIE__" ), SvREFCNT_inc (sv_diehook ), 0);
1513 if (!PL_warnhook) hv_store (hv_sig, strpair ("__WARN__"), SvREFCNT_inc (sv_warnhook), 0);
1514
1515 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
1516
1517 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
1518 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
1519 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
1520 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
1521
1522 main_mainstack = PL_mainstack;
1523 main_top_env = PL_top_env;
1524
1525 while (main_top_env->je_prev)
1526 main_top_env = main_top_env->je_prev;
1527
1528 coroapi.ver = CORO_API_VERSION;
1529 coroapi.transfer = api_transfer;
1530
1531 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
1532}
1533
1534SV *
1535new (char *klass, ...)
350 CODE: 1536 CODE:
351 Coro__State coro; 1537{
1538 struct coro *coro;
1539 HV *hv;
1540 int i;
352 1541
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); 1542 Newz (0, coro, 1, struct coro);
1543 coro->args = newAV ();
1544 coro->flags = CF_NEW;
357 1545
358 coro->mainstack = 0; /* actual work is done inside transfer */ 1546 if (coro_first) coro_first->prev = coro;
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args)); 1547 coro->next = coro_first;
1548 coro_first = coro;
360 1549
361 RETVAL = coro; 1550 coro->hv = hv = newHV ();
1551 sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
1552 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
1553
1554 av_extend (coro->args, items - 1);
1555 for (i = 1; i < items; i++)
1556 av_push (coro->args, newSVsv (ST (i)));
1557}
362 OUTPUT: 1558 OUTPUT:
363 RETVAL 1559 RETVAL
364 1560
1561# these not obviously related functions are all rolled into the same xs
1562# function to increase chances that they all will call transfer with the same
1563# stack offset
365void 1564void
366transfer(prev,next) 1565_set_stacklevel (...)
367 Coro::State_or_hashref prev 1566 ALIAS:
368 Coro::State_or_hashref next 1567 Coro::State::transfer = 1
1568 Coro::schedule = 2
1569 Coro::cede = 3
1570 Coro::cede_notself = 4
369 CODE: 1571 CODE:
1572{
1573 struct transfer_args ta;
370 1574
371 if (prev != next) 1575 switch (ix)
372 { 1576 {
373 PUTBACK;
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 {
384 LOAD (aTHX_ next);
385 next->mainstack = 0; /* unnecessary but much cleaner */
386 SPAGAIN;
387 }
388 else 1577 case 0:
1578 ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
1579 ta.next = 0;
389 { 1580 break;
390 /*
391 * emulate part of the perl startup here.
392 */
393 UNOP myop;
394 1581
395 init_stacks (); 1582 case 1:
396 PL_op = (OP *)&myop; 1583 if (items != 2)
397 /*PL_curcop = 0;*/ 1584 croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
398 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399 1585
400 SPAGAIN; 1586 prepare_transfer (aTHX_ &ta, ST (0), ST (1));
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 } 1587 break;
1588
1589 case 2:
1590 prepare_schedule (aTHX_ &ta);
1591 break;
1592
1593 case 3:
1594 prepare_cede (aTHX_ &ta);
1595 break;
1596
1597 case 4:
1598 if (!prepare_cede_notself (aTHX_ &ta))
1599 XSRETURN_EMPTY;
1600
1601 break;
419 } 1602 }
420 1603
1604 BARRIER;
1605 TRANSFER (ta);
1606
1607 if (expect_false (GIMME_V != G_VOID && ta.next != ta.prev))
1608 XSRETURN_YES;
1609}
1610
1611bool
1612_destroy (SV *coro_sv)
1613 CODE:
1614 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
1615 OUTPUT:
1616 RETVAL
1617
421void 1618void
422DESTROY(coro) 1619_exit (code)
423 Coro::State coro 1620 int code
424 CODE: 1621 PROTOTYPE: $
1622 CODE:
1623 _exit (code);
425 1624
1625int
1626cctx_stacksize (int new_stacksize = 0)
1627 CODE:
1628 RETVAL = coro_stacksize;
1629 if (new_stacksize)
1630 coro_stacksize = new_stacksize;
1631 OUTPUT:
1632 RETVAL
1633
1634int
1635cctx_count ()
1636 CODE:
1637 RETVAL = cctx_count;
1638 OUTPUT:
1639 RETVAL
1640
1641int
1642cctx_idle ()
1643 CODE:
1644 RETVAL = cctx_idle;
1645 OUTPUT:
1646 RETVAL
1647
1648void
1649list ()
1650 PPCODE:
1651{
1652 struct coro *coro;
1653 for (coro = coro_first; coro; coro = coro->next)
1654 if (coro->hv)
1655 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
1656}
1657
1658void
1659call (Coro::State coro, SV *coderef)
1660 ALIAS:
1661 eval = 1
1662 CODE:
1663{
426 if (coro->mainstack) 1664 if (coro->mainstack)
427 { 1665 {
428 struct coro temp; 1666 struct coro temp;
429 1667
1668 if (!(coro->flags & CF_RUNNING))
1669 {
1670 save_perl (aTHX_ &temp);
1671 load_perl (aTHX_ coro);
1672 }
1673
1674 {
1675 dSP;
1676 ENTER;
1677 SAVETMPS;
1678 PUSHMARK (SP);
430 PUTBACK; 1679 PUTBACK;
431 SAVE(aTHX_ (&temp));
432 LOAD(aTHX_ coro);
433 1680
434 S_nuke_stacks (); 1681 if (ix)
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv)); 1682 eval_sv (coderef, 0);
1683 else
1684 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
436 1685
437 LOAD((&temp));
438 SPAGAIN; 1686 SPAGAIN;
1687 FREETMPS;
1688 LEAVE;
1689 PUTBACK;
1690 }
1691
1692 if (!(coro->flags & CF_RUNNING))
1693 {
1694 save_perl (aTHX_ coro);
1695 load_perl (aTHX_ &temp);
1696 }
439 } 1697 }
1698}
440 1699
1700SV *
1701is_ready (Coro::State coro)
1702 PROTOTYPE: $
1703 ALIAS:
1704 is_ready = CF_READY
1705 is_running = CF_RUNNING
1706 is_new = CF_NEW
1707 is_destroyed = CF_DESTROYED
1708 CODE:
1709 RETVAL = boolSV (coro->flags & ix);
1710 OUTPUT:
1711 RETVAL
1712
1713void
1714api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
1715
1716SV *
1717has_stack (Coro::State coro)
1718 PROTOTYPE: $
1719 CODE:
1720 RETVAL = boolSV (!!coro->cctx);
1721 OUTPUT:
1722 RETVAL
1723
1724int
1725is_traced (Coro::State coro)
1726 PROTOTYPE: $
1727 CODE:
1728 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
1729 OUTPUT:
1730 RETVAL
1731
1732IV
1733rss (Coro::State coro)
1734 PROTOTYPE: $
1735 ALIAS:
1736 usecount = 1
1737 CODE:
1738 switch (ix)
1739 {
1740 case 0: RETVAL = coro_rss (aTHX_ coro); break;
1741 case 1: RETVAL = coro->usecount; break;
1742 }
1743 OUTPUT:
1744 RETVAL
1745
1746
1747MODULE = Coro::State PACKAGE = Coro
1748
1749BOOT:
1750{
1751 int i;
1752
1753 sv_pool_rss = coro_get_sv ("Coro::POOL_RSS" , TRUE);
1754 sv_pool_size = coro_get_sv ("Coro::POOL_SIZE" , TRUE);
1755 av_async_pool = coro_get_av ("Coro::async_pool", TRUE);
1756
1757 coro_current = coro_get_sv ("Coro::current", FALSE);
1758 SvREADONLY_on (coro_current);
1759
1760 coro_stash = gv_stashpv ("Coro", TRUE);
1761
1762 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
1763 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
1764 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
1765 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
1766 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
1767 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
1768
1769 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
1770 coro_ready[i] = newAV ();
1771
1772 {
1773 SV *sv = perl_get_sv ("Coro::API", TRUE);
1774 perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
1775
1776 coroapi.schedule = api_schedule;
1777 coroapi.cede = api_cede;
1778 coroapi.cede_notself = api_cede_notself;
1779 coroapi.ready = api_ready;
1780 coroapi.is_ready = api_is_ready;
1781 coroapi.nready = &coro_nready;
1782 coroapi.current = coro_current;
1783
1784 GCoroAPI = &coroapi;
1785 sv_setiv (sv, (IV)&coroapi);
1786 SvREADONLY_on (sv);
1787 }
1788}
1789
1790void
1791_set_current (SV *current)
1792 PROTOTYPE: $
1793 CODE:
1794 SvREFCNT_dec (SvRV (coro_current));
1795 SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
1796
1797int
1798prio (Coro::State coro, int newprio = 0)
1799 ALIAS:
1800 nice = 1
1801 CODE:
1802{
1803 RETVAL = coro->prio;
1804
1805 if (items > 1)
1806 {
1807 if (ix)
1808 newprio = coro->prio - newprio;
1809
1810 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
1811 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
1812
1813 coro->prio = newprio;
1814 }
1815}
1816 OUTPUT:
1817 RETVAL
1818
1819SV *
1820ready (SV *self)
1821 PROTOTYPE: $
1822 CODE:
1823 RETVAL = boolSV (api_ready (self));
1824 OUTPUT:
1825 RETVAL
1826
1827int
1828nready (...)
1829 PROTOTYPE:
1830 CODE:
1831 RETVAL = coro_nready;
1832 OUTPUT:
1833 RETVAL
1834
1835void
1836throw (Coro::State self, SV *throw = &PL_sv_undef)
1837 PROTOTYPE: $;$
1838 CODE:
1839 SvREFCNT_dec (self->throw);
1840 self->throw = SvOK (throw) ? newSVsv (throw) : 0;
1841
1842# for async_pool speedup
1843void
1844_pool_1 (SV *cb)
1845 CODE:
1846{
1847 struct coro *coro = SvSTATE (coro_current);
1848 HV *hv = (HV *)SvRV (coro_current);
1849 AV *defav = GvAV (PL_defgv);
1850 SV *invoke = hv_delete (hv, strpair ("_invoke"), 0);
1851 AV *invoke_av;
1852 int i, len;
1853
1854 if (!invoke)
1855 croak ("\3async_pool terminate\2\n");
1856
441 SvREFCNT_dec (coro->args); 1857 SvREFCNT_dec (coro->saved_deffh);
442 Safefree (coro); 1858 coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
443 1859
1860 hv_store (hv, "desc", sizeof ("desc") - 1,
1861 newSVpvn (strpair ("[async_pool]")), 0);
444 1862
1863 invoke_av = (AV *)SvRV (invoke);
1864 len = av_len (invoke_av);
1865
1866 sv_setsv (cb, AvARRAY (invoke_av)[0]);
1867
1868 if (len > 0)
1869 {
1870 av_fill (defav, len - 1);
1871 for (i = 0; i < len; ++i)
1872 av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
1873 }
1874
1875 SvREFCNT_dec (invoke);
1876}
1877
1878void
1879_pool_2 (SV *cb)
1880 CODE:
1881{
1882 struct coro *coro = SvSTATE (coro_current);
1883
1884 sv_setsv (cb, &PL_sv_undef);
1885
1886 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1887 coro->saved_deffh = 0;
1888
1889 if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
1890 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1891 croak ("\3async_pool terminate\2\n");
1892
1893 av_clear (GvAV (PL_defgv));
1894 hv_store ((HV *)SvRV (coro_current), strpair ("desc"),
1895 newSVpvn (strpair ("[async_pool idle]")), 0);
1896
1897 coro->prio = 0;
1898
1899 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
1900 api_trace (coro_current, 0);
1901
1902 av_push (av_async_pool, newSVsv (coro_current));
1903}
1904
1905
1906MODULE = Coro::State PACKAGE = Coro::AIO
1907
1908SV *
1909_get_state ()
1910 CODE:
1911{
1912 struct io_state *data;
1913
1914 RETVAL = newSV (sizeof (struct io_state));
1915 data = (struct io_state *)SvPVX (RETVAL);
1916 SvCUR_set (RETVAL, sizeof (struct io_state));
1917 SvPOK_only (RETVAL);
1918
1919 data->errorno = errno;
1920 data->laststype = PL_laststype;
1921 data->laststatval = PL_laststatval;
1922 data->statcache = PL_statcache;
1923}
1924 OUTPUT:
1925 RETVAL
1926
1927void
1928_set_state (char *data_)
1929 PROTOTYPE: $
1930 CODE:
1931{
1932 struct io_state *data = (void *)data_;
1933
1934 errno = data->errorno;
1935 PL_laststype = data->laststype;
1936 PL_laststatval = data->laststatval;
1937 PL_statcache = data->statcache;
1938}
1939

Diff Legend

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