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.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.201 by root, Mon Oct 8 01:23:14 2007 UTC

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

Diff Legend

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