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.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.297 by root, Tue Nov 18 11:04:42 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
162STATIC AV * 515 slf_frame = c->slf_frame;
163unuse_padlist (AV *padlist) 516 CORO_THROW = c->except;
164{
165 free_padlist (padlist);
166} 517}
167 518
168static void 519static void
169SAVE(pTHX_ Coro__State c) 520save_perl (pTHX_ Coro__State c)
170{ 521{
522 c->except = CORO_THROW;
523 c->slf_frame = slf_frame;
524
171 { 525 {
172 dSP; 526 dSP;
173 I32 cxix = cxstack_ix; 527 I32 cxix = cxstack_ix;
528 PERL_CONTEXT *ccstk = cxstack;
174 PERL_SI *top_si = PL_curstackinfo; 529 PERL_SI *top_si = PL_curstackinfo;
175 PERL_CONTEXT *ccstk = cxstack;
176 530
177 /* 531 /*
178 * 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
179 * (and reinitialize) all cv's in the whole callchain :( 533 * (and reinitialize) all cv's in the whole callchain :(
180 */ 534 */
181 535
182 PUSHs (Nullsv); 536 XPUSHs (Nullsv);
183 /* this loop was inspired by pp_caller */ 537 /* this loop was inspired by pp_caller */
184 for (;;) 538 for (;;)
185 { 539 {
186 while (cxix >= 0) 540 while (expect_true (cxix >= 0))
187 { 541 {
188 PERL_CONTEXT *cx = &ccstk[--cxix]; 542 PERL_CONTEXT *cx = &ccstk[cxix--];
189 543
190 if (CxTYPE(cx) == CXt_SUB) 544 if (expect_true (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT))
191 { 545 {
192 CV *cv = cx->blk_sub.cv; 546 CV *cv = cx->blk_sub.cv;
547
193 if (CvDEPTH(cv)) 548 if (expect_true (CvDEPTH (cv)))
194 { 549 {
195#ifdef USE_THREADS
196 XPUSHs ((SV *)CvOWNER(cv));
197#endif
198 EXTEND (SP, 3); 550 EXTEND (SP, 3);
199 PUSHs ((SV *)CvDEPTH(cv));
200 PUSHs ((SV *)CvPADLIST(cv)); 551 PUSHs ((SV *)CvPADLIST (cv));
552 PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
201 PUSHs ((SV *)cv); 553 PUSHs ((SV *)cv);
202 554
203 CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));
204
205 CvDEPTH(cv) = 0; 555 CvDEPTH (cv) = 0;
206#ifdef USE_THREADS 556 get_padlist (aTHX_ cv);
207 CvOWNER(cv) = 0;
208 error must unlock this cv etc.. etc...
209 if you are here wondering about this error message then
210 the reason is that it will not work as advertised yet
211#endif
212 } 557 }
213 } 558 }
214 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 (pTHX_ struct CoroSLF *frame)
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 SvIVX (count_sv) = SvIVX (count_sv) - 1;
2052 return 0;
2053 }
2054 else
2055 {
2056 int i;
2057 /* if we were woken up but can't down, we look through the whole */
2058 /* waiters list and only add us if we aren't in there already */
2059 /* this avoids some degenerate memory usage cases */
2060
2061 for (i = 1; i <= AvFILLp (av); ++i)
2062 if (AvARRAY (av)[i] == SvRV (coro_current))
2063 return 1;
2064
2065 av_push (av, SvREFCNT_inc (SvRV (coro_current)));
2066 return 1;
2067 }
2068}
2069
2070static void
2071slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2072{
2073 AV *av = (AV *)SvRV (arg [0]);
2074
2075 if (SvIVX (AvARRAY (av)[0]) > 0)
2076 {
2077 frame->data = (void *)av;
2078 frame->prepare = prepare_nop;
2079 }
2080 else
2081 {
2082 av_push (av, SvREFCNT_inc (SvRV (coro_current)));
2083
2084 frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
2085 frame->prepare = prepare_schedule;
2086
2087 /* to avoid race conditions when a woken-up coro gets terminated */
2088 /* we arrange for a temporary on_destroy that calls adjust (0) */
2089 SvSTATE_current->on_destroy = coro_semaphore_on_destroy;
2090 }
2091
2092 frame->check = slf_check_semaphore_down;
2093
2094}
2095
2096/*****************************************************************************/
2097/* gensub: simple closure generation utility */
2098
2099#define GENSUB_ARG CvXSUBANY (cv).any_ptr
2100
2101/* create a closure from XS, returns a code reference */
2102/* the arg can be accessed via GENSUB_ARG from the callback */
2103/* the callback must use dXSARGS/XSRETURN */
2104static SV *
2105gensub (pTHX_ void (*xsub)(pTHX_ CV *), void *arg)
2106{
2107 CV *cv = (CV *)newSV (0);
2108
2109 sv_upgrade ((SV *)cv, SVt_PVCV);
2110
2111 CvANON_on (cv);
2112 CvISXSUB_on (cv);
2113 CvXSUB (cv) = xsub;
2114 GENSUB_ARG = arg;
2115
2116 return newRV_noinc ((SV *)cv);
2117}
2118
2119/*****************************************************************************/
2120/* Coro::AIO */
2121
2122#define CORO_MAGIC_type_aio PERL_MAGIC_ext
2123
2124/* helper storage struct */
2125struct io_state
2126{
2127 int errorno;
2128 I32 laststype; /* U16 in 5.10.0 */
2129 int laststatval;
2130 Stat_t statcache;
2131};
2132
2133static void
2134coro_aio_callback (pTHX_ CV *cv)
2135{
2136 dXSARGS;
2137 AV *state = (AV *)GENSUB_ARG;
2138 SV *coro = av_pop (state);
2139 SV *data_sv = newSV (sizeof (struct io_state));
2140
2141 av_extend (state, items);
2142
2143 sv_upgrade (data_sv, SVt_PV);
2144 SvCUR_set (data_sv, sizeof (struct io_state));
2145 SvPOK_only (data_sv);
2146
2147 {
2148 struct io_state *data = (struct io_state *)SvPVX (data_sv);
2149
2150 data->errorno = errno;
2151 data->laststype = PL_laststype;
2152 data->laststatval = PL_laststatval;
2153 data->statcache = PL_statcache;
2154 }
2155
2156 /* now build the result vector out of all the parameters and the data_sv */
2157 {
2158 int i;
2159
2160 for (i = 0; i < items; ++i)
2161 av_push (state, SvREFCNT_inc_NN (ST (i)));
2162 }
2163
2164 av_push (state, data_sv);
2165
2166 api_ready (aTHX_ coro);
2167 SvREFCNT_dec (coro);
2168 SvREFCNT_dec ((AV *)state);
2169}
2170
2171static int
2172slf_check_aio_req (pTHX_ struct CoroSLF *frame)
2173{
2174 AV *state = (AV *)frame->data;
2175
2176 /* if we are about to throw, return early */
2177 /* this does not cancel the aio request, but at least */
2178 /* it quickly returns */
2179 if (CORO_THROW)
2180 return 0;
2181
2182 /* one element that is an RV? repeat! */
2183 if (AvFILLp (state) == 0 && SvROK (AvARRAY (state)[0]))
2184 return 1;
2185
2186 /* restore status */
2187 {
2188 SV *data_sv = av_pop (state);
2189 struct io_state *data = (struct io_state *)SvPVX (data_sv);
2190
2191 errno = data->errorno;
2192 PL_laststype = data->laststype;
2193 PL_laststatval = data->laststatval;
2194 PL_statcache = data->statcache;
2195
2196 SvREFCNT_dec (data_sv);
2197 }
2198
2199 /* push result values */
2200 {
2201 dSP;
2202 int i;
2203
2204 EXTEND (SP, AvFILLp (state) + 1);
2205 for (i = 0; i <= AvFILLp (state); ++i)
2206 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (state)[i])));
2207
2208 PUTBACK;
2209 }
2210
2211 return 0;
2212}
2213
2214static void
2215slf_init_aio_req (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2216{
2217 AV *state = (AV *)sv_2mortal ((SV *)newAV ());
2218 SV *coro_hv = SvRV (coro_current);
2219 struct coro *coro = SvSTATE_hv (coro_hv);
2220
2221 /* put our coroutine id on the state arg */
2222 av_push (state, SvREFCNT_inc_NN (coro_hv));
2223
2224 /* first see whether we have a non-zero priority and set it as AIO prio */
2225 if (coro->prio)
2226 {
2227 dSP;
2228
2229 static SV *prio_cv;
2230 static SV *prio_sv;
2231
2232 if (expect_false (!prio_cv))
2233 {
2234 prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);
2235 prio_sv = newSViv (0);
2236 }
2237
2238 PUSHMARK (SP);
2239 sv_setiv (prio_sv, coro->prio);
2240 XPUSHs (prio_sv);
2241
2242 PUTBACK;
2243 call_sv (prio_cv, G_VOID | G_DISCARD);
2244 }
2245
2246 /* now call the original request */
2247 {
2248 dSP;
2249 CV *req = (CV *)CORO_MAGIC_NN ((SV *)cv, CORO_MAGIC_type_aio)->mg_obj;
2250 int i;
2251
2252 PUSHMARK (SP);
2253
2254 /* first push all args to the stack */
2255 EXTEND (SP, items + 1);
2256
2257 for (i = 0; i < items; ++i)
2258 PUSHs (arg [i]);
2259
2260 /* now push the callback closure */
2261 PUSHs (sv_2mortal (gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));
2262
2263 /* now call the AIO function - we assume our request is uncancelable */
2264 PUTBACK;
2265 call_sv ((SV *)req, G_VOID | G_DISCARD);
2266 }
2267
2268 /* now that the requets is going, we loop toll we have a result */
2269 frame->data = (void *)state;
2270 frame->prepare = prepare_schedule;
2271 frame->check = slf_check_aio_req;
2272}
2273
2274static void
2275coro_aio_req_xs (pTHX_ CV *cv)
2276{
2277 dXSARGS;
2278
2279 CORO_EXECUTE_SLF_XS (slf_init_aio_req);
2280
2281 XSRETURN_EMPTY;
2282}
2283
2284/*****************************************************************************/
2285
2286MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
2287
2288PROTOTYPES: DISABLE
2289
2290BOOT:
2291{
2292#ifdef USE_ITHREADS
2293# if CORO_PTHREAD
2294 coro_thx = PERL_GET_CONTEXT;
2295# endif
2296#endif
2297 BOOT_PAGESIZE;
2298
2299 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
2300 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
2301
2302 orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
2303 orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
2304 orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
2305
2306 hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
2307 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
2308 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
2309
2310 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
2311
2312 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
2313 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
2314 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
2315 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
2316
2317 main_mainstack = PL_mainstack;
2318 main_top_env = PL_top_env;
2319
2320 while (main_top_env->je_prev)
2321 main_top_env = main_top_env->je_prev;
2322
2323 {
2324 SV *slf = sv_2mortal (newSViv (PTR2IV (pp_slf)));
2325
2326 if (!PL_custom_op_names) PL_custom_op_names = newHV ();
2327 hv_store_ent (PL_custom_op_names, slf,
2328 newSVpv ("coro_slf", 0), 0);
2329
2330 if (!PL_custom_op_descs) PL_custom_op_descs = newHV ();
2331 hv_store_ent (PL_custom_op_descs, slf,
2332 newSVpv ("coro schedule like function", 0), 0);
2333 }
2334
2335 coroapi.ver = CORO_API_VERSION;
2336 coroapi.rev = CORO_API_REVISION;
2337
2338 coroapi.transfer = api_transfer;
2339
2340 coroapi.sv_state = SvSTATE_;
2341 coroapi.execute_slf = api_execute_slf;
2342 coroapi.prepare_nop = prepare_nop;
2343 coroapi.prepare_schedule = prepare_schedule;
2344 coroapi.prepare_cede = prepare_cede;
2345 coroapi.prepare_cede_notself = prepare_cede_notself;
2346
2347 {
2348 SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
2349
2350 if (!svp) croak ("Time::HiRes is required");
2351 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
2352
2353 nvtime = INT2PTR (double (*)(), SvIV (*svp));
2354 }
2355
2356 assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
2357}
2358
2359SV *
2360new (char *klass, ...)
2361 CODE:
2362{
2363 struct coro *coro;
2364 MAGIC *mg;
2365 HV *hv;
2366 int i;
2367
2368 Newz (0, coro, 1, struct coro);
2369 coro->args = newAV ();
2370 coro->flags = CF_NEW;
2371
2372 if (coro_first) coro_first->prev = coro;
2373 coro->next = coro_first;
2374 coro_first = coro;
2375
2376 coro->hv = hv = newHV ();
2377 mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
2378 mg->mg_flags |= MGf_DUP;
2379 RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
2380
2381 av_extend (coro->args, items - 1);
2382 for (i = 1; i < items; i++)
2383 av_push (coro->args, newSVsv (ST (i)));
2384}
2385 OUTPUT:
2386 RETVAL
2387
2388void
2389transfer (...)
2390 PROTOTYPE: $$
2391 CODE:
2392 CORO_EXECUTE_SLF_XS (slf_init_transfer);
2393
2394bool
2395_destroy (SV *coro_sv)
2396 CODE:
2397 RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
2398 OUTPUT:
2399 RETVAL
2400
2401void
2402_exit (int code)
2403 PROTOTYPE: $
2404 CODE:
2405 _exit (code);
2406
2407int
2408cctx_stacksize (int new_stacksize = 0)
2409 PROTOTYPE: ;$
2410 CODE:
2411 RETVAL = cctx_stacksize;
2412 if (new_stacksize)
2413 {
2414 cctx_stacksize = new_stacksize;
2415 ++cctx_gen;
2416 }
2417 OUTPUT:
2418 RETVAL
2419
2420int
2421cctx_max_idle (int max_idle = 0)
2422 PROTOTYPE: ;$
2423 CODE:
2424 RETVAL = cctx_max_idle;
2425 if (max_idle > 1)
2426 cctx_max_idle = max_idle;
2427 OUTPUT:
2428 RETVAL
2429
2430int
2431cctx_count ()
2432 PROTOTYPE:
2433 CODE:
2434 RETVAL = cctx_count;
2435 OUTPUT:
2436 RETVAL
2437
2438int
2439cctx_idle ()
2440 PROTOTYPE:
2441 CODE:
2442 RETVAL = cctx_idle;
2443 OUTPUT:
2444 RETVAL
2445
2446void
2447list ()
2448 PROTOTYPE:
2449 PPCODE:
2450{
2451 struct coro *coro;
2452 for (coro = coro_first; coro; coro = coro->next)
2453 if (coro->hv)
2454 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
2455}
2456
2457void
2458call (Coro::State coro, SV *coderef)
2459 ALIAS:
2460 eval = 1
2461 CODE:
2462{
2463 if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
2464 {
2465 struct coro temp;
2466
2467 if (!(coro->flags & CF_RUNNING))
215 { 2468 {
216 /* I never used formats, so how should I know how these are implemented? */ 2469 PUTBACK;
217 /* my bold guess is as a simple, plain sub... */ 2470 save_perl (aTHX_ &temp);
218 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 2471 load_perl (aTHX_ coro);
2472 }
2473
2474 {
2475 dSP;
2476 ENTER;
2477 SAVETMPS;
2478 PUTBACK;
2479 PUSHSTACK;
2480 PUSHMARK (SP);
2481
2482 if (ix)
2483 eval_sv (coderef, 0);
2484 else
2485 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
2486
2487 POPSTACK;
2488 SPAGAIN;
2489 FREETMPS;
2490 LEAVE;
2491 PUTBACK;
2492 }
2493
2494 if (!(coro->flags & CF_RUNNING))
2495 {
2496 save_perl (aTHX_ coro);
2497 load_perl (aTHX_ &temp);
2498 SPAGAIN;
219 } 2499 }
220 } 2500 }
221
222 if (top_si->si_type == PERLSI_MAIN)
223 break;
224
225 top_si = top_si->si_prev;
226 ccstk = top_si->si_cxstack;
227 cxix = top_si->si_cxix;
228 }
229
230 PUTBACK;
231 }
232
233 c->dowarn = PL_dowarn;
234 c->defav = GvAV (PL_defgv);
235 c->curstackinfo = PL_curstackinfo;
236 c->curstack = PL_curstack;
237 c->mainstack = PL_mainstack;
238 c->stack_sp = PL_stack_sp;
239 c->op = PL_op;
240 c->curpad = PL_curpad;
241 c->stack_base = PL_stack_base;
242 c->stack_max = PL_stack_max;
243 c->tmps_stack = PL_tmps_stack;
244 c->tmps_floor = PL_tmps_floor;
245 c->tmps_ix = PL_tmps_ix;
246 c->tmps_max = PL_tmps_max;
247 c->markstack = PL_markstack;
248 c->markstack_ptr = PL_markstack_ptr;
249 c->markstack_max = PL_markstack_max;
250 c->scopestack = PL_scopestack;
251 c->scopestack_ix = PL_scopestack_ix;
252 c->scopestack_max = PL_scopestack_max;
253 c->savestack = PL_savestack;
254 c->savestack_ix = PL_savestack_ix;
255 c->savestack_max = PL_savestack_max;
256 c->retstack = PL_retstack;
257 c->retstack_ix = PL_retstack_ix;
258 c->retstack_max = PL_retstack_max;
259 c->curcop = PL_curcop;
260} 2501}
261 2502
262static void 2503SV *
263LOAD(pTHX_ Coro__State c) 2504is_ready (Coro::State coro)
264{ 2505 PROTOTYPE: $
265 PL_dowarn = c->dowarn; 2506 ALIAS:
266 GvAV (PL_defgv) = c->defav; 2507 is_ready = CF_READY
267 PL_curstackinfo = c->curstackinfo; 2508 is_running = CF_RUNNING
268 PL_curstack = c->curstack; 2509 is_new = CF_NEW
269 PL_mainstack = c->mainstack; 2510 is_destroyed = CF_DESTROYED
270 PL_stack_sp = c->stack_sp; 2511 CODE:
271 PL_op = c->op; 2512 RETVAL = boolSV (coro->flags & ix);
272 PL_curpad = c->curpad; 2513 OUTPUT:
273 PL_stack_base = c->stack_base; 2514 RETVAL
274 PL_stack_max = c->stack_max;
275 PL_tmps_stack = c->tmps_stack;
276 PL_tmps_floor = c->tmps_floor;
277 PL_tmps_ix = c->tmps_ix;
278 PL_tmps_max = c->tmps_max;
279 PL_markstack = c->markstack;
280 PL_markstack_ptr = c->markstack_ptr;
281 PL_markstack_max = c->markstack_max;
282 PL_scopestack = c->scopestack;
283 PL_scopestack_ix = c->scopestack_ix;
284 PL_scopestack_max = c->scopestack_max;
285 PL_savestack = c->savestack;
286 PL_savestack_ix = c->savestack_ix;
287 PL_savestack_max = c->savestack_max;
288 PL_retstack = c->retstack;
289 PL_retstack_ix = c->retstack_ix;
290 PL_retstack_max = c->retstack_max;
291 PL_curcop = c->curcop;
292 2515
2516void
2517throw (Coro::State self, SV *throw = &PL_sv_undef)
2518 PROTOTYPE: $;$
2519 CODE:
2520{
2521 struct coro *current = SvSTATE_current;
2522 SV **throwp = self == current ? &CORO_THROW : &self->except;
2523 SvREFCNT_dec (*throwp);
2524 *throwp = SvOK (throw) ? newSVsv (throw) : 0;
2525}
2526
2527void
2528api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
2529 PROTOTYPE: $;$
2530 C_ARGS: aTHX_ coro, flags
2531
2532SV *
2533has_cctx (Coro::State coro)
2534 PROTOTYPE: $
2535 CODE:
2536 RETVAL = boolSV (!!coro->cctx);
2537 OUTPUT:
2538 RETVAL
2539
2540int
2541is_traced (Coro::State coro)
2542 PROTOTYPE: $
2543 CODE:
2544 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
2545 OUTPUT:
2546 RETVAL
2547
2548UV
2549rss (Coro::State coro)
2550 PROTOTYPE: $
2551 ALIAS:
2552 usecount = 1
2553 CODE:
2554 switch (ix)
293 { 2555 {
294 dSP; 2556 case 0: RETVAL = coro_rss (aTHX_ coro); break;
295 CV *cv; 2557 case 1: RETVAL = coro->usecount; break;
296
297 /* now do the ugly restore mess */
298 while ((cv = (CV *)POPs))
299 {
300 AV *padlist = (AV *)POPs;
301
302 unuse_padlist (CvPADLIST(cv));
303 CvPADLIST(cv) = padlist;
304 CvDEPTH(cv) = (I32)POPs;
305
306#ifdef USE_THREADS
307 CvOWNER(cv) = (struct perl_thread *)POPs;
308 error does not work either
309#endif
310 } 2558 }
2559 OUTPUT:
2560 RETVAL
311 2561
312 PUTBACK; 2562void
313 } 2563force_cctx ()
314} 2564 PROTOTYPE:
2565 CODE:
2566 SvSTATE_current->cctx->idle_sp = 0;
315 2567
316/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */ 2568void
317STATIC void 2569swap_defsv (Coro::State self)
318S_nuke_stacks(pTHX) 2570 PROTOTYPE: $
319{ 2571 ALIAS:
320 while (PL_curstackinfo->si_next) 2572 swap_defav = 1
321 PL_curstackinfo = PL_curstackinfo->si_next; 2573 CODE:
322 while (PL_curstackinfo) { 2574 if (!self->slot)
323 PERL_SI *p = PL_curstackinfo->si_prev; 2575 croak ("cannot swap state with coroutine that has no saved state,");
324 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 2576 else
325 Safefree(PL_curstackinfo->si_cxstack); 2577 {
326 Safefree(PL_curstackinfo); 2578 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
327 PL_curstackinfo = p; 2579 SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
328 }
329 Safefree(PL_tmps_stack);
330 Safefree(PL_markstack);
331 Safefree(PL_scopestack);
332 Safefree(PL_savestack);
333 Safefree(PL_retstack);
334}
335 2580
336#define SUB_INIT "Coro::State::_newcoro" 2581 SV *tmp = *src; *src = *dst; *dst = tmp;
2582 }
337 2583
2584
338MODULE = Coro::State PACKAGE = Coro::State 2585MODULE = Coro::State PACKAGE = Coro
339
340PROTOTYPES: ENABLE
341 2586
342BOOT: 2587BOOT:
343 if (!padlist_cache) 2588{
344 padlist_cache = newHV (); 2589 int i;
345 2590
346Coro::State 2591 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
347_newprocess(args) 2592 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
348 SV * args 2593 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
2594
2595 coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
2596 SvREADONLY_on (coro_current);
2597
2598 coro_stash = gv_stashpv ("Coro", TRUE);
2599
2600 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
2601 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
2602 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
2603 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
2604 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
2605 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
2606
2607 for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
2608 coro_ready[i] = newAV ();
2609
2610 {
2611 SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
2612
2613 coroapi.schedule = api_schedule;
2614 coroapi.cede = api_cede;
2615 coroapi.cede_notself = api_cede_notself;
2616 coroapi.ready = api_ready;
2617 coroapi.is_ready = api_is_ready;
2618 coroapi.nready = coro_nready;
2619 coroapi.current = coro_current;
2620
2621 /*GCoroAPI = &coroapi;*/
2622 sv_setiv (sv, (IV)&coroapi);
2623 SvREADONLY_on (sv);
2624 }
2625}
2626
2627void
2628schedule (...)
2629 CODE:
2630 CORO_EXECUTE_SLF_XS (slf_init_schedule);
2631
2632void
2633cede (...)
2634 CODE:
2635 CORO_EXECUTE_SLF_XS (slf_init_cede);
2636
2637void
2638cede_notself (...)
2639 CODE:
2640 CORO_EXECUTE_SLF_XS (slf_init_cede_notself);
2641
2642void
2643_set_current (SV *current)
349 PROTOTYPE: $ 2644 PROTOTYPE: $
2645 CODE:
2646 SvREFCNT_dec (SvRV (coro_current));
2647 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
2648
2649void
2650_set_readyhook (SV *hook)
2651 PROTOTYPE: $
350 CODE: 2652 CODE:
351 Coro__State coro; 2653 SvREFCNT_dec (coro_readyhook);
2654 coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
352 2655
353 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 2656int
354 croak ("Coro::State::newprocess expects an arrayref"); 2657prio (Coro::State coro, int newprio = 0)
2658 PROTOTYPE: $;$
2659 ALIAS:
2660 nice = 1
355 2661 CODE:
356 New (0, coro, 1, struct coro); 2662{
357
358 coro->mainstack = 0; /* actual work is done inside transfer */
359 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
360
361 RETVAL = coro; 2663 RETVAL = coro->prio;
362 OUTPUT: 2664
2665 if (items > 1)
2666 {
2667 if (ix)
2668 newprio = coro->prio - newprio;
2669
2670 if (newprio < PRIO_MIN) newprio = PRIO_MIN;
2671 if (newprio > PRIO_MAX) newprio = PRIO_MAX;
2672
2673 coro->prio = newprio;
2674 }
2675}
2676 OUTPUT:
363 RETVAL 2677 RETVAL
364 2678
2679SV *
2680ready (SV *self)
2681 PROTOTYPE: $
2682 CODE:
2683 RETVAL = boolSV (api_ready (aTHX_ self));
2684 OUTPUT:
2685 RETVAL
2686
2687int
2688nready (...)
2689 PROTOTYPE:
2690 CODE:
2691 RETVAL = coro_nready;
2692 OUTPUT:
2693 RETVAL
2694
2695# for async_pool speedup
365void 2696void
366transfer(prev,next) 2697_pool_1 (SV *cb)
367 Coro::State_or_hashref prev 2698 CODE:
368 Coro::State_or_hashref next 2699{
2700 HV *hv = (HV *)SvRV (coro_current);
2701 struct coro *coro = SvSTATE_hv ((SV *)hv);
2702 AV *defav = GvAV (PL_defgv);
2703 SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
2704 AV *invoke_av;
2705 int i, len;
2706
2707 if (!invoke)
2708 {
2709 SV *old = PL_diehook;
2710 PL_diehook = 0;
2711 SvREFCNT_dec (old);
2712 croak ("\3async_pool terminate\2\n");
2713 }
2714
2715 SvREFCNT_dec (coro->saved_deffh);
2716 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
2717
2718 hv_store (hv, "desc", sizeof ("desc") - 1,
2719 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
2720
2721 invoke_av = (AV *)SvRV (invoke);
2722 len = av_len (invoke_av);
2723
2724 sv_setsv (cb, AvARRAY (invoke_av)[0]);
2725
2726 if (len > 0)
2727 {
2728 av_fill (defav, len - 1);
2729 for (i = 0; i < len; ++i)
2730 av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
2731 }
2732}
2733
2734void
2735_pool_2 (SV *cb)
2736 CODE:
2737{
2738 HV *hv = (HV *)SvRV (coro_current);
2739 struct coro *coro = SvSTATE_hv ((SV *)hv);
2740
2741 sv_setsv (cb, &PL_sv_undef);
2742
2743 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
2744 coro->saved_deffh = 0;
2745
2746 if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
2747 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2748 {
2749 SV *old = PL_diehook;
2750 PL_diehook = 0;
2751 SvREFCNT_dec (old);
2752 croak ("\3async_pool terminate\2\n");
2753 }
2754
2755 av_clear (GvAV (PL_defgv));
2756 hv_store (hv, "desc", sizeof ("desc") - 1,
2757 newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
2758
2759 coro->prio = 0;
2760
2761 if (coro->cctx && (coro->cctx->flags & CC_TRACE))
2762 api_trace (aTHX_ coro_current, 0);
2763
2764 av_push (av_async_pool, newSVsv (coro_current));
2765}
2766
2767
2768MODULE = Coro::State PACKAGE = PerlIO::cede
2769
2770BOOT:
2771 PerlIO_define_layer (aTHX_ &PerlIO_cede);
2772
2773
2774MODULE = Coro::State PACKAGE = Coro::Semaphore
2775
2776SV *
2777new (SV *klass, SV *count_ = 0)
2778 CODE:
2779{
2780 /* a semaphore contains a counter IV in $sem->[0] and any waiters after that */
2781 AV *av = newAV ();
2782 SV **ary;
2783
2784 /* unfortunately, building manually saves memory */
2785 Newx (ary, 2, SV *);
2786 AvALLOC (av) = ary;
2787 AvARRAY (av) = ary;
2788 AvMAX (av) = 1;
2789 AvFILLp (av) = 0;
2790 ary [0] = newSViv (count_ && SvOK (count_) ? SvIV (count_) : 1);
2791
2792 RETVAL = sv_bless (newRV_noinc ((SV *)av), GvSTASH (CvGV (cv)));
2793}
2794 OUTPUT:
2795 RETVAL
2796
2797SV *
2798count (SV *self)
2799 CODE:
2800 RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]);
2801 OUTPUT:
2802 RETVAL
2803
2804void
2805up (SV *self, int adjust = 1)
2806 ALIAS:
2807 adjust = 1
369 CODE: 2808 CODE:
2809 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), ix ? adjust : 1);
370 2810
371 if (prev != next) 2811void
2812down (SV *self)
2813 CODE:
2814 CORO_EXECUTE_SLF_XS (slf_init_semaphore_down);
2815
2816void
2817try (SV *self)
2818 PPCODE:
2819{
2820 AV *av = (AV *)SvRV (self);
2821 SV *count_sv = AvARRAY (av)[0];
2822 IV count = SvIVX (count_sv);
2823
2824 if (count > 0)
372 { 2825 {
2826 --count;
2827 SvIVX (count_sv) = count;
2828 XSRETURN_YES;
2829 }
2830 else
2831 XSRETURN_NO;
2832}
2833
2834void
2835waiters (SV *self)
2836 CODE:
2837{
2838 AV *av = (AV *)SvRV (self);
2839
2840 if (GIMME_V == G_SCALAR)
2841 XPUSHs (sv_2mortal (newSVsv (AvARRAY (av)[0])));
2842 else
2843 {
2844 int i;
2845 EXTEND (SP, AvFILLp (av) + 1 - 1);
2846 for (i = 1; i <= AvFILLp (av); ++i)
2847 PUSHs (sv_2mortal (newRV_inc (AvARRAY (av)[i])));
2848 }
2849}
2850
2851
2852MODULE = Coro::State PACKAGE = Coro::AnyEvent
2853
2854BOOT:
2855 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
2856
2857void
2858_schedule (...)
2859 CODE:
2860{
2861 static int incede;
2862
2863 api_cede_notself (aTHX);
2864
2865 ++incede;
2866 while (coro_nready >= incede && api_cede (aTHX))
2867 ;
2868
2869 sv_setsv (sv_activity, &PL_sv_undef);
2870 if (coro_nready >= incede)
2871 {
2872 PUSHMARK (SP);
373 PUTBACK; 2873 PUTBACK;
374 SAVE (aTHX_ prev); 2874 call_pv ("Coro::AnyEvent::_activity", G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
375
376 /*
377 * this could be done in newprocess which would lead to
378 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
379 * code here, but lazy allocation of stacks has also
380 * some virtues and the overhead of the if() is nil.
381 */
382 if (next->mainstack)
383 {
384 LOAD (aTHX_ next);
385 next->mainstack = 0; /* unnecessary but much cleaner */
386 SPAGAIN;
387 }
388 else
389 {
390 /*
391 * emulate part of the perl startup here.
392 */
393 UNOP myop;
394
395 init_stacks ();
396 PL_op = (OP *)&myop;
397 /*PL_curcop = 0;*/
398 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399
400 SPAGAIN;
401 Zero(&myop, 1, UNOP);
402 myop.op_next = Nullop;
403 myop.op_flags = OPf_WANT_VOID;
404
405 PUSHMARK(SP);
406 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
407 PUTBACK;
408 /*
409 * the next line is slightly wrong, as PL_op->op_next
410 * is actually being executed so we skip the first op.
411 * that doesn't matter, though, since it is only
412 * pp_nextstate and we never return...
413 */
414 PL_op = Perl_pp_entersub(aTHX);
415 SPAGAIN;
416
417 ENTER;
418 }
419 } 2875 }
420 2876
2877 --incede;
2878}
2879
2880
2881MODULE = Coro::State PACKAGE = Coro::AIO
2882
421void 2883void
422DESTROY(coro) 2884_register (char *target, char *proto, SV *req)
423 Coro::State coro 2885 CODE:
424 CODE: 2886{
2887 HV *st;
2888 GV *gvp;
2889 CV *req_cv = sv_2cv (req, &st, &gvp, 0);
2890 /* newXSproto doesn't return the CV on 5.8 */
2891 CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);
2892 sv_setpv ((SV *)slf_cv, proto);
2893 sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);
2894}
425 2895
426 if (coro->mainstack)
427 {
428 struct coro temp;
429
430 PUTBACK;
431 SAVE(aTHX_ (&temp));
432 LOAD(aTHX_ coro);
433
434 S_nuke_stacks ();
435 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437 LOAD((&temp));
438 SPAGAIN;
439 }
440
441 SvREFCNT_dec (coro->args);
442 Safefree (coro);
443
444

Diff Legend

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