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

Diff Legend

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