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.285 by root, Mon Nov 17 04:17:20 2008 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"
9#include "perliol.h"
4 10
5#if 0 11#include "patchlevel.h"
6# define CHK(x) (void *)0 12
13#include <stdio.h>
14#include <errno.h>
15#include <assert.h>
16
17#ifdef WIN32
18# undef setjmp
19# undef longjmp
20# undef _exit
21# define setjmp _setjmp // deep magic, don't ask
7#else 22#else
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x) 23# include <inttypes.h> /* most portable stdint.h */
24#endif
25
26#ifdef HAVE_MMAP
27# include <unistd.h>
28# include <sys/mman.h>
29# ifndef MAP_ANONYMOUS
30# ifdef MAP_ANON
31# define MAP_ANONYMOUS MAP_ANON
32# else
33# undef HAVE_MMAP
34# endif
9#endif 35# endif
36# include <limits.h>
37# ifndef PAGESIZE
38# define PAGESIZE pagesize
39# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
40static long pagesize;
41# else
42# define BOOT_PAGESIZE (void)0
43# endif
44#else
45# define PAGESIZE 0
46# define BOOT_PAGESIZE (void)0
47#endif
10 48
49#if CORO_USE_VALGRIND
50# include <valgrind/valgrind.h>
51#endif
52
53/* the maximum number of idle cctx that will be pooled */
54static int cctx_max_idle = 4;
55
56#define PERL_VERSION_ATLEAST(a,b,c) \
57 (PERL_REVISION > (a) \
58 || (PERL_REVISION == (a) \
59 && (PERL_VERSION > (b) \
60 || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
61
62#if !PERL_VERSION_ATLEAST (5,6,0)
63# ifndef PL_ppaddr
64# define PL_ppaddr ppaddr
65# endif
66# ifndef call_sv
67# define call_sv perl_call_sv
68# endif
69# ifndef get_sv
70# define get_sv perl_get_sv
71# endif
72# ifndef get_cv
73# define get_cv perl_get_cv
74# endif
75# ifndef IS_PADGV
76# define IS_PADGV(v) 0
77# endif
78# ifndef IS_PADCONST
79# define IS_PADCONST(v) 0
80# endif
81#endif
82
83/* 5.11 */
84#ifndef CxHASARGS
85# define CxHASARGS(cx) (cx)->blk_sub.hasargs
86#endif
87
88/* 5.10.0 */
89#ifndef SvREFCNT_inc_NN
90# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
91#endif
92
93/* 5.8.8 */
94#ifndef GV_NOTQUAL
95# define GV_NOTQUAL 0
96#endif
97#ifndef newSV
98# define newSV(l) NEWSV(0,l)
99#endif
100
101/* 5.8.7 */
102#ifndef SvRV_set
103# define SvRV_set(s,v) SvRV(s) = (v)
104#endif
105
106#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
107# undef CORO_STACKGUARD
108#endif
109
110#ifndef CORO_STACKGUARD
111# define CORO_STACKGUARD 0
112#endif
113
114/* prefer perl internal functions over our own? */
115#ifndef CORO_PREFER_PERL_FUNCTIONS
116# define CORO_PREFER_PERL_FUNCTIONS 0
117#endif
118
119/* The next macros try to return the current stack pointer, in an as
120 * portable way as possible. */
121#if __GNUC__ >= 4
122# define dSTACKLEVEL void *stacklevel = __builtin_frame_address (0)
123#else
124# define dSTACKLEVEL volatile void *stacklevel = (volatile void *)&stacklevel
125#endif
126
127#define IN_DESTRUCT (PL_main_cv == Nullcv)
128
129#if __GNUC__ >= 3
130# define attribute(x) __attribute__(x)
131# define expect(expr,value) __builtin_expect ((expr),(value))
132# define INLINE static inline
133#else
134# define attribute(x)
135# define expect(expr,value) (expr)
136# define INLINE static
137#endif
138
139#define expect_false(expr) expect ((expr) != 0, 0)
140#define expect_true(expr) expect ((expr) != 0, 1)
141
142#define NOINLINE attribute ((noinline))
143
144#include "CoroAPI.h"
145
146#ifdef USE_ITHREADS
147# if CORO_PTHREAD
148static void *coro_thx;
149# endif
150#endif
151
152/* helper storage struct for Coro::AIO */
153struct io_state
154{
155 AV *res;
156 int errorno;
157 I32 laststype; /* U16 in 5.10.0 */
158 int laststatval;
159 Stat_t statcache;
160};
161
162static double (*nvtime)(); /* so why doesn't it take void? */
163
164static U32 cctx_gen;
165static size_t cctx_stacksize = CORO_STACKSIZE;
166static struct CoroAPI coroapi;
167static AV *main_mainstack; /* used to differentiate between $main and others */
168static JMPENV *main_top_env;
169static HV *coro_state_stash, *coro_stash;
170static volatile SV *coro_mortal; /* will be freed/thrown after next transfer */
171
172static GV *irsgv; /* $/ */
173static GV *stdoutgv; /* *STDOUT */
174static SV *rv_diehook;
175static SV *rv_warnhook;
176static HV *hv_sig; /* %SIG */
177
178/* async_pool helper stuff */
179static SV *sv_pool_rss;
180static SV *sv_pool_size;
181static AV *av_async_pool;
182
183/* Coro::AnyEvent */
184static SV *sv_activity;
185
186static struct coro_cctx *cctx_first;
187static int cctx_count, cctx_idle;
188
189enum {
190 CC_MAPPED = 0x01,
191 CC_NOREUSE = 0x02, /* throw this away after tracing */
192 CC_TRACE = 0x04,
193 CC_TRACE_SUB = 0x08, /* trace sub calls */
194 CC_TRACE_LINE = 0x10, /* trace each statement */
195 CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
196};
197
198/* this is a structure representing a c-level coroutine */
199typedef struct coro_cctx
200{
201 struct coro_cctx *next;
202
203 /* the stack */
204 void *sptr;
205 size_t ssize;
206
207 /* cpu state */
208 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
209 JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
210 JMPENV *top_env;
211 coro_context cctx;
212
213 U32 gen;
214#if CORO_USE_VALGRIND
215 int valgrind_id;
216#endif
217 unsigned char flags;
218} coro_cctx;
219
220enum {
221 CF_RUNNING = 0x0001, /* coroutine is running */
222 CF_READY = 0x0002, /* coroutine is ready */
223 CF_NEW = 0x0004, /* has never been switched to */
224 CF_DESTROYED = 0x0008, /* coroutine data has been freed */
225};
226
227/* the structure where most of the perl state is stored, overlaid on the cxstack */
228typedef struct
229{
230 SV *defsv;
231 AV *defav;
232 SV *errsv;
233 SV *irsgv;
234#define VAR(name,type) type name;
235# include "state.h"
236#undef VAR
237} perl_slots;
238
239#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
240
241/* this is a structure representing a perl-level coroutine */
11struct coro { 242struct coro {
12 U8 dowarn; 243 /* the C coroutine allocated to this perl coroutine, if any */
13 AV *defav; 244 coro_cctx *cctx;
14 245
15 PERL_SI *curstackinfo; 246 /* state data */
16 AV *curstack; 247 struct CoroSLF slf_frame; /* saved slf frame */
17 AV *mainstack; 248 AV *mainstack;
18 SV **stack_sp; 249 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 250
41 AV *args; 251 AV *args; /* data associated with this coroutine (initial args) */
252 int refcnt; /* coroutines are refcounted, yes */
253 int flags; /* CF_ flags */
254 HV *hv; /* the perl hash associated with this coro, if any */
255 void (*on_destroy)(pTHX_ struct coro *coro);
256
257 /* statistics */
258 int usecount; /* number of transfers to this coro */
259
260 /* coro process data */
261 int prio;
262 SV *throw; /* exception to be thrown */
263
264 /* async_pool */
265 SV *saved_deffh;
266
267 /* linked list */
268 struct coro *next, *prev;
42}; 269};
43 270
44typedef struct coro *Coro__State; 271typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 272typedef struct coro *Coro__State_or_hashref;
46 273
47static HV *padlist_cache; 274/* the following variables are effectively part of the perl context */
275/* and get copied between struct coro and these variables */
276/* the mainr easonw e don't support windows process emulation */
277static struct CoroSLF slf_frame; /* the current slf frame */
278static SV *coro_throw;
48 279
49/* mostly copied from op.c:cv_clone2 */ 280/** Coro ********************************************************************/
50STATIC AV * 281
51clone_padlist (AV *protopadlist) 282#define PRIO_MAX 3
283#define PRIO_HIGH 1
284#define PRIO_NORMAL 0
285#define PRIO_LOW -1
286#define PRIO_IDLE -3
287#define PRIO_MIN -4
288
289/* for Coro.pm */
290static SV *coro_current;
291static SV *coro_readyhook;
292static AV *coro_ready [PRIO_MAX - PRIO_MIN + 1];
293static struct coro *coro_first;
294#define coro_nready coroapi.nready
295
296/** lowlevel stuff **********************************************************/
297
298static SV *
299coro_get_sv (pTHX_ const char *name, int create)
52{ 300{
53 AV *av; 301#if PERL_VERSION_ATLEAST (5,10,0)
54 I32 ix; 302 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE); 303 get_sv (name, create);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE); 304#endif
57 SV **pname = AvARRAY (protopad_name); 305 return get_sv (name, create);
58 SV **ppad = AvARRAY (protopad); 306}
59 I32 fname = AvFILLp (protopad_name); 307
60 I32 fpad = AvFILLp (protopad); 308static AV *
309coro_get_av (pTHX_ const char *name, int create)
310{
311#if PERL_VERSION_ATLEAST (5,10,0)
312 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
313 get_av (name, create);
314#endif
315 return get_av (name, create);
316}
317
318static HV *
319coro_get_hv (pTHX_ const char *name, int create)
320{
321#if PERL_VERSION_ATLEAST (5,10,0)
322 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
323 get_hv (name, create);
324#endif
325 return get_hv (name, create);
326}
327
328static AV *
329coro_clone_padlist (pTHX_ CV *cv)
330{
331 AV *padlist = CvPADLIST (cv);
61 AV *newpadlist, *newpad_name, *newpad; 332 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 333
72 newpadlist = newAV (); 334 newpadlist = newAV ();
73 AvREAL_off (newpadlist); 335 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 336#if PERL_VERSION_ATLEAST (5,10,0)
337 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
338#else
339 Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
340#endif
341 newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
342 --AvFILLp (padlist);
343
344 av_store (newpadlist, 0, SvREFCNT_inc_NN (*av_fetch (padlist, 0, FALSE)));
75 av_store (newpadlist, 1, (SV *) newpad); 345 av_store (newpadlist, 1, (SV *)newpad);
76 346
77 av = newAV (); /* will be @_ */ 347 return newpadlist;
78 av_extend (av, 0); 348}
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 349
82 for (ix = fpad; ix > 0; ix--) 350static void
351free_padlist (pTHX_ AV *padlist)
352{
353 /* may be during global destruction */
354 if (SvREFCNT (padlist))
83 { 355 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 356 I32 i = AvFILLp (padlist);
85 if (namesv && namesv != &PL_sv_undef) 357 while (i >= 0)
86 { 358 {
87 char *name = SvPVX (namesv); /* XXX */ 359 SV **svp = av_fetch (padlist, i--, FALSE);
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 360 if (svp)
89 { /* lexical from outside? */
90 npad[ix] = SvREFCNT_inc (ppad[ix]);
91 } 361 {
92 else
93 { /* our own lexical */
94 SV *sv; 362 SV *sv;
95 if (*name == '&') 363 while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96 sv = SvREFCNT_inc (ppad[ix]); 364 SvREFCNT_dec (sv);
97 else if (*name == '@') 365
98 sv = (SV *) newAV (); 366 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 } 367 }
107 } 368 }
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 369
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); 370 SvREFCNT_dec ((SV*)padlist);
371 }
372}
373
374static int
375coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
376{
377 AV *padlist;
378 AV *av = (AV *)mg->mg_obj;
379
380 /* casting is fun. */
381 while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
382 free_padlist (aTHX_ padlist);
383
384 SvREFCNT_dec (av); /* sv_magicext increased the refcount */
385
386 return 0;
387}
388
389#define CORO_MAGIC_type_cv PERL_MAGIC_ext
390#define CORO_MAGIC_type_state PERL_MAGIC_ext
391
392static MGVTBL coro_cv_vtbl = {
393 0, 0, 0, 0,
394 coro_cv_free
395};
396
397#define CORO_MAGIC(sv, type) \
398 expect_true (SvMAGIC (sv)) \
399 ? expect_true (SvMAGIC (sv)->mg_type == type) \
400 ? SvMAGIC (sv) \
401 : mg_find (sv, type) \
402 : 0
403
404#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
405#define CORO_MAGIC_state(sv) CORO_MAGIC (((SV *)(sv)), CORO_MAGIC_type_state)
406
407INLINE struct coro *
408SvSTATE_ (pTHX_ SV *coro)
409{
410 HV *stash;
411 MAGIC *mg;
412
413 if (SvROK (coro))
414 coro = SvRV (coro);
415
416 if (expect_false (SvTYPE (coro) != SVt_PVHV))
417 croak ("Coro::State object required");
418
419 stash = SvSTASH (coro);
420 if (expect_false (stash != coro_stash && stash != coro_state_stash))
421 {
422 /* very slow, but rare, check */
423 if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
424 croak ("Coro::State object required");
425 }
426
427 mg = CORO_MAGIC_state (coro);
428 return (struct coro *)mg->mg_ptr;
429}
430
431#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
432
433/* fastert than SvSTATE, but expects a coroutine hv */
434INLINE struct coro *
435SvSTATE_hv (SV *sv)
436{
437 MAGIC *mg = expect_true (SvMAGIC (sv)->mg_type == CORO_MAGIC_type_state)
438 ? SvMAGIC (sv)
439 : mg_find (sv, CORO_MAGIC_type_state);
440
441 return (struct coro *)mg->mg_ptr;
442}
443
444#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))
445
446/* the next two functions merely cache the padlists */
447static void
448get_padlist (pTHX_ CV *cv)
449{
450 MAGIC *mg = CORO_MAGIC_cv (cv);
451 AV *av;
452
453 if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))
454 CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
455 else
456 {
457#if CORO_PREFER_PERL_FUNCTIONS
458 /* this is probably cleaner? but also slower! */
459 /* in practise, it seems to be less stable */
460 CV *cp = Perl_cv_clone (cv);
461 CvPADLIST (cv) = CvPADLIST (cp);
462 CvPADLIST (cp) = 0;
463 SvREFCNT_dec (cp);
464#else
465 CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
466#endif
467 }
468}
469
470static void
471put_padlist (pTHX_ CV *cv)
472{
473 MAGIC *mg = CORO_MAGIC_cv (cv);
474 AV *av;
475
476 if (expect_false (!mg))
477 mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
478
479 av = (AV *)mg->mg_obj;
480
481 if (expect_false (AvFILLp (av) >= AvMAX (av)))
482 av_extend (av, AvMAX (av) + 1);
483
484 AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
485}
486
487/** load & save, init *******************************************************/
488
489static void
490load_perl (pTHX_ Coro__State c)
491{
492 perl_slots *slot = c->slot;
493 c->slot = 0;
494
495 PL_mainstack = c->mainstack;
496
497 GvSV (PL_defgv) = slot->defsv;
498 GvAV (PL_defgv) = slot->defav;
499 GvSV (PL_errgv) = slot->errsv;
500 GvSV (irsgv) = slot->irsgv;
501
502 #define VAR(name,type) PL_ ## name = slot->name;
503 # include "state.h"
504 #undef VAR
505
506 {
507 dSP;
508
509 CV *cv;
510
511 /* now do the ugly restore mess */
512 while (expect_true (cv = (CV *)POPs))
513 {
514 put_padlist (aTHX_ cv); /* mark this padlist as available */
515 CvDEPTH (cv) = PTR2IV (POPs);
516 CvPADLIST (cv) = (AV *)POPs;
517 }
518
519 PUTBACK;
159 } 520 }
160}
161 521
162/* the next tow functions merely cache the padlists */ 522 slf_frame = c->slf_frame;
163STATIC void 523 coro_throw = c->throw;
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} 524}
173 525
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 526static void
189SAVE(pTHX_ Coro__State c) 527save_perl (pTHX_ Coro__State c)
190{ 528{
529 c->throw = coro_throw;
530 c->slf_frame = slf_frame;
531
191 { 532 {
192 dSP; 533 dSP;
193 I32 cxix = cxstack_ix; 534 I32 cxix = cxstack_ix;
535 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 536 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 537
197 /* 538 /*
198 * the worst thing you can imagine happens first - we have to save 539 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 540 * (and reinitialize) all cv's in the whole callchain :(
200 */ 541 */
201 542
202 PUSHs (Nullsv); 543 XPUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 544 /* this loop was inspired by pp_caller */
204 for (;;) 545 for (;;)
205 { 546 {
206 while (cxix >= 0) 547 while (expect_true (cxix >= 0))
207 { 548 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 549 PERL_CONTEXT *cx = &ccstk[cxix--];
209 550
210 if (CxTYPE(cx) == CXt_SUB) 551 if (expect_true (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT))
211 { 552 {
212 CV *cv = cx->blk_sub.cv; 553 CV *cv = cx->blk_sub.cv;
554
213 if (CvDEPTH(cv)) 555 if (expect_true (CvDEPTH (cv)))
214 { 556 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3); 557 EXTEND (SP, 3);
219 PUSHs ((SV *)CvDEPTH(cv));
220 PUSHs ((SV *)CvPADLIST(cv)); 558 PUSHs ((SV *)CvPADLIST (cv));
559 PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
221 PUSHs ((SV *)cv); 560 PUSHs ((SV *)cv);
222 561
223 get_padlist (cv);
224
225 CvDEPTH(cv) = 0; 562 CvDEPTH (cv) = 0;
226#ifdef USE_THREADS 563 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 } 564 }
233 } 565 }
234 else if (CxTYPE(cx) == CXt_FORMAT) 566 }
567
568 if (expect_true (top_si->si_type == PERLSI_MAIN))
569 break;
570
571 top_si = top_si->si_prev;
572 ccstk = top_si->si_cxstack;
573 cxix = top_si->si_cxix;
574 }
575
576 PUTBACK;
577 }
578
579 /* allocate some space on the context stack for our purposes */
580 /* we manually unroll here, as usually 2 slots is enough */
581 if (SLOT_COUNT >= 1) CXINC;
582 if (SLOT_COUNT >= 2) CXINC;
583 if (SLOT_COUNT >= 3) CXINC;
584 {
585 int i;
586 for (i = 3; i < SLOT_COUNT; ++i)
587 CXINC;
588 }
589 cxstack_ix -= SLOT_COUNT; /* undo allocation */
590
591 c->mainstack = PL_mainstack;
592
593 {
594 perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
595
596 slot->defav = GvAV (PL_defgv);
597 slot->defsv = DEFSV;
598 slot->errsv = ERRSV;
599 slot->irsgv = GvSV (irsgv);
600
601 #define VAR(name,type) slot->name = PL_ ## name;
602 # include "state.h"
603 #undef VAR
604 }
605}
606
607/*
608 * allocate various perl stacks. This is almost an exact copy
609 * of perl.c:init_stacks, except that it uses less memory
610 * on the (sometimes correct) assumption that coroutines do
611 * not usually need a lot of stackspace.
612 */
613#if CORO_PREFER_PERL_FUNCTIONS
614# define coro_init_stacks init_stacks
615#else
616static void
617coro_init_stacks (pTHX)
618{
619 PL_curstackinfo = new_stackinfo(32, 8);
620 PL_curstackinfo->si_type = PERLSI_MAIN;
621 PL_curstack = PL_curstackinfo->si_stack;
622 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
623
624 PL_stack_base = AvARRAY(PL_curstack);
625 PL_stack_sp = PL_stack_base;
626 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
627
628 New(50,PL_tmps_stack,32,SV*);
629 PL_tmps_floor = -1;
630 PL_tmps_ix = -1;
631 PL_tmps_max = 32;
632
633 New(54,PL_markstack,16,I32);
634 PL_markstack_ptr = PL_markstack;
635 PL_markstack_max = PL_markstack + 16;
636
637#ifdef SET_MARK_OFFSET
638 SET_MARK_OFFSET;
639#endif
640
641 New(54,PL_scopestack,8,I32);
642 PL_scopestack_ix = 0;
643 PL_scopestack_max = 8;
644
645 New(54,PL_savestack,24,ANY);
646 PL_savestack_ix = 0;
647 PL_savestack_max = 24;
648
649#if !PERL_VERSION_ATLEAST (5,10,0)
650 New(54,PL_retstack,4,OP*);
651 PL_retstack_ix = 0;
652 PL_retstack_max = 4;
653#endif
654}
655#endif
656
657/*
658 * destroy the stacks, the callchain etc...
659 */
660static void
661coro_destruct_stacks (pTHX)
662{
663 while (PL_curstackinfo->si_next)
664 PL_curstackinfo = PL_curstackinfo->si_next;
665
666 while (PL_curstackinfo)
667 {
668 PERL_SI *p = PL_curstackinfo->si_prev;
669
670 if (!IN_DESTRUCT)
671 SvREFCNT_dec (PL_curstackinfo->si_stack);
672
673 Safefree (PL_curstackinfo->si_cxstack);
674 Safefree (PL_curstackinfo);
675 PL_curstackinfo = p;
676 }
677
678 Safefree (PL_tmps_stack);
679 Safefree (PL_markstack);
680 Safefree (PL_scopestack);
681 Safefree (PL_savestack);
682#if !PERL_VERSION_ATLEAST (5,10,0)
683 Safefree (PL_retstack);
684#endif
685}
686
687static size_t
688coro_rss (pTHX_ struct coro *coro)
689{
690 size_t rss = sizeof (*coro);
691
692 if (coro->mainstack)
693 {
694 perl_slots tmp_slot;
695 perl_slots *slot;
696
697 if (coro->flags & CF_RUNNING)
698 {
699 slot = &tmp_slot;
700
701 #define VAR(name,type) slot->name = PL_ ## name;
702 # include "state.h"
703 #undef VAR
704 }
705 else
706 slot = coro->slot;
707
708 if (slot)
709 {
710 rss += sizeof (slot->curstackinfo);
711 rss += (slot->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
712 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (slot->curstack)) * sizeof (SV *);
713 rss += slot->tmps_max * sizeof (SV *);
714 rss += (slot->markstack_max - slot->markstack_ptr) * sizeof (I32);
715 rss += slot->scopestack_max * sizeof (I32);
716 rss += slot->savestack_max * sizeof (ANY);
717
718#if !PERL_VERSION_ATLEAST (5,10,0)
719 rss += slot->retstack_max * sizeof (OP *);
720#endif
721 }
722 }
723
724 return rss;
725}
726
727/** coroutine stack handling ************************************************/
728
729static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg);
730static int (*orig_sigelem_set) (pTHX_ SV *sv, MAGIC *mg);
731static int (*orig_sigelem_clr) (pTHX_ SV *sv, MAGIC *mg);
732
733/* apparently < 5.8.8 */
734#ifndef MgPV_nolen_const
735#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
736 SvPV_nolen((SV*)((mg)->mg_ptr)) : \
737 (const char*)(mg)->mg_ptr)
738#endif
739
740/*
741 * This overrides the default magic get method of %SIG elements.
742 * The original one doesn't provide for reading back of PL_diehook/PL_warnhook
743 * and instead of tryign to save and restore the hash elements, we just provide
744 * readback here.
745 * We only do this when the hook is != 0, as they are often set to 0 temporarily,
746 * not expecting this to actually change the hook. This is a potential problem
747 * when a schedule happens then, but we ignore this.
748 */
749static int
750coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
751{
752 const char *s = MgPV_nolen_const (mg);
753
754 if (*s == '_')
755 {
756 SV **svp = 0;
757
758 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
759 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
760
761 if (svp)
762 {
763 sv_setsv (sv, *svp ? *svp : &PL_sv_undef);
764 return 0;
765 }
766 }
767
768 return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
769}
770
771static int
772coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
773{
774 const char *s = MgPV_nolen_const (mg);
775
776 if (*s == '_')
777 {
778 SV **svp = 0;
779
780 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
781 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
782
783 if (svp)
784 {
785 SV *old = *svp;
786 *svp = 0;
787 SvREFCNT_dec (old);
788 return 0;
789 }
790 }
791
792 return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
793}
794
795static int
796coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
797{
798 const char *s = MgPV_nolen_const (mg);
799
800 if (*s == '_')
801 {
802 SV **svp = 0;
803
804 if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
805 if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
806
807 if (svp)
808 {
809 SV *old = *svp;
810 *svp = newSVsv (sv);
811 SvREFCNT_dec (old);
812 return 0;
813 }
814 }
815
816 return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
817}
818
819static void
820prepare_nop (pTHX_ struct coro_transfer_args *ta)
821{
822 /* kind of mega-hacky, but works */
823 ta->next = ta->prev = (struct coro *)ta;
824}
825
826static int
827slf_check_nop (pTHX_ struct CoroSLF *frame)
828{
829 return 0;
830}
831
832static void NOINLINE /* noinline to keep it out of the transfer fast path */
833coro_setup (pTHX_ struct coro *coro)
834{
835 /*
836 * emulate part of the perl startup here.
837 */
838 coro_init_stacks (aTHX);
839
840 PL_runops = RUNOPS_DEFAULT;
841 PL_curcop = &PL_compiling;
842 PL_in_eval = EVAL_NULL;
843 PL_comppad = 0;
844 PL_curpm = 0;
845 PL_curpad = 0;
846 PL_localizing = 0;
847 PL_dirty = 0;
848 PL_restartop = 0;
849#if PERL_VERSION_ATLEAST (5,10,0)
850 PL_parser = 0;
851#endif
852
853 /* recreate the die/warn hooks */
854 PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
855 PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
856
857 GvSV (PL_defgv) = newSV (0);
858 GvAV (PL_defgv) = coro->args; coro->args = 0;
859 GvSV (PL_errgv) = newSV (0);
860 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
861 PL_rs = newSVsv (GvSV (irsgv));
862 PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
863
864 {
865 dSP;
866 UNOP myop;
867
868 Zero (&myop, 1, UNOP);
869 myop.op_next = Nullop;
870 myop.op_flags = OPf_WANT_VOID;
871
872 PUSHMARK (SP);
873 XPUSHs (sv_2mortal (av_shift (GvAV (PL_defgv))));
874 PUTBACK;
875 PL_op = (OP *)&myop;
876 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
877 SPAGAIN;
878 }
879
880 /* this newly created coroutine might be run on an existing cctx which most
881 * likely was suspended in pp_slf, so we have to emulate entering pp_slf here.
882 */
883 slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */
884 slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */
885
886 coro_throw = coro->throw;
887}
888
889static void
890coro_destruct (pTHX_ struct coro *coro)
891{
892 if (!IN_DESTRUCT)
893 {
894 /* restore all saved variables and stuff */
895 LEAVE_SCOPE (0);
896 assert (PL_tmps_floor == -1);
897
898 /* free all temporaries */
899 FREETMPS;
900 assert (PL_tmps_ix == -1);
901
902 /* unwind all extra stacks */
903 POPSTACK_TO (PL_mainstack);
904
905 /* unwind main stack */
906 dounwind (-1);
907 }
908
909 SvREFCNT_dec (GvSV (PL_defgv));
910 SvREFCNT_dec (GvAV (PL_defgv));
911 SvREFCNT_dec (GvSV (PL_errgv));
912 SvREFCNT_dec (PL_defoutgv);
913 SvREFCNT_dec (PL_rs);
914 SvREFCNT_dec (GvSV (irsgv));
915
916 SvREFCNT_dec (PL_diehook);
917 SvREFCNT_dec (PL_warnhook);
918
919 SvREFCNT_dec (coro->saved_deffh);
920 SvREFCNT_dec (coro_throw);
921
922 coro_destruct_stacks (aTHX);
923}
924
925INLINE void
926free_coro_mortal (pTHX)
927{
928 if (expect_true (coro_mortal))
929 {
930 SvREFCNT_dec (coro_mortal);
931 coro_mortal = 0;
932 }
933}
934
935static int
936runops_trace (pTHX)
937{
938 COP *oldcop = 0;
939 int oldcxix = -2;
940 struct coro *coro = SvSTATE_current; /* trace cctx is tied to specific coro */
941 coro_cctx *cctx = coro->cctx;
942
943 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
944 {
945 PERL_ASYNC_CHECK ();
946
947 if (cctx->flags & CC_TRACE_ALL)
948 {
949 if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
950 {
951 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
952 SV **bot, **top;
953 AV *av = newAV (); /* return values */
954 SV **cb;
955 dSP;
956
957 GV *gv = CvGV (cx->blk_sub.cv);
958 SV *fullname = sv_2mortal (newSV (0));
959 if (isGV (gv))
960 gv_efullname3 (fullname, gv, 0);
961
962 bot = PL_stack_base + cx->blk_oldsp + 1;
963 top = cx->blk_gimme == G_ARRAY ? SP + 1
964 : cx->blk_gimme == G_SCALAR ? bot + 1
965 : bot;
966
967 av_extend (av, top - bot);
968 while (bot < top)
969 av_push (av, SvREFCNT_inc_NN (*bot++));
970
971 PL_runops = RUNOPS_DEFAULT;
972 ENTER;
973 SAVETMPS;
974 EXTEND (SP, 3);
975 PUSHMARK (SP);
976 PUSHs (&PL_sv_no);
977 PUSHs (fullname);
978 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
979 PUTBACK;
980 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
981 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
982 SPAGAIN;
983 FREETMPS;
984 LEAVE;
985 PL_runops = runops_trace;
986 }
987
988 if (oldcop != PL_curcop)
989 {
990 oldcop = PL_curcop;
991
992 if (PL_curcop != &PL_compiling)
993 {
994 SV **cb;
995
996 if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
997 {
998 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
999
1000 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
1001 {
1002 runops_proc_t old_runops = PL_runops;
1003 dSP;
1004 GV *gv = CvGV (cx->blk_sub.cv);
1005 SV *fullname = sv_2mortal (newSV (0));
1006
1007 if (isGV (gv))
1008 gv_efullname3 (fullname, gv, 0);
1009
1010 PL_runops = RUNOPS_DEFAULT;
1011 ENTER;
1012 SAVETMPS;
1013 EXTEND (SP, 3);
1014 PUSHMARK (SP);
1015 PUSHs (&PL_sv_yes);
1016 PUSHs (fullname);
1017 PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
1018 PUTBACK;
1019 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
1020 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1021 SPAGAIN;
1022 FREETMPS;
1023 LEAVE;
1024 PL_runops = runops_trace;
1025 }
1026
1027 oldcxix = cxstack_ix;
1028 }
1029
1030 if (cctx->flags & CC_TRACE_LINE)
1031 {
1032 dSP;
1033
1034 PL_runops = RUNOPS_DEFAULT;
1035 ENTER;
1036 SAVETMPS;
1037 EXTEND (SP, 3);
1038 PL_runops = RUNOPS_DEFAULT;
1039 PUSHMARK (SP);
1040 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
1041 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
1042 PUTBACK;
1043 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
1044 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1045 SPAGAIN;
1046 FREETMPS;
1047 LEAVE;
1048 PL_runops = runops_trace;
1049 }
1050 }
1051 }
1052 }
1053 }
1054
1055 TAINT_NOT;
1056 return 0;
1057}
1058
1059static void
1060prepare_set_stacklevel (struct coro_transfer_args *ta, struct coro_cctx *cctx)
1061{
1062 ta->prev = (struct coro *)cctx;
1063 ta->next = 0;
1064}
1065
1066/* inject a fake call to Coro::State::_cctx_init into the execution */
1067/* _cctx_init should be careful, as it could be called at almost any time */
1068/* during execution of a perl program */
1069/* also initialises PL_top_env */
1070static void NOINLINE
1071cctx_prepare (pTHX_ coro_cctx *cctx)
1072{
1073 dSP;
1074 UNOP myop;
1075
1076 PL_top_env = &PL_start_env;
1077
1078 if (cctx->flags & CC_TRACE)
1079 PL_runops = runops_trace;
1080
1081 Zero (&myop, 1, UNOP);
1082 myop.op_next = PL_op;
1083 myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
1084
1085 PUSHMARK (SP);
1086 EXTEND (SP, 2);
1087 PUSHs (sv_2mortal (newSViv ((IV)cctx)));
1088 PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
1089 PUTBACK;
1090 PL_op = (OP *)&myop;
1091 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
1092 SPAGAIN;
1093}
1094
1095/* the tail of transfer: execute stuff we can only do after a transfer */
1096INLINE void
1097transfer_tail (pTHX)
1098{
1099 free_coro_mortal (aTHX);
1100}
1101
1102/*
1103 * this is a _very_ stripped down perl interpreter ;)
1104 */
1105static void
1106cctx_run (void *arg)
1107{
1108#ifdef USE_ITHREADS
1109# if CORO_PTHREAD
1110 PERL_SET_CONTEXT (coro_thx);
1111# endif
1112#endif
1113 {
1114 dTHX;
1115
1116 /* normally we would need to skip the entersub here */
1117 /* not doing so will re-execute it, which is exactly what we want */
1118 /* PL_nop = PL_nop->op_next */
1119
1120 /* inject a fake subroutine call to cctx_init */
1121 cctx_prepare (aTHX_ (coro_cctx *)arg);
1122
1123 /* cctx_run is the alternative tail of transfer() */
1124 transfer_tail (aTHX);
1125
1126 /* somebody or something will hit me for both perl_run and PL_restartop */
1127 PL_restartop = PL_op;
1128 perl_run (PL_curinterp);
1129
1130 /*
1131 * If perl-run returns we assume exit() was being called or the coro
1132 * fell off the end, which seems to be the only valid (non-bug)
1133 * reason for perl_run to return. We try to exit by jumping to the
1134 * bootstrap-time "top" top_env, as we cannot restore the "main"
1135 * coroutine as Coro has no such concept
1136 */
1137 PL_top_env = main_top_env;
1138 JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
1139 }
1140}
1141
1142static coro_cctx *
1143cctx_new ()
1144{
1145 coro_cctx *cctx;
1146
1147 ++cctx_count;
1148 New (0, cctx, 1, coro_cctx);
1149
1150 cctx->gen = cctx_gen;
1151 cctx->flags = 0;
1152 cctx->idle_sp = 0; /* can be accessed by transfer between cctx_run and set_stacklevel, on throw */
1153
1154 return cctx;
1155}
1156
1157/* create a new cctx only suitable as source */
1158static coro_cctx *
1159cctx_new_empty ()
1160{
1161 coro_cctx *cctx = cctx_new ();
1162
1163 cctx->sptr = 0;
1164 coro_create (&cctx->cctx, 0, 0, 0, 0);
1165
1166 return cctx;
1167}
1168
1169/* create a new cctx suitable as destination/running a perl interpreter */
1170static coro_cctx *
1171cctx_new_run ()
1172{
1173 coro_cctx *cctx = cctx_new ();
1174 void *stack_start;
1175 size_t stack_size;
1176
1177#if HAVE_MMAP
1178 cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
1179 /* mmap supposedly does allocate-on-write for us */
1180 cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
1181
1182 if (cctx->sptr != (void *)-1)
1183 {
1184 #if CORO_STACKGUARD
1185 mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
1186 #endif
1187 stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE;
1188 stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
1189 cctx->flags |= CC_MAPPED;
1190 }
1191 else
1192#endif
1193 {
1194 cctx->ssize = cctx_stacksize * (long)sizeof (long);
1195 New (0, cctx->sptr, cctx_stacksize, long);
1196
1197 if (!cctx->sptr)
1198 {
1199 perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1200 _exit (EXIT_FAILURE);
1201 }
1202
1203 stack_start = cctx->sptr;
1204 stack_size = cctx->ssize;
1205 }
1206
1207 #if CORO_USE_VALGRIND
1208 cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size);
1209 #endif
1210
1211 coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
1212
1213 return cctx;
1214}
1215
1216static void
1217cctx_destroy (coro_cctx *cctx)
1218{
1219 if (!cctx)
1220 return;
1221
1222 --cctx_count;
1223 coro_destroy (&cctx->cctx);
1224
1225 /* coro_transfer creates new, empty cctx's */
1226 if (cctx->sptr)
1227 {
1228 #if CORO_USE_VALGRIND
1229 VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1230 #endif
1231
1232#if HAVE_MMAP
1233 if (cctx->flags & CC_MAPPED)
1234 munmap (cctx->sptr, cctx->ssize);
1235 else
1236#endif
1237 Safefree (cctx->sptr);
1238 }
1239
1240 Safefree (cctx);
1241}
1242
1243/* wether this cctx should be destructed */
1244#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1245
1246static coro_cctx *
1247cctx_get (pTHX)
1248{
1249 while (expect_true (cctx_first))
1250 {
1251 coro_cctx *cctx = cctx_first;
1252 cctx_first = cctx->next;
1253 --cctx_idle;
1254
1255 if (expect_true (!CCTX_EXPIRED (cctx)))
1256 return cctx;
1257
1258 cctx_destroy (cctx);
1259 }
1260
1261 return cctx_new_run ();
1262}
1263
1264static void
1265cctx_put (coro_cctx *cctx)
1266{
1267 assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr));
1268
1269 /* free another cctx if overlimit */
1270 if (expect_false (cctx_idle >= cctx_max_idle))
1271 {
1272 coro_cctx *first = cctx_first;
1273 cctx_first = first->next;
1274 --cctx_idle;
1275
1276 cctx_destroy (first);
1277 }
1278
1279 ++cctx_idle;
1280 cctx->next = cctx_first;
1281 cctx_first = cctx;
1282}
1283
1284/** coroutine switching *****************************************************/
1285
1286static void
1287transfer_check (pTHX_ struct coro *prev, struct coro *next)
1288{
1289 /* TODO: throwing up here is considered harmful */
1290
1291 if (expect_true (prev != next))
1292 {
1293 if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1294 croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states,");
1295
1296 if (expect_false (next->flags & CF_RUNNING))
1297 croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states,");
1298
1299 if (expect_false (next->flags & CF_DESTROYED))
1300 croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states,");
1301
1302#if !PERL_VERSION_ATLEAST (5,10,0)
1303 if (expect_false (PL_lex_state != LEX_NOTPARSING))
1304 croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");
1305#endif
1306 }
1307}
1308
1309/* always use the TRANSFER macro */
1310static void NOINLINE /* noinline so we have a fixed stackframe */
1311transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1312{
1313 dSTACKLEVEL;
1314
1315 /* sometimes transfer is only called to set idle_sp */
1316 if (expect_false (!next))
1317 {
1318 ((coro_cctx *)prev)->idle_sp = (void *)stacklevel;
1319 assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1320 }
1321 else if (expect_true (prev != next))
1322 {
1323 coro_cctx *prev__cctx;
1324
1325 if (expect_false (prev->flags & CF_NEW))
1326 {
1327 /* create a new empty/source context */
1328 prev->cctx = cctx_new_empty ();
1329 prev->flags &= ~CF_NEW;
1330 prev->flags |= CF_RUNNING;
1331 }
1332
1333 prev->flags &= ~CF_RUNNING;
1334 next->flags |= CF_RUNNING;
1335
1336 /* first get rid of the old state */
1337 save_perl (aTHX_ prev);
1338
1339 if (expect_false (next->flags & CF_NEW))
1340 {
1341 /* need to start coroutine */
1342 next->flags &= ~CF_NEW;
1343 /* setup coroutine call */
1344 coro_setup (aTHX_ next);
1345 }
1346 else
1347 load_perl (aTHX_ next);
1348
1349 prev__cctx = prev->cctx;
1350
1351 /* possibly untie and reuse the cctx */
1352 if (expect_true (
1353 prev__cctx->idle_sp == (void *)stacklevel
1354 && !(prev__cctx->flags & CC_TRACE)
1355 && !force_cctx
1356 ))
1357 {
1358 /* I assume that stacklevel is a stronger indicator than PL_top_env changes */
1359 assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == prev__cctx->idle_te));
1360
1361 prev->cctx = 0;
1362
1363 /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
1364 /* without this the next cctx_get might destroy the prev__cctx while still in use */
1365 if (expect_false (CCTX_EXPIRED (prev__cctx)))
1366 if (!next->cctx)
1367 next->cctx = cctx_get (aTHX);
1368
1369 cctx_put (prev__cctx);
1370 }
1371
1372 ++next->usecount;
1373
1374 if (expect_true (!next->cctx))
1375 next->cctx = cctx_get (aTHX);
1376
1377 if (expect_false (prev__cctx != next->cctx))
1378 {
1379 prev__cctx->top_env = PL_top_env;
1380 PL_top_env = next->cctx->top_env;
1381 coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
1382 }
1383
1384 transfer_tail (aTHX);
1385 }
1386}
1387
1388#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1389#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1390
1391/** high level stuff ********************************************************/
1392
1393static int
1394coro_state_destroy (pTHX_ struct coro *coro)
1395{
1396 if (coro->flags & CF_DESTROYED)
1397 return 0;
1398
1399 if (coro->on_destroy)
1400 coro->on_destroy (aTHX_ coro);
1401
1402 coro->flags |= CF_DESTROYED;
1403
1404 if (coro->flags & CF_READY)
1405 {
1406 /* reduce nready, as destroying a ready coro effectively unreadies it */
1407 /* alternative: look through all ready queues and remove the coro */
1408 --coro_nready;
1409 }
1410 else
1411 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1412
1413 if (coro->mainstack && coro->mainstack != main_mainstack)
1414 {
1415 struct coro temp;
1416
1417 assert (("FATAL: tried to destroy currently running coroutine (please report)", !(coro->flags & CF_RUNNING)));
1418
1419 save_perl (aTHX_ &temp);
1420 load_perl (aTHX_ coro);
1421
1422 coro_destruct (aTHX_ coro);
1423
1424 load_perl (aTHX_ &temp);
1425
1426 coro->slot = 0;
1427 }
1428
1429 cctx_destroy (coro->cctx);
1430 SvREFCNT_dec (coro->args);
1431
1432 if (coro->next) coro->next->prev = coro->prev;
1433 if (coro->prev) coro->prev->next = coro->next;
1434 if (coro == coro_first) coro_first = coro->next;
1435
1436 return 1;
1437}
1438
1439static int
1440coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1441{
1442 struct coro *coro = (struct coro *)mg->mg_ptr;
1443 mg->mg_ptr = 0;
1444
1445 coro->hv = 0;
1446
1447 if (--coro->refcnt < 0)
1448 {
1449 coro_state_destroy (aTHX_ coro);
1450 Safefree (coro);
1451 }
1452
1453 return 0;
1454}
1455
1456static int
1457coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1458{
1459 struct coro *coro = (struct coro *)mg->mg_ptr;
1460
1461 ++coro->refcnt;
1462
1463 return 0;
1464}
1465
1466static MGVTBL coro_state_vtbl = {
1467 0, 0, 0, 0,
1468 coro_state_free,
1469 0,
1470#ifdef MGf_DUP
1471 coro_state_dup,
1472#else
1473# define MGf_DUP 0
1474#endif
1475};
1476
1477static void
1478prepare_transfer (pTHX_ struct coro_transfer_args *ta, SV *prev_sv, SV *next_sv)
1479{
1480 ta->prev = SvSTATE (prev_sv);
1481 ta->next = SvSTATE (next_sv);
1482 TRANSFER_CHECK (*ta);
1483}
1484
1485static void
1486api_transfer (pTHX_ SV *prev_sv, SV *next_sv)
1487{
1488 struct coro_transfer_args ta;
1489
1490 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1491 TRANSFER (ta, 1);
1492}
1493
1494/** Coro ********************************************************************/
1495
1496INLINE void
1497coro_enq (pTHX_ struct coro *coro)
1498{
1499 av_push (coro_ready [coro->prio - PRIO_MIN], SvREFCNT_inc_NN (coro->hv));
1500}
1501
1502INLINE SV *
1503coro_deq (pTHX)
1504{
1505 int prio;
1506
1507 for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
1508 if (AvFILLp (coro_ready [prio]) >= 0)
1509 return av_shift (coro_ready [prio]);
1510
1511 return 0;
1512}
1513
1514static int
1515api_ready (pTHX_ SV *coro_sv)
1516{
1517 struct coro *coro;
1518 SV *sv_hook;
1519 void (*xs_hook)(void);
1520
1521 if (SvROK (coro_sv))
1522 coro_sv = SvRV (coro_sv);
1523
1524 coro = SvSTATE (coro_sv);
1525
1526 if (coro->flags & CF_READY)
1527 return 0;
1528
1529 coro->flags |= CF_READY;
1530
1531 sv_hook = coro_nready ? 0 : coro_readyhook;
1532 xs_hook = coro_nready ? 0 : coroapi.readyhook;
1533
1534 coro_enq (aTHX_ coro);
1535 ++coro_nready;
1536
1537 if (sv_hook)
1538 {
1539 dSP;
1540
1541 ENTER;
1542 SAVETMPS;
1543
1544 PUSHMARK (SP);
1545 PUTBACK;
1546 call_sv (sv_hook, G_DISCARD);
1547 SPAGAIN;
1548
1549 FREETMPS;
1550 LEAVE;
1551 }
1552
1553 if (xs_hook)
1554 xs_hook ();
1555
1556 return 1;
1557}
1558
1559static int
1560api_is_ready (pTHX_ SV *coro_sv)
1561{
1562 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1563}
1564
1565INLINE void
1566prepare_schedule (pTHX_ struct coro_transfer_args *ta)
1567{
1568 SV *prev_sv, *next_sv;
1569
1570 for (;;)
1571 {
1572 next_sv = coro_deq (aTHX);
1573
1574 /* nothing to schedule: call the idle handler */
1575 if (expect_false (!next_sv))
1576 {
1577 dSP;
1578
1579 ENTER;
1580 SAVETMPS;
1581
1582 PUSHMARK (SP);
1583 PUTBACK;
1584 call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
1585 SPAGAIN;
1586
1587 FREETMPS;
1588 LEAVE;
1589 continue;
1590 }
1591
1592 ta->next = SvSTATE_hv (next_sv);
1593
1594 /* cannot transfer to destroyed coros, skip and look for next */
1595 if (expect_false (ta->next->flags & CF_DESTROYED))
1596 {
1597 SvREFCNT_dec (next_sv);
1598 /* coro_nready has already been taken care of by destroy */
1599 continue;
1600 }
1601
1602 --coro_nready;
1603 break;
1604 }
1605
1606 /* free this only after the transfer */
1607 prev_sv = SvRV (coro_current);
1608 ta->prev = SvSTATE_hv (prev_sv);
1609 TRANSFER_CHECK (*ta);
1610 assert (("FATAL: next coroutine isn't marked as ready in Coro (please report)", ta->next->flags & CF_READY));
1611 ta->next->flags &= ~CF_READY;
1612 SvRV_set (coro_current, next_sv);
1613
1614 free_coro_mortal (aTHX);
1615 coro_mortal = prev_sv;
1616}
1617
1618INLINE void
1619prepare_cede (pTHX_ struct coro_transfer_args *ta)
1620{
1621 api_ready (aTHX_ coro_current);
1622 prepare_schedule (aTHX_ ta);
1623}
1624
1625INLINE void
1626prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
1627{
1628 SV *prev = SvRV (coro_current);
1629
1630 if (coro_nready)
1631 {
1632 prepare_schedule (aTHX_ ta);
1633 api_ready (aTHX_ prev);
1634 }
1635 else
1636 prepare_nop (aTHX_ ta);
1637}
1638
1639static void
1640api_schedule (pTHX)
1641{
1642 struct coro_transfer_args ta;
1643
1644 prepare_schedule (aTHX_ &ta);
1645 TRANSFER (ta, 1);
1646}
1647
1648static int
1649api_cede (pTHX)
1650{
1651 struct coro_transfer_args ta;
1652
1653 prepare_cede (aTHX_ &ta);
1654
1655 if (expect_true (ta.prev != ta.next))
1656 {
1657 TRANSFER (ta, 1);
1658 return 1;
1659 }
1660 else
1661 return 0;
1662}
1663
1664static int
1665api_cede_notself (pTHX)
1666{
1667 if (coro_nready)
1668 {
1669 struct coro_transfer_args ta;
1670
1671 prepare_cede_notself (aTHX_ &ta);
1672 TRANSFER (ta, 1);
1673 return 1;
1674 }
1675 else
1676 return 0;
1677}
1678
1679static void
1680api_trace (pTHX_ SV *coro_sv, int flags)
1681{
1682 struct coro *coro = SvSTATE (coro_sv);
1683
1684 if (flags & CC_TRACE)
1685 {
1686 if (!coro->cctx)
1687 coro->cctx = cctx_new_run ();
1688 else if (!(coro->cctx->flags & CC_TRACE))
1689 croak ("cannot enable tracing on coroutine with custom stack,");
1690
1691 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
1692 }
1693 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
1694 {
1695 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
1696
1697 if (coro->flags & CF_RUNNING)
1698 PL_runops = RUNOPS_DEFAULT;
1699 else
1700 coro->slot->runops = RUNOPS_DEFAULT;
1701 }
1702}
1703
1704/*****************************************************************************/
1705/* PerlIO::cede */
1706
1707typedef struct
1708{
1709 PerlIOBuf base;
1710 NV next, every;
1711} PerlIOCede;
1712
1713static IV
1714PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1715{
1716 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1717
1718 self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
1719 self->next = nvtime () + self->every;
1720
1721 return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
1722}
1723
1724static SV *
1725PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
1726{
1727 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1728
1729 return newSVnv (self->every);
1730}
1731
1732static IV
1733PerlIOCede_flush (pTHX_ PerlIO *f)
1734{
1735 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
1736 double now = nvtime ();
1737
1738 if (now >= self->next)
1739 {
1740 api_cede (aTHX);
1741 self->next = now + self->every;
1742 }
1743
1744 return PerlIOBuf_flush (aTHX_ f);
1745}
1746
1747static PerlIO_funcs PerlIO_cede =
1748{
1749 sizeof(PerlIO_funcs),
1750 "cede",
1751 sizeof(PerlIOCede),
1752 PERLIO_K_DESTRUCT | PERLIO_K_RAW,
1753 PerlIOCede_pushed,
1754 PerlIOBuf_popped,
1755 PerlIOBuf_open,
1756 PerlIOBase_binmode,
1757 PerlIOCede_getarg,
1758 PerlIOBase_fileno,
1759 PerlIOBuf_dup,
1760 PerlIOBuf_read,
1761 PerlIOBuf_unread,
1762 PerlIOBuf_write,
1763 PerlIOBuf_seek,
1764 PerlIOBuf_tell,
1765 PerlIOBuf_close,
1766 PerlIOCede_flush,
1767 PerlIOBuf_fill,
1768 PerlIOBase_eof,
1769 PerlIOBase_error,
1770 PerlIOBase_clearerr,
1771 PerlIOBase_setlinebuf,
1772 PerlIOBuf_get_base,
1773 PerlIOBuf_bufsiz,
1774 PerlIOBuf_get_ptr,
1775 PerlIOBuf_get_cnt,
1776 PerlIOBuf_set_ptrcnt,
1777};
1778
1779/*****************************************************************************/
1780
1781static UNOP slf_restore; /* restore stack as entersub did, for first-re-run */
1782static const CV *slf_cv;
1783static SV **slf_argv;
1784static int slf_argc, slf_arga; /* count, allocated */
1785static I32 slf_ax; /* top of stack, for restore */
1786
1787/* this restores the stack in the case we patched the entersub, to */
1788/* recreate the stack frame as perl will on following calls */
1789/* since entersub cleared the stack */
1790static OP *
1791pp_restore (pTHX)
1792{
1793 int i;
1794 SV **SP = PL_stack_base + slf_ax;
1795
1796 PUSHMARK (SP);
1797
1798 EXTEND (SP, slf_argc + 1);
1799
1800 for (i = 0; i < slf_argc; ++i)
1801 PUSHs (sv_2mortal (slf_argv [i]));
1802
1803 PUSHs ((SV *)CvGV (slf_cv));
1804
1805 RETURNOP (slf_restore.op_first);
1806}
1807
1808static void
1809slf_prepare_set_stacklevel (pTHX_ struct coro_transfer_args *ta)
1810{
1811 prepare_set_stacklevel (ta, (struct coro_cctx *)slf_frame.data);
1812}
1813
1814static void
1815slf_init_set_stacklevel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1816{
1817 assert (("FATAL: set_stacklevel needs the coro cctx as sole argument", items == 1));
1818
1819 frame->prepare = slf_prepare_set_stacklevel;
1820 frame->check = slf_check_nop;
1821 frame->data = (void *)SvIV (arg [0]);
1822}
1823
1824static void
1825slf_prepare_transfer (pTHX_ struct coro_transfer_args *ta)
1826{
1827 SV **arg = (SV **)slf_frame.data;
1828
1829 prepare_transfer (aTHX_ ta, arg [0], arg [1]);
1830}
1831
1832static void
1833slf_init_transfer (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1834{
1835 if (items != 2)
1836 croak ("Coro::State::transfer (prev, next) expects two arguments, not %d,", items);
1837
1838 frame->prepare = slf_prepare_transfer;
1839 frame->check = slf_check_nop;
1840 frame->data = (void *)arg; /* let's hope it will stay valid */
1841}
1842
1843static void
1844slf_init_schedule (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1845{
1846 frame->prepare = prepare_schedule;
1847 frame->check = slf_check_nop;
1848}
1849
1850static void
1851slf_init_cede (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1852{
1853 frame->prepare = prepare_cede;
1854 frame->check = slf_check_nop;
1855}
1856
1857static void
1858slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1859{
1860 frame->prepare = prepare_cede_notself;
1861 frame->check = slf_check_nop;
1862}
1863
1864/* we hijack an hopefully unused CV flag for our purposes */
1865#define CVf_SLF 0x4000
1866
1867/*
1868 * these not obviously related functions are all rolled into one
1869 * function to increase chances that they all will call transfer with the same
1870 * stack offset
1871 * SLF stands for "schedule-like-function".
1872 */
1873static OP *
1874pp_slf (pTHX)
1875{
1876 I32 checkmark; /* mark SP to see how many elements check has pushed */
1877
1878 /* set up the slf frame, unless it has already been set-up */
1879 /* the latter happens when a new coro has been started */
1880 /* or when a new cctx was attached to an existing coroutine */
1881 if (expect_true (!slf_frame.prepare))
1882 {
1883 /* first iteration */
1884 dSP;
1885 SV **arg = PL_stack_base + TOPMARK + 1;
1886 int items = SP - arg; /* args without function object */
1887 SV *gv = *sp;
1888
1889 /* do a quick consistency check on the "function" object, and if it isn't */
1890 /* for us, divert to the real entersub */
1891 if (SvTYPE (gv) != SVt_PVGV || !(CvFLAGS (GvCV (gv)) & CVf_SLF))
1892 return PL_ppaddr[OP_ENTERSUB](aTHX);
1893
1894 if (!(PL_op->op_flags & OPf_STACKED))
1895 {
1896 /* ampersand-form of call, use @_ instead of stack */
1897 AV *av = GvAV (PL_defgv);
1898 arg = AvARRAY (av);
1899 items = AvFILLp (av) + 1;
1900 }
1901
1902 /* now call the init function, which needs to set up slf_frame */
1903 ((coro_slf_cb)CvXSUBANY (GvCV (gv)).any_ptr)
1904 (aTHX_ &slf_frame, GvCV (gv), arg, items);
1905
1906 /* pop args */
1907 SP = PL_stack_base + POPMARK;
1908
1909 PUTBACK;
1910 }
1911
1912 /* now that we have a slf_frame, interpret it! */
1913 /* we use a callback system not to make the code needlessly */
1914 /* complicated, but so we can run multiple perl coros from one cctx */
1915
1916 do
1917 {
1918 struct coro_transfer_args ta;
1919
1920 slf_frame.prepare (aTHX_ &ta);
1921 TRANSFER (ta, 0);
1922
1923 checkmark = PL_stack_sp - PL_stack_base;
1924 }
1925 while (slf_frame.check (aTHX_ &slf_frame));
1926
1927 slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */
1928
1929 /* return value handling - mostly like entersub */
1930 {
1931 dSP;
1932 SV **bot = PL_stack_base + checkmark;
1933 int gimme = GIMME_V;
1934
1935 /* make sure we put something on the stack in scalar context */
1936 if (gimme == G_SCALAR)
1937 {
1938 if (sp == bot)
1939 XPUSHs (&PL_sv_undef);
1940
1941 SP = bot + 1;
1942 }
1943
1944 PUTBACK;
1945 }
1946
1947 /* exception handling */
1948 if (expect_false (coro_throw))
1949 {
1950 SV *exception = sv_2mortal (coro_throw);
1951
1952 coro_throw = 0;
1953 sv_setsv (ERRSV, exception);
1954 croak (0);
1955 }
1956
1957 return NORMAL;
1958}
1959
1960static void
1961api_execute_slf (pTHX_ CV *cv, coro_slf_cb init_cb, I32 ax)
1962{
1963 int i;
1964 SV **arg = PL_stack_base + ax;
1965 int items = PL_stack_sp - arg + 1;
1966
1967 assert (("FATAL: SLF call with illegal CV value", !CvANON (cv)));
1968
1969 if (PL_op->op_ppaddr != PL_ppaddr [OP_ENTERSUB]
1970 && PL_op->op_ppaddr != pp_slf)
1971 croak ("FATAL: Coro SLF calls can only be made normally, not via goto or any other means, caught");
1972
1973 CvFLAGS (cv) |= CVf_SLF;
1974 CvXSUBANY (cv).any_ptr = (void *)init_cb;
1975 slf_cv = cv;
1976
1977 /* we patch the op, and then re-run the whole call */
1978 /* we have to put the same argument on the stack for this to work */
1979 /* and this will be done by pp_restore */
1980 slf_restore.op_next = (OP *)&slf_restore;
1981 slf_restore.op_type = OP_CUSTOM;
1982 slf_restore.op_ppaddr = pp_restore;
1983 slf_restore.op_first = PL_op;
1984
1985 slf_ax = ax - 1; /* undo the ax++ inside dAXMARK */
1986
1987 if (items > slf_arga)
1988 {
1989 slf_arga = items;
1990 free (slf_argv);
1991 slf_argv = malloc (slf_arga * sizeof (SV *));
1992 }
1993
1994 slf_argc = items;
1995
1996 for (i = 0; i < items; ++i)
1997 slf_argv [i] = SvREFCNT_inc (arg [i]);
1998
1999 PL_op->op_ppaddr = pp_slf;
2000 PL_op->op_type = OP_CUSTOM; /* maybe we should leave it at entersub? */
2001
2002 PL_op = (OP *)&slf_restore;
2003}
2004
2005/*****************************************************************************/
2006
2007static void
2008coro_semaphore_adjust (pTHX_ AV *av, IV adjust)
2009{
2010 SV *count_sv = AvARRAY (av)[0];
2011 IV count = SvIVX (count_sv);
2012
2013 count += adjust;
2014 SvIVX (count_sv) = count;
2015
2016 /* now wake up as many waiters as are expected to lock */
2017 while (count > 0 && AvFILLp (av) > 0)
2018 {
2019 SV *cb;
2020
2021 /* swap first two elements so we can shift a waiter */
2022 AvARRAY (av)[0] = AvARRAY (av)[1];
2023 AvARRAY (av)[1] = count_sv;
2024 cb = av_shift (av);
2025
2026 if (SvOBJECT (cb))
2027 api_ready (aTHX_ cb);
2028 else
2029 croak ("callbacks not yet supported");
2030
2031 SvREFCNT_dec (cb);
2032
2033 --count;
2034 }
2035}
2036
2037static void
2038coro_semaphore_on_destroy (pTHX_ struct coro *coro)
2039{
2040 /* call $sem->adjust (0) to possibly wake up some other waiters */
2041 coro_semaphore_adjust (aTHX_ (AV *)coro->slf_frame.data, 0);
2042}
2043
2044static int
2045slf_check_semaphore_down (pTHX_ struct CoroSLF *frame)
2046{
2047 AV *av = (AV *)frame->data;
2048 SV *count_sv = AvARRAY (av)[0];
2049
2050 if (SvIVX (count_sv) > 0)
2051 {
2052 SvSTATE_current->on_destroy = 0;
2053 SvIVX (count_sv) = SvIVX (count_sv) - 1;
2054 return 0;
2055 }
2056 else
2057 {
2058 int i;
2059 /* if we were woken up but can't down, we look through the whole */
2060 /* waiters list and only add us if we aren't in there already */
2061 /* this avoids some degenerate memory usage cases */
2062
2063 for (i = 1; i <= AvFILLp (av); ++i)
2064 if (AvARRAY (av)[i] == SvRV (coro_current))
2065 return 1;
2066
2067 av_push (av, SvREFCNT_inc (SvRV (coro_current)));
2068 return 1;
2069 }
2070}
2071
2072static void
2073slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2074{
2075 AV *av = (AV *)SvRV (arg [0]);
2076
2077 if (SvIVX (AvARRAY (av)[0]) > 0)
2078 {
2079 frame->data = (void *)av;
2080 frame->prepare = prepare_nop;
2081 SvSTATE_current->on_destroy = coro_semaphore_on_destroy;
2082 }
2083 else
2084 {
2085 av_push (av, SvREFCNT_inc (SvRV (coro_current)));
2086
2087 frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
2088 frame->prepare = prepare_schedule;
2089
2090 /* to avoid race conditions when a woken-up coro gets terminated */
2091 /* we arrange for a temporary on_destroy that calls adjust (0) */
2092 assert (!SvSTATE_current->on_destroy);//D
2093 SvSTATE_current->on_destroy = coro_semaphore_on_destroy;
2094 }
2095
2096 frame->check = slf_check_semaphore_down;
2097
2098}
2099
2100/*****************************************************************************/
2101
2102#define GENSUB_ARG CvXSUBANY (cv).any_ptr
2103
2104/* create a closure from XS, returns a code reference */
2105/* the arg can be accessed via GENSUB_ARG from the callback */
2106/* the callback must use dXSARGS/XSRETURN */
2107static SV *
2108gensub (pTHX_ void (*xsub)(pTHX_ CV *), void *arg)
2109{
2110 CV *cv = (CV *)NEWSV (0, 0);
2111
2112 sv_upgrade ((SV *)cv, SVt_PVCV);
2113
2114 CvANON_on (cv);
2115 CvISXSUB_on (cv);
2116 CvXSUB (cv) = xsub;
2117 GENSUB_ARG = arg;
2118
2119 return newRV_noinc ((SV *)cv);
2120}
2121
2122/*****************************************************************************/
2123
2124MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
2125
2126PROTOTYPES: DISABLE
2127
2128BOOT:
2129{
2130#ifdef USE_ITHREADS
2131# if CORO_PTHREAD
2132 coro_thx = PERL_GET_CONTEXT;
2133# endif
2134#endif
2135 BOOT_PAGESIZE;
2136
2137 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
2138 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
2139
2140 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
2141 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
2142 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
2143
2144 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
2145 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
2146 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
2147
2148 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
2149
2150 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
2151 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
2152 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
2153 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
2154
2155 main_mainstack = PL_mainstack;
2156 main_top_env = PL_top_env;
2157
2158 while (main_top_env->je_prev)
2159 main_top_env = main_top_env->je_prev;
2160
2161 {
2162 SV *slf = sv_2mortal (newSViv (PTR2IV (pp_slf)));
2163
2164 if (!PL_custom_op_names) PL_custom_op_names = newHV ();
2165 hv_store_ent (PL_custom_op_names, slf,
2166 newSVpv ("coro_slf", 0), 0);
2167
2168 if (!PL_custom_op_descs) PL_custom_op_descs = newHV ();
2169 hv_store_ent (PL_custom_op_descs, slf,
2170 newSVpv ("coro schedule like function", 0), 0);
2171 }
2172
2173 coroapi.ver = CORO_API_VERSION;
2174 coroapi.rev = CORO_API_REVISION;
2175
2176 coroapi.transfer = api_transfer;
2177
2178 coroapi.sv_state = SvSTATE_;
2179 coroapi.execute_slf = api_execute_slf;
2180 coroapi.prepare_nop = prepare_nop;
2181 coroapi.prepare_schedule = prepare_schedule;
2182 coroapi.prepare_cede = prepare_cede;
2183 coroapi.prepare_cede_notself = prepare_cede_notself;
2184
2185 {
2186 SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
2187
2188 if (!svp) croak ("Time::HiRes is required");
2189 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
2190
2191 nvtime = INT2PTR (double (*)(), SvIV (*svp));
2192 }
2193
2194 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
2195}
2196
2197SV *
2198new (char *klass, ...)
2199 CODE:
2200{
2201 struct coro *coro;
2202 MAGIC *mg;
2203 HV *hv;
2204 int i;
2205
2206 Newz (0, coro, 1, struct coro);
2207 coro->args = newAV ();
2208 coro->flags = CF_NEW;
2209
2210 if (coro_first) coro_first->prev = coro;
2211 coro->next = coro_first;
2212 coro_first = coro;
2213
2214 coro->hv = hv = newHV ();
2215 mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
2216 mg->mg_flags |= MGf_DUP;
2217 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
2218
2219 av_extend (coro->args, items - 1);
2220 for (i = 1; i < items; i++)
2221 av_push (coro->args, newSVsv (ST (i)));
2222}
2223 OUTPUT:
2224 RETVAL
2225
2226void
2227_set_stacklevel (...)
2228 CODE:
2229 CORO_EXECUTE_SLF_XS (slf_init_set_stacklevel);
2230
2231void
2232transfer (...)
2233 PROTOTYPE: $$
2234 CODE:
2235 CORO_EXECUTE_SLF_XS (slf_init_transfer);
2236
2237bool
2238_destroy (SV *coro_sv)
2239 CODE:
2240 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
2241 OUTPUT:
2242 RETVAL
2243
2244void
2245_exit (int code)
2246 PROTOTYPE: $
2247 CODE:
2248 _exit (code);
2249
2250int
2251cctx_stacksize (int new_stacksize = 0)
2252 PROTOTYPE: ;$
2253 CODE:
2254 RETVAL = cctx_stacksize;
2255 if (new_stacksize)
2256 {
2257 cctx_stacksize = new_stacksize;
2258 ++cctx_gen;
2259 }
2260 OUTPUT:
2261 RETVAL
2262
2263int
2264cctx_max_idle (int max_idle = 0)
2265 PROTOTYPE: ;$
2266 CODE:
2267 RETVAL = cctx_max_idle;
2268 if (max_idle > 1)
2269 cctx_max_idle = max_idle;
2270 OUTPUT:
2271 RETVAL
2272
2273int
2274cctx_count ()
2275 PROTOTYPE:
2276 CODE:
2277 RETVAL = cctx_count;
2278 OUTPUT:
2279 RETVAL
2280
2281int
2282cctx_idle ()
2283 PROTOTYPE:
2284 CODE:
2285 RETVAL = cctx_idle;
2286 OUTPUT:
2287 RETVAL
2288
2289void
2290list ()
2291 PROTOTYPE:
2292 PPCODE:
2293{
2294 struct coro *coro;
2295 for (coro = coro_first; coro; coro = coro->next)
2296 if (coro->hv)
2297 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
2298}
2299
2300void
2301call (Coro::State coro, SV *coderef)
2302 ALIAS:
2303 eval = 1
2304 CODE:
2305{
2306 if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
2307 {
2308 struct coro temp;
2309
2310 if (!(coro->flags & CF_RUNNING))
235 { 2311 {
236 /* I never used formats, so how should I know how these are implemented? */ 2312 PUTBACK;
237 /* my bold guess is as a simple, plain sub... */ 2313 save_perl (aTHX_ &temp);
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 2314 load_perl (aTHX_ coro);
2315 }
2316
2317 {
2318 dSP;
2319 ENTER;
2320 SAVETMPS;
2321 PUTBACK;
2322 PUSHSTACK;
2323 PUSHMARK (SP);
2324
2325 if (ix)
2326 eval_sv (coderef, 0);
2327 else
2328 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
2329
2330 POPSTACK;
2331 SPAGAIN;
2332 FREETMPS;
2333 LEAVE;
2334 PUTBACK;
2335 }
2336
2337 if (!(coro->flags & CF_RUNNING))
2338 {
2339 save_perl (aTHX_ coro);
2340 load_perl (aTHX_ &temp);
2341 SPAGAIN;
239 } 2342 }
240 } 2343 }
241
242 if (top_si->si_type == PERLSI_MAIN)
243 break;
244
245 top_si = top_si->si_prev;
246 ccstk = top_si->si_cxstack;
247 cxix = top_si->si_cxix;
248 }
249
250 PUTBACK;
251 }
252
253 c->dowarn = PL_dowarn;
254 c->defav = GvAV (PL_defgv);
255 c->curstackinfo = PL_curstackinfo;
256 c->curstack = PL_curstack;
257 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp;
259 c->op = PL_op;
260 c->curpad = PL_curpad;
261 c->stack_base = PL_stack_base;
262 c->stack_max = PL_stack_max;
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} 2344}
281 2345
282static void 2346SV *
283LOAD(pTHX_ Coro__State c) 2347is_ready (Coro::State coro)
284{ 2348 PROTOTYPE: $
285 PL_dowarn = c->dowarn; 2349 ALIAS:
286 GvAV (PL_defgv) = c->defav; 2350 is_ready = CF_READY
287 PL_curstackinfo = c->curstackinfo; 2351 is_running = CF_RUNNING
288 PL_curstack = c->curstack; 2352 is_new = CF_NEW
289 PL_mainstack = c->mainstack; 2353 is_destroyed = CF_DESTROYED
290 PL_stack_sp = c->stack_sp; 2354 CODE:
291 PL_op = c->op; 2355 RETVAL = boolSV (coro->flags & ix);
292 PL_curpad = c->curpad; 2356 OUTPUT:
293 PL_stack_base = c->stack_base; 2357 RETVAL
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;
301 PL_markstack_max = c->markstack_max;
302 PL_scopestack = c->scopestack;
303 PL_scopestack_ix = c->scopestack_ix;
304 PL_scopestack_max = c->scopestack_max;
305 PL_savestack = c->savestack;
306 PL_savestack_ix = c->savestack_ix;
307 PL_savestack_max = c->savestack_max;
308 PL_retstack = c->retstack;
309 PL_retstack_ix = c->retstack_ix;
310 PL_retstack_max = c->retstack_max;
311 PL_curcop = c->curcop;
312 2358
2359void
2360throw (Coro::State self, SV *throw = &PL_sv_undef)
2361 PROTOTYPE: $;$
2362 CODE:
2363{
2364 struct coro *current = SvSTATE_current;
2365 SV **throwp = self == current ? &coro_throw : &self->throw;
2366 SvREFCNT_dec (*throwp);
2367 *throwp = SvOK (throw) ? newSVsv (throw) : 0;
2368}
2369
2370void
2371api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
2372 PROTOTYPE: $;$
2373 C_ARGS: aTHX_ coro, flags
2374
2375SV *
2376has_cctx (Coro::State coro)
2377 PROTOTYPE: $
2378 CODE:
2379 RETVAL = boolSV (!!coro->cctx);
2380 OUTPUT:
2381 RETVAL
2382
2383int
2384is_traced (Coro::State coro)
2385 PROTOTYPE: $
2386 CODE:
2387 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
2388 OUTPUT:
2389 RETVAL
2390
2391UV
2392rss (Coro::State coro)
2393 PROTOTYPE: $
2394 ALIAS:
2395 usecount = 1
2396 CODE:
2397 switch (ix)
313 { 2398 {
314 dSP; 2399 case 0: RETVAL = coro_rss (aTHX_ coro); break;
315 CV *cv; 2400 case 1: RETVAL = coro->usecount; break;
316
317 /* now do the ugly restore mess */
318 while ((cv = (CV *)POPs))
319 {
320 AV *padlist = (AV *)POPs;
321
322 put_padlist (cv);
323 CvPADLIST(cv) = padlist;
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 } 2401 }
2402 OUTPUT:
2403 RETVAL
331 2404
332 PUTBACK; 2405void
333 } 2406force_cctx ()
334} 2407 PROTOTYPE:
2408 CODE:
2409 SvSTATE_current->cctx->idle_sp = 0;
335 2410
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 2411void
337STATIC void 2412swap_defsv (Coro::State self)
338destroy_stacks(pTHX) 2413 PROTOTYPE: $
339{ 2414 ALIAS:
340 dSP; 2415 swap_defav = 1
2416 CODE:
2417 if (!self->slot)
2418 croak ("cannot swap state with coroutine that has no saved state,");
2419 else
2420 {
2421 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
2422 SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
341 2423
342 /* die does this while calling POPSTACK, but I just don't see why. */ 2424 SV *tmp = *src; *src = *dst; *dst = tmp;
343 dounwind(-1); 2425 }
344 2426
345 /* is this ugly, I ask? */
346 while (PL_scopestack_ix)
347 LEAVE;
348
349 while (PL_curstackinfo->si_next)
350 PL_curstackinfo = PL_curstackinfo->si_next;
351
352 while (PL_curstackinfo)
353 {
354 PERL_SI *p = PL_curstackinfo->si_prev;
355
356 SvREFCNT_dec(PL_curstackinfo->si_stack);
357 Safefree(PL_curstackinfo->si_cxstack);
358 Safefree(PL_curstackinfo);
359 PL_curstackinfo = p;
360 }
361
362 if (PL_scopestack_ix != 0)
363 Perl_warner(aTHX_ WARN_INTERNAL,
364 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365 (long)PL_scopestack_ix);
366 if (PL_savestack_ix != 0)
367 Perl_warner(aTHX_ WARN_INTERNAL,
368 "Unbalanced saves: %ld more saves than restores\n",
369 (long)PL_savestack_ix);
370 if (PL_tmps_floor != -1)
371 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372 (long)PL_tmps_floor + 1);
373 /*
374 */
375 Safefree(PL_tmps_stack);
376 Safefree(PL_markstack);
377 Safefree(PL_scopestack);
378 Safefree(PL_savestack);
379 Safefree(PL_retstack);
380}
381
382#define SUB_INIT "Coro::State::_newcoro"
383
384MODULE = Coro::State PACKAGE = Coro::State 2427MODULE = Coro::State PACKAGE = Coro
385
386PROTOTYPES: ENABLE
387 2428
388BOOT: 2429BOOT:
389 if (!padlist_cache) 2430{
390 padlist_cache = newHV (); 2431 int i;
391 2432
392Coro::State 2433 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
393_newprocess(args) 2434 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
394 SV * args 2435 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
2436
2437 coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
2438 SvREADONLY_on (coro_current);
2439
2440 coro_stash = gv_stashpv ("Coro", TRUE);
2441
2442 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
2443 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
2444 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
2445 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
2446 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
2447 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
2448
2449 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
2450 coro_ready[i] = newAV ();
2451
2452 {
2453 SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
2454
2455 coroapi.schedule = api_schedule;
2456 coroapi.cede = api_cede;
2457 coroapi.cede_notself = api_cede_notself;
2458 coroapi.ready = api_ready;
2459 coroapi.is_ready = api_is_ready;
2460 coroapi.nready = coro_nready;
2461 coroapi.current = coro_current;
2462
2463 GCoroAPI = &coroapi;
2464 sv_setiv (sv, (IV)&coroapi);
2465 SvREADONLY_on (sv);
2466 }
2467}
2468
2469void
2470schedule (...)
2471 CODE:
2472 CORO_EXECUTE_SLF_XS (slf_init_schedule);
2473
2474void
2475cede (...)
2476 CODE:
2477 CORO_EXECUTE_SLF_XS (slf_init_cede);
2478
2479void
2480cede_notself (...)
2481 CODE:
2482 CORO_EXECUTE_SLF_XS (slf_init_cede_notself);
2483
2484void
2485_set_current (SV *current)
395 PROTOTYPE: $ 2486 PROTOTYPE: $
2487 CODE:
2488 SvREFCNT_dec (SvRV (coro_current));
2489 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
2490
2491void
2492_set_readyhook (SV *hook)
2493 PROTOTYPE: $
396 CODE: 2494 CODE:
397 Coro__State coro; 2495 SvREFCNT_dec (coro_readyhook);
2496 coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
398 2497
399 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 2498int
400 croak ("Coro::State::newprocess expects an arrayref"); 2499prio (Coro::State coro, int newprio = 0)
2500 PROTOTYPE: $;$
2501 ALIAS:
2502 nice = 1
401 2503 CODE:
402 New (0, coro, 1, struct coro); 2504{
403
404 coro->mainstack = 0; /* actual work is done inside transfer */
405 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406
407 RETVAL = coro; 2505 RETVAL = coro->prio;
408 OUTPUT: 2506
2507 if (items > 1)
2508 {
2509 if (ix)
2510 newprio = coro->prio - newprio;
2511
2512 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
2513 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
2514
2515 coro->prio = newprio;
2516 }
2517}
2518 OUTPUT:
409 RETVAL 2519 RETVAL
410 2520
2521SV *
2522ready (SV *self)
2523 PROTOTYPE: $
2524 CODE:
2525 RETVAL = boolSV (api_ready (aTHX_ self));
2526 OUTPUT:
2527 RETVAL
2528
2529int
2530nready (...)
2531 PROTOTYPE:
2532 CODE:
2533 RETVAL = coro_nready;
2534 OUTPUT:
2535 RETVAL
2536
2537# for async_pool speedup
411void 2538void
412transfer(prev,next) 2539_pool_1 (SV *cb)
413 Coro::State_or_hashref prev 2540 CODE:
414 Coro::State_or_hashref next 2541{
415 CODE: 2542 HV *hv = (HV *)SvRV (coro_current);
2543 struct coro *coro = SvSTATE_hv ((SV *)hv);
2544 AV *defav = GvAV (PL_defgv);
2545 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
2546 AV *invoke_av;
2547 int i, len;
416 2548
417 if (prev != next) 2549 if (!invoke)
418 { 2550 {
2551 SV *old = PL_diehook;
2552 PL_diehook = 0;
2553 SvREFCNT_dec (old);
2554 croak ("\3async_pool terminate\2\n");
2555 }
2556
2557 SvREFCNT_dec (coro->saved_deffh);
2558 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
2559
2560 hv_store (hv, "desc", sizeof ("desc") - 1,
2561 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
2562
2563 invoke_av = (AV *)SvRV (invoke);
2564 len = av_len (invoke_av);
2565
2566 sv_setsv (cb, AvARRAY (invoke_av)[0]);
2567
2568 if (len > 0)
2569 {
2570 av_fill (defav, len - 1);
2571 for (i = 0; i < len; ++i)
2572 av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
2573 }
2574}
2575
2576void
2577_pool_2 (SV *cb)
2578 CODE:
2579{
2580 HV *hv = (HV *)SvRV (coro_current);
2581 struct coro *coro = SvSTATE_hv ((SV *)hv);
2582
2583 sv_setsv (cb, &PL_sv_undef);
2584
2585 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
2586 coro->saved_deffh = 0;
2587
2588 if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
2589 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2590 {
2591 SV *old = PL_diehook;
2592 PL_diehook = 0;
2593 SvREFCNT_dec (old);
2594 croak ("\3async_pool terminate\2\n");
2595 }
2596
2597 av_clear (GvAV (PL_defgv));
2598 hv_store (hv, "desc", sizeof ("desc") - 1,
2599 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
2600
2601 coro->prio = 0;
2602
2603 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
2604 api_trace (aTHX_ coro_current, 0);
2605
2606 av_push (av_async_pool, newSVsv (coro_current));
2607}
2608
2609
2610MODULE = Coro::State PACKAGE = Coro::AIO
2611
2612void
2613_get_state (SV *self)
2614 PROTOTYPE: $
2615 PPCODE:
2616{
2617 AV *defav = GvAV (PL_defgv);
2618 AV *av = newAV ();
2619 int i;
2620 SV *data_sv = newSV (sizeof (struct io_state));
2621 struct io_state *data = (struct io_state *)SvPVX (data_sv);
2622 SvCUR_set (data_sv, sizeof (struct io_state));
2623 SvPOK_only (data_sv);
2624
2625 data->errorno = errno;
2626 data->laststype = PL_laststype;
2627 data->laststatval = PL_laststatval;
2628 data->statcache = PL_statcache;
2629
2630 av_extend (av, AvFILLp (defav) + 1 + 1);
2631
2632 for (i = 0; i <= AvFILLp (defav); ++i)
2633 av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
2634
2635 av_push (av, data_sv);
2636
2637 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
2638
2639 api_ready (aTHX_ self);
2640}
2641
2642void
2643_set_state (SV *state)
2644 PROTOTYPE: $
2645 PPCODE:
2646{
2647 AV *av = (AV *)SvRV (state);
2648 struct io_state *data = (struct io_state *)SvPVX (AvARRAY (av)[AvFILLp (av)]);
2649 int i;
2650
2651 errno = data->errorno;
2652 PL_laststype = data->laststype;
2653 PL_laststatval = data->laststatval;
2654 PL_statcache = data->statcache;
2655
2656 EXTEND (SP, AvFILLp (av));
2657 for (i = 0; i < AvFILLp (av); ++i)
2658 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
2659}
2660
2661
2662MODULE = Coro::State PACKAGE = Coro::AnyEvent
2663
2664BOOT:
2665 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
2666
2667void
2668_schedule (...)
2669 CODE:
2670{
2671 static int incede;
2672
2673 api_cede_notself (aTHX);
2674
2675 ++incede;
2676 while (coro_nready >= incede && api_cede (aTHX))
2677 ;
2678
2679 sv_setsv (sv_activity, &PL_sv_undef);
2680 if (coro_nready >= incede)
2681 {
2682 PUSHMARK (SP);
419 PUTBACK; 2683 PUTBACK;
420 SAVE (aTHX_ prev); 2684 call_pv ("Coro::AnyEvent::_activity", G_DISCARD | G_EVAL);
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
435 {
436 /*
437 * emulate part of the perl startup here.
438 */
439 UNOP myop;
440
441 init_stacks (); /* from perl.c */
442 PL_op = (OP *)&myop;
443 /*PL_curcop = 0;*/
444 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445
446 SPAGAIN;
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 }
465 }
466
467void
468DESTROY(coro)
469 Coro::State coro
470 CODE:
471
472 if (coro->mainstack)
473 {
474 struct coro temp;
475
476 PUTBACK;
477 SAVE(aTHX_ (&temp));
478 LOAD(aTHX_ coro);
479
480 destroy_stacks ();
481 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483 LOAD((&temp));
484 SPAGAIN; 2685 SPAGAIN;
485 } 2686 }
486 2687
487 SvREFCNT_dec (coro->args); 2688 --incede;
488 Safefree (coro); 2689}
489 2690
490 2691
2692MODULE = Coro::State PACKAGE = PerlIO::cede
2693
2694BOOT:
2695 PerlIO_define_layer (aTHX_ &PerlIO_cede);
2696
2697MODULE = Coro::State PACKAGE = Coro::Semaphore
2698
2699SV *
2700new (SV *klass, SV *count_ = 0)
2701 CODE:
2702{
2703 /* a semaphore contains a counter IV in $sem->[0] and any waiters after that */
2704 AV *av = newAV ();
2705 av_push (av, newSViv (count_ && SvOK (count_) ? SvIV (count_) : 1));
2706 RETVAL = sv_bless (newRV_noinc ((SV *)av), GvSTASH (CvGV (cv)));
2707}
2708 OUTPUT:
2709 RETVAL
2710
2711SV *
2712count (SV *self)
2713 CODE:
2714 RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]);
2715 OUTPUT:
2716 RETVAL
2717
2718void
2719up (SV *self, int adjust = 1)
2720 ALIAS:
2721 adjust = 1
2722 CODE:
2723 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), ix ? adjust : 1);
2724
2725void
2726down (SV *self)
2727 CODE:
2728 CORO_EXECUTE_SLF_XS (slf_init_semaphore_down);
2729
2730void
2731try (SV *self)
2732 PPCODE:
2733{
2734 AV *av = (AV *)SvRV (self);
2735 SV *count_sv = AvARRAY (av)[0];
2736 IV count = SvIVX (count_sv);
2737
2738 if (count > 0)
2739 {
2740 --count;
2741 SvIVX (count_sv) = count;
2742 XSRETURN_YES;
2743 }
2744 else
2745 XSRETURN_NO;
2746}
2747
2748void
2749waiters (SV *self)
2750 CODE:
2751{
2752 AV *av = (AV *)SvRV (self);
2753
2754 if (GIMME_V == G_SCALAR)
2755 XPUSHs (sv_2mortal (newSVsv (AvARRAY (av)[0])));
2756 else
2757 {
2758 int i;
2759 EXTEND (SP, AvFILLp (av) + 1 - 1);
2760 for (i = 1; i <= AvFILLp (av); ++i)
2761 PUSHs (newSVsv (AvARRAY (av)[i]));
2762 }
2763}
2764

Diff Legend

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