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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.478 by root, Mon Mar 16 11:12:52 2020 UTC

1/* this works around a bug in mingw32 providing a non-working setjmp */
2#define USE_NO_MINGW_SETJMP_TWO_ARGS
3
4#define NDEBUG 1 /* perl usually disables NDEBUG later */
5
6#include "libcoro/coro.c"
7
8#if CORO_UCONTEXT
9 #define CORO_BACKEND "ucontext"
10#elif CORO_SJLJ
11 #define CORO_BACKEND "sjlj"
12#elif CORO_LINUX
13 #define CORO_BACKEND "linux"
14#elif CORO_LOSER
15 #define CORO_BACKEND "loser"
16#elif CORO_FIBER
17 #define CORO_BACKEND "fiber"
18#elif CORO_IRIX
19 #define CORO_BACKEND "irix"
20#elif CORO_ASM
21 #define CORO_BACKEND "asm"
22#elif CORO_PTHREAD
23 #define CORO_BACKEND "pthread"
24#else
25 #define CORO_BACKEND "unknown"
26#endif
27
28#define PERL_NO_GET_CONTEXT
29#define PERL_EXT
30
1#include "EXTERN.h" 31#include "EXTERN.h"
2#include "perl.h" 32#include "perl.h"
3#include "XSUB.h" 33#include "XSUB.h"
34#include "perliol.h"
4 35
36#include "schmorp.h"
37
38#define ECB_NO_THREADS 1
39#define ECB_NO_LIBM 1
40#include "ecb.h"
41
42#include <stddef.h>
43#include <stdio.h>
44#include <errno.h>
45#include <assert.h>
46
47#ifndef SvREFCNT_dec_NN
48 #define SvREFCNT_dec_NN(sv) SvREFCNT_dec (sv)
49#endif
50
51#ifndef SvREFCNT_inc_NN
52 #define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
53#endif
54
55#ifndef SVs_PADSTALE
56# define SVs_PADSTALE 0
57#endif
58
59#ifdef PadARRAY
60# define NEWPADAPI 1
61# define newPADLIST(var) (Newz (0, var, 1, PADLIST), Newx (PadlistARRAY (var), 2, PAD *))
62#else
63typedef AV PADNAMELIST;
64# if !PERL_VERSION_ATLEAST(5,8,0)
65typedef AV PADLIST;
66typedef AV PAD;
67# endif
68# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
69# define PadlistMAX(pl) AvFILLp (pl)
70# define PadlistNAMES(pl) (*PadlistARRAY (pl))
71# define PadARRAY AvARRAY
72# define PadMAX AvFILLp
73# define newPADLIST(var) ((var) = newAV (), av_extend (var, 1))
74#endif
75#ifndef PadnamelistREFCNT
76# define PadnamelistREFCNT(pnl) SvREFCNT (pnl)
77#endif
78#ifndef PadnamelistREFCNT_dec
79# define PadnamelistREFCNT_dec(pnl) SvREFCNT_dec (pnl)
80#endif
81
82/* 5.19.something has replaced SVt_BIND by SVt_INVLIST */
83/* we just alias it to SVt_IV, as that is sufficient for swap_sv for now */
84#if PERL_VERSION_ATLEAST(5,19,0)
85# define SVt_BIND SVt_IV
86#endif
87
88#if defined(_WIN32)
89# undef HAS_GETTIMEOFDAY
90# undef setjmp
91# undef longjmp
92# undef _exit
93# define setjmp _setjmp /* deep magic */
94#else
95# include <inttypes.h> /* most portable stdint.h */
96#endif
97
98/* the maximum number of idle cctx that will be pooled */
99static int cctx_max_idle = 4;
100
101#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)
102# define HAS_SCOPESTACK_NAME 1
103#endif
104
105/* prefer perl internal functions over our own? */
106#ifndef CORO_PREFER_PERL_FUNCTIONS
107# define CORO_PREFER_PERL_FUNCTIONS 0
108#endif
109
110/* The next macros try to return the current stack pointer, in an as
111 * portable way as possible. */
112#if __GNUC__ >= 4
113# define dSTACKLEVEL int stacklevel_dummy
114# define STACKLEVEL __builtin_frame_address (0)
115#else
116# define dSTACKLEVEL volatile void *stacklevel
117# define STACKLEVEL ((void *)&stacklevel)
118#endif
119
120#define IN_DESTRUCT PL_dirty
121
122#include "CoroAPI.h"
123#define GCoroAPI (&coroapi) /* very sneaky */
124
125#ifdef USE_ITHREADS
126# if CORO_PTHREAD
127static void *coro_thx;
128# endif
129#endif
130
131#ifdef __linux
132# include <time.h> /* for timespec */
133# include <syscall.h> /* for SYS_* */
134# ifdef SYS_clock_gettime
135# define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts))
136# define CORO_CLOCK_MONOTONIC 1
137# define CORO_CLOCK_THREAD_CPUTIME_ID 3
138# endif
139#endif
140
141/* one off bugfix for perl 5.22 */
142#if PERL_VERSION_ATLEAST(5,22,0) && !PERL_VERSION_ATLEAST(5,24,0)
143# undef PadlistNAMES
144# define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY (pl))
145#endif
146
147#if PERL_VERSION_ATLEAST(5,24,0)
148# define SUB_ARGARRAY PL_curpad[0]
149#else
150# define SUB_ARGARRAY (SV *)cx->blk_sub.argarray
151#endif
152
153/* perl usually suppresses asserts. for debugging, we sometimes force it to be on */
5#if 0 154#if 0
6# define CHK(x) (void *)0 155# undef NDEBUG
7#else 156# include <assert.h>
8# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9#endif 157#endif
10 158
159static double (*nvtime)(); /* so why doesn't it take void? */
160static void (*u2time)(pTHX_ UV ret[2]);
161
162/* we hijack an hopefully unused CV flag for our purposes */
163#define CVf_SLF 0x4000
164static OP *pp_slf (pTHX);
165static void slf_destroy (pTHX_ struct coro *coro);
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 AV *av_destroy; /* destruction queue */
176static SV *sv_manager; /* the manager coro */
177static SV *sv_idle; /* $Coro::idle */
178
179static GV *irsgv; /* $/ */
180static GV *stdoutgv; /* *STDOUT */
181static SV *rv_diehook;
182static SV *rv_warnhook;
183
184/* async_pool helper stuff */
185static SV *sv_pool_rss;
186static SV *sv_pool_size;
187static SV *sv_async_pool_idle; /* description string */
188static AV *av_async_pool; /* idle pool */
189static SV *sv_Coro; /* class string */
190static CV *cv_pool_handler;
191
192/* Coro::AnyEvent */
193static SV *sv_activity;
194
195/* enable processtime/realtime profiling */
196static char enable_times;
197typedef U32 coro_ts[2];
198static coro_ts time_real, time_cpu;
199static char times_valid;
200
201static struct coro_cctx *cctx_first;
202static int cctx_count, cctx_idle;
203
204enum
205{
206 CC_MAPPED = 0x01,
207 CC_NOREUSE = 0x02, /* throw this away after tracing */
208 CC_TRACE = 0x04,
209 CC_TRACE_SUB = 0x08, /* trace sub calls */
210 CC_TRACE_LINE = 0x10, /* trace each statement */
211 CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
212};
213
214/* this is a structure representing a c-level coroutine */
215typedef struct coro_cctx
216{
217 struct coro_cctx *next;
218
219 /* the stack */
220 struct coro_stack stack;
221
222 /* cpu state */
223 void *idle_sp; /* sp of top-level transfer/schedule/cede call */
224#ifndef NDEBUG
225 JMPENV *idle_te; /* same as idle_sp, but for top_env */
226#endif
227 JMPENV *top_env;
228 coro_context cctx;
229
230 U32 gen;
231#if CORO_USE_VALGRIND
232 int valgrind_id;
233#endif
234 unsigned char flags;
235} coro_cctx;
236
237static coro_cctx *cctx_current; /* the currently running cctx */
238
239/*****************************************************************************/
240
241static MGVTBL coro_state_vtbl;
242
243enum
244{
245 CF_RUNNING = 0x0001, /* coroutine is running */
246 CF_READY = 0x0002, /* coroutine is ready */
247 CF_NEW = 0x0004, /* has never been switched to */
248 CF_ZOMBIE = 0x0008, /* coroutine data has been freed */
249 CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */
250 CF_NOCANCEL = 0x0020, /* cannot cancel, set slf_frame.data to 1 (hackish) */
251};
252
253/* the structure where most of the perl state is stored, overlaid on the cxstack */
254typedef struct
255{
256 #define VARx(name,expr,type) type name;
257 #include "state.h"
258} perl_slots;
259
260/* how many context stack entries do we need for perl_slots */
261#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
262
263/* this is a structure representing a perl-level coroutine */
11struct coro { 264struct coro
12 U8 dowarn; 265{
13 AV *defav; 266 /* the C coroutine allocated to this perl coroutine, if any */
14 267 coro_cctx *cctx;
15 PERL_SI *curstackinfo; 268
16 AV *curstack; 269 /* ready queue */
270 struct coro *next_ready;
271
272 /* state data */
273 struct CoroSLF slf_frame; /* saved slf frame */
17 AV *mainstack; 274 AV *mainstack;
18 SV **stack_sp; 275 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 276
41 AV *args; 277 CV *startcv; /* the CV to execute */
278 AV *args; /* data associated with this coroutine (initial args) */
279 int flags; /* CF_ flags */
280 HV *hv; /* the perl hash associated with this coro, if any */
281
282 /* statistics */
283 int usecount; /* number of transfers to this coro */
284
285 /* coro process data */
286 int prio;
287 SV *except; /* exception to be thrown */
288 SV *rouse_cb; /* most recently created rouse callback */
289 AV *on_destroy; /* callbacks or coros to notify on destroy */
290 AV *status; /* the exit status list */
291
292 /* async_pool */
293 SV *saved_deffh;
294 SV *invoke_cb;
295 AV *invoke_av;
296
297 /* on_enter/on_leave */
298 AV *on_enter; AV *on_enter_xs;
299 AV *on_leave; AV *on_leave_xs;
300
301 /* swap_sv */
302 AV *swap_sv;
303
304 /* times */
305 coro_ts t_cpu, t_real;
306
307 /* linked list */
308 struct coro *next, *prev;
42}; 309};
43 310
44typedef struct coro *Coro__State; 311typedef struct coro *Coro__State;
45typedef struct coro *Coro__State_or_hashref; 312typedef struct coro *Coro__State_or_hashref;
46 313
47static HV *padlist_cache; 314/* the following variables are effectively part of the perl context */
315/* and get copied between struct coro and these variables */
316/* the main reason we don't support windows process emulation */
317static struct CoroSLF slf_frame; /* the current slf frame */
48 318
49/* mostly copied from op.c:cv_clone2 */ 319/** Coro ********************************************************************/
50STATIC AV * 320
51clone_padlist (AV *protopadlist) 321#define CORO_PRIO_MAX 3
322#define CORO_PRIO_HIGH 1
323#define CORO_PRIO_NORMAL 0
324#define CORO_PRIO_LOW -1
325#define CORO_PRIO_IDLE -3
326#define CORO_PRIO_MIN -4
327
328/* for Coro.pm */
329static SV *coro_current;
330static SV *coro_readyhook;
331static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */
332static CV *cv_coro_run;
333static struct coro *coro_first;
334#define coro_nready coroapi.nready
335
336/** JIT *********************************************************************/
337
338#if CORO_JIT
339 /* APPLE doesn't have mmap though */
340 #define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__)
341 #ifndef CORO_JIT_TYPE
342 #if ECB_AMD64 && CORO_JIT_UNIXY
343 #define CORO_JIT_TYPE "amd64-unix"
344 #elif __i386 && CORO_JIT_UNIXY
345 #define CORO_JIT_TYPE "x86-unix"
346 #endif
347 #endif
348#endif
349
350#if !defined(CORO_JIT_TYPE) || _POSIX_MEMORY_PROTECTION <= 0
351 #undef CORO_JIT
352#endif
353
354#if CORO_JIT
355 typedef void (*load_save_perl_slots_type)(perl_slots *);
356 static load_save_perl_slots_type load_perl_slots, save_perl_slots;
357#endif
358
359/** Coro::Select ************************************************************/
360
361static OP *(*coro_old_pp_sselect) (pTHX);
362static SV *coro_select_select;
363
364/* horrible hack, but if it works... */
365static OP *
366coro_pp_sselect (pTHX)
52{ 367{
53 AV *av; 368 dSP;
54 I32 ix; 369 PUSHMARK (SP - 4); /* fake argument list */
55 AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE); 370 XPUSHs (coro_select_select);
56 AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE); 371 PUTBACK;
57 SV **pname = AvARRAY (protopad_name); 372
58 SV **ppad = AvARRAY (protopad); 373 /* entersub is an UNOP, select a LISTOP... keep your fingers crossed */
59 I32 fname = AvFILLp (protopad_name); 374 PL_op->op_flags |= OPf_STACKED;
60 I32 fpad = AvFILLp (protopad); 375 PL_op->op_private = 0;
61 AV *newpadlist, *newpad_name, *newpad; 376 return PL_ppaddr [OP_ENTERSUB](aTHX);
377}
378
379/** time stuff **************************************************************/
380
381#ifdef HAS_GETTIMEOFDAY
382
383ecb_inline void
384coro_u2time (pTHX_ UV ret[2])
385{
386 struct timeval tv;
387 gettimeofday (&tv, 0);
388
389 ret [0] = tv.tv_sec;
390 ret [1] = tv.tv_usec;
391}
392
393ecb_inline double
394coro_nvtime (void)
395{
396 struct timeval tv;
397 gettimeofday (&tv, 0);
398
399 return tv.tv_sec + tv.tv_usec * 1e-6;
400}
401
402ecb_inline void
403time_init (pTHX)
404{
405 nvtime = coro_nvtime;
406 u2time = coro_u2time;
407}
408
409#else
410
411ecb_inline void
412time_init (pTHX)
413{
62 SV **npad; 414 SV **svp;
63 415
64 newpad_name = newAV (); 416 require_pv ("Time/HiRes.pm");
65 for (ix = fname; ix >= 0; ix--)
66 av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
67 417
68 newpad = newAV (); 418 svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
69 av_fill (newpad, AvFILLp (protopad));
70 npad = AvARRAY (newpad);
71 419
72 newpadlist = newAV (); 420 if (!svp) croak ("Time::HiRes is required, but missing. Caught");
421 if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught");
422
423 nvtime = INT2PTR (double (*)(), SvIV (*svp));
424
425 svp = hv_fetch (PL_modglobal, "Time::U2time", 12, 0);
426 u2time = INT2PTR (void (*)(pTHX_ UV ret[2]), SvIV (*svp));
427}
428
429#endif
430
431/** lowlevel stuff **********************************************************/
432
433static SV * ecb_noinline
434coro_get_sv (pTHX_ const char *name, int create)
435{
436#if PERL_VERSION_ATLEAST (5,10,0)
437 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
438 get_sv (name, create);
439#endif
440 return get_sv (name, create);
441}
442
443static AV * ecb_noinline
444coro_get_av (pTHX_ const char *name, int create)
445{
446#if PERL_VERSION_ATLEAST (5,10,0)
447 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
448 get_av (name, create);
449#endif
450 return get_av (name, create);
451}
452
453static HV * ecb_noinline
454coro_get_hv (pTHX_ const char *name, int create)
455{
456#if PERL_VERSION_ATLEAST (5,10,0)
457 /* silence stupid and wrong 5.10 warning that I am unable to switch off */
458 get_hv (name, create);
459#endif
460 return get_hv (name, create);
461}
462
463ecb_inline void
464coro_times_update (void)
465{
466#ifdef coro_clock_gettime
467 struct timespec ts;
468
469 ts.tv_sec = ts.tv_nsec = 0;
470 coro_clock_gettime (CORO_CLOCK_THREAD_CPUTIME_ID, &ts);
471 time_cpu [0] = ts.tv_sec; time_cpu [1] = ts.tv_nsec;
472
473 ts.tv_sec = ts.tv_nsec = 0;
474 coro_clock_gettime (CORO_CLOCK_MONOTONIC, &ts);
475 time_real [0] = ts.tv_sec; time_real [1] = ts.tv_nsec;
476#else
477 dTHX;
478 UV tv[2];
479
480 u2time (aTHX_ tv);
481 time_real [0] = tv [0];
482 time_real [1] = tv [1] * 1000;
483#endif
484}
485
486ecb_inline void
487coro_times_add (struct coro *c)
488{
489 c->t_real [1] += time_real [1];
490 if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; }
491 c->t_real [0] += time_real [0];
492
493 c->t_cpu [1] += time_cpu [1];
494 if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; }
495 c->t_cpu [0] += time_cpu [0];
496}
497
498ecb_inline void
499coro_times_sub (struct coro *c)
500{
501 if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; }
502 c->t_real [1] -= time_real [1];
503 c->t_real [0] -= time_real [0];
504
505 if (c->t_cpu [1] < time_cpu [1]) { c->t_cpu [1] += 1000000000; --c->t_cpu [0]; }
506 c->t_cpu [1] -= time_cpu [1];
507 c->t_cpu [0] -= time_cpu [0];
508}
509
510/*****************************************************************************/
511/* magic glue */
512
513#define CORO_MAGIC_type_cv 26
514#define CORO_MAGIC_type_state PERL_MAGIC_ext
515
516#define CORO_MAGIC_NN(sv, type) \
517 (ecb_expect_true (SvMAGIC (sv)->mg_type == type) \
518 ? SvMAGIC (sv) \
519 : mg_find (sv, type))
520
521#define CORO_MAGIC(sv, type) \
522 (ecb_expect_true (SvMAGIC (sv)) \
523 ? CORO_MAGIC_NN (sv, type) \
524 : 0)
525
526#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
527#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)
528
529ecb_inline MAGIC *
530SvSTATEhv_p (pTHX_ SV *coro)
531{
532 MAGIC *mg;
533
534 if (ecb_expect_true (
535 SvTYPE (coro) == SVt_PVHV
536 && (mg = CORO_MAGIC_state (coro))
537 && mg->mg_virtual == &coro_state_vtbl
538 ))
539 return mg;
540
541 return 0;
542}
543
544ecb_inline struct coro *
545SvSTATE_ (pTHX_ SV *coro_sv)
546{
547 MAGIC *mg;
548
549 if (SvROK (coro_sv))
550 coro_sv = SvRV (coro_sv);
551
552 mg = SvSTATEhv_p (aTHX_ coro_sv);
553 if (!mg)
554 croak ("Coro::State object required");
555
556 return (struct coro *)mg->mg_ptr;
557}
558
559#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
560
561/* faster than SvSTATE, but expects a coroutine hv */
562#define SvSTATE_hv(hv) ((struct coro *)CORO_MAGIC_NN ((SV *)hv, CORO_MAGIC_type_state)->mg_ptr)
563#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))
564
565/*****************************************************************************/
566/* padlist management and caching */
567
568ecb_inline PADLIST *
569coro_derive_padlist (pTHX_ CV *cv)
570{
571 PADLIST *padlist = CvPADLIST (cv);
572 PADLIST *newpadlist;
573 PADNAMELIST *padnames;
574 PAD *newpad;
575 PADOFFSET off = PadlistMAX (padlist) + 1;
576
577#if NEWPADAPI
578
579 /* if we had the original CvDEPTH, we might be able to steal the CvDEPTH+1 entry instead */
580 /* 20131102194744.GA6705@schmorp.de, 20131102195825.2013.qmail@lists-nntp.develooper.com */
581 while (!PadlistARRAY (padlist)[off - 1])
582 --off;
583
584 Perl_pad_push (aTHX_ padlist, off);
585
586 newpad = PadlistARRAY (padlist)[off];
587 PadlistARRAY (padlist)[off] = 0;
588
589#else
590
591#if PERL_VERSION_ATLEAST (5,10,0)
592 Perl_pad_push (aTHX_ padlist, off);
593#else
594 Perl_pad_push (aTHX_ padlist, off, 1);
595#endif
596
597 newpad = PadlistARRAY (padlist)[off];
598 PadlistMAX (padlist) = off - 1;
599
600#endif
601
602 newPADLIST (newpadlist);
603#if !PERL_VERSION_ATLEAST(5,15,3)
604 /* Padlists are AvREAL as of 5.15.3. See perl bug #98092 and perl commit 7d953ba. */
73 AvREAL_off (newpadlist); 605 AvREAL_off (newpadlist);
74 av_store (newpadlist, 0, (SV *) newpad_name); 606#endif
75 av_store (newpadlist, 1, (SV *) newpad);
76 607
77 av = newAV (); /* will be @_ */ 608 /* Already extended to 2 elements by newPADLIST. */
78 av_extend (av, 0); 609 PadlistMAX (newpadlist) = 1;
79 av_store (newpad, 0, (SV *) av);
80 AvFLAGS (av) = AVf_REIFY;
81 610
82 for (ix = fpad; ix > 0; ix--) 611 padnames = PadlistNAMES (padlist);
612 ++PadnamelistREFCNT (padnames);
613 PadlistNAMES (newpadlist) = padnames;
614
615 PadlistARRAY (newpadlist)[1] = newpad;
616
617 return newpadlist;
618}
619
620ecb_inline void
621free_padlist (pTHX_ PADLIST *padlist)
622{
623 /* may be during global destruction */
624 if (!IN_DESTRUCT)
83 { 625 {
84 SV *namesv = (ix <= fname) ? pname[ix] : Nullsv; 626 I32 i = PadlistMAX (padlist);
85 if (namesv && namesv != &PL_sv_undef) 627
628 while (i > 0) /* special-case index 0 */
86 { 629 {
87 char *name = SvPVX (namesv); /* XXX */ 630 /* we try to be extra-careful here */
88 if (SvFLAGS (namesv) & SVf_FAKE || *name == '&') 631 PAD *pad = PadlistARRAY (padlist)[i--];
89 { /* lexical from outside? */ 632
90 npad[ix] = SvREFCNT_inc (ppad[ix]); 633 if (pad)
91 } 634 {
92 else 635 I32 j = PadMAX (pad);
93 { /* our own lexical */ 636
94 SV *sv; 637 while (j >= 0)
95 if (*name == '&') 638 SvREFCNT_dec (PadARRAY (pad)[j--]);
639
640 PadMAX (pad) = -1;
96 sv = SvREFCNT_inc (ppad[ix]); 641 SvREFCNT_dec (pad);
97 else if (*name == '@')
98 sv = (SV *) newAV ();
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 } 642 }
107 } 643 }
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 644
120#if 0 /* NONOTUNDERSTOOD */ 645 PadnamelistREFCNT_dec (PadlistNAMES (padlist));
121 /* Now that vars are all in place, clone nested closures. */
122 646
123 for (ix = fpad; ix > 0; ix--) { 647#if NEWPADAPI
124 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; 648 Safefree (PadlistARRAY (padlist));
125 if (namesv 649 Safefree (padlist);
126 && namesv != &PL_sv_undef 650#else
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); 651 AvFILLp (padlist) = -1;
150 while (i >= 0) 652 AvREAL_off (padlist);
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); 653 SvREFCNT_dec ((SV*)padlist);
654#endif
655 }
656}
657
658static int
659coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
660{
661 PADLIST *padlist;
662 PADLIST **padlists = (PADLIST **)(mg->mg_ptr + sizeof(size_t));
663 size_t len = *(size_t *)mg->mg_ptr;
664
665 /* perl manages to free our internal AV and _then_ call us */
666 if (IN_DESTRUCT)
667 return 0;
668
669 while (len--)
670 free_padlist (aTHX_ padlists[len]);
671
672 return 0;
673}
674
675static MGVTBL coro_cv_vtbl = {
676 0, 0, 0, 0,
677 coro_cv_free
678};
679
680/* the next two functions merely cache the padlists */
681ecb_inline void
682get_padlist (pTHX_ CV *cv)
683{
684 MAGIC *mg = CORO_MAGIC_cv (cv);
685 size_t *lenp;
686
687 if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr)))
688 CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp];
689 else
690 {
691#if CORO_PREFER_PERL_FUNCTIONS
692 /* this is probably cleaner? but also slower! */
693 /* in practise, it seems to be less stable */
694 CV *cp = Perl_cv_clone (aTHX_ cv);
695 CvPADLIST (cv) = CvPADLIST (cp);
696 CvPADLIST (cp) = 0;
697 SvREFCNT_dec (cp);
698#else
699 CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);
700#endif
701 }
702}
703
704ecb_inline void
705put_padlist (pTHX_ CV *cv)
706{
707 MAGIC *mg = CORO_MAGIC_cv (cv);
708
709 if (ecb_expect_false (!mg))
710 {
711 mg = sv_magicext ((SV *)cv, 0, CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
712 Newz (0, mg->mg_ptr ,sizeof (size_t) + sizeof (PADLIST *), char);
713 mg->mg_len = 1; /* so mg_free frees mg_ptr */
714 }
715 else
716 Renew (mg->mg_ptr,
717 sizeof(size_t) + (*(size_t *)mg->mg_ptr + 1) * sizeof(PADLIST *),
718 char);
719
720 ((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv);
721}
722
723/** load & save, init *******************************************************/
724
725ecb_inline void
726swap_sv (SV *a, SV *b)
727{
728 const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
729 SV tmp;
730
731 /* swap sv_any */
732 SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
733
734 /* swap sv_flags */
735 SvFLAGS (&tmp) = SvFLAGS (a);
736 SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
737 SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
738
739#if PERL_VERSION_ATLEAST (5,10,0)
740 /* perl 5.10 and later complicates this _quite_ a bit, but it also
741 * is much faster, so no quarrels here. alternatively, we could
742 * sv_upgrade to avoid this.
743 */
744 {
745 /* swap sv_u */
746 tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
747
748 /* if SvANY points to the head, we need to adjust the pointers,
749 * as the pointer for a still points to b, and maybe vice versa.
750 */
751 U32 svany_in_head_set = (1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV);
752 #if NVSIZE <= IVSIZE && PERL_VERSION_ATLEAST(5,22,0)
753 svany_in_head_set |= 1 << SVt_NV;
754 #endif
755
756 #define svany_in_head(type) (svany_in_head_set & (1 << (type)))
757
758 if (svany_in_head (SvTYPE (a)))
759 SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
760
761 if (svany_in_head (SvTYPE (b)))
762 SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
159 } 763 }
764#endif
160} 765}
161 766
162/* the next tow functions merely cache the padlists */ 767/* swap sv heads, at least logically */
163STATIC void 768static void
164get_padlist (CV *cv) 769swap_svs_enter (pTHX_ Coro__State c)
165{ 770{
166 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0); 771 int i;
167 772
168 if (he && AvFILLp ((AV *)*he) >= 0) 773 for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
169 CvPADLIST (cv) = (AV *)av_pop ((AV *)*he); 774 swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
170 else
171 CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172} 775}
173 776
174STATIC void 777static void
175put_padlist (CV *cv) 778swap_svs_leave (pTHX_ Coro__State c)
176{ 779{
177 SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1); 780 int i;
178 781
179 if (SvTYPE (*he) != SVt_PVAV) 782 for (i = AvFILLp (c->swap_sv) - 1; i >= 0; i -= 2)
783 swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
784}
785
786#define SWAP_SVS_ENTER(coro) \
787 if (ecb_expect_false ((coro)->swap_sv)) \
788 swap_svs_enter (aTHX_ (coro))
789
790#define SWAP_SVS_LEAVE(coro) \
791 if (ecb_expect_false ((coro)->swap_sv)) \
792 swap_svs_leave (aTHX_ (coro))
793
794static void
795on_enterleave_call (pTHX_ SV *cb);
796
797static void
798load_perl (pTHX_ Coro__State c)
799{
800 perl_slots *slot = c->slot;
801 c->slot = 0;
802
803 PL_mainstack = c->mainstack;
804
805#if CORO_JIT
806 load_perl_slots (slot);
807#else
808 #define VARx(name,expr,type) expr = slot->name;
809 #include "state.h"
810#endif
811
812 {
813 dSP;
814
815 CV *cv;
816
817 /* now do the ugly restore mess */
818 while (ecb_expect_true (cv = (CV *)POPs))
180 { 819 {
181 SvREFCNT_dec (*he); 820 put_padlist (aTHX_ cv); /* mark this padlist as available */
182 *he = (SV *)newAV (); 821 CvDEPTH (cv) = PTR2IV (POPs);
822 CvPADLIST (cv) = (PADLIST *)POPs;
183 } 823 }
184 824
185 av_push ((AV *)*he, (SV *)CvPADLIST (cv)); 825 PUTBACK;
186} 826 }
187 827
828 slf_frame = c->slf_frame;
829 CORO_THROW = c->except;
830
831 if (ecb_expect_false (enable_times))
832 {
833 if (ecb_expect_false (!times_valid))
834 coro_times_update ();
835
836 coro_times_sub (c);
837 }
838
839 if (ecb_expect_false (c->on_enter))
840 {
841 int i;
842
843 for (i = 0; i <= AvFILLp (c->on_enter); ++i)
844 on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);
845 }
846
847 if (ecb_expect_false (c->on_enter_xs))
848 {
849 int i;
850
851 for (i = 0; i <= AvFILLp (c->on_enter_xs); i += 2)
852 ((coro_enterleave_hook)AvARRAY (c->on_enter_xs)[i]) (aTHX_ AvARRAY (c->on_enter_xs)[i + 1]);
853 }
854
855 SWAP_SVS_ENTER (c);
856}
857
188static void 858static void
189save_state(pTHX_ Coro__State c) 859save_perl (pTHX_ Coro__State c)
190{ 860{
861 SWAP_SVS_LEAVE (c);
862
863 if (ecb_expect_false (c->on_leave_xs))
864 {
865 int i;
866
867 for (i = AvFILLp (c->on_leave_xs) - 1; i >= 0; i -= 2)
868 ((coro_enterleave_hook)AvARRAY (c->on_leave_xs)[i]) (aTHX_ AvARRAY (c->on_leave_xs)[i + 1]);
869 }
870
871 if (ecb_expect_false (c->on_leave))
872 {
873 int i;
874
875 for (i = AvFILLp (c->on_leave); i >= 0; --i)
876 on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]);
877 }
878
879 times_valid = 0;
880
881 if (ecb_expect_false (enable_times))
882 {
883 coro_times_update (); times_valid = 1;
884 coro_times_add (c);
885 }
886
887 c->except = CORO_THROW;
888 c->slf_frame = slf_frame;
889
191 { 890 {
192 dSP; 891 dSP;
193 I32 cxix = cxstack_ix; 892 I32 cxix = cxstack_ix;
893 PERL_CONTEXT *ccstk = cxstack;
194 PERL_SI *top_si = PL_curstackinfo; 894 PERL_SI *top_si = PL_curstackinfo;
195 PERL_CONTEXT *ccstk = cxstack;
196 895
197 /* 896 /*
198 * the worst thing you can imagine happens first - we have to save 897 * the worst thing you can imagine happens first - we have to save
199 * (and reinitialize) all cv's in the whole callchain :( 898 * (and reinitialize) all cv's in the whole callchain :(
200 */ 899 */
201 900
202 PUSHs (Nullsv); 901 XPUSHs (Nullsv);
203 /* this loop was inspired by pp_caller */ 902 /* this loop was inspired by pp_caller */
204 for (;;) 903 for (;;)
205 { 904 {
206 while (cxix >= 0) 905 while (ecb_expect_true (cxix >= 0))
207 { 906 {
208 PERL_CONTEXT *cx = &ccstk[cxix--]; 907 PERL_CONTEXT *cx = &ccstk[cxix--];
209 908
210 if (CxTYPE(cx) == CXt_SUB) 909 if (ecb_expect_true (CxTYPE (cx) == CXt_SUB) || ecb_expect_false (CxTYPE (cx) == CXt_FORMAT))
211 { 910 {
212 CV *cv = cx->blk_sub.cv; 911 CV *cv = cx->blk_sub.cv;
912
213 if (CvDEPTH(cv)) 913 if (ecb_expect_true (CvDEPTH (cv)))
214 { 914 {
215#ifdef USE_THREADS
216 XPUSHs ((SV *)CvOWNER(cv));
217#endif
218 EXTEND (SP, 3); 915 EXTEND (SP, 3);
219 PUSHs ((SV *)CvDEPTH(cv));
220 PUSHs ((SV *)CvPADLIST(cv)); 916 PUSHs ((SV *)CvPADLIST (cv));
917 PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
221 PUSHs ((SV *)cv); 918 PUSHs ((SV *)cv);
222 919
223 get_padlist (cv);
224
225 CvDEPTH(cv) = 0; 920 CvDEPTH (cv) = 0;
226#ifdef USE_THREADS 921 get_padlist (aTHX_ cv);
227 CvOWNER(cv) = 0;
228 error must unlock this cv etc.. etc...
229 if you are here wondering about this error message then
230 the reason is that it will not work as advertised yet
231#endif
232 } 922 }
233 } 923 }
234 else if (CxTYPE(cx) == CXt_FORMAT) 924 }
925
926 if (ecb_expect_true (top_si->si_type == PERLSI_MAIN))
927 break;
928
929 top_si = top_si->si_prev;
930 ccstk = top_si->si_cxstack;
931 cxix = top_si->si_cxix;
932 }
933
934 PUTBACK;
935 }
936
937 /* allocate some space on the context stack for our purposes */
938 if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max))
939 {
940 unsigned int i;
941
942 for (i = 0; i < SLOT_COUNT; ++i)
943 CXINC;
944
945 cxstack_ix -= SLOT_COUNT; /* undo allocation */
946 }
947
948 c->mainstack = PL_mainstack;
949
950 {
951 perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
952
953#if CORO_JIT
954 save_perl_slots (slot);
955#else
956 #define VARx(name,expr,type) slot->name = expr;
957 #include "state.h"
958#endif
959 }
960}
961
962/*
963 * allocate various perl stacks. This is almost an exact copy
964 * of perl.c:init_stacks, except that it uses less memory
965 * on the (sometimes correct) assumption that coroutines do
966 * not usually need a lot of stackspace.
967 */
968#if CORO_PREFER_PERL_FUNCTIONS
969# define coro_init_stacks(thx) init_stacks ()
970#else
971static void
972coro_init_stacks (pTHX)
973{
974 PL_curstackinfo = new_stackinfo(32, 4 + SLOT_COUNT); /* 3 is minimum due to perl rounding down in scope.c:GROW() */
975 PL_curstackinfo->si_type = PERLSI_MAIN;
976 PL_curstack = PL_curstackinfo->si_stack;
977 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
978
979 PL_stack_base = AvARRAY(PL_curstack);
980 PL_stack_sp = PL_stack_base;
981 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
982
983 New(50,PL_tmps_stack,32,SV*);
984 PL_tmps_floor = -1;
985 PL_tmps_ix = -1;
986 PL_tmps_max = 32;
987
988 New(54,PL_markstack,16,I32);
989 PL_markstack_ptr = PL_markstack;
990 PL_markstack_max = PL_markstack + 16;
991
992#ifdef SET_MARK_OFFSET
993 SET_MARK_OFFSET;
994#endif
995
996 New(54,PL_scopestack,8,I32);
997 PL_scopestack_ix = 0;
998 PL_scopestack_max = 8;
999#if HAS_SCOPESTACK_NAME
1000 New(54,PL_scopestack_name,8,const char*);
1001#endif
1002
1003 New(54,PL_savestack,24,ANY);
1004 PL_savestack_ix = 0;
1005 PL_savestack_max = 24;
1006#if PERL_VERSION_ATLEAST (5,24,0)
1007 /* perl 5.24 moves SS_MAXPUSH optimisation from */
1008 /* the header macros to PL_savestack_max */
1009 PL_savestack_max -= SS_MAXPUSH;
1010#endif
1011
1012#if !PERL_VERSION_ATLEAST (5,10,0)
1013 New(54,PL_retstack,4,OP*);
1014 PL_retstack_ix = 0;
1015 PL_retstack_max = 4;
1016#endif
1017}
1018#endif
1019
1020/*
1021 * destroy the stacks, the callchain etc...
1022 */
1023static void
1024coro_destruct_stacks (pTHX)
1025{
1026 while (PL_curstackinfo->si_next)
1027 PL_curstackinfo = PL_curstackinfo->si_next;
1028
1029 while (PL_curstackinfo)
1030 {
1031 PERL_SI *p = PL_curstackinfo->si_prev;
1032
1033 if (!IN_DESTRUCT)
1034 SvREFCNT_dec (PL_curstackinfo->si_stack);
1035
1036 Safefree (PL_curstackinfo->si_cxstack);
1037 Safefree (PL_curstackinfo);
1038 PL_curstackinfo = p;
1039 }
1040
1041 Safefree (PL_tmps_stack);
1042 Safefree (PL_markstack);
1043 Safefree (PL_scopestack);
1044#if HAS_SCOPESTACK_NAME
1045 Safefree (PL_scopestack_name);
1046#endif
1047 Safefree (PL_savestack);
1048#if !PERL_VERSION_ATLEAST (5,10,0)
1049 Safefree (PL_retstack);
1050#endif
1051}
1052
1053#define CORO_RSS \
1054 rss += sizeof (SYM (curstackinfo)); \
1055 rss += (SYM (curstackinfo->si_cxmax) + 1) * sizeof (PERL_CONTEXT); \
1056 rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (SYM (curstack))) * sizeof (SV *); \
1057 rss += SYM (tmps_max) * sizeof (SV *); \
1058 rss += (SYM (markstack_max) - SYM (markstack_ptr)) * sizeof (I32); \
1059 rss += SYM (scopestack_max) * sizeof (I32); \
1060 rss += SYM (savestack_max) * sizeof (ANY);
1061
1062static size_t
1063coro_rss (pTHX_ struct coro *coro)
1064{
1065 size_t rss = sizeof (*coro);
1066
1067 if (coro->mainstack)
1068 {
1069 if (coro->flags & CF_RUNNING)
1070 {
1071 #define SYM(sym) PL_ ## sym
1072 CORO_RSS;
1073 #undef SYM
1074 }
1075 else
1076 {
1077 #define SYM(sym) coro->slot->sym
1078 CORO_RSS;
1079 #undef SYM
1080 }
1081 }
1082
1083 return rss;
1084}
1085
1086/** provide custom get/set/clear methods for %SIG elements ******************/
1087
1088/* apparently < 5.8.8 */
1089#ifndef MgPV_nolen_const
1090#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
1091 SvPV_nolen((SV*)((mg)->mg_ptr)) : \
1092 (const char*)(mg)->mg_ptr)
1093#endif
1094
1095/* this will be a patched copy of PL_vtbl_sigelem */
1096static MGVTBL coro_sigelem_vtbl;
1097
1098static int ecb_cold
1099coro_sig_copy (pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, I32 namlen)
1100{
1101 char *key = SvPV_nolen ((SV *)name);
1102
1103 /* do what mg_copy normally does */
1104 sv_magic (nsv, mg->mg_obj, PERL_MAGIC_sigelem, name, namlen);
1105 assert (mg_find (nsv, PERL_MAGIC_sigelem)->mg_virtual == &PL_vtbl_sigelem);
1106
1107 /* patch sigelem vtbl, but only for __WARN__ and __DIE__ */
1108 if (*key == '_'
1109 && (strEQ (key, "__DIE__")
1110 || strEQ (key, "__WARN__")))
1111 mg_find (nsv, PERL_MAGIC_sigelem)->mg_virtual = &coro_sigelem_vtbl;
1112
1113 return 1;
1114}
1115
1116/* perl does not have a %SIG vtbl, we provide one so we can override */
1117/* the magic vtbl for the __DIE__ and __WARN__ members */
1118static const MGVTBL coro_sig_vtbl = {
1119 0, 0, 0, 0, 0,
1120 coro_sig_copy
1121};
1122
1123/*
1124 * This overrides the default magic get method of %SIG elements.
1125 * The original one doesn't provide for reading back of PL_diehook/PL_warnhook
1126 * and instead of trying to save and restore the hash elements (extremely slow),
1127 * we just provide our own readback here.
1128 */
1129static int ecb_cold
1130coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
1131{
1132 const char *s = MgPV_nolen_const (mg);
1133 /* the key must be either __DIE__ or __WARN__ here */
1134 SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook;
1135
1136 SV *ssv;
1137
1138 if (!*svp)
1139 ssv = &PL_sv_undef;
1140 else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
1141 ssv = sv_2mortal (newRV_inc (*svp));
1142 else
1143 ssv = *svp;
1144
1145 sv_setsv (sv, ssv);
1146 return 0;
1147}
1148
1149static int ecb_cold
1150coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
1151{
1152 const char *s = MgPV_nolen_const (mg);
1153 /* the key must be either __DIE__ or __WARN__ here */
1154 SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook;
1155
1156 SV *old = *svp;
1157 *svp = 0;
1158 SvREFCNT_dec (old);
1159 return 0;
1160}
1161
1162static int ecb_cold
1163coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
1164{
1165 const char *s = MgPV_nolen_const (mg);
1166 /* the key must be either __DIE__ or __WARN__ here */
1167 SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook;
1168
1169 SV *old = *svp;
1170 *svp = SvOK (sv) ? newSVsv (sv) : 0;
1171 SvREFCNT_dec (old);
1172 return 0;
1173}
1174
1175static void
1176prepare_nop (pTHX_ struct coro_transfer_args *ta)
1177{
1178 /* kind of mega-hacky, but works */
1179 ta->next = ta->prev = (struct coro *)ta;
1180}
1181
1182static int
1183slf_check_nop (pTHX_ struct CoroSLF *frame)
1184{
1185 return 0;
1186}
1187
1188static int
1189slf_check_repeat (pTHX_ struct CoroSLF *frame)
1190{
1191 return 1;
1192}
1193
1194/** coroutine stack handling ************************************************/
1195
1196static UNOP init_perl_op;
1197
1198ecb_noinline static void /* noinline to keep it out of the transfer fast path */
1199init_perl (pTHX_ struct coro *coro)
1200{
1201 /*
1202 * emulate part of the perl startup here.
1203 */
1204 coro_init_stacks (aTHX);
1205
1206 PL_runops = RUNOPS_DEFAULT;
1207 PL_curcop = &PL_compiling;
1208 PL_in_eval = EVAL_NULL;
1209 PL_comppad = 0;
1210 PL_comppad_name = 0;
1211 PL_comppad_name_fill = 0;
1212 PL_comppad_name_floor = 0;
1213 PL_curpm = 0;
1214 PL_curpad = 0;
1215 PL_localizing = 0;
1216 PL_restartop = 0;
1217#if PERL_VERSION_ATLEAST (5,10,0)
1218 PL_parser = 0;
1219#endif
1220 PL_hints = 0;
1221
1222 /* recreate the die/warn hooks */
1223 PL_diehook = SvREFCNT_inc (rv_diehook);
1224 PL_warnhook = SvREFCNT_inc (rv_warnhook);
1225
1226 GvSV (PL_defgv) = newSV (0);
1227 GvAV (PL_defgv) = coro->args; coro->args = 0;
1228 GvSV (PL_errgv) = newSV (0);
1229 GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
1230 GvHV (PL_hintgv) = newHV ();
1231#if PERL_VERSION_ATLEAST (5,10,0)
1232 hv_magic (GvHV (PL_hintgv), 0, PERL_MAGIC_hints);
1233#endif
1234 PL_rs = newSVsv (GvSV (irsgv));
1235 PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
1236
1237 {
1238 dSP;
1239 UNOP myop;
1240
1241 Zero (&myop, 1, UNOP);
1242 myop.op_next = Nullop;
1243 myop.op_type = OP_ENTERSUB;
1244 myop.op_flags = OPf_WANT_VOID;
1245
1246 PUSHMARK (SP);
1247 XPUSHs ((SV *)coro->startcv);
1248 PUTBACK;
1249 PL_op = (OP *)&myop;
1250 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
1251 }
1252
1253 /* this newly created coroutine might be run on an existing cctx which most
1254 * likely was suspended in pp_slf, so we have to emulate entering pp_slf here.
1255 */
1256 slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */
1257 slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */
1258 slf_frame.destroy = 0;
1259
1260 /* and we have to provide the pp_slf op in any case, so pp_slf can skip it */
1261 init_perl_op.op_next = PL_op;
1262 init_perl_op.op_type = OP_ENTERSUB;
1263 init_perl_op.op_ppaddr = pp_slf;
1264 /* no flags etc. required, as an init function won't be called */
1265
1266 PL_op = (OP *)&init_perl_op;
1267
1268 /* copy throw, in case it was set before init_perl */
1269 CORO_THROW = coro->except;
1270
1271 SWAP_SVS_ENTER (coro);
1272
1273 if (ecb_expect_false (enable_times))
1274 {
1275 coro_times_update ();
1276 coro_times_sub (coro);
1277 }
1278}
1279
1280static void
1281coro_unwind_stacks (pTHX)
1282{
1283 if (!IN_DESTRUCT)
1284 {
1285 /* restore all saved variables and stuff */
1286 LEAVE_SCOPE (0);
1287 assert (PL_tmps_floor == -1);
1288
1289 /* free all temporaries */
1290 FREETMPS;
1291 assert (PL_tmps_ix == -1);
1292
1293 /* unwind all extra stacks */
1294 POPSTACK_TO (PL_mainstack);
1295
1296 /* unwind main stack */
1297 dounwind (-1);
1298 }
1299}
1300
1301static void
1302destroy_perl (pTHX_ struct coro *coro)
1303{
1304 SV *svf [9];
1305
1306 {
1307 SV *old_current = SvRV (coro_current);
1308 struct coro *current = SvSTATE (old_current);
1309
1310 assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));
1311
1312 save_perl (aTHX_ current);
1313
1314 /* this will cause transfer_check to croak on block*/
1315 SvRV_set (coro_current, (SV *)coro->hv);
1316
1317 load_perl (aTHX_ coro);
1318
1319 /* restore swapped sv's */
1320 SWAP_SVS_LEAVE (coro);
1321
1322 coro_unwind_stacks (aTHX);
1323
1324 coro_destruct_stacks (aTHX);
1325
1326 /* now save some sv's to be free'd later */
1327 svf [0] = GvSV (PL_defgv);
1328 svf [1] = (SV *)GvAV (PL_defgv);
1329 svf [2] = GvSV (PL_errgv);
1330 svf [3] = (SV *)PL_defoutgv;
1331 svf [4] = PL_rs;
1332 svf [5] = GvSV (irsgv);
1333 svf [6] = (SV *)GvHV (PL_hintgv);
1334 svf [7] = PL_diehook;
1335 svf [8] = PL_warnhook;
1336 assert (9 == sizeof (svf) / sizeof (*svf));
1337
1338 SvRV_set (coro_current, old_current);
1339
1340 load_perl (aTHX_ current);
1341 }
1342
1343 {
1344 unsigned int i;
1345
1346 for (i = 0; i < sizeof (svf) / sizeof (*svf); ++i)
1347 SvREFCNT_dec (svf [i]);
1348
1349 SvREFCNT_dec (coro->saved_deffh);
1350 SvREFCNT_dec (coro->rouse_cb);
1351 SvREFCNT_dec (coro->invoke_cb);
1352 SvREFCNT_dec (coro->invoke_av);
1353 SvREFCNT_dec (coro->on_enter_xs);
1354 SvREFCNT_dec (coro->on_leave_xs);
1355 }
1356}
1357
1358ecb_inline void
1359free_coro_mortal (pTHX)
1360{
1361 if (ecb_expect_true (coro_mortal))
1362 {
1363 SvREFCNT_dec ((SV *)coro_mortal);
1364 coro_mortal = 0;
1365 }
1366}
1367
1368static int
1369runops_trace (pTHX)
1370{
1371 COP *oldcop = 0;
1372 int oldcxix = -2;
1373
1374 while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
1375 {
1376 PERL_ASYNC_CHECK ();
1377
1378 if (cctx_current->flags & CC_TRACE_ALL)
1379 {
1380 if (PL_op->op_type == OP_LEAVESUB && cctx_current->flags & CC_TRACE_SUB)
1381 {
1382 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1383 SV **bot, **top;
1384 AV *av = newAV (); /* return values */
1385 SV **cb;
1386 dSP;
1387
1388 GV *gv = CvGV (cx->blk_sub.cv);
1389 SV *fullname = sv_2mortal (newSV (0));
1390 if (isGV (gv))
1391 gv_efullname3 (fullname, gv, 0);
1392
1393 bot = PL_stack_base + cx->blk_oldsp + 1;
1394 top = cx->blk_gimme == G_ARRAY ? SP + 1
1395 : cx->blk_gimme == G_SCALAR ? bot + 1
1396 : bot;
1397
1398 av_extend (av, top - bot);
1399 while (bot < top)
1400 av_push (av, SvREFCNT_inc_NN (*bot++));
1401
1402 PL_runops = RUNOPS_DEFAULT;
1403 ENTER;
1404 SAVETMPS;
1405 PUSHMARK (SP);
1406 EXTEND (SP, 3);
1407 PUSHs (&PL_sv_no);
1408 PUSHs (fullname);
1409 PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
1410 PUTBACK;
1411 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
1412 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1413 SPAGAIN;
1414 FREETMPS;
1415 LEAVE;
1416 PL_runops = runops_trace;
1417 }
1418
1419 if (oldcop != PL_curcop)
1420 {
1421 oldcop = PL_curcop;
1422
1423 if (PL_curcop != &PL_compiling)
1424 {
1425 SV **cb;
1426
1427 if (oldcxix != cxstack_ix && cctx_current->flags & CC_TRACE_SUB && cxstack_ix >= 0)
1428 {
1429 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1430
1431 if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
1432 {
1433 dSP;
1434 GV *gv = CvGV (cx->blk_sub.cv);
1435 SV *fullname = sv_2mortal (newSV (0));
1436
1437 if (isGV (gv))
1438 gv_efullname3 (fullname, gv, 0);
1439
1440 PL_runops = RUNOPS_DEFAULT;
1441 ENTER;
1442 SAVETMPS;
1443 PUSHMARK (SP);
1444 EXTEND (SP, 3);
1445 PUSHs (&PL_sv_yes);
1446 PUSHs (fullname);
1447 PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc (SUB_ARGARRAY)) : &PL_sv_undef);
1448 PUTBACK;
1449 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
1450 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1451 SPAGAIN;
1452 FREETMPS;
1453 LEAVE;
1454 PL_runops = runops_trace;
1455 }
1456
1457 oldcxix = cxstack_ix;
1458 }
1459
1460 if (cctx_current->flags & CC_TRACE_LINE)
1461 {
1462 dSP;
1463
1464 PL_runops = RUNOPS_DEFAULT;
1465 ENTER;
1466 SAVETMPS;
1467 PUSHMARK (SP);
1468 EXTEND (SP, 2);
1469 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
1470 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
1471 PUTBACK;
1472 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
1473 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1474 SPAGAIN;
1475 FREETMPS;
1476 LEAVE;
1477 PL_runops = runops_trace;
1478 }
1479 }
1480 }
1481 }
1482 }
1483
1484 TAINT_NOT;
1485 return 0;
1486}
1487
1488static struct CoroSLF cctx_ssl_frame;
1489
1490static void
1491slf_prepare_set_stacklevel (pTHX_ struct coro_transfer_args *ta)
1492{
1493 ta->prev = 0;
1494}
1495
1496static int
1497slf_check_set_stacklevel (pTHX_ struct CoroSLF *frame)
1498{
1499 *frame = cctx_ssl_frame;
1500
1501 return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */
1502}
1503
1504/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */
1505static void ecb_noinline
1506cctx_prepare (pTHX)
1507{
1508 PL_top_env = &PL_start_env;
1509
1510 if (cctx_current->flags & CC_TRACE)
1511 PL_runops = runops_trace;
1512
1513 /* we already must be executing an SLF op, there is no other valid way
1514 * that can lead to creation of a new cctx */
1515 assert (("FATAL: can't prepare slf-less cctx in Coro module (please report)",
1516 slf_frame.prepare && PL_op->op_ppaddr == pp_slf));
1517
1518 /* we must emulate leaving pp_slf, which is done inside slf_check_set_stacklevel */
1519 cctx_ssl_frame = slf_frame;
1520
1521 slf_frame.prepare = slf_prepare_set_stacklevel;
1522 slf_frame.check = slf_check_set_stacklevel;
1523}
1524
1525/* the tail of transfer: execute stuff we can only do after a transfer */
1526ecb_inline void
1527transfer_tail (pTHX)
1528{
1529 free_coro_mortal (aTHX);
1530}
1531
1532/* try to exit the same way perl's main function would do */
1533/* we do not bother resetting the environment or other things *7
1534/* that are not, uhm, essential */
1535/* this obviously also doesn't work when perl is embedded */
1536static void ecb_noinline ecb_cold
1537perlish_exit (pTHX)
1538{
1539 int exitstatus = perl_destruct (PL_curinterp);
1540 perl_free (PL_curinterp);
1541 exit (exitstatus);
1542}
1543
1544/*
1545 * this is a _very_ stripped down perl interpreter ;)
1546 */
1547static void
1548cctx_run (void *arg)
1549{
1550#ifdef USE_ITHREADS
1551# if CORO_PTHREAD
1552 PERL_SET_CONTEXT (coro_thx);
1553# endif
1554#endif
1555 {
1556 dTHX;
1557
1558 /* normally we would need to skip the entersub here */
1559 /* not doing so will re-execute it, which is exactly what we want */
1560 /* PL_nop = PL_nop->op_next */
1561
1562 /* inject a fake subroutine call to cctx_init */
1563 cctx_prepare (aTHX);
1564
1565 /* cctx_run is the alternative tail of transfer() */
1566 transfer_tail (aTHX);
1567
1568 /* somebody or something will hit me for both perl_run and PL_restartop */
1569 PL_restartop = PL_op;
1570 perl_run (PL_curinterp);
1571 /*
1572 * Unfortunately, there is no way to get at the return values of the
1573 * coro body here, as perl_run destroys these. Likewise, we cannot catch
1574 * runtime errors here, as this is just a random interpreter, not a thread.
1575 */
1576
1577 /*
1578 * pp_entersub in 5.24 no longer ENTERs, but perl_destruct
1579 * requires PL_scopestack_ix, so do it here if required.
1580 */
1581 if (!PL_scopestack_ix)
1582 ENTER;
1583
1584 /*
1585 * If perl-run returns we assume exit() was being called or the coro
1586 * fell off the end, which seems to be the only valid (non-bug)
1587 * reason for perl_run to return. We try to mimic whatever perl is normally
1588 * doing in that case. YMMV.
1589 */
1590 perlish_exit (aTHX);
1591 }
1592}
1593
1594static coro_cctx *
1595cctx_new (void)
1596{
1597 coro_cctx *cctx;
1598
1599 ++cctx_count;
1600 New (0, cctx, 1, coro_cctx);
1601
1602 cctx->gen = cctx_gen;
1603 cctx->flags = 0;
1604 cctx->idle_sp = 0; /* can be accessed by transfer between cctx_run and set_stacklevel, on throw */
1605
1606 return cctx;
1607}
1608
1609/* create a new cctx only suitable as source */
1610static coro_cctx *
1611cctx_new_empty (void)
1612{
1613 coro_cctx *cctx = cctx_new ();
1614
1615 cctx->stack.sptr = 0;
1616 coro_create (&cctx->cctx, 0, 0, 0, 0);
1617
1618 return cctx;
1619}
1620
1621/* create a new cctx suitable as destination/running a perl interpreter */
1622static coro_cctx *
1623cctx_new_run (void)
1624{
1625 coro_cctx *cctx = cctx_new ();
1626
1627 if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
1628 {
1629 perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1630 _exit (EXIT_FAILURE);
1631 }
1632
1633 coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze);
1634
1635 return cctx;
1636}
1637
1638static void
1639cctx_destroy (coro_cctx *cctx)
1640{
1641 if (!cctx)
1642 return;
1643
1644 assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
1645
1646 --cctx_count;
1647 coro_destroy (&cctx->cctx);
1648
1649 coro_stack_free (&cctx->stack);
1650
1651 Safefree (cctx);
1652}
1653
1654/* wether this cctx should be destructed */
1655#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1656
1657static coro_cctx *
1658cctx_get (pTHX)
1659{
1660 while (ecb_expect_true (cctx_first))
1661 {
1662 coro_cctx *cctx = cctx_first;
1663 cctx_first = cctx->next;
1664 --cctx_idle;
1665
1666 if (ecb_expect_true (!CCTX_EXPIRED (cctx)))
1667 return cctx;
1668
1669 cctx_destroy (cctx);
1670 }
1671
1672 return cctx_new_run ();
1673}
1674
1675static void
1676cctx_put (coro_cctx *cctx)
1677{
1678 assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr));
1679
1680 /* free another cctx if overlimit */
1681 if (ecb_expect_false (cctx_idle >= cctx_max_idle))
1682 {
1683 coro_cctx *first = cctx_first;
1684 cctx_first = first->next;
1685 --cctx_idle;
1686
1687 cctx_destroy (first);
1688 }
1689
1690 ++cctx_idle;
1691 cctx->next = cctx_first;
1692 cctx_first = cctx;
1693}
1694
1695/** coroutine switching *****************************************************/
1696
1697static void
1698transfer_check (pTHX_ struct coro *prev, struct coro *next)
1699{
1700 /* TODO: throwing up here is considered harmful */
1701
1702 if (ecb_expect_true (prev != next))
1703 {
1704 if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1705 croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");
1706
1707 if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED)))
1708 croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");
1709
1710#if !PERL_VERSION_ATLEAST (5,10,0)
1711 if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING))
1712 croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");
1713#endif
1714 }
1715}
1716
1717/* always use the TRANSFER macro */
1718static void ecb_noinline /* noinline so we have a fixed stackframe */
1719transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1720{
1721 dSTACKLEVEL;
1722
1723 /* sometimes transfer is only called to set idle_sp */
1724 if (ecb_expect_false (!prev))
1725 {
1726 cctx_current->idle_sp = STACKLEVEL;
1727 assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1728 }
1729 else if (ecb_expect_true (prev != next))
1730 {
1731 coro_cctx *cctx_prev;
1732
1733 if (ecb_expect_false (prev->flags & CF_NEW))
1734 {
1735 /* create a new empty/source context */
1736 prev->flags &= ~CF_NEW;
1737 prev->flags |= CF_RUNNING;
1738 }
1739
1740 prev->flags &= ~CF_RUNNING;
1741 next->flags |= CF_RUNNING;
1742
1743 /* first get rid of the old state */
1744 save_perl (aTHX_ prev);
1745
1746 if (ecb_expect_false (next->flags & CF_NEW))
1747 {
1748 /* need to start coroutine */
1749 next->flags &= ~CF_NEW;
1750 /* setup coroutine call */
1751 init_perl (aTHX_ next);
1752 }
1753 else
1754 load_perl (aTHX_ next);
1755
1756 /* possibly untie and reuse the cctx */
1757 if (ecb_expect_true (
1758 cctx_current->idle_sp == STACKLEVEL
1759 && !(cctx_current->flags & CC_TRACE)
1760 && !force_cctx
1761 ))
1762 {
1763 /* I assume that stacklevel is a stronger indicator than PL_top_env changes */
1764 assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));
1765
1766 /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */
1767 /* without this the next cctx_get might destroy the running cctx while still in use */
1768 if (ecb_expect_false (CCTX_EXPIRED (cctx_current)))
1769 if (ecb_expect_true (!next->cctx))
1770 next->cctx = cctx_get (aTHX);
1771
1772 cctx_put (cctx_current);
1773 }
1774 else
1775 prev->cctx = cctx_current;
1776
1777 ++next->usecount;
1778
1779 cctx_prev = cctx_current;
1780 cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);
1781
1782 next->cctx = 0;
1783
1784 if (ecb_expect_false (cctx_prev != cctx_current))
1785 {
1786 cctx_prev->top_env = PL_top_env;
1787 PL_top_env = cctx_current->top_env;
1788 coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);
1789 }
1790
1791 transfer_tail (aTHX);
1792 }
1793}
1794
1795#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1796#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1797
1798/** high level stuff ********************************************************/
1799
1800/* this function is actually Coro, not Coro::State, but we call it from here */
1801/* because it is convenient - but it hasn't been declared yet for that reason */
1802static void
1803coro_call_on_destroy (pTHX_ struct coro *coro);
1804
1805static void
1806coro_state_destroy (pTHX_ struct coro *coro)
1807{
1808 if (coro->flags & CF_ZOMBIE)
1809 return;
1810
1811 slf_destroy (aTHX_ coro);
1812
1813 coro->flags |= CF_ZOMBIE;
1814
1815 if (coro->flags & CF_READY)
1816 {
1817 /* reduce nready, as destroying a ready coro effectively unreadies it */
1818 /* alternative: look through all ready queues and remove the coro */
1819 --coro_nready;
1820 }
1821 else
1822 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1823
1824 if (coro->next) coro->next->prev = coro->prev;
1825 if (coro->prev) coro->prev->next = coro->next;
1826 if (coro == coro_first) coro_first = coro->next;
1827
1828 if (coro->mainstack
1829 && coro->mainstack != main_mainstack
1830 && coro->slot
1831 && !PL_dirty)
1832 destroy_perl (aTHX_ coro);
1833
1834 cctx_destroy (coro->cctx);
1835 SvREFCNT_dec (coro->startcv);
1836 SvREFCNT_dec (coro->args);
1837 SvREFCNT_dec (coro->swap_sv);
1838 SvREFCNT_dec (CORO_THROW);
1839
1840 coro_call_on_destroy (aTHX_ coro);
1841
1842 /* more destruction mayhem in coro_state_free */
1843}
1844
1845static int
1846coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1847{
1848 struct coro *coro = (struct coro *)mg->mg_ptr;
1849 mg->mg_ptr = 0;
1850
1851 coro_state_destroy (aTHX_ coro);
1852 SvREFCNT_dec (coro->on_destroy);
1853 SvREFCNT_dec (coro->status);
1854
1855 Safefree (coro);
1856
1857 return 0;
1858}
1859
1860static int ecb_cold
1861coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1862{
1863 /* called when perl clones the current process the slow way (windows process emulation) */
1864 /* we simply nuke the pointers in the copy, causing perl to croak */
1865 mg->mg_ptr = 0;
1866 mg->mg_virtual = 0;
1867
1868 return 0;
1869}
1870
1871static MGVTBL coro_state_vtbl = {
1872 0, 0, 0, 0,
1873 coro_state_free,
1874 0,
1875#ifdef MGf_DUP
1876 coro_state_dup,
1877#else
1878# define MGf_DUP 0
1879#endif
1880};
1881
1882static void
1883prepare_transfer (pTHX_ struct coro_transfer_args *ta, SV *prev_sv, SV *next_sv)
1884{
1885 ta->prev = SvSTATE (prev_sv);
1886 ta->next = SvSTATE (next_sv);
1887 TRANSFER_CHECK (*ta);
1888}
1889
1890static void
1891api_transfer (pTHX_ SV *prev_sv, SV *next_sv)
1892{
1893 struct coro_transfer_args ta;
1894
1895 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1896 TRANSFER (ta, 1);
1897}
1898
1899/** Coro ********************************************************************/
1900
1901ecb_inline void
1902coro_enq (pTHX_ struct coro *coro)
1903{
1904 struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
1905
1906 SvREFCNT_inc_NN (coro->hv);
1907
1908 coro->next_ready = 0;
1909 *(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
1910 ready [1] = coro;
1911}
1912
1913ecb_inline struct coro *
1914coro_deq (pTHX)
1915{
1916 int prio;
1917
1918 for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
1919 {
1920 struct coro **ready = coro_ready [prio];
1921
1922 if (ready [0])
1923 {
1924 struct coro *coro = ready [0];
1925 ready [0] = coro->next_ready;
1926 return coro;
1927 }
1928 }
1929
1930 return 0;
1931}
1932
1933static void
1934invoke_sv_ready_hook_helper (void)
1935{
1936 dTHX;
1937 dSP;
1938
1939 ENTER;
1940 SAVETMPS;
1941
1942 PUSHMARK (SP);
1943 PUTBACK;
1944 call_sv (coro_readyhook, G_VOID | G_DISCARD);
1945
1946 FREETMPS;
1947 LEAVE;
1948}
1949
1950static int
1951api_ready (pTHX_ SV *coro_sv)
1952{
1953 struct coro *coro = SvSTATE (coro_sv);
1954
1955 if (coro->flags & CF_READY)
1956 return 0;
1957
1958 coro->flags |= CF_READY;
1959
1960 coro_enq (aTHX_ coro);
1961
1962 if (!coro_nready++)
1963 if (coroapi.readyhook)
1964 coroapi.readyhook ();
1965
1966 return 1;
1967}
1968
1969static int
1970api_is_ready (pTHX_ SV *coro_sv)
1971{
1972 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1973}
1974
1975/* expects to own a reference to next->hv */
1976ecb_inline void
1977prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)
1978{
1979 SV *prev_sv = SvRV (coro_current);
1980
1981 ta->prev = SvSTATE_hv (prev_sv);
1982 ta->next = next;
1983
1984 TRANSFER_CHECK (*ta);
1985
1986 SvRV_set (coro_current, (SV *)next->hv);
1987
1988 free_coro_mortal (aTHX);
1989 coro_mortal = prev_sv;
1990}
1991
1992static void
1993prepare_schedule (pTHX_ struct coro_transfer_args *ta)
1994{
1995 for (;;)
1996 {
1997 struct coro *next = coro_deq (aTHX);
1998
1999 if (ecb_expect_true (next))
2000 {
2001 /* cannot transfer to destroyed coros, skip and look for next */
2002 if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED)))
2003 SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */
2004 else
2005 {
2006 next->flags &= ~CF_READY;
2007 --coro_nready;
2008
2009 prepare_schedule_to (aTHX_ ta, next);
2010 break;
2011 }
2012 }
2013 else
2014 {
2015 /* nothing to schedule: call the idle handler */
2016 if (SvROK (sv_idle)
2017 && SvOBJECT (SvRV (sv_idle)))
2018 {
2019 if (SvRV (sv_idle) == SvRV (coro_current))
2020 {
2021 require_pv ("Carp");
2022
2023 {
2024 dSP;
2025
2026 ENTER;
2027 SAVETMPS;
2028
2029 PUSHMARK (SP);
2030 XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::idle blocked itself - did you try to block inside an event loop callback? Caught", 0)));
2031 PUTBACK;
2032 call_pv ("Carp::confess", G_VOID | G_DISCARD);
2033
2034 FREETMPS;
2035 LEAVE;
2036 }
2037 }
2038
2039 ++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
2040 api_ready (aTHX_ SvRV (sv_idle));
2041 --coro_nready;
2042 }
2043 else
2044 {
2045 /* TODO: deprecated, remove, cannot work reliably *//*D*/
2046 dSP;
2047
2048 ENTER;
2049 SAVETMPS;
2050
2051 PUSHMARK (SP);
2052 PUTBACK;
2053 call_sv (sv_idle, G_VOID | G_DISCARD);
2054
2055 FREETMPS;
2056 LEAVE;
2057 }
2058 }
2059 }
2060}
2061
2062ecb_inline void
2063prepare_cede (pTHX_ struct coro_transfer_args *ta)
2064{
2065 api_ready (aTHX_ coro_current);
2066 prepare_schedule (aTHX_ ta);
2067}
2068
2069ecb_inline void
2070prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
2071{
2072 SV *prev = SvRV (coro_current);
2073
2074 if (coro_nready)
2075 {
2076 prepare_schedule (aTHX_ ta);
2077 api_ready (aTHX_ prev);
2078 }
2079 else
2080 prepare_nop (aTHX_ ta);
2081}
2082
2083static void
2084api_schedule (pTHX)
2085{
2086 struct coro_transfer_args ta;
2087
2088 prepare_schedule (aTHX_ &ta);
2089 TRANSFER (ta, 1);
2090}
2091
2092static void
2093api_schedule_to (pTHX_ SV *coro_sv)
2094{
2095 struct coro_transfer_args ta;
2096 struct coro *next = SvSTATE (coro_sv);
2097
2098 SvREFCNT_inc_NN (coro_sv);
2099 prepare_schedule_to (aTHX_ &ta, next);
2100}
2101
2102static int
2103api_cede (pTHX)
2104{
2105 struct coro_transfer_args ta;
2106
2107 prepare_cede (aTHX_ &ta);
2108
2109 if (ecb_expect_true (ta.prev != ta.next))
2110 {
2111 TRANSFER (ta, 1);
2112 return 1;
2113 }
2114 else
2115 return 0;
2116}
2117
2118static int
2119api_cede_notself (pTHX)
2120{
2121 if (coro_nready)
2122 {
2123 struct coro_transfer_args ta;
2124
2125 prepare_cede_notself (aTHX_ &ta);
2126 TRANSFER (ta, 1);
2127 return 1;
2128 }
2129 else
2130 return 0;
2131}
2132
2133static void
2134api_trace (pTHX_ SV *coro_sv, int flags)
2135{
2136 struct coro *coro = SvSTATE (coro_sv);
2137
2138 if (coro->flags & CF_RUNNING)
2139 croak ("cannot enable tracing on a running coroutine, caught");
2140
2141 if (flags & CC_TRACE)
2142 {
2143 if (!coro->cctx)
2144 coro->cctx = cctx_new_run ();
2145 else if (!(coro->cctx->flags & CC_TRACE))
2146 croak ("cannot enable tracing on coroutine with custom stack, caught");
2147
2148 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
2149 }
2150 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
2151 {
2152 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
2153
2154 if (coro->flags & CF_RUNNING)
2155 PL_runops = RUNOPS_DEFAULT;
2156 else
2157 coro->slot->runops = RUNOPS_DEFAULT;
2158 }
2159}
2160
2161static void
2162coro_push_av (pTHX_ AV *av, I32 gimme_v)
2163{
2164 if (AvFILLp (av) >= 0 && gimme_v != G_VOID)
2165 {
2166 dSP;
2167
2168 if (gimme_v == G_SCALAR)
2169 XPUSHs (AvARRAY (av)[AvFILLp (av)]);
2170 else
2171 {
2172 int i;
2173 EXTEND (SP, AvFILLp (av) + 1);
2174
2175 for (i = 0; i <= AvFILLp (av); ++i)
2176 PUSHs (AvARRAY (av)[i]);
2177 }
2178
2179 PUTBACK;
2180 }
2181}
2182
2183static void
2184coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)
2185{
2186 if (!coro->on_destroy)
2187 coro->on_destroy = newAV ();
2188
2189 av_push (coro->on_destroy, cb);
2190}
2191
2192static void
2193slf_destroy_join (pTHX_ struct CoroSLF *frame)
2194{
2195 SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv);
2196}
2197
2198static int
2199slf_check_join (pTHX_ struct CoroSLF *frame)
2200{
2201 struct coro *coro = (struct coro *)frame->data;
2202
2203 if (!coro->status)
2204 return 1;
2205
2206 frame->destroy = 0;
2207
2208 coro_push_av (aTHX_ coro->status, GIMME_V);
2209
2210 SvREFCNT_dec ((SV *)coro->hv);
2211
2212 return 0;
2213}
2214
2215static void
2216slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2217{
2218 struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef);
2219
2220 if (items > 1)
2221 croak ("join called with too many arguments");
2222
2223 if (coro->status)
2224 frame->prepare = prepare_nop;
2225 else
2226 {
2227 coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current)));
2228 frame->prepare = prepare_schedule;
2229 }
2230
2231 frame->check = slf_check_join;
2232 frame->destroy = slf_destroy_join;
2233 frame->data = (void *)coro;
2234 SvREFCNT_inc (coro->hv);
2235}
2236
2237static void
2238coro_call_on_destroy (pTHX_ struct coro *coro)
2239{
2240 AV *od = coro->on_destroy;
2241
2242 if (!od)
2243 return;
2244
2245 coro->on_destroy = 0;
2246 sv_2mortal ((SV *)od);
2247
2248 while (AvFILLp (od) >= 0)
2249 {
2250 SV *cb = sv_2mortal (av_pop (od));
2251
2252 /* coro hv's (and only hv's at the moment) are supported as well */
2253 if (SvSTATEhv_p (aTHX_ cb))
2254 api_ready (aTHX_ cb);
2255 else
2256 {
2257 dSP; /* don't disturb outer sp */
2258 PUSHMARK (SP);
2259
2260 if (coro->status)
2261 {
2262 PUTBACK;
2263 coro_push_av (aTHX_ coro->status, G_ARRAY);
2264 SPAGAIN;
2265 }
2266
2267 PUTBACK;
2268 call_sv (cb, G_VOID | G_DISCARD);
2269 }
2270 }
2271}
2272
2273static void
2274coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
2275{
2276 AV *av;
2277
2278 if (coro->status)
2279 {
2280 av = coro->status;
2281 av_clear (av);
2282 }
2283 else
2284 av = coro->status = newAV ();
2285
2286 /* items are actually not so common, so optimise for this case */
2287 if (items)
2288 {
2289 int i;
2290
2291 av_extend (av, items - 1);
2292
2293 for (i = 0; i < items; ++i)
2294 av_push (av, SvREFCNT_inc_NN (arg [i]));
2295 }
2296}
2297
2298static void
2299slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv)
2300{
2301 av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */
2302 api_ready (aTHX_ sv_manager);
2303
2304 frame->prepare = prepare_schedule;
2305 frame->check = slf_check_repeat;
2306
2307 /* as a minor optimisation, we could unwind all stacks here */
2308 /* but that puts extra pressure on pp_slf, and is not worth much */
2309 /*coro_unwind_stacks (aTHX);*/
2310}
2311
2312static void
2313slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2314{
2315 HV *coro_hv = (HV *)SvRV (coro_current);
2316
2317 coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items);
2318 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
2319}
2320
2321static void
2322slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2323{
2324 HV *coro_hv;
2325 struct coro *coro;
2326
2327 if (items <= 0)
2328 croak ("Coro::cancel called without coro object,");
2329
2330 coro = SvSTATE (arg [0]);
2331 coro_hv = coro->hv;
2332
2333 coro_set_status (aTHX_ coro, arg + 1, items - 1);
2334
2335 if (ecb_expect_false (coro->flags & CF_NOCANCEL))
2336 {
2337 /* coro currently busy cancelling something, so just notify it */
2338 coro->slf_frame.data = (void *)coro;
2339
2340 frame->prepare = prepare_nop;
2341 frame->check = slf_check_nop;
2342 }
2343 else if (coro_hv == (HV *)SvRV (coro_current))
2344 {
2345 /* cancelling the current coro is allowed, and equals terminate */
2346 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
2347 }
2348 else
2349 {
2350 struct coro *self = SvSTATE_current;
2351
2352 if (!self)
2353 croak ("Coro::cancel called outside of thread content,");
2354
2355 /* otherwise we cancel directly, purely for speed reasons
2356 * unfortunately, this requires some magic trickery, as
2357 * somebody else could cancel us, so we have to fight the cancellation.
2358 * this is ugly, and hopefully fully worth the extra speed.
2359 * besides, I can't get the slow-but-safe version working...
2360 */
2361 slf_frame.data = 0;
2362 self->flags |= CF_NOCANCEL;
2363 coro_state_destroy (aTHX_ coro);
2364 self->flags &= ~CF_NOCANCEL;
2365
2366 if (slf_frame.data)
2367 {
2368 /* while we were busy we have been cancelled, so terminate */
2369 slf_init_terminate_cancel_common (aTHX_ frame, self->hv);
2370 }
2371 else
2372 {
2373 frame->prepare = prepare_nop;
2374 frame->check = slf_check_nop;
2375 }
2376 }
2377}
2378
2379static int
2380slf_check_safe_cancel (pTHX_ struct CoroSLF *frame)
2381{
2382 frame->prepare = 0;
2383 coro_unwind_stacks (aTHX);
2384
2385 slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current));
2386
2387 return 1;
2388}
2389
2390static int
2391safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)
2392{
2393 if (coro->cctx)
2394 croak ("coro inside C callback, unable to cancel at this time, caught");
2395
2396 if (coro->flags & (CF_NEW | CF_ZOMBIE))
2397 {
2398 coro_set_status (aTHX_ coro, arg, items);
2399 coro_state_destroy (aTHX_ coro);
2400 }
2401 else
2402 {
2403 if (!coro->slf_frame.prepare)
2404 croak ("coro outside an SLF function, unable to cancel at this time, caught");
2405
2406 slf_destroy (aTHX_ coro);
2407
2408 coro_set_status (aTHX_ coro, arg, items);
2409 coro->slf_frame.prepare = prepare_nop;
2410 coro->slf_frame.check = slf_check_safe_cancel;
2411
2412 api_ready (aTHX_ (SV *)coro->hv);
2413 }
2414
2415 return 1;
2416}
2417
2418/*****************************************************************************/
2419/* async pool handler */
2420
2421static int
2422slf_check_pool_handler (pTHX_ struct CoroSLF *frame)
2423{
2424 HV *hv = (HV *)SvRV (coro_current);
2425 struct coro *coro = (struct coro *)frame->data;
2426
2427 if (!coro->invoke_cb)
2428 return 1; /* loop till we have invoke */
2429 else
2430 {
2431 hv_store (hv, "desc", sizeof ("desc") - 1,
2432 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
2433
2434 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
2435
2436 {
2437 dSP;
2438 XPUSHs (sv_2mortal (coro->invoke_cb)); coro->invoke_cb = 0;
2439 PUTBACK;
2440 }
2441
2442 SvREFCNT_dec (GvAV (PL_defgv));
2443 GvAV (PL_defgv) = coro->invoke_av;
2444 coro->invoke_av = 0;
2445
2446 return 0;
2447 }
2448}
2449
2450static void
2451slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2452{
2453 HV *hv = (HV *)SvRV (coro_current);
2454 struct coro *coro = SvSTATE_hv ((SV *)hv);
2455
2456 if (ecb_expect_true (coro->saved_deffh))
2457 {
2458 /* subsequent iteration */
2459 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
2460 coro->saved_deffh = 0;
2461
2462 if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
2463 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2464 {
2465 slf_init_terminate_cancel_common (aTHX_ frame, hv);
2466 return;
2467 }
2468 else
2469 {
2470 av_clear (GvAV (PL_defgv));
2471 hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
2472
2473 if (ecb_expect_false (coro->swap_sv))
2474 {
2475 SWAP_SVS_LEAVE (coro);
2476 SvREFCNT_dec_NN (coro->swap_sv);
2477 coro->swap_sv = 0;
2478 }
2479
2480 coro->prio = 0;
2481
2482 if (ecb_expect_false (coro->cctx) && ecb_expect_false (coro->cctx->flags & CC_TRACE))
2483 api_trace (aTHX_ coro_current, 0);
2484
2485 frame->prepare = prepare_schedule;
2486 av_push (av_async_pool, SvREFCNT_inc_NN (hv));
2487 }
2488 }
2489 else
2490 {
2491 /* first iteration, simply fall through */
2492 frame->prepare = prepare_nop;
2493 }
2494
2495 frame->check = slf_check_pool_handler;
2496 frame->data = (void *)coro;
2497}
2498
2499/*****************************************************************************/
2500/* rouse callback */
2501
2502#define CORO_MAGIC_type_rouse PERL_MAGIC_ext
2503
2504static void
2505coro_rouse_callback (pTHX_ CV *cv)
2506{
2507 dXSARGS;
2508 SV *data = (SV *)S_GENSUB_ARG;
2509 SV *coro = SvRV (data);
2510
2511 /* data starts being either undef or a coro, and is replaced by the results when done */
2512 if (SvTYPE (coro) != SVt_PVAV)
2513 {
2514 /* first call, set args */
2515
2516 assert (&ST (0) < &ST (1)); /* ensure the stack is in the order we expect it to be */
2517 SvRV_set (data, (SV *)av_make (items, &ST (0))); /* av_make copies the SVs */
2518
2519 if (coro != &PL_sv_undef)
2520 {
2521 api_ready (aTHX_ coro);
2522 SvREFCNT_dec_NN (coro);
2523 }
2524 }
2525
2526 XSRETURN_EMPTY;
2527}
2528
2529static int
2530slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
2531{
2532 SV *data = (SV *)frame->data;
2533
2534 if (CORO_THROW)
2535 return 0;
2536
2537 if (SvTYPE (SvRV (data)) != SVt_PVAV)
2538 return 1;
2539
2540 /* now push all results on the stack */
2541 {
2542 dSP;
2543 AV *av = (AV *)SvRV (data);
2544 int i;
2545
2546 EXTEND (SP, AvFILLp (av) + 1);
2547 for (i = 0; i <= AvFILLp (av); ++i)
2548 PUSHs (sv_2mortal (AvARRAY (av)[i]));
2549
2550 /* we have stolen the elements, make it unreal and free */
2551 AvREAL_off (av);
2552 av_undef (av);
2553
2554 PUTBACK;
2555 }
2556
2557 return 0;
2558}
2559
2560static void
2561slf_init_rouse_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2562{
2563 SV *cb;
2564
2565 if (items)
2566 cb = arg [0];
2567 else
2568 {
2569 struct coro *coro = SvSTATE_current;
2570
2571 if (!coro->rouse_cb)
2572 croak ("Coro::rouse_wait called without rouse callback, and no default rouse callback found either,");
2573
2574 cb = sv_2mortal (coro->rouse_cb);
2575 coro->rouse_cb = 0;
2576 }
2577
2578 if (!SvROK (cb)
2579 || SvTYPE (SvRV (cb)) != SVt_PVCV
2580 || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
2581 croak ("Coro::rouse_wait called with illegal callback argument,");
2582
2583 {
2584 CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
2585 SV *data = (SV *)S_GENSUB_ARG;
2586 int data_ready = SvTYPE (SvRV (data)) == SVt_PVAV;
2587
2588 /* if there is no data, we need to store the current coro in the reference so we can be woken up */
2589 if (!data_ready)
2590 if (SvRV (data) != &PL_sv_undef)
2591 croak ("Coro::rouse_wait was called on a calback that is already being waited for - only one thread can wait for a rouse callback, caught");
2592 else
2593 SvRV_set (data, SvREFCNT_inc_NN (SvRV (coro_current)));
2594
2595 frame->data = (void *)data;
2596 frame->prepare = data_ready ? prepare_nop : prepare_schedule;
2597 frame->check = slf_check_rouse_wait;
2598 }
2599}
2600
2601static SV *
2602coro_new_rouse_cb (pTHX)
2603{
2604 HV *hv = (HV *)SvRV (coro_current);
2605 struct coro *coro = SvSTATE_hv (hv);
2606 SV *data = newRV_noinc (&PL_sv_undef);
2607 SV *cb = s_gensub (aTHX_ coro_rouse_callback, (void *)data);
2608
2609 sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0);
2610 SvREFCNT_dec_NN (data); /* magicext increases the refcount */
2611
2612 SvREFCNT_dec (coro->rouse_cb);
2613 coro->rouse_cb = SvREFCNT_inc_NN (cb);
2614
2615 return cb;
2616}
2617
2618/*****************************************************************************/
2619/* schedule-like-function opcode (SLF) */
2620
2621static UNOP slf_restore; /* restore stack as entersub did, for first-re-run */
2622static const CV *slf_cv;
2623static SV **slf_argv;
2624static int slf_argc, slf_arga; /* count, allocated */
2625static I32 slf_ax; /* top of stack, for restore */
2626
2627/* this restores the stack in the case we patched the entersub, to */
2628/* recreate the stack frame as perl will on following calls */
2629/* since entersub cleared the stack */
2630static OP *
2631pp_restore (pTHX)
2632{
2633 int i;
2634 SV **SP = PL_stack_base + slf_ax;
2635
2636 PUSHMARK (SP);
2637
2638 EXTEND (SP, slf_argc + 1);
2639
2640 for (i = 0; i < slf_argc; ++i)
2641 PUSHs (sv_2mortal (slf_argv [i]));
2642
2643 PUSHs ((SV *)CvGV (slf_cv));
2644
2645 RETURNOP (slf_restore.op_first);
2646}
2647
2648static void
2649slf_prepare_transfer (pTHX_ struct coro_transfer_args *ta)
2650{
2651 SV **arg = (SV **)slf_frame.data;
2652
2653 prepare_transfer (aTHX_ ta, arg [0], arg [1]);
2654}
2655
2656static void
2657slf_init_transfer (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2658{
2659 if (items != 2)
2660 croak ("Coro::State::transfer (prev, next) expects two arguments, not %d,", items);
2661
2662 frame->prepare = slf_prepare_transfer;
2663 frame->check = slf_check_nop;
2664 frame->data = (void *)arg; /* let's hope it will stay valid */
2665}
2666
2667static void
2668slf_init_schedule (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2669{
2670 frame->prepare = prepare_schedule;
2671 frame->check = slf_check_nop;
2672}
2673
2674static void
2675slf_prepare_schedule_to (pTHX_ struct coro_transfer_args *ta)
2676{
2677 struct coro *next = (struct coro *)slf_frame.data;
2678
2679 SvREFCNT_inc_NN (next->hv);
2680 prepare_schedule_to (aTHX_ ta, next);
2681}
2682
2683static void
2684slf_init_schedule_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2685{
2686 if (!items)
2687 croak ("Coro::schedule_to expects a coroutine argument, caught");
2688
2689 frame->data = (void *)SvSTATE (arg [0]);
2690 frame->prepare = slf_prepare_schedule_to;
2691 frame->check = slf_check_nop;
2692}
2693
2694static void
2695slf_init_cede_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2696{
2697 api_ready (aTHX_ SvRV (coro_current));
2698
2699 slf_init_schedule_to (aTHX_ frame, cv, arg, items);
2700}
2701
2702static void
2703slf_init_cede (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2704{
2705 frame->prepare = prepare_cede;
2706 frame->check = slf_check_nop;
2707}
2708
2709static void
2710slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2711{
2712 frame->prepare = prepare_cede_notself;
2713 frame->check = slf_check_nop;
2714}
2715
2716/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
2717static void
2718slf_destroy (pTHX_ struct coro *coro)
2719{
2720 struct CoroSLF frame = coro->slf_frame;
2721
2722 /*
2723 * The on_destroy below most likely is from an SLF call.
2724 * Since by definition the SLF call will not finish when we destroy
2725 * the coro, we will have to force-finish it here, otherwise
2726 * cleanup functions cannot call SLF functions.
2727 */
2728 coro->slf_frame.prepare = 0;
2729
2730 /* this callback is reserved for slf functions needing to do cleanup */
2731 if (frame.destroy && frame.prepare && !PL_dirty)
2732 frame.destroy (aTHX_ &frame);
2733}
2734
2735/*
2736 * these not obviously related functions are all rolled into one
2737 * function to increase chances that they all will call transfer with the same
2738 * stack offset
2739 * SLF stands for "schedule-like-function".
2740 */
2741static OP *
2742pp_slf (pTHX)
2743{
2744 I32 checkmark; /* mark SP to see how many elements check has pushed */
2745
2746 /* set up the slf frame, unless it has already been set-up */
2747 /* the latter happens when a new coro has been started */
2748 /* or when a new cctx was attached to an existing coroutine */
2749 if (ecb_expect_true (!slf_frame.prepare))
2750 {
2751 /* first iteration */
2752 dSP;
2753 SV **arg = PL_stack_base + TOPMARK + 1;
2754 int items = SP - arg; /* args without function object */
2755 SV *gv = *sp;
2756
2757 /* do a quick consistency check on the "function" object, and if it isn't */
2758 /* for us, divert to the real entersub */
2759 if (SvTYPE (gv) != SVt_PVGV
2760 || !GvCV (gv)
2761 || !(CvFLAGS (GvCV (gv)) & CVf_SLF))
2762 return PL_ppaddr[OP_ENTERSUB](aTHX);
2763
2764 if (!(PL_op->op_flags & OPf_STACKED))
2765 {
2766 /* ampersand-form of call, use @_ instead of stack */
2767 AV *av = GvAV (PL_defgv);
2768 arg = AvARRAY (av);
2769 items = AvFILLp (av) + 1;
2770 }
2771
2772 /* now call the init function, which needs to set up slf_frame */
2773 ((coro_slf_cb)CvXSUBANY (GvCV (gv)).any_ptr)
2774 (aTHX_ &slf_frame, GvCV (gv), arg, items);
2775
2776 /* pop args */
2777 SP = PL_stack_base + POPMARK;
2778
2779 PUTBACK;
2780 }
2781
2782 /* now that we have a slf_frame, interpret it! */
2783 /* we use a callback system not to make the code needlessly */
2784 /* complicated, but so we can run multiple perl coros from one cctx */
2785
2786 do
2787 {
2788 struct coro_transfer_args ta;
2789
2790 slf_frame.prepare (aTHX_ &ta);
2791 TRANSFER (ta, 0);
2792
2793 checkmark = PL_stack_sp - PL_stack_base;
2794 }
2795 while (slf_frame.check (aTHX_ &slf_frame));
2796
2797 slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */
2798
2799 /* exception handling */
2800 if (ecb_expect_false (CORO_THROW))
2801 {
2802 SV *exception = sv_2mortal (CORO_THROW);
2803
2804 CORO_THROW = 0;
2805 sv_setsv (ERRSV, exception);
2806 croak (0);
2807 }
2808
2809 /* return value handling - mostly like entersub */
2810 /* make sure we put something on the stack in scalar context */
2811 if (GIMME_V == G_SCALAR
2812 && ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1))
2813 {
2814 dSP;
2815 SV **bot = PL_stack_base + checkmark;
2816
2817 if (sp == bot) /* too few, push undef */
2818 bot [1] = &PL_sv_undef;
2819 else /* too many, take last one */
2820 bot [1] = *sp;
2821
2822 SP = bot + 1;
2823
2824 PUTBACK;
2825 }
2826
2827 return NORMAL;
2828}
2829
2830static void
2831api_execute_slf (pTHX_ CV *cv, coro_slf_cb init_cb, I32 ax)
2832{
2833 int i;
2834 SV **arg = PL_stack_base + ax;
2835 int items = PL_stack_sp - arg + 1;
2836
2837 assert (("FATAL: SLF call with illegal CV value", !CvANON (cv)));
2838
2839 if (PL_op->op_ppaddr != PL_ppaddr [OP_ENTERSUB]
2840 && PL_op->op_ppaddr != pp_slf)
2841 croak ("FATAL: Coro SLF calls can only be made normally, not via goto or any other means, caught");
2842
2843 CvFLAGS (cv) |= CVf_SLF;
2844 CvXSUBANY (cv).any_ptr = (void *)init_cb;
2845 slf_cv = cv;
2846
2847 /* we patch the op, and then re-run the whole call */
2848 /* we have to put the same argument on the stack for this to work */
2849 /* and this will be done by pp_restore */
2850 slf_restore.op_next = (OP *)&slf_restore;
2851 slf_restore.op_type = OP_CUSTOM;
2852 slf_restore.op_ppaddr = pp_restore;
2853 slf_restore.op_first = PL_op;
2854
2855 slf_ax = ax - 1; /* undo the ax++ inside dAXMARK */
2856
2857 if (PL_op->op_flags & OPf_STACKED)
2858 {
2859 if (items > slf_arga)
2860 {
2861 slf_arga = items;
2862 Safefree (slf_argv);
2863 New (0, slf_argv, slf_arga, SV *);
2864 }
2865
2866 slf_argc = items;
2867
2868 for (i = 0; i < items; ++i)
2869 slf_argv [i] = SvREFCNT_inc (arg [i]);
2870 }
2871 else
2872 slf_argc = 0;
2873
2874 PL_op->op_ppaddr = pp_slf;
2875 /*PL_op->op_type = OP_CUSTOM; /* we do behave like entersub still */
2876
2877 PL_op = (OP *)&slf_restore;
2878}
2879
2880/*****************************************************************************/
2881/* dynamic wind */
2882
2883static void
2884on_enterleave_call (pTHX_ SV *cb)
2885{
2886 dSP;
2887
2888 PUSHSTACK;
2889
2890 PUSHMARK (SP);
2891 PUTBACK;
2892 call_sv (cb, G_VOID | G_DISCARD);
2893 SPAGAIN;
2894
2895 POPSTACK;
2896}
2897
2898static SV *
2899coro_avp_pop_and_free (pTHX_ AV **avp)
2900{
2901 AV *av = *avp;
2902 SV *res = av_pop (av);
2903
2904 if (AvFILLp (av) < 0)
2905 {
2906 *avp = 0;
2907 SvREFCNT_dec (av);
2908 }
2909
2910 return res;
2911}
2912
2913static void
2914coro_pop_on_enter (pTHX_ void *coro)
2915{
2916 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_enter);
2917 SvREFCNT_dec (cb);
2918}
2919
2920static void
2921coro_pop_on_leave (pTHX_ void *coro)
2922{
2923 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_leave);
2924 on_enterleave_call (aTHX_ sv_2mortal (cb));
2925}
2926
2927static void
2928enterleave_hook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, void *arg)
2929{
2930 if (!hook)
2931 return;
2932
2933 if (!*avp)
2934 {
2935 *avp = newAV ();
2936 AvREAL_off (*avp);
2937 }
2938
2939 av_push (*avp, (SV *)hook);
2940 av_push (*avp, (SV *)arg);
2941}
2942
2943static void
2944enterleave_unhook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, int execute)
2945{
2946 AV *av = *avp;
2947 int i;
2948
2949 if (!av)
2950 return;
2951
2952 for (i = AvFILLp (av) - 1; i >= 0; i -= 2)
2953 if (AvARRAY (av)[i] == (SV *)hook)
2954 {
2955 if (execute)
2956 hook (aTHX_ (void *)AvARRAY (av)[i + 1]);
2957
2958 memmove (AvARRAY (av) + i, AvARRAY (av) + i + 2, AvFILLp (av) - i - 1);
2959 av_pop (av);
2960 av_pop (av);
2961 break;
2962 }
2963
2964 if (AvFILLp (av) >= 0)
2965 {
2966 *avp = 0;
2967 SvREFCNT_dec_NN (av);
2968 }
2969}
2970
2971static void
2972api_enterleave_hook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
2973{
2974 struct coro *coro = SvSTATE (coro_sv);
2975
2976 if (SvSTATE_current == coro)
2977 if (enter)
2978 enter (aTHX_ enter_arg);
2979
2980 enterleave_hook_xs (aTHX_ coro, &coro->on_enter_xs, enter, enter_arg);
2981 enterleave_hook_xs (aTHX_ coro, &coro->on_leave_xs, leave, leave_arg);
2982}
2983
2984static void
2985api_enterleave_unhook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, coro_enterleave_hook leave)
2986{
2987 struct coro *coro = SvSTATE (coro_sv);
2988
2989 enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
2990 enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, SvSTATE_current == coro);
2991}
2992
2993static void
2994savedestructor_unhook_enter (pTHX_ coro_enterleave_hook enter)
2995{
2996 struct coro *coro = SvSTATE_current;
2997
2998 enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
2999}
3000
3001static void
3002savedestructor_unhook_leave (pTHX_ coro_enterleave_hook leave)
3003{
3004 struct coro *coro = SvSTATE_current;
3005
3006 enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, 1);
3007}
3008
3009static void
3010api_enterleave_scope_hook (pTHX_ coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
3011{
3012 api_enterleave_hook (aTHX_ coro_current, enter, enter_arg, leave, leave_arg);
3013
3014 /* this ought to be much cheaper than malloc + a single destructor call */
3015 if (enter) SAVEDESTRUCTOR_X (savedestructor_unhook_enter, enter);
3016 if (leave) SAVEDESTRUCTOR_X (savedestructor_unhook_leave, leave);
3017}
3018
3019/*****************************************************************************/
3020/* PerlIO::cede */
3021
3022typedef struct
3023{
3024 PerlIOBuf base;
3025 NV next, every;
3026} PerlIOCede;
3027
3028static IV ecb_cold
3029PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3030{
3031 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
3032
3033 self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
3034 self->next = nvtime () + self->every;
3035
3036 return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
3037}
3038
3039static SV * ecb_cold
3040PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
3041{
3042 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
3043
3044 return newSVnv (self->every);
3045}
3046
3047static IV
3048PerlIOCede_flush (pTHX_ PerlIO *f)
3049{
3050 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
3051 double now = nvtime ();
3052
3053 if (now >= self->next)
3054 {
3055 api_cede (aTHX);
3056 self->next = now + self->every;
3057 }
3058
3059 return PerlIOBuf_flush (aTHX_ f);
3060}
3061
3062static PerlIO_funcs PerlIO_cede =
3063{
3064 sizeof(PerlIO_funcs),
3065 "cede",
3066 sizeof(PerlIOCede),
3067 PERLIO_K_DESTRUCT | PERLIO_K_RAW,
3068 PerlIOCede_pushed,
3069 PerlIOBuf_popped,
3070 PerlIOBuf_open,
3071 PerlIOBase_binmode,
3072 PerlIOCede_getarg,
3073 PerlIOBase_fileno,
3074 PerlIOBuf_dup,
3075 PerlIOBuf_read,
3076 PerlIOBuf_unread,
3077 PerlIOBuf_write,
3078 PerlIOBuf_seek,
3079 PerlIOBuf_tell,
3080 PerlIOBuf_close,
3081 PerlIOCede_flush,
3082 PerlIOBuf_fill,
3083 PerlIOBase_eof,
3084 PerlIOBase_error,
3085 PerlIOBase_clearerr,
3086 PerlIOBase_setlinebuf,
3087 PerlIOBuf_get_base,
3088 PerlIOBuf_bufsiz,
3089 PerlIOBuf_get_ptr,
3090 PerlIOBuf_get_cnt,
3091 PerlIOBuf_set_ptrcnt,
3092};
3093
3094/*****************************************************************************/
3095/* Coro::Semaphore & Coro::Signal */
3096
3097static SV *
3098coro_waitarray_new (pTHX_ int count)
3099{
3100 /* a waitarray=semaphore contains a counter IV in $sem->[0] and any waiters after that */
3101 AV *av = newAV ();
3102 SV **ary;
3103
3104 /* unfortunately, building manually saves memory */
3105 Newx (ary, 2, SV *);
3106 AvALLOC (av) = ary;
3107#if PERL_VERSION_ATLEAST (5,10,0)
3108 AvARRAY (av) = ary;
3109#else
3110 /* 5.8.8 needs this syntax instead of AvARRAY = ary, yet */
3111 /* -DDEBUGGING flags this as a bug, despite it perfectly working */
3112 SvPVX ((SV *)av) = (char *)ary;
3113#endif
3114 AvMAX (av) = 1;
3115 AvFILLp (av) = 0;
3116 ary [0] = newSViv (count);
3117
3118 return newRV_noinc ((SV *)av);
3119}
3120
3121/* semaphore */
3122
3123static void
3124coro_semaphore_adjust (pTHX_ AV *av, IV adjust)
3125{
3126 SV *count_sv = AvARRAY (av)[0];
3127 IV count = SvIVX (count_sv);
3128
3129 count += adjust;
3130 SvIVX (count_sv) = count;
3131
3132 /* now wake up as many waiters as are expected to lock */
3133 while (count > 0 && AvFILLp (av) > 0)
3134 {
3135 SV *cb;
3136
3137 /* swap first two elements so we can shift a waiter */
3138 AvARRAY (av)[0] = AvARRAY (av)[1];
3139 AvARRAY (av)[1] = count_sv;
3140 cb = av_shift (av);
3141
3142 if (SvOBJECT (cb))
3143 {
3144 api_ready (aTHX_ cb);
3145 --count;
3146 }
3147 else if (SvTYPE (cb) == SVt_PVCV)
3148 {
3149 dSP;
3150 PUSHMARK (SP);
3151 XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
3152 PUTBACK;
3153 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
3154 }
3155
3156 SvREFCNT_dec_NN (cb);
3157 }
3158}
3159
3160static void
3161coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
3162{
3163 /* call $sem->adjust (0) to possibly wake up some other waiters */
3164 coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0);
3165}
3166
3167static int
3168slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)
3169{
3170 AV *av = (AV *)frame->data;
3171 SV *count_sv = AvARRAY (av)[0];
3172 SV *coro_hv = SvRV (coro_current);
3173
3174 frame->destroy = 0;
3175
3176 /* if we are about to throw, don't actually acquire the lock, just throw */
3177 if (ecb_expect_false (CORO_THROW))
3178 {
3179 /* we still might be responsible for the semaphore, so wake up others */
3180 coro_semaphore_adjust (aTHX_ av, 0);
3181
3182 return 0;
3183 }
3184 else if (SvIVX (count_sv) > 0)
3185 {
3186 if (acquire)
3187 SvIVX (count_sv) = SvIVX (count_sv) - 1;
3188 else
3189 coro_semaphore_adjust (aTHX_ av, 0);
3190
3191 return 0;
3192 }
3193 else
3194 {
3195 int i;
3196 /* if we were woken up but can't down, we look through the whole */
3197 /* waiters list and only add us if we aren't in there already */
3198 /* this avoids some degenerate memory usage cases */
3199 for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */
3200 if (AvARRAY (av)[i] == coro_hv)
3201 return 1;
3202
3203 av_push (av, SvREFCNT_inc (coro_hv));
3204 return 1;
3205 }
3206}
3207
3208static int
3209slf_check_semaphore_down (pTHX_ struct CoroSLF *frame)
3210{
3211 return slf_check_semaphore_down_or_wait (aTHX_ frame, 1);
3212}
3213
3214static int
3215slf_check_semaphore_wait (pTHX_ struct CoroSLF *frame)
3216{
3217 return slf_check_semaphore_down_or_wait (aTHX_ frame, 0);
3218}
3219
3220static void
3221slf_init_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3222{
3223 AV *av = (AV *)SvRV (arg [0]);
3224
3225 if (SvIVX (AvARRAY (av)[0]) > 0)
3226 {
3227 frame->data = (void *)av;
3228 frame->prepare = prepare_nop;
3229 }
3230 else
3231 {
3232 av_push (av, SvREFCNT_inc (SvRV (coro_current)));
3233
3234 frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
3235 frame->prepare = prepare_schedule;
3236 /* to avoid race conditions when a woken-up coro gets terminated */
3237 /* we arrange for a temporary on_destroy that calls adjust (0) */
3238 frame->destroy = coro_semaphore_destroy;
3239 }
3240}
3241
3242static void
3243slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3244{
3245 slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items);
3246 frame->check = slf_check_semaphore_down;
3247}
3248
3249static void
3250slf_init_semaphore_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3251{
3252 if (items >= 2)
3253 {
3254 /* callback form */
3255 AV *av = (AV *)SvRV (arg [0]);
3256 SV *cb_cv = s_get_cv_croak (arg [1]);
3257
3258 av_push (av, SvREFCNT_inc_NN (cb_cv));
3259
3260 if (SvIVX (AvARRAY (av)[0]) > 0)
3261 coro_semaphore_adjust (aTHX_ av, 0);
3262
3263 frame->prepare = prepare_nop;
3264 frame->check = slf_check_nop;
3265 }
3266 else
3267 {
3268 slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items);
3269 frame->check = slf_check_semaphore_wait;
3270 }
3271}
3272
3273/* signal */
3274
3275static void
3276coro_signal_wake (pTHX_ AV *av, int count)
3277{
3278 SvIVX (AvARRAY (av)[0]) = 0;
3279
3280 /* now signal count waiters */
3281 while (count > 0 && AvFILLp (av) > 0)
3282 {
3283 SV *cb;
3284
3285 /* swap first two elements so we can shift a waiter */
3286 cb = AvARRAY (av)[0];
3287 AvARRAY (av)[0] = AvARRAY (av)[1];
3288 AvARRAY (av)[1] = cb;
3289
3290 cb = av_shift (av);
3291
3292 if (SvTYPE (cb) == SVt_PVCV)
3293 {
3294 dSP;
3295 PUSHMARK (SP);
3296 XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
3297 PUTBACK;
3298 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
3299 }
3300 else
3301 {
3302 api_ready (aTHX_ cb);
3303 sv_setiv (cb, 0); /* signal waiter */
3304 }
3305
3306 SvREFCNT_dec_NN (cb);
3307
3308 --count;
3309 }
3310}
3311
3312static int
3313slf_check_signal_wait (pTHX_ struct CoroSLF *frame)
3314{
3315 /* if we are about to throw, also stop waiting */
3316 return SvROK ((SV *)frame->data) && !CORO_THROW;
3317}
3318
3319static void
3320slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3321{
3322 AV *av = (AV *)SvRV (arg [0]);
3323
3324 if (items >= 2)
3325 {
3326 SV *cb_cv = s_get_cv_croak (arg [1]);
3327 av_push (av, SvREFCNT_inc_NN (cb_cv));
3328
3329 if (SvIVX (AvARRAY (av)[0]))
3330 coro_signal_wake (aTHX_ av, 1); /* must be the only waiter */
3331
3332 frame->prepare = prepare_nop;
3333 frame->check = slf_check_nop;
3334 }
3335 else if (SvIVX (AvARRAY (av)[0]))
3336 {
3337 SvIVX (AvARRAY (av)[0]) = 0;
3338 frame->prepare = prepare_nop;
3339 frame->check = slf_check_nop;
3340 }
3341 else
3342 {
3343 SV *waiter = newSVsv (coro_current); /* owned by signal av */
3344
3345 av_push (av, waiter);
3346
3347 frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */
3348 frame->prepare = prepare_schedule;
3349 frame->check = slf_check_signal_wait;
3350 }
3351}
3352
3353/*****************************************************************************/
3354/* Coro::AIO */
3355
3356#define CORO_MAGIC_type_aio PERL_MAGIC_ext
3357
3358/* helper storage struct */
3359struct io_state
3360{
3361 int errorno;
3362 I32 laststype; /* U16 in 5.10.0 */
3363 int laststatval;
3364 Stat_t statcache;
3365};
3366
3367static void
3368coro_aio_callback (pTHX_ CV *cv)
3369{
3370 dXSARGS;
3371 AV *state = (AV *)S_GENSUB_ARG;
3372 SV *coro = av_pop (state);
3373 SV *data_sv = newSV (sizeof (struct io_state));
3374
3375 av_extend (state, items - 1);
3376
3377 sv_upgrade (data_sv, SVt_PV);
3378 SvCUR_set (data_sv, sizeof (struct io_state));
3379 SvPOK_only (data_sv);
3380
3381 {
3382 struct io_state *data = (struct io_state *)SvPVX (data_sv);
3383
3384 data->errorno = errno;
3385 data->laststype = PL_laststype;
3386 data->laststatval = PL_laststatval;
3387 data->statcache = PL_statcache;
3388 }
3389
3390 /* now build the result vector out of all the parameters and the data_sv */
3391 {
3392 int i;
3393
3394 for (i = 0; i < items; ++i)
3395 av_push (state, SvREFCNT_inc_NN (ST (i)));
3396 }
3397
3398 av_push (state, data_sv);
3399
3400 api_ready (aTHX_ coro);
3401 SvREFCNT_dec_NN (coro);
3402 SvREFCNT_dec_NN ((AV *)state);
3403}
3404
3405static int
3406slf_check_aio_req (pTHX_ struct CoroSLF *frame)
3407{
3408 AV *state = (AV *)frame->data;
3409
3410 /* if we are about to throw, return early */
3411 /* this does not cancel the aio request, but at least */
3412 /* it quickly returns */
3413 if (CORO_THROW)
3414 return 0;
3415
3416 /* one element that is an RV? repeat! */
3417 if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
3418 return 1;
3419
3420 /* restore status */
3421 {
3422 SV *data_sv = av_pop (state);
3423 struct io_state *data = (struct io_state *)SvPVX (data_sv);
3424
3425 errno = data->errorno;
3426 PL_laststype = data->laststype;
3427 PL_laststatval = data->laststatval;
3428 PL_statcache = data->statcache;
3429
3430 SvREFCNT_dec_NN (data_sv);
3431 }
3432
3433 /* push result values */
3434 {
3435 dSP;
3436 int i;
3437
3438 EXTEND (SP, AvFILLp (state) + 1);
3439 for (i = 0; i <= AvFILLp (state); ++i)
3440 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (state)[i])));
3441
3442 PUTBACK;
3443 }
3444
3445 return 0;
3446}
3447
3448static void
3449slf_init_aio_req (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3450{
3451 AV *state = (AV *)sv_2mortal ((SV *)newAV ());
3452 SV *coro_hv = SvRV (coro_current);
3453 struct coro *coro = SvSTATE_hv (coro_hv);
3454
3455 /* put our coroutine id on the state arg */
3456 av_push (state, SvREFCNT_inc_NN (coro_hv));
3457
3458 /* first see whether we have a non-zero priority and set it as AIO prio */
3459 if (coro->prio)
3460 {
3461 dSP;
3462
3463 static SV *prio_cv;
3464 static SV *prio_sv;
3465
3466 if (ecb_expect_false (!prio_cv))
3467 {
3468 prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);
3469 prio_sv = newSViv (0);
3470 }
3471
3472 PUSHMARK (SP);
3473 sv_setiv (prio_sv, coro->prio);
3474 XPUSHs (prio_sv);
3475
3476 PUTBACK;
3477 call_sv (prio_cv, G_VOID | G_DISCARD);
3478 }
3479
3480 /* now call the original request */
3481 {
3482 dSP;
3483 CV *req = (CV *)CORO_MAGIC_NN ((SV *)cv, CORO_MAGIC_type_aio)->mg_obj;
3484 int i;
3485
3486 PUSHMARK (SP);
3487
3488 /* first push all args to the stack */
3489 EXTEND (SP, items + 1);
3490
3491 for (i = 0; i < items; ++i)
3492 PUSHs (arg [i]);
3493
3494 /* now push the callback closure */
3495 PUSHs (sv_2mortal (s_gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));
3496
3497 /* now call the AIO function - we assume our request is uncancelable */
3498 PUTBACK;
3499 call_sv ((SV *)req, G_VOID | G_DISCARD);
3500 }
3501
3502 /* now that the request is going, we loop till we have a result */
3503 frame->data = (void *)state;
3504 frame->prepare = prepare_schedule;
3505 frame->check = slf_check_aio_req;
3506}
3507
3508static void
3509coro_aio_req_xs (pTHX_ CV *cv)
3510{
3511 dXSARGS;
3512
3513 CORO_EXECUTE_SLF_XS (slf_init_aio_req);
3514
3515 XSRETURN_EMPTY;
3516}
3517
3518/*****************************************************************************/
3519
3520#if CORO_CLONE
3521# include "clone.c"
3522#endif
3523
3524/*****************************************************************************/
3525
3526static SV *
3527coro_new (pTHX_ HV *stash, SV **argv, int argc, int is_coro)
3528{
3529 SV *coro_sv;
3530 struct coro *coro;
3531 MAGIC *mg;
3532 HV *hv;
3533 SV *cb;
3534 int i;
3535
3536 if (argc > 0)
3537 {
3538 cb = s_get_cv_croak (argv [0]);
3539
3540 if (!is_coro)
3541 {
3542 if (CvISXSUB (cb))
3543 croak ("Coro::State doesn't support XS functions as coroutine start, caught");
3544
3545 if (!CvROOT (cb))
3546 croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught");
3547 }
3548 }
3549
3550 Newz (0, coro, 1, struct coro);
3551 coro->args = newAV ();
3552 coro->flags = CF_NEW;
3553
3554 if (coro_first) coro_first->prev = coro;
3555 coro->next = coro_first;
3556 coro_first = coro;
3557
3558 coro->hv = hv = newHV ();
3559 mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
3560 mg->mg_flags |= MGf_DUP;
3561 coro_sv = sv_bless (newRV_noinc ((SV *)hv), stash);
3562
3563 if (argc > 0)
3564 {
3565 av_extend (coro->args, argc + is_coro - 1);
3566
3567 if (is_coro)
3568 {
3569 av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb));
3570 cb = (SV *)cv_coro_run;
3571 }
3572
3573 coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb);
3574
3575 for (i = 1; i < argc; i++)
3576 av_push (coro->args, newSVsv (argv [i]));
3577 }
3578
3579 return coro_sv;
3580}
3581
3582#ifndef __cplusplus
3583ecb_cold XS(boot_Coro__State);
3584#endif
3585
3586#if CORO_JIT
3587
3588static void ecb_noinline ecb_cold
3589pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)
3590{
3591 dSP;
3592 AV *av = newAV ();
3593
3594 av_store (av, 3, newSVuv (d));
3595 av_store (av, 2, newSVuv (c));
3596 av_store (av, 1, newSVuv (b));
3597 av_store (av, 0, newSVuv (a));
3598
3599 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
3600
3601 PUTBACK;
3602}
3603
3604static void ecb_noinline ecb_cold
3605jit_init (pTHX)
3606{
3607 dSP;
3608 SV *load, *save;
3609 char *map_base;
3610 char *load_ptr, *save_ptr;
3611 STRLEN load_len, save_len, map_len;
3612 int count;
3613
3614 eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
3615
3616 PUSHMARK (SP);
3617 #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
3618 #include "state.h"
3619 count = call_pv ("Coro::State::_jit", G_ARRAY);
3620 SPAGAIN;
3621
3622 save = POPs; save_ptr = SvPVbyte (save, save_len);
3623 load = POPs; load_ptr = SvPVbyte (load, load_len);
3624
3625 map_len = load_len + save_len + 16;
3626
3627 map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
3628
3629 if (map_base == (char *)MAP_FAILED)
3630 map_base = mmap (0, map_len, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
3631
3632 assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED));
3633
3634 load_perl_slots = (load_save_perl_slots_type)map_base;
3635 memcpy (map_base, load_ptr, load_len);
3636
3637 map_base += (load_len + 15) & ~15;
3638
3639 save_perl_slots = (load_save_perl_slots_type)map_base;
3640 memcpy (map_base, save_ptr, save_len);
3641
3642 /* we are good citizens and try to make the page read-only, so the evil evil */
3643 /* hackers might have it a bit more difficult */
3644 mprotect (map_base, map_len, PROT_READ | PROT_EXEC);
3645
3646 PUTBACK;
3647 eval_pv ("undef &Coro::State::_jit", 1);
3648}
3649
3650#endif
3651
3652MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
3653
3654PROTOTYPES: DISABLE
3655
3656BOOT:
3657{
3658#define VARx(name,expr,type) if (sizeof (type) < sizeof (expr)) croak ("FATAL: Coro thread context slot '" # name "' too small for this version of perl.");
3659#include "state.h"
3660#ifdef USE_ITHREADS
3661# if CORO_PTHREAD
3662 coro_thx = PERL_GET_CONTEXT;
3663# endif
3664#endif
3665 /* perl defines these to check for existance first, but why it doesn't */
3666 /* just create them one at init time is not clear to me, except for */
3667 /* programs trying to delete them, but... */
3668 /* anyway, we declare this as invalid and make sure they are initialised here */
3669 DEFSV;
3670 ERRSV;
3671
3672 cctx_current = cctx_new_empty ();
3673
3674 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
3675 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3676
3677 {
3678 /*
3679 * we provide a vtbvl for %SIG magic that replaces PL_vtbl_sig
3680 * by coro_sig_vtbl in hash values.
3681 */
3682 MAGIC *mg = mg_find ((SV *)GvHV (gv_fetchpv ("SIG", GV_ADD | GV_NOTQUAL, SVt_PVHV)), PERL_MAGIC_sig);
3683
3684 /* this only works if perl doesn't have a vtbl for %SIG */
3685 assert (!mg->mg_virtual);
3686
3687 /*
3688 * The irony is that the perl API itself asserts that mg_virtual
3689 * must be non-const, yet perl5porters insisted on marking their
3690 * vtbls as read-only, just to thwart perl modules from patching
3691 * them.
3692 */
3693 mg->mg_virtual = (MGVTBL *)&coro_sig_vtbl;
3694 mg->mg_flags |= MGf_COPY;
3695
3696 coro_sigelem_vtbl = PL_vtbl_sigelem;
3697 coro_sigelem_vtbl.svt_get = coro_sigelem_get;
3698 coro_sigelem_vtbl.svt_set = coro_sigelem_set;
3699 coro_sigelem_vtbl.svt_clear = coro_sigelem_clr;
3700 }
3701
3702 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
3703 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
3704
3705 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
3706
3707 newCONSTSUB (coro_state_stash, "BACKEND", newSVpv (CORO_BACKEND, 0)); /* undocumented */
3708
3709 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
3710 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
3711 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
3712 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
3713
3714 main_mainstack = PL_mainstack;
3715 main_top_env = PL_top_env;
3716
3717 while (main_top_env->je_prev)
3718 main_top_env = main_top_env->je_prev;
3719
3720 {
3721 SV *slf = sv_2mortal (newSViv (PTR2IV (pp_slf)));
3722
3723 if (!PL_custom_op_names) PL_custom_op_names = newHV ();
3724 hv_store_ent (PL_custom_op_names, slf, newSVpv ("coro_slf", 0), 0);
3725
3726 if (!PL_custom_op_descs) PL_custom_op_descs = newHV ();
3727 hv_store_ent (PL_custom_op_descs, slf, newSVpv ("coro schedule like function", 0), 0);
3728 }
3729
3730 coroapi.ver = CORO_API_VERSION;
3731 coroapi.rev = CORO_API_REVISION;
3732
3733 coroapi.transfer = api_transfer;
3734
3735 coroapi.sv_state = SvSTATE_;
3736 coroapi.execute_slf = api_execute_slf;
3737 coroapi.prepare_nop = prepare_nop;
3738 coroapi.prepare_schedule = prepare_schedule;
3739 coroapi.prepare_cede = prepare_cede;
3740 coroapi.prepare_cede_notself = prepare_cede_notself;
3741
3742 time_init (aTHX);
3743
3744 assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));
3745#if CORO_JIT
3746 PUTBACK;
3747 jit_init (aTHX);
3748 SPAGAIN;
3749#endif
3750}
3751
3752SV *
3753new (SV *klass, ...)
3754 ALIAS:
3755 Coro::new = 1
3756 CODE:
3757 RETVAL = coro_new (aTHX_ ix ? coro_stash : coro_state_stash, &ST (1), items - 1, ix);
3758 OUTPUT:
3759 RETVAL
3760
3761void
3762transfer (...)
3763 PROTOTYPE: $$
3764 CODE:
3765 CORO_EXECUTE_SLF_XS (slf_init_transfer);
3766
3767SV *
3768clone (Coro::State coro)
3769 CODE:
3770{
3771#if CORO_CLONE
3772 struct coro *ncoro = coro_clone (aTHX_ coro);
3773 MAGIC *mg;
3774 /* TODO: too much duplication */
3775 ncoro->hv = newHV ();
3776 mg = sv_magicext ((SV *)ncoro->hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)ncoro, 0);
3777 mg->mg_flags |= MGf_DUP;
3778 RETVAL = sv_bless (newRV_noinc ((SV *)ncoro->hv), SvSTASH (coro->hv));
3779#else
3780 croak ("Coro::State->clone has not been configured into this installation of Coro, realised");
3781#endif
3782}
3783 OUTPUT:
3784 RETVAL
3785
3786int
3787cctx_stacksize (int new_stacksize = 0)
3788 PROTOTYPE: ;$
3789 CODE:
3790 RETVAL = cctx_stacksize;
3791 if (new_stacksize)
3792 {
3793 cctx_stacksize = new_stacksize;
3794 ++cctx_gen;
3795 }
3796 OUTPUT:
3797 RETVAL
3798
3799int
3800cctx_max_idle (int max_idle = 0)
3801 PROTOTYPE: ;$
3802 CODE:
3803 RETVAL = cctx_max_idle;
3804 if (max_idle > 1)
3805 cctx_max_idle = max_idle;
3806 OUTPUT:
3807 RETVAL
3808
3809int
3810cctx_count ()
3811 PROTOTYPE:
3812 CODE:
3813 RETVAL = cctx_count;
3814 OUTPUT:
3815 RETVAL
3816
3817int
3818cctx_idle ()
3819 PROTOTYPE:
3820 CODE:
3821 RETVAL = cctx_idle;
3822 OUTPUT:
3823 RETVAL
3824
3825void
3826list ()
3827 PROTOTYPE:
3828 PPCODE:
3829{
3830 struct coro *coro;
3831 for (coro = coro_first; coro; coro = coro->next)
3832 if (coro->hv)
3833 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
3834}
3835
3836void
3837call (Coro::State coro, SV *coderef)
3838 ALIAS:
3839 eval = 1
3840 CODE:
3841{
3842 struct coro *current = SvSTATE_current;
3843
3844 if ((coro == current) || (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot)))
3845 {
3846 struct CoroSLF slf_save;
3847
3848 if (current != coro)
235 { 3849 {
236 /* I never used formats, so how should I know how these are implemented? */ 3850 PUTBACK;
237 /* my bold guess is as a simple, plain sub... */ 3851 save_perl (aTHX_ current);
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 3852 load_perl (aTHX_ coro);
3853 /* the coro is most likely in an active SLF call.
3854 * while not strictly required (the code we execute is
3855 * not allowed to call any SLF functions), it's cleaner
3856 * to reinitialise the slf_frame and restore it later.
3857 * This might one day allow us to actually do SLF calls
3858 * from code executed here.
3859 */
3860 slf_save = slf_frame;
3861 slf_frame.prepare = 0;
3862 SPAGAIN;
3863 }
3864
3865 PUSHSTACK;
3866
3867 PUSHMARK (SP);
3868 PUTBACK;
3869
3870 if (ix)
3871 eval_sv (coderef, 0);
3872 else
3873 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
3874
3875 POPSTACK;
3876 SPAGAIN;
3877
3878 if (current != coro)
3879 {
3880 PUTBACK;
3881 slf_frame = slf_save;
3882 save_perl (aTHX_ coro);
3883 load_perl (aTHX_ current);
3884 SPAGAIN;
239 } 3885 }
240 } 3886 }
241
242 if (top_si->si_type == PERLSI_MAIN)
243 break;
244
245 top_si = top_si->si_prev;
246 ccstk = top_si->si_cxstack;
247 cxix = top_si->si_cxix;
248 }
249
250 PUTBACK;
251 }
252
253 c->dowarn = PL_dowarn;
254 c->defav = GvAV (PL_defgv);
255 c->curstackinfo = PL_curstackinfo;
256 c->curstack = PL_curstack;
257 c->mainstack = PL_mainstack;
258 c->stack_sp = PL_stack_sp;
259 c->op = PL_op;
260 c->curpad = PL_curpad;
261 c->stack_base = PL_stack_base;
262 c->stack_max = PL_stack_max;
263 c->tmps_stack = PL_tmps_stack;
264 c->tmps_floor = PL_tmps_floor;
265 c->tmps_ix = PL_tmps_ix;
266 c->tmps_max = PL_tmps_max;
267 c->markstack = PL_markstack;
268 c->markstack_ptr = PL_markstack_ptr;
269 c->markstack_max = PL_markstack_max;
270 c->scopestack = PL_scopestack;
271 c->scopestack_ix = PL_scopestack_ix;
272 c->scopestack_max = PL_scopestack_max;
273 c->savestack = PL_savestack;
274 c->savestack_ix = PL_savestack_ix;
275 c->savestack_max = PL_savestack_max;
276 c->retstack = PL_retstack;
277 c->retstack_ix = PL_retstack_ix;
278 c->retstack_max = PL_retstack_max;
279 c->curcop = PL_curcop;
280} 3887}
281 3888
282#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0) 3889SV *
283#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0) 3890is_ready (Coro::State coro)
284
285static void
286load_state(pTHX_ Coro__State c)
287{
288 PL_dowarn = c->dowarn;
289 GvAV (PL_defgv) = c->defav;
290 PL_curstackinfo = c->curstackinfo;
291 PL_curstack = c->curstack;
292 PL_mainstack = c->mainstack;
293 PL_stack_sp = c->stack_sp;
294 PL_op = c->op;
295 PL_curpad = c->curpad;
296 PL_stack_base = c->stack_base;
297 PL_stack_max = c->stack_max;
298 PL_tmps_stack = c->tmps_stack;
299 PL_tmps_floor = c->tmps_floor;
300 PL_tmps_ix = c->tmps_ix;
301 PL_tmps_max = c->tmps_max;
302 PL_markstack = c->markstack;
303 PL_markstack_ptr = c->markstack_ptr;
304 PL_markstack_max = c->markstack_max;
305 PL_scopestack = c->scopestack;
306 PL_scopestack_ix = c->scopestack_ix;
307 PL_scopestack_max = c->scopestack_max;
308 PL_savestack = c->savestack;
309 PL_savestack_ix = c->savestack_ix;
310 PL_savestack_max = c->savestack_max;
311 PL_retstack = c->retstack;
312 PL_retstack_ix = c->retstack_ix;
313 PL_retstack_max = c->retstack_max;
314 PL_curcop = c->curcop;
315
316 {
317 dSP;
318 CV *cv;
319
320 /* now do the ugly restore mess */
321 while ((cv = (CV *)POPs))
322 {
323 AV *padlist = (AV *)POPs;
324
325 put_padlist (cv);
326 CvPADLIST(cv) = padlist;
327 CvDEPTH(cv) = (I32)POPs;
328
329#ifdef USE_THREADS
330 CvOWNER(cv) = (struct perl_thread *)POPs;
331 error does not work either
332#endif
333 }
334
335 PUTBACK;
336 }
337}
338
339/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
340STATIC void
341destroy_stacks(pTHX)
342{
343 /* die does this while calling POPSTACK, but I just don't see why. */
344 /* OTOH, die does not have a memleak, but we do... */
345 dounwind(-1);
346
347 /* is this ugly, I ask? */
348 while (PL_scopestack_ix)
349 LEAVE;
350
351 while (PL_curstackinfo->si_next)
352 PL_curstackinfo = PL_curstackinfo->si_next;
353
354 while (PL_curstackinfo)
355 {
356 PERL_SI *p = PL_curstackinfo->si_prev;
357
358 SvREFCNT_dec(PL_curstackinfo->si_stack);
359 Safefree(PL_curstackinfo->si_cxstack);
360 Safefree(PL_curstackinfo);
361 PL_curstackinfo = p;
362 }
363
364 if (PL_scopestack_ix != 0)
365 Perl_warner(aTHX_ WARN_INTERNAL,
366 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367 (long)PL_scopestack_ix);
368 if (PL_savestack_ix != 0)
369 Perl_warner(aTHX_ WARN_INTERNAL,
370 "Unbalanced saves: %ld more saves than restores\n",
371 (long)PL_savestack_ix);
372 if (PL_tmps_floor != -1)
373 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374 (long)PL_tmps_floor + 1);
375 /*
376 */
377 Safefree(PL_tmps_stack);
378 Safefree(PL_markstack);
379 Safefree(PL_scopestack);
380 Safefree(PL_savestack);
381 Safefree(PL_retstack);
382}
383
384#define SUB_INIT "Coro::State::_newcoro"
385
386MODULE = Coro::State PACKAGE = Coro::State
387
388PROTOTYPES: ENABLE
389
390BOOT:
391 if (!padlist_cache)
392 padlist_cache = newHV ();
393
394Coro::State
395_newprocess(args)
396 SV * args
397 PROTOTYPE: $ 3891 PROTOTYPE: $
3892 ALIAS:
3893 is_ready = CF_READY
3894 is_running = CF_RUNNING
3895 is_new = CF_NEW
3896 is_destroyed = CF_ZOMBIE
3897 is_zombie = CF_ZOMBIE
3898 is_suspended = CF_SUSPENDED
3899 CODE:
3900 RETVAL = boolSV (coro->flags & ix);
3901 OUTPUT:
3902 RETVAL
3903
3904void
3905throw (SV *self, SV *exception = &PL_sv_undef)
3906 PROTOTYPE: $;$
398 CODE: 3907 CODE:
399 Coro__State coro; 3908{
3909 struct coro *coro = SvSTATE (self);
3910 struct coro *current = SvSTATE_current;
3911 SV **exceptionp = coro == current ? &CORO_THROW : &coro->except;
3912 SvREFCNT_dec (*exceptionp);
3913 SvGETMAGIC (exception);
3914 *exceptionp = SvOK (exception) ? newSVsv (exception) : 0;
400 3915
401 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 3916 api_ready (aTHX_ self);
402 croak ("Coro::State::newprocess expects an arrayref"); 3917}
3918
3919void
3920api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
3921 PROTOTYPE: $;$
3922 C_ARGS: aTHX_ coro, flags
3923
3924SV *
3925has_cctx (Coro::State coro)
3926 PROTOTYPE: $
3927 CODE:
3928 /* maybe manage the running flag differently */
3929 RETVAL = boolSV (!!coro->cctx || (coro->flags & CF_RUNNING));
3930 OUTPUT:
3931 RETVAL
3932
3933int
3934is_traced (Coro::State coro)
3935 PROTOTYPE: $
3936 CODE:
3937 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
3938 OUTPUT:
3939 RETVAL
3940
3941UV
3942rss (Coro::State coro)
3943 PROTOTYPE: $
3944 ALIAS:
3945 usecount = 1
3946 CODE:
3947 switch (ix)
3948 {
3949 case 0: RETVAL = coro_rss (aTHX_ coro); break;
3950 case 1: RETVAL = coro->usecount; break;
403 3951 }
404 New (0, coro, 1, struct coro); 3952 OUTPUT:
405
406 coro->mainstack = 0; /* actual work is done inside transfer */
407 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
408
409 RETVAL = coro; 3953 RETVAL
3954
3955void
3956force_cctx ()
3957 PROTOTYPE:
3958 CODE:
3959 cctx_current->idle_sp = 0;
3960
3961void
3962swap_defsv (Coro::State self)
3963 PROTOTYPE: $
3964 ALIAS:
3965 swap_defav = 1
3966 CODE:
3967 if (!self->slot)
3968 croak ("cannot swap state with coroutine that has no saved state,");
3969 else
3970 {
3971 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
3972 SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
3973
3974 SV *tmp = *src; *src = *dst; *dst = tmp;
3975 }
3976
3977void
3978cancel (Coro::State self)
3979 CODE:
3980 coro_state_destroy (aTHX_ self);
3981
3982SV *
3983enable_times (int enabled = enable_times)
3984 CODE:
3985{
3986 RETVAL = boolSV (enable_times);
3987
3988 if (enabled != enable_times)
3989 {
3990 enable_times = enabled;
3991
3992 coro_times_update ();
3993 (enabled ? coro_times_sub : coro_times_add)(SvSTATE (coro_current));
3994 }
3995}
410 OUTPUT: 3996 OUTPUT:
411 RETVAL 3997 RETVAL
412 3998
413void 3999void
414transfer(prev,next) 4000times (Coro::State self)
415 Coro::State_or_hashref prev 4001 PPCODE:
416 Coro::State_or_hashref next 4002{
417 CODE: 4003 struct coro *current = SvSTATE (coro_current);
418 4004
419 if (prev != next) 4005 if (ecb_expect_false (current == self))
420 { 4006 {
4007 coro_times_update ();
4008 coro_times_add (SvSTATE (coro_current));
421 /* 4009 }
422 * this could be done in newprocess which would lead to 4010
423 * extremely elegant and fast (just SAVE/LOAD) 4011 EXTEND (SP, 2);
424 * code here, but lazy allocation of stacks has also 4012 PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));
425 * some virtues and the overhead of the if() is nil. 4013 PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));
4014
4015 if (ecb_expect_false (current == self))
4016 coro_times_sub (SvSTATE (coro_current));
4017}
4018
4019void
4020swap_sv (Coro::State coro, SV *sva, SV *svb)
4021 CODE:
4022{
4023 struct coro *current = SvSTATE_current;
4024 AV *swap_sv;
4025 int i;
4026
4027 sva = SvRV (sva);
4028 svb = SvRV (svb);
4029
4030 if (current == coro)
4031 SWAP_SVS_LEAVE (current);
4032
4033 if (!coro->swap_sv)
4034 coro->swap_sv = newAV ();
4035
4036 swap_sv = coro->swap_sv;
4037
4038 for (i = AvFILLp (swap_sv) - 1; i >= 0; i -= 2)
426 */ 4039 {
427 if (next->mainstack) 4040 SV *a = AvARRAY (swap_sv)[i ];
4041 SV *b = AvARRAY (swap_sv)[i + 1];
4042
4043 if (a == sva && b == svb)
428 { 4044 {
429 SAVE (prev); 4045 SvREFCNT_dec_NN (a);
430 LOAD (next); 4046 SvREFCNT_dec_NN (b);
431 /* mark this state as in-use */
432 next->mainstack = 0;
433 next->tmps_ix = -2;
434 }
435 else if (next->tmps_ix == -2)
436 {
437 croak ("tried to transfer to running coroutine");
438 }
439 else
440 {
441 SAVE (prev);
442 4047
443 /* 4048 for (; i <= AvFILLp (swap_sv) - 2; i++)
444 * emulate part of the perl startup here. 4049 AvARRAY (swap_sv)[i] = AvARRAY (swap_sv)[i + 2];
445 */
446 UNOP myop;
447 4050
448 init_stacks (); /* from perl.c */ 4051 AvFILLp (swap_sv) -= 2;
449 PL_op = (OP *)&myop;
450 /*PL_curcop = 0;*/
451 GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452 4052
453 SPAGAIN; 4053 goto removed;
454 Zero(&myop, 1, UNOP);
455 myop.op_next = Nullop;
456 myop.op_flags = OPf_WANT_VOID;
457
458 PUSHMARK(SP);
459 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460 PUTBACK;
461 /*
462 * the next line is slightly wrong, as PL_op->op_next
463 * is actually being executed so we skip the first op.
464 * that doesn't matter, though, since it is only
465 * pp_nextstate and we never return...
466 */
467 PL_op = Perl_pp_entersub(aTHX);
468 SPAGAIN;
469
470 ENTER;
471 } 4054 }
472 } 4055 }
473 4056
4057 av_push (swap_sv, SvREFCNT_inc_NN (sva));
4058 av_push (swap_sv, SvREFCNT_inc_NN (svb));
4059
4060 removed:
4061
4062 if (current == coro)
4063 SWAP_SVS_ENTER (current);
4064}
4065
4066
4067MODULE = Coro::State PACKAGE = Coro
4068
4069BOOT:
4070{
4071 if (SVt_LAST > 32)
4072 croak ("Coro internal error: SVt_LAST > 32, swap_sv might need adjustment");
4073
4074 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
4075 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
4076 cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);
4077 coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);
4078 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
4079 av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);
4080 sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);
4081 sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);
4082
4083 sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
4084 sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);
4085 cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);
4086 CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */
4087
4088 coro_stash = gv_stashpv ("Coro", TRUE);
4089
4090 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));
4091 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));
4092 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
4093 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (CORO_PRIO_LOW));
4094 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (CORO_PRIO_IDLE));
4095 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (CORO_PRIO_MIN));
4096
4097 {
4098 SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
4099
4100 coroapi.schedule = api_schedule;
4101 coroapi.schedule_to = api_schedule_to;
4102 coroapi.cede = api_cede;
4103 coroapi.cede_notself = api_cede_notself;
4104 coroapi.ready = api_ready;
4105 coroapi.is_ready = api_is_ready;
4106 coroapi.nready = coro_nready;
4107 coroapi.current = coro_current;
4108
4109 coroapi.enterleave_hook = api_enterleave_hook;
4110 coroapi.enterleave_unhook = api_enterleave_unhook;
4111 coroapi.enterleave_scope_hook = api_enterleave_scope_hook;
4112
4113 /*GCoroAPI = &coroapi;*/
4114 sv_setiv (sv, PTR2IV (&coroapi));
4115 SvREADONLY_on (sv);
4116 }
4117}
4118
4119SV *
4120async (...)
4121 PROTOTYPE: &@
4122 CODE:
4123 RETVAL = coro_new (aTHX_ coro_stash, &ST (0), items, 1);
4124 api_ready (aTHX_ RETVAL);
4125 OUTPUT:
4126 RETVAL
4127
474void 4128void
475DESTROY(coro) 4129_destroy (Coro::State coro)
476 Coro::State coro 4130 CODE:
4131 /* used by the manager thread */
4132 coro_state_destroy (aTHX_ coro);
4133
4134void
4135on_destroy (Coro::State coro, SV *cb)
4136 CODE:
4137 coro_push_on_destroy (aTHX_ coro, newSVsv (cb));
4138
4139void
4140join (...)
4141 CODE:
4142 CORO_EXECUTE_SLF_XS (slf_init_join);
4143
4144void
4145terminate (...)
4146 CODE:
4147 CORO_EXECUTE_SLF_XS (slf_init_terminate);
4148
4149void
4150cancel (...)
4151 CODE:
4152 CORO_EXECUTE_SLF_XS (slf_init_cancel);
4153
4154int
4155safe_cancel (Coro::State self, ...)
4156 C_ARGS: aTHX_ self, &ST (1), items - 1
4157
4158void
4159schedule (...)
4160 CODE:
4161 CORO_EXECUTE_SLF_XS (slf_init_schedule);
4162
4163void
4164schedule_to (...)
4165 CODE:
4166 CORO_EXECUTE_SLF_XS (slf_init_schedule_to);
4167
4168void
4169cede_to (...)
4170 CODE:
4171 CORO_EXECUTE_SLF_XS (slf_init_cede_to);
4172
4173void
4174cede (...)
4175 CODE:
4176 CORO_EXECUTE_SLF_XS (slf_init_cede);
4177
4178void
4179cede_notself (...)
4180 CODE:
4181 CORO_EXECUTE_SLF_XS (slf_init_cede_notself);
4182
4183void
4184_set_current (SV *current)
4185 PROTOTYPE: $
4186 CODE:
4187 SvREFCNT_dec_NN (SvRV (coro_current));
4188 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
4189
4190void
4191_set_readyhook (SV *hook)
4192 PROTOTYPE: $
477 CODE: 4193 CODE:
478 4194 SvREFCNT_dec (coro_readyhook);
479 if (coro->mainstack) 4195 SvGETMAGIC (hook);
4196 if (SvOK (hook))
4197 {
4198 coro_readyhook = newSVsv (hook);
4199 CORO_READYHOOK = invoke_sv_ready_hook_helper;
4200 }
4201 else
480 { 4202 {
481 struct coro temp; 4203 coro_readyhook = 0;
482 4204 CORO_READYHOOK = 0;
483 SAVE(aTHX_ (&temp));
484 LOAD(aTHX_ coro);
485
486 destroy_stacks ();
487 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488
489 LOAD((&temp));
490 } 4205 }
491 4206
492 SvREFCNT_dec (coro->args); 4207int
493 Safefree (coro); 4208prio (Coro::State coro, int newprio = 0)
4209 PROTOTYPE: $;$
4210 ALIAS:
4211 nice = 1
4212 CODE:
4213{
4214 RETVAL = coro->prio;
494 4215
4216 if (items > 1)
4217 {
4218 if (ix)
4219 newprio = coro->prio - newprio;
495 4220
4221 if (newprio < CORO_PRIO_MIN) newprio = CORO_PRIO_MIN;
4222 if (newprio > CORO_PRIO_MAX) newprio = CORO_PRIO_MAX;
4223
4224 coro->prio = newprio;
4225 }
4226}
4227 OUTPUT:
4228 RETVAL
4229
4230SV *
4231ready (SV *self)
4232 PROTOTYPE: $
4233 CODE:
4234 RETVAL = boolSV (api_ready (aTHX_ self));
4235 OUTPUT:
4236 RETVAL
4237
4238int
4239nready (...)
4240 PROTOTYPE:
4241 CODE:
4242 RETVAL = coro_nready;
4243 OUTPUT:
4244 RETVAL
4245
4246void
4247suspend (Coro::State self)
4248 PROTOTYPE: $
4249 CODE:
4250 self->flags |= CF_SUSPENDED;
4251
4252void
4253resume (Coro::State self)
4254 PROTOTYPE: $
4255 CODE:
4256 self->flags &= ~CF_SUSPENDED;
4257
4258void
4259_pool_handler (...)
4260 CODE:
4261 CORO_EXECUTE_SLF_XS (slf_init_pool_handler);
4262
4263void
4264async_pool (SV *cv, ...)
4265 PROTOTYPE: &@
4266 PPCODE:
4267{
4268 HV *hv = (HV *)av_pop (av_async_pool);
4269 AV *av = newAV ();
4270 SV *cb = ST (0);
4271 int i;
4272
4273 av_extend (av, items - 2);
4274 for (i = 1; i < items; ++i)
4275 av_push (av, SvREFCNT_inc_NN (ST (i)));
4276
4277 if ((SV *)hv == &PL_sv_undef)
4278 {
4279 SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1);
4280 hv = (HV *)SvREFCNT_inc_NN (SvRV (sv));
4281 SvREFCNT_dec_NN (sv);
4282 }
4283
4284 {
4285 struct coro *coro = SvSTATE_hv (hv);
4286
4287 assert (!coro->invoke_cb);
4288 assert (!coro->invoke_av);
4289 coro->invoke_cb = SvREFCNT_inc (cb);
4290 coro->invoke_av = av;
4291 }
4292
4293 api_ready (aTHX_ (SV *)hv);
4294
4295 if (GIMME_V != G_VOID)
4296 XPUSHs (sv_2mortal (newRV_noinc ((SV *)hv)));
4297 else
4298 SvREFCNT_dec_NN (hv);
4299}
4300
4301SV *
4302rouse_cb ()
4303 PROTOTYPE:
4304 CODE:
4305 RETVAL = coro_new_rouse_cb (aTHX);
4306 OUTPUT:
4307 RETVAL
4308
4309void
4310rouse_wait (...)
4311 PROTOTYPE: ;$
4312 PPCODE:
4313 CORO_EXECUTE_SLF_XS (slf_init_rouse_wait);
4314
4315void
4316on_enter (SV *block)
4317 ALIAS:
4318 on_leave = 1
4319 PROTOTYPE: &
4320 CODE:
4321{
4322 struct coro *coro = SvSTATE_current;
4323 AV **avp = ix ? &coro->on_leave : &coro->on_enter;
4324
4325 block = s_get_cv_croak (block);
4326
4327 if (!*avp)
4328 *avp = newAV ();
4329
4330 av_push (*avp, SvREFCNT_inc (block));
4331
4332 if (!ix)
4333 on_enterleave_call (aTHX_ block);
4334
4335 LEAVE; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */
4336 SAVEDESTRUCTOR_X (ix ? coro_pop_on_leave : coro_pop_on_enter, (void *)coro);
4337 ENTER; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */
4338}
4339
4340
4341MODULE = Coro::State PACKAGE = PerlIO::cede
4342
4343BOOT:
4344 PerlIO_define_layer (aTHX_ &PerlIO_cede);
4345
4346
4347MODULE = Coro::State PACKAGE = Coro::Semaphore
4348
4349SV *
4350new (SV *klass, SV *count = 0)
4351 CODE:
4352{
4353 int semcnt = 1;
4354
4355 if (count)
4356 {
4357 SvGETMAGIC (count);
4358
4359 if (SvOK (count))
4360 semcnt = SvIV (count);
4361 }
4362
4363 RETVAL = sv_bless (
4364 coro_waitarray_new (aTHX_ semcnt),
4365 GvSTASH (CvGV (cv))
4366 );
4367}
4368 OUTPUT:
4369 RETVAL
4370
4371# helper for Coro::Channel and others
4372SV *
4373_alloc (int count)
4374 CODE:
4375 RETVAL = coro_waitarray_new (aTHX_ count);
4376 OUTPUT:
4377 RETVAL
4378
4379SV *
4380count (SV *self)
4381 CODE:
4382 RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]);
4383 OUTPUT:
4384 RETVAL
4385
4386void
4387up (SV *self)
4388 CODE:
4389 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), 1);
4390
4391void
4392adjust (SV *self, int adjust)
4393 CODE:
4394 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), adjust);
4395
4396void
4397down (...)
4398 CODE:
4399 CORO_EXECUTE_SLF_XS (slf_init_semaphore_down);
4400
4401void
4402wait (...)
4403 CODE:
4404 CORO_EXECUTE_SLF_XS (slf_init_semaphore_wait);
4405
4406void
4407try (SV *self)
4408 PPCODE:
4409{
4410 AV *av = (AV *)SvRV (self);
4411 SV *count_sv = AvARRAY (av)[0];
4412 IV count = SvIVX (count_sv);
4413
4414 if (count > 0)
4415 {
4416 --count;
4417 SvIVX (count_sv) = count;
4418 XSRETURN_YES;
4419 }
4420 else
4421 XSRETURN_NO;
4422}
4423
4424void
4425waiters (SV *self)
4426 PPCODE:
4427{
4428 AV *av = (AV *)SvRV (self);
4429 int wcount = AvFILLp (av) + 1 - 1;
4430
4431 if (GIMME_V == G_SCALAR)
4432 XPUSHs (sv_2mortal (newSViv (wcount)));
4433 else
4434 {
4435 int i;
4436 EXTEND (SP, wcount);
4437 for (i = 1; i <= wcount; ++i)
4438 PUSHs (sv_2mortal (newRV_inc (AvARRAY (av)[i])));
4439 }
4440}
4441
4442MODULE = Coro::State PACKAGE = Coro::SemaphoreSet
4443
4444void
4445_may_delete (SV *sem, int count, unsigned int extra_refs)
4446 PPCODE:
4447{
4448 AV *av = (AV *)SvRV (sem);
4449
4450 if (SvREFCNT ((SV *)av) == 1 + extra_refs
4451 && AvFILLp (av) == 0 /* no waiters, just count */
4452 && SvIV (AvARRAY (av)[0]) == count)
4453 XSRETURN_YES;
4454
4455 XSRETURN_NO;
4456}
4457
4458MODULE = Coro::State PACKAGE = Coro::Signal
4459
4460SV *
4461new (SV *klass)
4462 CODE:
4463 RETVAL = sv_bless (
4464 coro_waitarray_new (aTHX_ 0),
4465 GvSTASH (CvGV (cv))
4466 );
4467 OUTPUT:
4468 RETVAL
4469
4470void
4471wait (...)
4472 CODE:
4473 CORO_EXECUTE_SLF_XS (slf_init_signal_wait);
4474
4475void
4476broadcast (SV *self)
4477 CODE:
4478{
4479 AV *av = (AV *)SvRV (self);
4480 coro_signal_wake (aTHX_ av, AvFILLp (av));
4481}
4482
4483void
4484send (SV *self)
4485 CODE:
4486{
4487 AV *av = (AV *)SvRV (self);
4488
4489 if (AvFILLp (av))
4490 coro_signal_wake (aTHX_ av, 1);
4491 else
4492 SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
4493}
4494
4495IV
4496awaited (SV *self)
4497 CODE:
4498 RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
4499 OUTPUT:
4500 RETVAL
4501
4502
4503MODULE = Coro::State PACKAGE = Coro::AnyEvent
4504
4505BOOT:
4506 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
4507
4508void
4509_schedule (...)
4510 CODE:
4511{
4512 static int incede;
4513
4514 api_cede_notself (aTHX);
4515
4516 ++incede;
4517 while (coro_nready >= incede && api_cede (aTHX))
4518 ;
4519
4520 sv_setsv (sv_activity, &PL_sv_undef);
4521 if (coro_nready >= incede)
4522 {
4523 PUSHMARK (SP);
4524 PUTBACK;
4525 call_pv ("Coro::AnyEvent::_activity", G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
4526 }
4527
4528 --incede;
4529}
4530
4531
4532MODULE = Coro::State PACKAGE = Coro::AIO
4533
4534void
4535_register (char *target, char *proto, SV *req)
4536 CODE:
4537{
4538 SV *req_cv = s_get_cv_croak (req);
4539 /* newXSproto doesn't return the CV on 5.8 */
4540 CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);
4541 sv_setpv ((SV *)slf_cv, proto);
4542 sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);
4543}
4544
4545MODULE = Coro::State PACKAGE = Coro::Select
4546
4547void
4548patch_pp_sselect ()
4549 CODE:
4550 if (!coro_old_pp_sselect)
4551 {
4552 coro_select_select = (SV *)get_cv ("Coro::Select::select", 0);
4553 coro_old_pp_sselect = PL_ppaddr [OP_SSELECT];
4554 PL_ppaddr [OP_SSELECT] = coro_pp_sselect;
4555 }
4556
4557void
4558unpatch_pp_sselect ()
4559 CODE:
4560 if (coro_old_pp_sselect)
4561 {
4562 PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
4563 coro_old_pp_sselect = 0;
4564 }
4565
4566MODULE = Coro::State PACKAGE = Coro::Util
4567
4568void
4569_exit (int code)
4570 CODE:
4571 _exit (code);
4572
4573NV
4574time ()
4575 CODE:
4576 RETVAL = nvtime (aTHX);
4577 OUTPUT:
4578 RETVAL
4579
4580NV
4581gettimeofday ()
4582 PPCODE:
4583{
4584 UV tv [2];
4585 u2time (aTHX_ tv);
4586 EXTEND (SP, 2);
4587 PUSHs (sv_2mortal (newSVuv (tv [0])));
4588 PUSHs (sv_2mortal (newSVuv (tv [1])));
4589}
4590

Diff Legend

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