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

Diff Legend

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