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

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

Diff Legend

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