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

Diff Legend

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