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