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

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

Diff Legend

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