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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.473 by root, Sun Sep 3 23:36:01 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(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 XPUSHs ((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 PUSHMARK (SP);
1386 EXTEND (SP, 3);
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 PUSHMARK (SP);
1424 EXTEND (SP, 3);
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 PUSHMARK (SP);
1448 EXTEND (SP, 2);
1449 PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
1450 PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
1451 PUTBACK;
1452 cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
1453 if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
1454 SPAGAIN;
1455 FREETMPS;
1456 LEAVE;
1457 PL_runops = runops_trace;
1458 }
1459 }
1460 }
1461 }
1462 }
1463
1464 TAINT_NOT;
1465 return 0;
1466}
1467
1468static struct CoroSLF cctx_ssl_frame;
1469
1470static void
1471slf_prepare_set_stacklevel (pTHX_ struct coro_transfer_args *ta)
1472{
1473 ta->prev = 0;
1474}
1475
1476static int
1477slf_check_set_stacklevel (pTHX_ struct CoroSLF *frame)
1478{
1479 *frame = cctx_ssl_frame;
1480
1481 return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */
1482}
1483
1484/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */
1485static void ecb_noinline
1486cctx_prepare (pTHX)
1487{
1488 PL_top_env = &PL_start_env;
1489
1490 if (cctx_current->flags & CC_TRACE)
1491 PL_runops = runops_trace;
1492
1493 /* we already must be executing an SLF op, there is no other valid way
1494 * that can lead to creation of a new cctx */
1495 assert (("FATAL: can't prepare slf-less cctx in Coro module (please report)",
1496 slf_frame.prepare && PL_op->op_ppaddr == pp_slf));
1497
1498 /* we must emulate leaving pp_slf, which is done inside slf_check_set_stacklevel */
1499 cctx_ssl_frame = slf_frame;
1500
1501 slf_frame.prepare = slf_prepare_set_stacklevel;
1502 slf_frame.check = slf_check_set_stacklevel;
1503}
1504
1505/* the tail of transfer: execute stuff we can only do after a transfer */
1506ecb_inline void
1507transfer_tail (pTHX)
1508{
1509 free_coro_mortal (aTHX);
1510}
1511
1512/* try to exit the same way perl's main function would do */
1513/* we do not bother resetting the environment or other things *7
1514/* that are not, uhm, essential */
1515/* this obviously also doesn't work when perl is embedded */
1516static void ecb_noinline ecb_cold
1517perlish_exit (pTHX)
1518{
1519 int exitstatus = perl_destruct (PL_curinterp);
1520 perl_free (PL_curinterp);
1521 exit (exitstatus);
1522}
1523
1524/*
1525 * this is a _very_ stripped down perl interpreter ;)
1526 */
1527static void
1528cctx_run (void *arg)
1529{
1530#ifdef USE_ITHREADS
1531# if CORO_PTHREAD
1532 PERL_SET_CONTEXT (coro_thx);
1533# endif
1534#endif
1535 {
1536 dTHX;
1537
1538 /* normally we would need to skip the entersub here */
1539 /* not doing so will re-execute it, which is exactly what we want */
1540 /* PL_nop = PL_nop->op_next */
1541
1542 /* inject a fake subroutine call to cctx_init */
1543 cctx_prepare (aTHX);
1544
1545 /* cctx_run is the alternative tail of transfer() */
1546 transfer_tail (aTHX);
1547
1548 /* somebody or something will hit me for both perl_run and PL_restartop */
1549 PL_restartop = PL_op;
1550 perl_run (PL_curinterp);
1551 /*
1552 * Unfortunately, there is no way to get at the return values of the
1553 * coro body here, as perl_run destroys these. Likewise, we cannot catch
1554 * runtime errors here, as this is just a random interpreter, not a thread.
1555 */
1556
1557 /*
1558 * pp_entersub in 5.24 no longer ENTERs, but perl_destruct
1559 * requires PL_scopestack_ix, so do it here if required.
1560 */
1561 if (!PL_scopestack_ix)
1562 ENTER;
1563
1564 /*
1565 * If perl-run returns we assume exit() was being called or the coro
1566 * fell off the end, which seems to be the only valid (non-bug)
1567 * reason for perl_run to return. We try to mimic whatever perl is normally
1568 * doing in that case. YMMV.
1569 */
1570 perlish_exit (aTHX);
1571 }
1572}
1573
1574static coro_cctx *
1575cctx_new (void)
1576{
1577 coro_cctx *cctx;
1578
1579 ++cctx_count;
1580 New (0, cctx, 1, coro_cctx);
1581
1582 cctx->gen = cctx_gen;
1583 cctx->flags = 0;
1584 cctx->idle_sp = 0; /* can be accessed by transfer between cctx_run and set_stacklevel, on throw */
1585
1586 return cctx;
1587}
1588
1589/* create a new cctx only suitable as source */
1590static coro_cctx *
1591cctx_new_empty (void)
1592{
1593 coro_cctx *cctx = cctx_new ();
1594
1595 cctx->stack.sptr = 0;
1596 coro_create (&cctx->cctx, 0, 0, 0, 0);
1597
1598 return cctx;
1599}
1600
1601/* create a new cctx suitable as destination/running a perl interpreter */
1602static coro_cctx *
1603cctx_new_run (void)
1604{
1605 coro_cctx *cctx = cctx_new ();
1606
1607 if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
1608 {
1609 perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1610 _exit (EXIT_FAILURE);
1611 }
1612
1613 coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze);
1614
1615 return cctx;
1616}
1617
1618static void
1619cctx_destroy (coro_cctx *cctx)
1620{
1621 if (!cctx)
1622 return;
1623
1624 assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
1625
1626 --cctx_count;
1627 coro_destroy (&cctx->cctx);
1628
1629 coro_stack_free (&cctx->stack);
1630
1631 Safefree (cctx);
1632}
1633
1634/* wether this cctx should be destructed */
1635#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1636
1637static coro_cctx *
1638cctx_get (pTHX)
1639{
1640 while (ecb_expect_true (cctx_first))
1641 {
1642 coro_cctx *cctx = cctx_first;
1643 cctx_first = cctx->next;
1644 --cctx_idle;
1645
1646 if (ecb_expect_true (!CCTX_EXPIRED (cctx)))
1647 return cctx;
1648
1649 cctx_destroy (cctx);
1650 }
1651
1652 return cctx_new_run ();
1653}
1654
1655static void
1656cctx_put (coro_cctx *cctx)
1657{
1658 assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr));
1659
1660 /* free another cctx if overlimit */
1661 if (ecb_expect_false (cctx_idle >= cctx_max_idle))
1662 {
1663 coro_cctx *first = cctx_first;
1664 cctx_first = first->next;
1665 --cctx_idle;
1666
1667 cctx_destroy (first);
1668 }
1669
1670 ++cctx_idle;
1671 cctx->next = cctx_first;
1672 cctx_first = cctx;
1673}
1674
1675/** coroutine switching *****************************************************/
1676
1677static void
1678transfer_check (pTHX_ struct coro *prev, struct coro *next)
1679{
1680 /* TODO: throwing up here is considered harmful */
1681
1682 if (ecb_expect_true (prev != next))
1683 {
1684 if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1685 croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");
1686
1687 if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED)))
1688 croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");
1689
1690#if !PERL_VERSION_ATLEAST (5,10,0)
1691 if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING))
1692 croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");
1693#endif
1694 }
1695}
1696
1697/* always use the TRANSFER macro */
1698static void ecb_noinline /* noinline so we have a fixed stackframe */
1699transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1700{
1701 dSTACKLEVEL;
1702
1703 /* sometimes transfer is only called to set idle_sp */
1704 if (ecb_expect_false (!prev))
1705 {
1706 cctx_current->idle_sp = STACKLEVEL;
1707 assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1708 }
1709 else if (ecb_expect_true (prev != next))
1710 {
1711 coro_cctx *cctx_prev;
1712
1713 if (ecb_expect_false (prev->flags & CF_NEW))
1714 {
1715 /* create a new empty/source context */
1716 prev->flags &= ~CF_NEW;
1717 prev->flags |= CF_RUNNING;
1718 }
1719
1720 prev->flags &= ~CF_RUNNING;
1721 next->flags |= CF_RUNNING;
1722
1723 /* first get rid of the old state */
1724 save_perl (aTHX_ prev);
1725
1726 if (ecb_expect_false (next->flags & CF_NEW))
1727 {
1728 /* need to start coroutine */
1729 next->flags &= ~CF_NEW;
1730 /* setup coroutine call */
1731 init_perl (aTHX_ next);
1732 }
1733 else
1734 load_perl (aTHX_ next);
1735
1736 /* possibly untie and reuse the cctx */
1737 if (ecb_expect_true (
1738 cctx_current->idle_sp == STACKLEVEL
1739 && !(cctx_current->flags & CC_TRACE)
1740 && !force_cctx
1741 ))
1742 {
1743 /* I assume that stacklevel is a stronger indicator than PL_top_env changes */
1744 assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));
1745
1746 /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */
1747 /* without this the next cctx_get might destroy the running cctx while still in use */
1748 if (ecb_expect_false (CCTX_EXPIRED (cctx_current)))
1749 if (ecb_expect_true (!next->cctx))
1750 next->cctx = cctx_get (aTHX);
1751
1752 cctx_put (cctx_current);
1753 }
1754 else
1755 prev->cctx = cctx_current;
1756
1757 ++next->usecount;
1758
1759 cctx_prev = cctx_current;
1760 cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);
1761
1762 next->cctx = 0;
1763
1764 if (ecb_expect_false (cctx_prev != cctx_current))
1765 {
1766 cctx_prev->top_env = PL_top_env;
1767 PL_top_env = cctx_current->top_env;
1768 coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);
1769 }
1770
1771 transfer_tail (aTHX);
1772 }
1773}
1774
1775#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1776#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1777
1778/** high level stuff ********************************************************/
1779
1780/* this function is actually Coro, not Coro::State, but we call it from here */
1781/* because it is convenient - but it hasn't been declared yet for that reason */
1782static void
1783coro_call_on_destroy (pTHX_ struct coro *coro);
1784
1785static void
1786coro_state_destroy (pTHX_ struct coro *coro)
1787{
1788 if (coro->flags & CF_ZOMBIE)
1789 return;
1790
1791 slf_destroy (aTHX_ coro);
1792
1793 coro->flags |= CF_ZOMBIE;
1794
1795 if (coro->flags & CF_READY)
1796 {
1797 /* reduce nready, as destroying a ready coro effectively unreadies it */
1798 /* alternative: look through all ready queues and remove the coro */
1799 --coro_nready;
1800 }
1801 else
1802 coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
1803
1804 if (coro->next) coro->next->prev = coro->prev;
1805 if (coro->prev) coro->prev->next = coro->next;
1806 if (coro == coro_first) coro_first = coro->next;
1807
1808 if (coro->mainstack
1809 && coro->mainstack != main_mainstack
1810 && coro->slot
1811 && !PL_dirty)
1812 destroy_perl (aTHX_ coro);
1813
1814 cctx_destroy (coro->cctx);
1815 SvREFCNT_dec (coro->startcv);
1816 SvREFCNT_dec (coro->args);
1817 SvREFCNT_dec (coro->swap_sv);
1818 SvREFCNT_dec (CORO_THROW);
1819
1820 coro_call_on_destroy (aTHX_ coro);
1821
1822 /* more destruction mayhem in coro_state_free */
1823}
1824
1825static int
1826coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1827{
1828 struct coro *coro = (struct coro *)mg->mg_ptr;
1829 mg->mg_ptr = 0;
1830
1831 coro_state_destroy (aTHX_ coro);
1832 SvREFCNT_dec (coro->on_destroy);
1833 SvREFCNT_dec (coro->status);
1834
1835 Safefree (coro);
1836
1837 return 0;
1838}
1839
1840static int ecb_cold
1841coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1842{
1843 /* called when perl clones the current process the slow way (windows process emulation) */
1844 /* WE SIMply nuke the pointers in the copy, causing perl to croak */
1845 mg->mg_ptr = 0;
1846 mg->mg_virtual = 0;
1847
1848 return 0;
1849}
1850
1851static MGVTBL coro_state_vtbl = {
1852 0, 0, 0, 0,
1853 coro_state_free,
1854 0,
1855#ifdef MGf_DUP
1856 coro_state_dup,
1857#else
1858# define MGf_DUP 0
1859#endif
1860};
1861
1862static void
1863prepare_transfer (pTHX_ struct coro_transfer_args *ta, SV *prev_sv, SV *next_sv)
1864{
1865 ta->prev = SvSTATE (prev_sv);
1866 ta->next = SvSTATE (next_sv);
1867 TRANSFER_CHECK (*ta);
1868}
1869
1870static void
1871api_transfer (pTHX_ SV *prev_sv, SV *next_sv)
1872{
1873 struct coro_transfer_args ta;
1874
1875 prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1876 TRANSFER (ta, 1);
1877}
1878
1879/** Coro ********************************************************************/
1880
1881ecb_inline void
1882coro_enq (pTHX_ struct coro *coro)
1883{
1884 struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
1885
1886 SvREFCNT_inc_NN (coro->hv);
1887
1888 coro->next_ready = 0;
1889 *(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
1890 ready [1] = coro;
1891}
1892
1893ecb_inline struct coro *
1894coro_deq (pTHX)
1895{
1896 int prio;
1897
1898 for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
1899 {
1900 struct coro **ready = coro_ready [prio];
1901
1902 if (ready [0])
1903 {
1904 struct coro *coro = ready [0];
1905 ready [0] = coro->next_ready;
1906 return coro;
1907 }
1908 }
1909
1910 return 0;
1911}
1912
1913static void
1914invoke_sv_ready_hook_helper (void)
1915{
1916 dTHX;
1917 dSP;
1918
1919 ENTER;
1920 SAVETMPS;
1921
1922 PUSHMARK (SP);
1923 PUTBACK;
1924 call_sv (coro_readyhook, G_VOID | G_DISCARD);
1925
1926 FREETMPS;
1927 LEAVE;
1928}
1929
1930static int
1931api_ready (pTHX_ SV *coro_sv)
1932{
1933 struct coro *coro = SvSTATE (coro_sv);
1934
1935 if (coro->flags & CF_READY)
1936 return 0;
1937
1938 coro->flags |= CF_READY;
1939
1940 coro_enq (aTHX_ coro);
1941
1942 if (!coro_nready++)
1943 if (coroapi.readyhook)
1944 coroapi.readyhook ();
1945
1946 return 1;
1947}
1948
1949static int
1950api_is_ready (pTHX_ SV *coro_sv)
1951{
1952 return !!(SvSTATE (coro_sv)->flags & CF_READY);
1953}
1954
1955/* expects to own a reference to next->hv */
1956ecb_inline void
1957prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)
1958{
1959 SV *prev_sv = SvRV (coro_current);
1960
1961 ta->prev = SvSTATE_hv (prev_sv);
1962 ta->next = next;
1963
1964 TRANSFER_CHECK (*ta);
1965
1966 SvRV_set (coro_current, (SV *)next->hv);
1967
1968 free_coro_mortal (aTHX);
1969 coro_mortal = prev_sv;
1970}
1971
1972static void
1973prepare_schedule (pTHX_ struct coro_transfer_args *ta)
1974{
1975 for (;;)
1976 {
1977 struct coro *next = coro_deq (aTHX);
1978
1979 if (ecb_expect_true (next))
1980 {
1981 /* cannot transfer to destroyed coros, skip and look for next */
1982 if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED)))
1983 SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */
1984 else
1985 {
1986 next->flags &= ~CF_READY;
1987 --coro_nready;
1988
1989 prepare_schedule_to (aTHX_ ta, next);
1990 break;
1991 }
1992 }
1993 else
1994 {
1995 /* nothing to schedule: call the idle handler */
1996 if (SvROK (sv_idle)
1997 && SvOBJECT (SvRV (sv_idle)))
1998 {
1999 if (SvRV (sv_idle) == SvRV (coro_current))
2000 {
2001 require_pv ("Carp");
2002
2003 {
2004 dSP;
2005
2006 ENTER;
2007 SAVETMPS;
2008
2009 PUSHMARK (SP);
2010 XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::idle blocked itself - did you try to block inside an event loop callback? Caught", 0)));
2011 PUTBACK;
2012 call_pv ("Carp::confess", G_VOID | G_DISCARD);
2013
2014 FREETMPS;
2015 LEAVE;
2016 }
2017 }
2018
2019 ++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
2020 api_ready (aTHX_ SvRV (sv_idle));
2021 --coro_nready;
2022 }
2023 else
2024 {
2025 /* TODO: deprecated, remove, cannot work reliably *//*D*/
2026 dSP;
2027
2028 ENTER;
2029 SAVETMPS;
2030
2031 PUSHMARK (SP);
2032 PUTBACK;
2033 call_sv (sv_idle, G_VOID | G_DISCARD);
2034
2035 FREETMPS;
2036 LEAVE;
2037 }
2038 }
2039 }
2040}
2041
2042ecb_inline void
2043prepare_cede (pTHX_ struct coro_transfer_args *ta)
2044{
2045 api_ready (aTHX_ coro_current);
2046 prepare_schedule (aTHX_ ta);
2047}
2048
2049ecb_inline void
2050prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
2051{
2052 SV *prev = SvRV (coro_current);
2053
2054 if (coro_nready)
2055 {
2056 prepare_schedule (aTHX_ ta);
2057 api_ready (aTHX_ prev);
2058 }
2059 else
2060 prepare_nop (aTHX_ ta);
2061}
2062
2063static void
2064api_schedule (pTHX)
2065{
2066 struct coro_transfer_args ta;
2067
2068 prepare_schedule (aTHX_ &ta);
2069 TRANSFER (ta, 1);
2070}
2071
2072static void
2073api_schedule_to (pTHX_ SV *coro_sv)
2074{
2075 struct coro_transfer_args ta;
2076 struct coro *next = SvSTATE (coro_sv);
2077
2078 SvREFCNT_inc_NN (coro_sv);
2079 prepare_schedule_to (aTHX_ &ta, next);
2080}
2081
2082static int
2083api_cede (pTHX)
2084{
2085 struct coro_transfer_args ta;
2086
2087 prepare_cede (aTHX_ &ta);
2088
2089 if (ecb_expect_true (ta.prev != ta.next))
2090 {
2091 TRANSFER (ta, 1);
2092 return 1;
2093 }
2094 else
2095 return 0;
2096}
2097
2098static int
2099api_cede_notself (pTHX)
2100{
2101 if (coro_nready)
2102 {
2103 struct coro_transfer_args ta;
2104
2105 prepare_cede_notself (aTHX_ &ta);
2106 TRANSFER (ta, 1);
2107 return 1;
2108 }
2109 else
2110 return 0;
2111}
2112
2113static void
2114api_trace (pTHX_ SV *coro_sv, int flags)
2115{
2116 struct coro *coro = SvSTATE (coro_sv);
2117
2118 if (coro->flags & CF_RUNNING)
2119 croak ("cannot enable tracing on a running coroutine, caught");
2120
2121 if (flags & CC_TRACE)
2122 {
2123 if (!coro->cctx)
2124 coro->cctx = cctx_new_run ();
2125 else if (!(coro->cctx->flags & CC_TRACE))
2126 croak ("cannot enable tracing on coroutine with custom stack, caught");
2127
2128 coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
2129 }
2130 else if (coro->cctx && coro->cctx->flags & CC_TRACE)
2131 {
2132 coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
2133
2134 if (coro->flags & CF_RUNNING)
2135 PL_runops = RUNOPS_DEFAULT;
2136 else
2137 coro->slot->runops = RUNOPS_DEFAULT;
2138 }
2139}
2140
2141static void
2142coro_push_av (pTHX_ AV *av, I32 gimme_v)
2143{
2144 if (AvFILLp (av) >= 0 && gimme_v != G_VOID)
2145 {
2146 dSP;
2147
2148 if (gimme_v == G_SCALAR)
2149 XPUSHs (AvARRAY (av)[AvFILLp (av)]);
2150 else
2151 {
2152 int i;
2153 EXTEND (SP, AvFILLp (av) + 1);
2154
2155 for (i = 0; i <= AvFILLp (av); ++i)
2156 PUSHs (AvARRAY (av)[i]);
2157 }
2158
2159 PUTBACK;
2160 }
2161}
2162
2163static void
2164coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)
2165{
2166 if (!coro->on_destroy)
2167 coro->on_destroy = newAV ();
2168
2169 av_push (coro->on_destroy, cb);
2170}
2171
2172static void
2173slf_destroy_join (pTHX_ struct CoroSLF *frame)
2174{
2175 SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv);
2176}
2177
2178static int
2179slf_check_join (pTHX_ struct CoroSLF *frame)
2180{
2181 struct coro *coro = (struct coro *)frame->data;
2182
2183 if (!coro->status)
2184 return 1;
2185
2186 frame->destroy = 0;
2187
2188 coro_push_av (aTHX_ coro->status, GIMME_V);
2189
2190 SvREFCNT_dec ((SV *)coro->hv);
2191
2192 return 0;
2193}
2194
2195static void
2196slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2197{
2198 struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef);
2199
2200 if (items > 1)
2201 croak ("join called with too many arguments");
2202
2203 if (coro->status)
2204 frame->prepare = prepare_nop;
2205 else
2206 {
2207 coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current)));
2208 frame->prepare = prepare_schedule;
2209 }
2210
2211 frame->check = slf_check_join;
2212 frame->destroy = slf_destroy_join;
2213 frame->data = (void *)coro;
2214 SvREFCNT_inc (coro->hv);
2215}
2216
2217static void
2218coro_call_on_destroy (pTHX_ struct coro *coro)
2219{
2220 AV *od = coro->on_destroy;
2221
2222 if (!od)
2223 return;
2224
2225 coro->on_destroy = 0;
2226 sv_2mortal ((SV *)od);
2227
2228 while (AvFILLp (od) >= 0)
2229 {
2230 SV *cb = sv_2mortal (av_pop (od));
2231
2232 /* coro hv's (and only hv's at the moment) are supported as well */
2233 if (SvSTATEhv_p (aTHX_ cb))
2234 api_ready (aTHX_ cb);
2235 else
2236 {
2237 dSP; /* don't disturb outer sp */
2238 PUSHMARK (SP);
2239
2240 if (coro->status)
2241 {
2242 PUTBACK;
2243 coro_push_av (aTHX_ coro->status, G_ARRAY);
2244 SPAGAIN;
2245 }
2246
2247 PUTBACK;
2248 call_sv (cb, G_VOID | G_DISCARD);
2249 }
2250 }
2251}
2252
2253static void
2254coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
2255{
2256 AV *av;
2257
2258 if (coro->status)
2259 {
2260 av = coro->status;
2261 av_clear (av);
2262 }
2263 else
2264 av = coro->status = newAV ();
2265
2266 /* items are actually not so common, so optimise for this case */
2267 if (items)
2268 {
2269 int i;
2270
2271 av_extend (av, items - 1);
2272
2273 for (i = 0; i < items; ++i)
2274 av_push (av, SvREFCNT_inc_NN (arg [i]));
2275 }
2276}
2277
2278static void
2279slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv)
2280{
2281 av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */
2282 api_ready (aTHX_ sv_manager);
2283
2284 frame->prepare = prepare_schedule;
2285 frame->check = slf_check_repeat;
2286
2287 /* as a minor optimisation, we could unwind all stacks here */
2288 /* but that puts extra pressure on pp_slf, and is not worth much */
2289 /*coro_unwind_stacks (aTHX);*/
2290}
2291
2292static void
2293slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2294{
2295 HV *coro_hv = (HV *)SvRV (coro_current);
2296
2297 coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items);
2298 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
2299}
2300
2301static void
2302slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2303{
2304 HV *coro_hv;
2305 struct coro *coro;
2306
2307 if (items <= 0)
2308 croak ("Coro::cancel called without coro object,");
2309
2310 coro = SvSTATE (arg [0]);
2311 coro_hv = coro->hv;
2312
2313 coro_set_status (aTHX_ coro, arg + 1, items - 1);
2314
2315 if (ecb_expect_false (coro->flags & CF_NOCANCEL))
2316 {
2317 /* coro currently busy cancelling something, so just notify it */
2318 coro->slf_frame.data = (void *)coro;
2319
2320 frame->prepare = prepare_nop;
2321 frame->check = slf_check_nop;
2322 }
2323 else if (coro_hv == (HV *)SvRV (coro_current))
2324 {
2325 /* cancelling the current coro is allowed, and equals terminate */
2326 slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
2327 }
2328 else
2329 {
2330 struct coro *self = SvSTATE_current;
2331
2332 if (!self)
2333 croak ("Coro::cancel called outside of thread content,");
2334
2335 /* otherwise we cancel directly, purely for speed reasons
2336 * unfortunately, this requires some magic trickery, as
2337 * somebody else could cancel us, so we have to fight the cancellation.
2338 * this is ugly, and hopefully fully worth the extra speed.
2339 * besides, I can't get the slow-but-safe version working...
2340 */
2341 slf_frame.data = 0;
2342 self->flags |= CF_NOCANCEL;
2343 coro_state_destroy (aTHX_ coro);
2344 self->flags &= ~CF_NOCANCEL;
2345
2346 if (slf_frame.data)
2347 {
2348 /* while we were busy we have been cancelled, so terminate */
2349 slf_init_terminate_cancel_common (aTHX_ frame, self->hv);
2350 }
2351 else
2352 {
2353 frame->prepare = prepare_nop;
2354 frame->check = slf_check_nop;
2355 }
2356 }
2357}
2358
2359static int
2360slf_check_safe_cancel (pTHX_ struct CoroSLF *frame)
2361{
2362 frame->prepare = 0;
2363 coro_unwind_stacks (aTHX);
2364
2365 slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current));
2366
2367 return 1;
2368}
2369
2370static int
2371safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)
2372{
2373 if (coro->cctx)
2374 croak ("coro inside C callback, unable to cancel at this time, caught");
2375
2376 if (coro->flags & (CF_NEW | CF_ZOMBIE))
2377 {
2378 coro_set_status (aTHX_ coro, arg, items);
2379 coro_state_destroy (aTHX_ coro);
2380 }
2381 else
2382 {
2383 if (!coro->slf_frame.prepare)
2384 croak ("coro outside an SLF function, unable to cancel at this time, caught");
2385
2386 slf_destroy (aTHX_ coro);
2387
2388 coro_set_status (aTHX_ coro, arg, items);
2389 coro->slf_frame.prepare = prepare_nop;
2390 coro->slf_frame.check = slf_check_safe_cancel;
2391
2392 api_ready (aTHX_ (SV *)coro->hv);
2393 }
2394
2395 return 1;
2396}
2397
2398/*****************************************************************************/
2399/* async pool handler */
2400
2401static int
2402slf_check_pool_handler (pTHX_ struct CoroSLF *frame)
2403{
2404 HV *hv = (HV *)SvRV (coro_current);
2405 struct coro *coro = (struct coro *)frame->data;
2406
2407 if (!coro->invoke_cb)
2408 return 1; /* loop till we have invoke */
2409 else
2410 {
2411 hv_store (hv, "desc", sizeof ("desc") - 1,
2412 newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
2413
2414 coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
2415
2416 {
2417 dSP;
2418 XPUSHs (sv_2mortal (coro->invoke_cb)); coro->invoke_cb = 0;
2419 PUTBACK;
2420 }
2421
2422 SvREFCNT_dec (GvAV (PL_defgv));
2423 GvAV (PL_defgv) = coro->invoke_av;
2424 coro->invoke_av = 0;
2425
2426 return 0;
2427 }
2428}
2429
2430static void
2431slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2432{
2433 HV *hv = (HV *)SvRV (coro_current);
2434 struct coro *coro = SvSTATE_hv ((SV *)hv);
2435
2436 if (ecb_expect_true (coro->saved_deffh))
2437 {
2438 /* subsequent iteration */
2439 SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
2440 coro->saved_deffh = 0;
2441
2442 if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
2443 || av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
2444 {
2445 slf_init_terminate_cancel_common (aTHX_ frame, hv);
2446 return;
2447 }
2448 else
2449 {
2450 av_clear (GvAV (PL_defgv));
2451 hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
2452
2453 if (ecb_expect_false (coro->swap_sv))
2454 {
2455 SWAP_SVS_LEAVE (coro);
2456 SvREFCNT_dec_NN (coro->swap_sv);
2457 coro->swap_sv = 0;
2458 }
2459
2460 coro->prio = 0;
2461
2462 if (ecb_expect_false (coro->cctx) && ecb_expect_false (coro->cctx->flags & CC_TRACE))
2463 api_trace (aTHX_ coro_current, 0);
2464
2465 frame->prepare = prepare_schedule;
2466 av_push (av_async_pool, SvREFCNT_inc (hv));
2467 }
2468 }
2469 else
2470 {
2471 /* first iteration, simply fall through */
2472 frame->prepare = prepare_nop;
2473 }
2474
2475 frame->check = slf_check_pool_handler;
2476 frame->data = (void *)coro;
2477}
2478
2479/*****************************************************************************/
2480/* rouse callback */
2481
2482#define CORO_MAGIC_type_rouse PERL_MAGIC_ext
2483
2484static void
2485coro_rouse_callback (pTHX_ CV *cv)
2486{
2487 dXSARGS;
2488 SV *data = (SV *)S_GENSUB_ARG;
2489
2490 if (SvTYPE (SvRV (data)) != SVt_PVAV)
2491 {
2492 /* first call, set args */
2493 SV *coro = SvRV (data);
2494 AV *av = newAV ();
2495
2496 SvRV_set (data, (SV *)av);
2497
2498 /* better take a full copy of the arguments */
2499 while (items--)
2500 av_store (av, items, newSVsv (ST (items)));
2501
2502 api_ready (aTHX_ coro);
2503 SvREFCNT_dec (coro);
2504 }
2505
2506 XSRETURN_EMPTY;
2507}
2508
2509static int
2510slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
2511{
2512 SV *data = (SV *)frame->data;
2513
2514 if (CORO_THROW)
2515 return 0;
2516
2517 if (SvTYPE (SvRV (data)) != SVt_PVAV)
2518 return 1;
2519
2520 /* now push all results on the stack */
2521 {
2522 dSP;
2523 AV *av = (AV *)SvRV (data);
2524 int i;
2525
2526 EXTEND (SP, AvFILLp (av) + 1);
2527 for (i = 0; i <= AvFILLp (av); ++i)
2528 PUSHs (sv_2mortal (AvARRAY (av)[i]));
2529
2530 /* we have stolen the elements, so set length to zero and free */
2531 AvFILLp (av) = -1;
2532 av_undef (av);
2533
2534 PUTBACK;
2535 }
2536
2537 return 0;
2538}
2539
2540static void
2541slf_init_rouse_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2542{
2543 SV *cb;
2544
2545 if (items)
2546 cb = arg [0];
2547 else
2548 {
2549 struct coro *coro = SvSTATE_current;
2550
2551 if (!coro->rouse_cb)
2552 croak ("Coro::rouse_wait called without rouse callback, and no default rouse callback found either,");
2553
2554 cb = sv_2mortal (coro->rouse_cb);
2555 coro->rouse_cb = 0;
2556 }
2557
2558 if (!SvROK (cb)
2559 || SvTYPE (SvRV (cb)) != SVt_PVCV
2560 || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
2561 croak ("Coro::rouse_wait called with illegal callback argument,");
2562
2563 {
2564 CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
2565 SV *data = (SV *)S_GENSUB_ARG;
2566
2567 frame->data = (void *)data;
2568 frame->prepare = SvTYPE (SvRV (data)) == SVt_PVAV ? prepare_nop : prepare_schedule;
2569 frame->check = slf_check_rouse_wait;
2570 }
2571}
2572
2573static SV *
2574coro_new_rouse_cb (pTHX)
2575{
2576 HV *hv = (HV *)SvRV (coro_current);
2577 struct coro *coro = SvSTATE_hv (hv);
2578 SV *data = newRV_inc ((SV *)hv);
2579 SV *cb = s_gensub (aTHX_ coro_rouse_callback, (void *)data);
2580
2581 sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0);
2582 SvREFCNT_dec (data); /* magicext increases the refcount */
2583
2584 SvREFCNT_dec (coro->rouse_cb);
2585 coro->rouse_cb = SvREFCNT_inc_NN (cb);
2586
2587 return cb;
2588}
2589
2590/*****************************************************************************/
2591/* schedule-like-function opcode (SLF) */
2592
2593static UNOP slf_restore; /* restore stack as entersub did, for first-re-run */
2594static const CV *slf_cv;
2595static SV **slf_argv;
2596static int slf_argc, slf_arga; /* count, allocated */
2597static I32 slf_ax; /* top of stack, for restore */
2598
2599/* this restores the stack in the case we patched the entersub, to */
2600/* recreate the stack frame as perl will on following calls */
2601/* since entersub cleared the stack */
2602static OP *
2603pp_restore (pTHX)
2604{
2605 int i;
2606 SV **SP = PL_stack_base + slf_ax;
2607
2608 PUSHMARK (SP);
2609
2610 EXTEND (SP, slf_argc + 1);
2611
2612 for (i = 0; i < slf_argc; ++i)
2613 PUSHs (sv_2mortal (slf_argv [i]));
2614
2615 PUSHs ((SV *)CvGV (slf_cv));
2616
2617 RETURNOP (slf_restore.op_first);
2618}
2619
2620static void
2621slf_prepare_transfer (pTHX_ struct coro_transfer_args *ta)
2622{
2623 SV **arg = (SV **)slf_frame.data;
2624
2625 prepare_transfer (aTHX_ ta, arg [0], arg [1]);
2626}
2627
2628static void
2629slf_init_transfer (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2630{
2631 if (items != 2)
2632 croak ("Coro::State::transfer (prev, next) expects two arguments, not %d,", items);
2633
2634 frame->prepare = slf_prepare_transfer;
2635 frame->check = slf_check_nop;
2636 frame->data = (void *)arg; /* let's hope it will stay valid */
2637}
2638
2639static void
2640slf_init_schedule (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2641{
2642 frame->prepare = prepare_schedule;
2643 frame->check = slf_check_nop;
2644}
2645
2646static void
2647slf_prepare_schedule_to (pTHX_ struct coro_transfer_args *ta)
2648{
2649 struct coro *next = (struct coro *)slf_frame.data;
2650
2651 SvREFCNT_inc_NN (next->hv);
2652 prepare_schedule_to (aTHX_ ta, next);
2653}
2654
2655static void
2656slf_init_schedule_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2657{
2658 if (!items)
2659 croak ("Coro::schedule_to expects a coroutine argument, caught");
2660
2661 frame->data = (void *)SvSTATE (arg [0]);
2662 frame->prepare = slf_prepare_schedule_to;
2663 frame->check = slf_check_nop;
2664}
2665
2666static void
2667slf_init_cede_to (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2668{
2669 api_ready (aTHX_ SvRV (coro_current));
2670
2671 slf_init_schedule_to (aTHX_ frame, cv, arg, items);
2672}
2673
2674static void
2675slf_init_cede (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2676{
2677 frame->prepare = prepare_cede;
2678 frame->check = slf_check_nop;
2679}
2680
2681static void
2682slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2683{
2684 frame->prepare = prepare_cede_notself;
2685 frame->check = slf_check_nop;
2686}
2687
2688/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
2689static void
2690slf_destroy (pTHX_ struct coro *coro)
2691{
2692 struct CoroSLF frame = coro->slf_frame;
2693
2694 /*
2695 * The on_destroy below most likely is from an SLF call.
2696 * Since by definition the SLF call will not finish when we destroy
2697 * the coro, we will have to force-finish it here, otherwise
2698 * cleanup functions cannot call SLF functions.
2699 */
2700 coro->slf_frame.prepare = 0;
2701
2702 /* this callback is reserved for slf functions needing to do cleanup */
2703 if (frame.destroy && frame.prepare && !PL_dirty)
2704 frame.destroy (aTHX_ &frame);
2705}
2706
2707/*
2708 * these not obviously related functions are all rolled into one
2709 * function to increase chances that they all will call transfer with the same
2710 * stack offset
2711 * SLF stands for "schedule-like-function".
2712 */
2713static OP *
2714pp_slf (pTHX)
2715{
2716 I32 checkmark; /* mark SP to see how many elements check has pushed */
2717
2718 /* set up the slf frame, unless it has already been set-up */
2719 /* the latter happens when a new coro has been started */
2720 /* or when a new cctx was attached to an existing coroutine */
2721 if (ecb_expect_true (!slf_frame.prepare))
2722 {
2723 /* first iteration */
2724 dSP;
2725 SV **arg = PL_stack_base + TOPMARK + 1;
2726 int items = SP - arg; /* args without function object */
2727 SV *gv = *sp;
2728
2729 /* do a quick consistency check on the "function" object, and if it isn't */
2730 /* for us, divert to the real entersub */
2731 if (SvTYPE (gv) != SVt_PVGV
2732 || !GvCV (gv)
2733 || !(CvFLAGS (GvCV (gv)) & CVf_SLF))
2734 return PL_ppaddr[OP_ENTERSUB](aTHX);
2735
2736 if (!(PL_op->op_flags & OPf_STACKED))
2737 {
2738 /* ampersand-form of call, use @_ instead of stack */
2739 AV *av = GvAV (PL_defgv);
2740 arg = AvARRAY (av);
2741 items = AvFILLp (av) + 1;
2742 }
2743
2744 /* now call the init function, which needs to set up slf_frame */
2745 ((coro_slf_cb)CvXSUBANY (GvCV (gv)).any_ptr)
2746 (aTHX_ &slf_frame, GvCV (gv), arg, items);
2747
2748 /* pop args */
2749 SP = PL_stack_base + POPMARK;
2750
2751 PUTBACK;
2752 }
2753
2754 /* now that we have a slf_frame, interpret it! */
2755 /* we use a callback system not to make the code needlessly */
2756 /* complicated, but so we can run multiple perl coros from one cctx */
2757
2758 do
2759 {
2760 struct coro_transfer_args ta;
2761
2762 slf_frame.prepare (aTHX_ &ta);
2763 TRANSFER (ta, 0);
2764
2765 checkmark = PL_stack_sp - PL_stack_base;
2766 }
2767 while (slf_frame.check (aTHX_ &slf_frame));
2768
2769 slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */
2770
2771 /* exception handling */
2772 if (ecb_expect_false (CORO_THROW))
2773 {
2774 SV *exception = sv_2mortal (CORO_THROW);
2775
2776 CORO_THROW = 0;
2777 sv_setsv (ERRSV, exception);
2778 croak (0);
2779 }
2780
2781 /* return value handling - mostly like entersub */
2782 /* make sure we put something on the stack in scalar context */
2783 if (GIMME_V == G_SCALAR
2784 && ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1))
2785 {
2786 dSP;
2787 SV **bot = PL_stack_base + checkmark;
2788
2789 if (sp == bot) /* too few, push undef */
2790 bot [1] = &PL_sv_undef;
2791 else /* too many, take last one */
2792 bot [1] = *sp;
2793
2794 SP = bot + 1;
2795
2796 PUTBACK;
2797 }
2798
2799 return NORMAL;
2800}
2801
2802static void
2803api_execute_slf (pTHX_ CV *cv, coro_slf_cb init_cb, I32 ax)
2804{
2805 int i;
2806 SV **arg = PL_stack_base + ax;
2807 int items = PL_stack_sp - arg + 1;
2808
2809 assert (("FATAL: SLF call with illegal CV value", !CvANON (cv)));
2810
2811 if (PL_op->op_ppaddr != PL_ppaddr [OP_ENTERSUB]
2812 && PL_op->op_ppaddr != pp_slf)
2813 croak ("FATAL: Coro SLF calls can only be made normally, not via goto or any other means, caught");
2814
2815 CvFLAGS (cv) |= CVf_SLF;
2816 CvXSUBANY (cv).any_ptr = (void *)init_cb;
2817 slf_cv = cv;
2818
2819 /* we patch the op, and then re-run the whole call */
2820 /* we have to put the same argument on the stack for this to work */
2821 /* and this will be done by pp_restore */
2822 slf_restore.op_next = (OP *)&slf_restore;
2823 slf_restore.op_type = OP_CUSTOM;
2824 slf_restore.op_ppaddr = pp_restore;
2825 slf_restore.op_first = PL_op;
2826
2827 slf_ax = ax - 1; /* undo the ax++ inside dAXMARK */
2828
2829 if (PL_op->op_flags & OPf_STACKED)
2830 {
2831 if (items > slf_arga)
2832 {
2833 slf_arga = items;
2834 Safefree (slf_argv);
2835 New (0, slf_argv, slf_arga, SV *);
2836 }
2837
2838 slf_argc = items;
2839
2840 for (i = 0; i < items; ++i)
2841 slf_argv [i] = SvREFCNT_inc (arg [i]);
2842 }
2843 else
2844 slf_argc = 0;
2845
2846 PL_op->op_ppaddr = pp_slf;
2847 /*PL_op->op_type = OP_CUSTOM; /* we do behave like entersub still */
2848
2849 PL_op = (OP *)&slf_restore;
2850}
2851
2852/*****************************************************************************/
2853/* dynamic wind */
2854
2855static void
2856on_enterleave_call (pTHX_ SV *cb)
2857{
2858 dSP;
2859
2860 PUSHSTACK;
2861
2862 PUSHMARK (SP);
2863 PUTBACK;
2864 call_sv (cb, G_VOID | G_DISCARD);
2865 SPAGAIN;
2866
2867 POPSTACK;
2868}
2869
2870static SV *
2871coro_avp_pop_and_free (pTHX_ AV **avp)
2872{
2873 AV *av = *avp;
2874 SV *res = av_pop (av);
2875
2876 if (AvFILLp (av) < 0)
2877 {
2878 *avp = 0;
2879 SvREFCNT_dec (av);
2880 }
2881
2882 return res;
2883}
2884
2885static void
2886coro_pop_on_enter (pTHX_ void *coro)
2887{
2888 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_enter);
2889 SvREFCNT_dec (cb);
2890}
2891
2892static void
2893coro_pop_on_leave (pTHX_ void *coro)
2894{
2895 SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_leave);
2896 on_enterleave_call (aTHX_ sv_2mortal (cb));
2897}
2898
2899static void
2900enterleave_hook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, void *arg)
2901{
2902 if (!hook)
2903 return;
2904
2905 if (!*avp)
2906 {
2907 *avp = newAV ();
2908 AvREAL_off (*avp);
2909 }
2910
2911 av_push (*avp, (SV *)hook);
2912 av_push (*avp, (SV *)arg);
2913}
2914
2915static void
2916enterleave_unhook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, int execute)
2917{
2918 AV *av = *avp;
2919 int i;
2920
2921 if (!av)
2922 return;
2923
2924 for (i = AvFILLp (av) - 1; i >= 0; i -= 2)
2925 if (AvARRAY (av)[i] == (SV *)hook)
2926 {
2927 if (execute)
2928 hook (aTHX_ (void *)AvARRAY (av)[i + 1]);
2929
2930 memmove (AvARRAY (av) + i, AvARRAY (av) + i + 2, AvFILLp (av) - i - 1);
2931 av_pop (av);
2932 av_pop (av);
2933 break;
2934 }
2935
2936 if (AvFILLp (av) >= 0)
2937 {
2938 *avp = 0;
2939 SvREFCNT_dec_NN (av);
2940 }
2941}
2942
2943static void
2944api_enterleave_hook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
2945{
2946 struct coro *coro = SvSTATE (coro_sv);
2947
2948 if (SvSTATE_current == coro)
2949 if (enter)
2950 enter (aTHX_ enter_arg);
2951
2952 enterleave_hook_xs (aTHX_ coro, &coro->on_enter_xs, enter, enter_arg);
2953 enterleave_hook_xs (aTHX_ coro, &coro->on_leave_xs, leave, leave_arg);
2954}
2955
2956static void
2957api_enterleave_unhook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, coro_enterleave_hook leave)
2958{
2959 struct coro *coro = SvSTATE (coro_sv);
2960
2961 enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
2962 enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, SvSTATE_current == coro);
2963}
2964
2965static void
2966savedestructor_unhook_enter (pTHX_ coro_enterleave_hook enter)
2967{
2968 struct coro *coro = SvSTATE_current;
2969
2970 enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
2971}
2972
2973static void
2974savedestructor_unhook_leave (pTHX_ coro_enterleave_hook leave)
2975{
2976 struct coro *coro = SvSTATE_current;
2977
2978 enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, 1);
2979}
2980
2981static void
2982api_enterleave_scope_hook (pTHX_ coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
2983{
2984 api_enterleave_hook (aTHX_ coro_current, enter, enter_arg, leave, leave_arg);
2985
2986 /* this ought to be much cheaper than malloc + a single destructor call */
2987 if (enter) SAVEDESTRUCTOR_X (savedestructor_unhook_enter, enter);
2988 if (leave) SAVEDESTRUCTOR_X (savedestructor_unhook_leave, leave);
2989}
2990
2991/*****************************************************************************/
2992/* PerlIO::cede */
2993
2994typedef struct
2995{
2996 PerlIOBuf base;
2997 NV next, every;
2998} PerlIOCede;
2999
3000static IV ecb_cold
3001PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3002{
3003 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
3004
3005 self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
3006 self->next = nvtime () + self->every;
3007
3008 return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
3009}
3010
3011static SV * ecb_cold
3012PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
3013{
3014 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
3015
3016 return newSVnv (self->every);
3017}
3018
3019static IV
3020PerlIOCede_flush (pTHX_ PerlIO *f)
3021{
3022 PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
3023 double now = nvtime ();
3024
3025 if (now >= self->next)
3026 {
3027 api_cede (aTHX);
3028 self->next = now + self->every;
3029 }
3030
3031 return PerlIOBuf_flush (aTHX_ f);
3032}
3033
3034static PerlIO_funcs PerlIO_cede =
3035{
3036 sizeof(PerlIO_funcs),
3037 "cede",
3038 sizeof(PerlIOCede),
3039 PERLIO_K_DESTRUCT | PERLIO_K_RAW,
3040 PerlIOCede_pushed,
3041 PerlIOBuf_popped,
3042 PerlIOBuf_open,
3043 PerlIOBase_binmode,
3044 PerlIOCede_getarg,
3045 PerlIOBase_fileno,
3046 PerlIOBuf_dup,
3047 PerlIOBuf_read,
3048 PerlIOBuf_unread,
3049 PerlIOBuf_write,
3050 PerlIOBuf_seek,
3051 PerlIOBuf_tell,
3052 PerlIOBuf_close,
3053 PerlIOCede_flush,
3054 PerlIOBuf_fill,
3055 PerlIOBase_eof,
3056 PerlIOBase_error,
3057 PerlIOBase_clearerr,
3058 PerlIOBase_setlinebuf,
3059 PerlIOBuf_get_base,
3060 PerlIOBuf_bufsiz,
3061 PerlIOBuf_get_ptr,
3062 PerlIOBuf_get_cnt,
3063 PerlIOBuf_set_ptrcnt,
3064};
3065
3066/*****************************************************************************/
3067/* Coro::Semaphore & Coro::Signal */
3068
3069static SV *
3070coro_waitarray_new (pTHX_ int count)
3071{
3072 /* a waitarray=semaphore contains a counter IV in $sem->[0] and any waiters after that */
3073 AV *av = newAV ();
3074 SV **ary;
3075
3076 /* unfortunately, building manually saves memory */
3077 Newx (ary, 2, SV *);
3078 AvALLOC (av) = ary;
3079#if PERL_VERSION_ATLEAST (5,10,0)
3080 AvARRAY (av) = ary;
3081#else
3082 /* 5.8.8 needs this syntax instead of AvARRAY = ary, yet */
3083 /* -DDEBUGGING flags this as a bug, despite it perfectly working */
3084 SvPVX ((SV *)av) = (char *)ary;
3085#endif
3086 AvMAX (av) = 1;
3087 AvFILLp (av) = 0;
3088 ary [0] = newSViv (count);
3089
3090 return newRV_noinc ((SV *)av);
3091}
3092
3093/* semaphore */
3094
3095static void
3096coro_semaphore_adjust (pTHX_ AV *av, IV adjust)
3097{
3098 SV *count_sv = AvARRAY (av)[0];
3099 IV count = SvIVX (count_sv);
3100
3101 count += adjust;
3102 SvIVX (count_sv) = count;
3103
3104 /* now wake up as many waiters as are expected to lock */
3105 while (count > 0 && AvFILLp (av) > 0)
3106 {
3107 SV *cb;
3108
3109 /* swap first two elements so we can shift a waiter */
3110 AvARRAY (av)[0] = AvARRAY (av)[1];
3111 AvARRAY (av)[1] = count_sv;
3112 cb = av_shift (av);
3113
3114 if (SvOBJECT (cb))
3115 {
3116 api_ready (aTHX_ cb);
3117 --count;
3118 }
3119 else if (SvTYPE (cb) == SVt_PVCV)
3120 {
3121 dSP;
3122 PUSHMARK (SP);
3123 XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
3124 PUTBACK;
3125 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
3126 }
3127
3128 SvREFCNT_dec_NN (cb);
3129 }
3130}
3131
3132static void
3133coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
3134{
3135 /* call $sem->adjust (0) to possibly wake up some other waiters */
3136 coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0);
3137}
3138
3139static int
3140slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)
3141{
3142 AV *av = (AV *)frame->data;
3143 SV *count_sv = AvARRAY (av)[0];
3144 SV *coro_hv = SvRV (coro_current);
3145
3146 frame->destroy = 0;
3147
3148 /* if we are about to throw, don't actually acquire the lock, just throw */
3149 if (ecb_expect_false (CORO_THROW))
3150 {
3151 /* we still might be responsible for the semaphore, so wake up others */
3152 coro_semaphore_adjust (aTHX_ av, 0);
3153
3154 return 0;
3155 }
3156 else if (SvIVX (count_sv) > 0)
3157 {
3158 if (acquire)
3159 SvIVX (count_sv) = SvIVX (count_sv) - 1;
3160 else
3161 coro_semaphore_adjust (aTHX_ av, 0);
3162
3163 return 0;
3164 }
3165 else
3166 {
3167 int i;
3168 /* if we were woken up but can't down, we look through the whole */
3169 /* waiters list and only add us if we aren't in there already */
3170 /* this avoids some degenerate memory usage cases */
3171 for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */
3172 if (AvARRAY (av)[i] == coro_hv)
3173 return 1;
3174
3175 av_push (av, SvREFCNT_inc (coro_hv));
3176 return 1;
3177 }
3178}
3179
3180static int
3181slf_check_semaphore_down (pTHX_ struct CoroSLF *frame)
3182{
3183 return slf_check_semaphore_down_or_wait (aTHX_ frame, 1);
3184}
3185
3186static int
3187slf_check_semaphore_wait (pTHX_ struct CoroSLF *frame)
3188{
3189 return slf_check_semaphore_down_or_wait (aTHX_ frame, 0);
3190}
3191
3192static void
3193slf_init_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3194{
3195 AV *av = (AV *)SvRV (arg [0]);
3196
3197 if (SvIVX (AvARRAY (av)[0]) > 0)
3198 {
3199 frame->data = (void *)av;
3200 frame->prepare = prepare_nop;
3201 }
3202 else
3203 {
3204 av_push (av, SvREFCNT_inc (SvRV (coro_current)));
3205
3206 frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
3207 frame->prepare = prepare_schedule;
3208 /* to avoid race conditions when a woken-up coro gets terminated */
3209 /* we arrange for a temporary on_destroy that calls adjust (0) */
3210 frame->destroy = coro_semaphore_destroy;
3211 }
3212}
3213
3214static void
3215slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3216{
3217 slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items);
3218 frame->check = slf_check_semaphore_down;
3219}
3220
3221static void
3222slf_init_semaphore_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3223{
3224 if (items >= 2)
3225 {
3226 /* callback form */
3227 AV *av = (AV *)SvRV (arg [0]);
3228 SV *cb_cv = s_get_cv_croak (arg [1]);
3229
3230 av_push (av, SvREFCNT_inc_NN (cb_cv));
3231
3232 if (SvIVX (AvARRAY (av)[0]) > 0)
3233 coro_semaphore_adjust (aTHX_ av, 0);
3234
3235 frame->prepare = prepare_nop;
3236 frame->check = slf_check_nop;
3237 }
3238 else
3239 {
3240 slf_init_semaphore_down_or_wait (aTHX_ frame, cv, arg, items);
3241 frame->check = slf_check_semaphore_wait;
3242 }
3243}
3244
3245/* signal */
3246
3247static void
3248coro_signal_wake (pTHX_ AV *av, int count)
3249{
3250 SvIVX (AvARRAY (av)[0]) = 0;
3251
3252 /* now signal count waiters */
3253 while (count > 0 && AvFILLp (av) > 0)
3254 {
3255 SV *cb;
3256
3257 /* swap first two elements so we can shift a waiter */
3258 cb = AvARRAY (av)[0];
3259 AvARRAY (av)[0] = AvARRAY (av)[1];
3260 AvARRAY (av)[1] = cb;
3261
3262 cb = av_shift (av);
3263
3264 if (SvTYPE (cb) == SVt_PVCV)
3265 {
3266 dSP;
3267 PUSHMARK (SP);
3268 XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
3269 PUTBACK;
3270 call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
3271 }
3272 else
3273 {
3274 api_ready (aTHX_ cb);
3275 sv_setiv (cb, 0); /* signal waiter */
3276 }
3277
3278 SvREFCNT_dec_NN (cb);
3279
3280 --count;
3281 }
3282}
3283
3284static int
3285slf_check_signal_wait (pTHX_ struct CoroSLF *frame)
3286{
3287 /* if we are about to throw, also stop waiting */
3288 return SvROK ((SV *)frame->data) && !CORO_THROW;
3289}
3290
3291static void
3292slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3293{
3294 AV *av = (AV *)SvRV (arg [0]);
3295
3296 if (items >= 2)
3297 {
3298 SV *cb_cv = s_get_cv_croak (arg [1]);
3299 av_push (av, SvREFCNT_inc_NN (cb_cv));
3300
3301 if (SvIVX (AvARRAY (av)[0]))
3302 coro_signal_wake (aTHX_ av, 1); /* must be the only waiter */
3303
3304 frame->prepare = prepare_nop;
3305 frame->check = slf_check_nop;
3306 }
3307 else if (SvIVX (AvARRAY (av)[0]))
3308 {
3309 SvIVX (AvARRAY (av)[0]) = 0;
3310 frame->prepare = prepare_nop;
3311 frame->check = slf_check_nop;
3312 }
3313 else
3314 {
3315 SV *waiter = newSVsv (coro_current); /* owned by signal av */
3316
3317 av_push (av, waiter);
3318
3319 frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */
3320 frame->prepare = prepare_schedule;
3321 frame->check = slf_check_signal_wait;
3322 }
3323}
3324
3325/*****************************************************************************/
3326/* Coro::AIO */
3327
3328#define CORO_MAGIC_type_aio PERL_MAGIC_ext
3329
3330/* helper storage struct */
3331struct io_state
3332{
3333 int errorno;
3334 I32 laststype; /* U16 in 5.10.0 */
3335 int laststatval;
3336 Stat_t statcache;
3337};
3338
3339static void
3340coro_aio_callback (pTHX_ CV *cv)
3341{
3342 dXSARGS;
3343 AV *state = (AV *)S_GENSUB_ARG;
3344 SV *coro = av_pop (state);
3345 SV *data_sv = newSV (sizeof (struct io_state));
3346
3347 av_extend (state, items - 1);
3348
3349 sv_upgrade (data_sv, SVt_PV);
3350 SvCUR_set (data_sv, sizeof (struct io_state));
3351 SvPOK_only (data_sv);
3352
3353 {
3354 struct io_state *data = (struct io_state *)SvPVX (data_sv);
3355
3356 data->errorno = errno;
3357 data->laststype = PL_laststype;
3358 data->laststatval = PL_laststatval;
3359 data->statcache = PL_statcache;
3360 }
3361
3362 /* now build the result vector out of all the parameters and the data_sv */
3363 {
3364 int i;
3365
3366 for (i = 0; i < items; ++i)
3367 av_push (state, SvREFCNT_inc_NN (ST (i)));
3368 }
3369
3370 av_push (state, data_sv);
3371
3372 api_ready (aTHX_ coro);
3373 SvREFCNT_dec_NN (coro);
3374 SvREFCNT_dec_NN ((AV *)state);
3375}
3376
3377static int
3378slf_check_aio_req (pTHX_ struct CoroSLF *frame)
3379{
3380 AV *state = (AV *)frame->data;
3381
3382 /* if we are about to throw, return early */
3383 /* this does not cancel the aio request, but at least */
3384 /* it quickly returns */
3385 if (CORO_THROW)
3386 return 0;
3387
3388 /* one element that is an RV? repeat! */
3389 if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
3390 return 1;
3391
3392 /* restore status */
3393 {
3394 SV *data_sv = av_pop (state);
3395 struct io_state *data = (struct io_state *)SvPVX (data_sv);
3396
3397 errno = data->errorno;
3398 PL_laststype = data->laststype;
3399 PL_laststatval = data->laststatval;
3400 PL_statcache = data->statcache;
3401
3402 SvREFCNT_dec_NN (data_sv);
3403 }
3404
3405 /* push result values */
3406 {
3407 dSP;
3408 int i;
3409
3410 EXTEND (SP, AvFILLp (state) + 1);
3411 for (i = 0; i <= AvFILLp (state); ++i)
3412 PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (state)[i])));
3413
3414 PUTBACK;
3415 }
3416
3417 return 0;
3418}
3419
3420static void
3421slf_init_aio_req (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
3422{
3423 AV *state = (AV *)sv_2mortal ((SV *)newAV ());
3424 SV *coro_hv = SvRV (coro_current);
3425 struct coro *coro = SvSTATE_hv (coro_hv);
3426
3427 /* put our coroutine id on the state arg */
3428 av_push (state, SvREFCNT_inc_NN (coro_hv));
3429
3430 /* first see whether we have a non-zero priority and set it as AIO prio */
3431 if (coro->prio)
3432 {
3433 dSP;
3434
3435 static SV *prio_cv;
3436 static SV *prio_sv;
3437
3438 if (ecb_expect_false (!prio_cv))
3439 {
3440 prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);
3441 prio_sv = newSViv (0);
3442 }
3443
3444 PUSHMARK (SP);
3445 sv_setiv (prio_sv, coro->prio);
3446 XPUSHs (prio_sv);
3447
3448 PUTBACK;
3449 call_sv (prio_cv, G_VOID | G_DISCARD);
3450 }
3451
3452 /* now call the original request */
3453 {
3454 dSP;
3455 CV *req = (CV *)CORO_MAGIC_NN ((SV *)cv, CORO_MAGIC_type_aio)->mg_obj;
3456 int i;
3457
3458 PUSHMARK (SP);
3459
3460 /* first push all args to the stack */
3461 EXTEND (SP, items + 1);
3462
3463 for (i = 0; i < items; ++i)
3464 PUSHs (arg [i]);
3465
3466 /* now push the callback closure */
3467 PUSHs (sv_2mortal (s_gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));
3468
3469 /* now call the AIO function - we assume our request is uncancelable */
3470 PUTBACK;
3471 call_sv ((SV *)req, G_VOID | G_DISCARD);
3472 }
3473
3474 /* now that the request is going, we loop till we have a result */
3475 frame->data = (void *)state;
3476 frame->prepare = prepare_schedule;
3477 frame->check = slf_check_aio_req;
3478}
3479
3480static void
3481coro_aio_req_xs (pTHX_ CV *cv)
3482{
3483 dXSARGS;
3484
3485 CORO_EXECUTE_SLF_XS (slf_init_aio_req);
3486
3487 XSRETURN_EMPTY;
3488}
3489
3490/*****************************************************************************/
3491
3492#if CORO_CLONE
3493# include "clone.c"
3494#endif
3495
3496/*****************************************************************************/
3497
3498static SV *
3499coro_new (pTHX_ HV *stash, SV **argv, int argc, int is_coro)
3500{
3501 SV *coro_sv;
3502 struct coro *coro;
3503 MAGIC *mg;
3504 HV *hv;
3505 SV *cb;
3506 int i;
3507
3508 if (argc > 0)
3509 {
3510 cb = s_get_cv_croak (argv [0]);
3511
3512 if (!is_coro)
3513 {
3514 if (CvISXSUB (cb))
3515 croak ("Coro::State doesn't support XS functions as coroutine start, caught");
3516
3517 if (!CvROOT (cb))
3518 croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught");
3519 }
3520 }
3521
3522 Newz (0, coro, 1, struct coro);
3523 coro->args = newAV ();
3524 coro->flags = CF_NEW;
3525
3526 if (coro_first) coro_first->prev = coro;
3527 coro->next = coro_first;
3528 coro_first = coro;
3529
3530 coro->hv = hv = newHV ();
3531 mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
3532 mg->mg_flags |= MGf_DUP;
3533 coro_sv = sv_bless (newRV_noinc ((SV *)hv), stash);
3534
3535 if (argc > 0)
3536 {
3537 av_extend (coro->args, argc + is_coro - 1);
3538
3539 if (is_coro)
3540 {
3541 av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb));
3542 cb = (SV *)cv_coro_run;
3543 }
3544
3545 coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb);
3546
3547 for (i = 1; i < argc; i++)
3548 av_push (coro->args, newSVsv (argv [i]));
3549 }
3550
3551 return coro_sv;
3552}
3553
3554#ifndef __cplusplus
3555ecb_cold XS(boot_Coro__State);
3556#endif
3557
3558#if CORO_JIT
3559
3560static void ecb_noinline ecb_cold
3561pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)
3562{
3563 dSP;
3564 AV *av = newAV ();
3565
3566 av_store (av, 3, newSVuv (d));
3567 av_store (av, 2, newSVuv (c));
3568 av_store (av, 1, newSVuv (b));
3569 av_store (av, 0, newSVuv (a));
3570
3571 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
3572
3573 PUTBACK;
3574}
3575
3576static void ecb_noinline ecb_cold
3577jit_init (pTHX)
3578{
3579 dSP;
3580 SV *load, *save;
3581 char *map_base;
3582 char *load_ptr, *save_ptr;
3583 STRLEN load_len, save_len, map_len;
3584 int count;
3585
3586 eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
3587
3588 PUSHMARK (SP);
3589 #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
3590 #include "state.h"
3591 count = call_pv ("Coro::State::_jit", G_ARRAY);
3592 SPAGAIN;
3593
3594 save = POPs; save_ptr = SvPVbyte (save, save_len);
3595 load = POPs; load_ptr = SvPVbyte (load, load_len);
3596
3597 map_len = load_len + save_len + 16;
3598
3599 map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
3600
3601 if (map_base == (char *)MAP_FAILED)
3602 map_base = mmap (0, map_len, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
3603
3604 assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED));
3605
3606 load_perl_slots = (load_save_perl_slots_type)map_base;
3607 memcpy (map_base, load_ptr, load_len);
3608
3609 map_base += (load_len + 15) & ~15;
3610
3611 save_perl_slots = (load_save_perl_slots_type)map_base;
3612 memcpy (map_base, save_ptr, save_len);
3613
3614 /* we are good citizens and try to make the page read-only, so the evil evil */
3615 /* hackers might have it a bit more difficult */
3616 mprotect (map_base, map_len, PROT_READ | PROT_EXEC);
3617
3618 PUTBACK;
3619 eval_pv ("undef &Coro::State::_jit", 1);
3620}
3621
3622#endif
3623
3624MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
3625
3626PROTOTYPES: DISABLE
3627
3628BOOT:
3629{
3630#define VARx(name,expr,type) if (sizeof (type) < sizeof (expr)) croak ("FATAL: Coro thread context slot '" # name "' too small for this version of perl.");
3631#include "state.h"
3632#ifdef USE_ITHREADS
3633# if CORO_PTHREAD
3634 coro_thx = PERL_GET_CONTEXT;
3635# endif
3636#endif
3637 /* perl defines these to check for existance first, but why it doesn't */
3638 /* just create them one at init time is not clear to me, except for */
3639 /* programs trying to delete them, but... */
3640 /* anyway, we declare this as invalid and make sure they are initialised here */
3641 DEFSV;
3642 ERRSV;
3643
3644 cctx_current = cctx_new_empty ();
3645
3646 irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
3647 stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3648
3649 {
3650 /*
3651 * we provide a vtbvl for %SIG magic that replaces PL_vtbl_sig
3652 * by coro_sig_vtbl in hash values.
3653 */
3654 MAGIC *mg = mg_find ((SV *)GvHV (gv_fetchpv ("SIG", GV_ADD | GV_NOTQUAL, SVt_PVHV)), PERL_MAGIC_sig);
3655
3656 /* this only works if perl doesn't have a vtbl for %SIG */
3657 assert (!mg->mg_virtual);
3658
3659 /*
3660 * The irony is that the perl API itself asserts that mg_virtual
3661 * must be non-const, yet perl5porters insisted on marking their
3662 * vtbls as read-only, just to thwart perl modules from patching
3663 * them.
3664 */
3665 mg->mg_virtual = (MGVTBL *)&coro_sig_vtbl;
3666 mg->mg_flags |= MGf_COPY;
3667
3668 coro_sigelem_vtbl = PL_vtbl_sigelem;
3669 coro_sigelem_vtbl.svt_get = coro_sigelem_get;
3670 coro_sigelem_vtbl.svt_set = coro_sigelem_set;
3671 coro_sigelem_vtbl.svt_clear = coro_sigelem_clr;
3672 }
3673
3674 rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
3675 rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
3676
3677 coro_state_stash = gv_stashpv ("Coro::State", TRUE);
3678
3679 newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
3680 newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
3681 newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
3682 newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
3683
3684 main_mainstack = PL_mainstack;
3685 main_top_env = PL_top_env;
3686
3687 while (main_top_env->je_prev)
3688 main_top_env = main_top_env->je_prev;
3689
3690 {
3691 SV *slf = sv_2mortal (newSViv (PTR2IV (pp_slf)));
3692
3693 if (!PL_custom_op_names) PL_custom_op_names = newHV ();
3694 hv_store_ent (PL_custom_op_names, slf, newSVpv ("coro_slf", 0), 0);
3695
3696 if (!PL_custom_op_descs) PL_custom_op_descs = newHV ();
3697 hv_store_ent (PL_custom_op_descs, slf, newSVpv ("coro schedule like function", 0), 0);
3698 }
3699
3700 coroapi.ver = CORO_API_VERSION;
3701 coroapi.rev = CORO_API_REVISION;
3702
3703 coroapi.transfer = api_transfer;
3704
3705 coroapi.sv_state = SvSTATE_;
3706 coroapi.execute_slf = api_execute_slf;
3707 coroapi.prepare_nop = prepare_nop;
3708 coroapi.prepare_schedule = prepare_schedule;
3709 coroapi.prepare_cede = prepare_cede;
3710 coroapi.prepare_cede_notself = prepare_cede_notself;
3711
3712 time_init (aTHX);
3713
3714 assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));
3715#if CORO_JIT
3716 PUTBACK;
3717 jit_init (aTHX);
3718 SPAGAIN;
3719#endif
3720}
3721
3722SV *
3723new (SV *klass, ...)
3724 ALIAS:
3725 Coro::new = 1
3726 CODE:
3727 RETVAL = coro_new (aTHX_ ix ? coro_stash : coro_state_stash, &ST (1), items - 1, ix);
3728 OUTPUT:
3729 RETVAL
3730
3731void
3732transfer (...)
3733 PROTOTYPE: $$
3734 CODE:
3735 CORO_EXECUTE_SLF_XS (slf_init_transfer);
3736
3737SV *
3738clone (Coro::State coro)
3739 CODE:
3740{
3741#if CORO_CLONE
3742 struct coro *ncoro = coro_clone (aTHX_ coro);
3743 MAGIC *mg;
3744 /* TODO: too much duplication */
3745 ncoro->hv = newHV ();
3746 mg = sv_magicext ((SV *)ncoro->hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)ncoro, 0);
3747 mg->mg_flags |= MGf_DUP;
3748 RETVAL = sv_bless (newRV_noinc ((SV *)ncoro->hv), SvSTASH (coro->hv));
3749#else
3750 croak ("Coro::State->clone has not been configured into this installation of Coro, realised");
3751#endif
3752}
3753 OUTPUT:
3754 RETVAL
3755
3756int
3757cctx_stacksize (int new_stacksize = 0)
3758 PROTOTYPE: ;$
3759 CODE:
3760 RETVAL = cctx_stacksize;
3761 if (new_stacksize)
3762 {
3763 cctx_stacksize = new_stacksize;
3764 ++cctx_gen;
3765 }
3766 OUTPUT:
3767 RETVAL
3768
3769int
3770cctx_max_idle (int max_idle = 0)
3771 PROTOTYPE: ;$
3772 CODE:
3773 RETVAL = cctx_max_idle;
3774 if (max_idle > 1)
3775 cctx_max_idle = max_idle;
3776 OUTPUT:
3777 RETVAL
3778
3779int
3780cctx_count ()
3781 PROTOTYPE:
3782 CODE:
3783 RETVAL = cctx_count;
3784 OUTPUT:
3785 RETVAL
3786
3787int
3788cctx_idle ()
3789 PROTOTYPE:
3790 CODE:
3791 RETVAL = cctx_idle;
3792 OUTPUT:
3793 RETVAL
3794
3795void
3796list ()
3797 PROTOTYPE:
3798 PPCODE:
3799{
3800 struct coro *coro;
3801 for (coro = coro_first; coro; coro = coro->next)
3802 if (coro->hv)
3803 XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
3804}
3805
3806void
3807call (Coro::State coro, SV *coderef)
3808 ALIAS:
3809 eval = 1
3810 CODE:
3811{
3812 if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
3813 {
3814 struct coro *current = SvSTATE_current;
3815 struct CoroSLF slf_save;
3816
3817 if (current != coro)
235 { 3818 {
236 /* I never used formats, so how should I know how these are implemented? */ 3819 PUTBACK;
237 /* my bold guess is as a simple, plain sub... */ 3820 save_perl (aTHX_ current);
238 croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats"); 3821 load_perl (aTHX_ coro);
3822 /* the coro is most likely in an active SLF call.
3823 * while not strictly required (the code we execute is
3824 * not allowed to call any SLF functions), it's cleaner
3825 * to reinitialise the slf_frame and restore it later.
3826 * This might one day allow us to actually do SLF calls
3827 * from code executed here.
3828 */
3829 slf_save = slf_frame;
3830 slf_frame.prepare = 0;
3831 SPAGAIN;
3832 }
3833
3834 PUSHSTACK;
3835
3836 PUSHMARK (SP);
3837 PUTBACK;
3838
3839 if (ix)
3840 eval_sv (coderef, 0);
3841 else
3842 call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
3843
3844 POPSTACK;
3845 SPAGAIN;
3846
3847 if (current != coro)
3848 {
3849 PUTBACK;
3850 slf_frame = slf_save;
3851 save_perl (aTHX_ coro);
3852 load_perl (aTHX_ current);
3853 SPAGAIN;
239 } 3854 }
240 } 3855 }
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} 3856}
281 3857
282static void 3858SV *
283LOAD(pTHX_ Coro__State c) 3859is_ready (Coro::State coro)
284{
285 PL_dowarn = c->dowarn;
286 GvAV (PL_defgv) = c->defav;
287 PL_curstackinfo = c->curstackinfo;
288 PL_curstack = c->curstack;
289 PL_mainstack = c->mainstack;
290 PL_stack_sp = c->stack_sp;
291 PL_op = c->op;
292 PL_curpad = c->curpad;
293 PL_stack_base = c->stack_base;
294 PL_stack_max = c->stack_max;
295 PL_tmps_stack = c->tmps_stack;
296 PL_tmps_floor = c->tmps_floor;
297 PL_tmps_ix = c->tmps_ix;
298 PL_tmps_max = c->tmps_max;
299 PL_markstack = c->markstack;
300 PL_markstack_ptr = c->markstack_ptr;
301 PL_markstack_max = c->markstack_max;
302 PL_scopestack = c->scopestack;
303 PL_scopestack_ix = c->scopestack_ix;
304 PL_scopestack_max = c->scopestack_max;
305 PL_savestack = c->savestack;
306 PL_savestack_ix = c->savestack_ix;
307 PL_savestack_max = c->savestack_max;
308 PL_retstack = c->retstack;
309 PL_retstack_ix = c->retstack_ix;
310 PL_retstack_max = c->retstack_max;
311 PL_curcop = c->curcop;
312
313 {
314 dSP;
315 CV *cv;
316
317 /* now do the ugly restore mess */
318 while ((cv = (CV *)POPs))
319 {
320 AV *padlist = (AV *)POPs;
321
322 put_padlist (cv);
323 CvPADLIST(cv) = padlist;
324 CvDEPTH(cv) = (I32)POPs;
325
326#ifdef USE_THREADS
327 CvOWNER(cv) = (struct perl_thread *)POPs;
328 error does not work either
329#endif
330 }
331
332 PUTBACK;
333 }
334}
335
336/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
337STATIC void
338destroy_stacks(pTHX)
339{
340 dSP;
341
342 /* die does this while calling POPSTACK, but I just don't see why. */
343 dounwind(-1);
344
345 /* is this ugly, I ask? */
346 while (PL_scopestack_ix)
347 LEAVE;
348
349 while (PL_curstackinfo->si_next)
350 PL_curstackinfo = PL_curstackinfo->si_next;
351
352 while (PL_curstackinfo)
353 {
354 PERL_SI *p = PL_curstackinfo->si_prev;
355
356 SvREFCNT_dec(PL_curstackinfo->si_stack);
357 Safefree(PL_curstackinfo->si_cxstack);
358 Safefree(PL_curstackinfo);
359 PL_curstackinfo = p;
360 }
361
362 if (PL_scopestack_ix != 0)
363 Perl_warner(aTHX_ WARN_INTERNAL,
364 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365 (long)PL_scopestack_ix);
366 if (PL_savestack_ix != 0)
367 Perl_warner(aTHX_ WARN_INTERNAL,
368 "Unbalanced saves: %ld more saves than restores\n",
369 (long)PL_savestack_ix);
370 if (PL_tmps_floor != -1)
371 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372 (long)PL_tmps_floor + 1);
373 /*
374 */
375 Safefree(PL_tmps_stack);
376 Safefree(PL_markstack);
377 Safefree(PL_scopestack);
378 Safefree(PL_savestack);
379 Safefree(PL_retstack);
380}
381
382#define SUB_INIT "Coro::State::_newcoro"
383
384MODULE = Coro::State PACKAGE = Coro::State
385
386PROTOTYPES: ENABLE
387
388BOOT:
389 if (!padlist_cache)
390 padlist_cache = newHV ();
391
392Coro::State
393_newprocess(args)
394 SV * args
395 PROTOTYPE: $ 3860 PROTOTYPE: $
3861 ALIAS:
3862 is_ready = CF_READY
3863 is_running = CF_RUNNING
3864 is_new = CF_NEW
3865 is_destroyed = CF_ZOMBIE
3866 is_zombie = CF_ZOMBIE
3867 is_suspended = CF_SUSPENDED
3868 CODE:
3869 RETVAL = boolSV (coro->flags & ix);
3870 OUTPUT:
3871 RETVAL
3872
3873void
3874throw (SV *self, SV *exception = &PL_sv_undef)
3875 PROTOTYPE: $;$
396 CODE: 3876 CODE:
397 Coro__State coro; 3877{
3878 struct coro *coro = SvSTATE (self);
3879 struct coro *current = SvSTATE_current;
3880 SV **exceptionp = coro == current ? &CORO_THROW : &coro->except;
3881 SvREFCNT_dec (*exceptionp);
3882 SvGETMAGIC (exception);
3883 *exceptionp = SvOK (exception) ? newSVsv (exception) : 0;
398 3884
399 if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV) 3885 api_ready (aTHX_ self);
400 croak ("Coro::State::newprocess expects an arrayref"); 3886}
3887
3888void
3889api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
3890 PROTOTYPE: $;$
3891 C_ARGS: aTHX_ coro, flags
3892
3893SV *
3894has_cctx (Coro::State coro)
3895 PROTOTYPE: $
3896 CODE:
3897 /* maybe manage the running flag differently */
3898 RETVAL = boolSV (!!coro->cctx || (coro->flags & CF_RUNNING));
3899 OUTPUT:
3900 RETVAL
3901
3902int
3903is_traced (Coro::State coro)
3904 PROTOTYPE: $
3905 CODE:
3906 RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
3907 OUTPUT:
3908 RETVAL
3909
3910UV
3911rss (Coro::State coro)
3912 PROTOTYPE: $
3913 ALIAS:
3914 usecount = 1
3915 CODE:
3916 switch (ix)
3917 {
3918 case 0: RETVAL = coro_rss (aTHX_ coro); break;
3919 case 1: RETVAL = coro->usecount; break;
401 3920 }
402 New (0, coro, 1, struct coro); 3921 OUTPUT:
403
404 coro->mainstack = 0; /* actual work is done inside transfer */
405 coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406
407 RETVAL = coro; 3922 RETVAL
3923
3924void
3925force_cctx ()
3926 PROTOTYPE:
3927 CODE:
3928 cctx_current->idle_sp = 0;
3929
3930void
3931swap_defsv (Coro::State self)
3932 PROTOTYPE: $
3933 ALIAS:
3934 swap_defav = 1
3935 CODE:
3936 if (!self->slot)
3937 croak ("cannot swap state with coroutine that has no saved state,");
3938 else
3939 {
3940 SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
3941 SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
3942
3943 SV *tmp = *src; *src = *dst; *dst = tmp;
3944 }
3945
3946void
3947cancel (Coro::State self)
3948 CODE:
3949 coro_state_destroy (aTHX_ self);
3950
3951SV *
3952enable_times (int enabled = enable_times)
3953 CODE:
3954{
3955 RETVAL = boolSV (enable_times);
3956
3957 if (enabled != enable_times)
3958 {
3959 enable_times = enabled;
3960
3961 coro_times_update ();
3962 (enabled ? coro_times_sub : coro_times_add)(SvSTATE (coro_current));
3963 }
3964}
408 OUTPUT: 3965 OUTPUT:
409 RETVAL 3966 RETVAL
410 3967
411void 3968void
412transfer(prev,next) 3969times (Coro::State self)
413 Coro::State_or_hashref prev 3970 PPCODE:
414 Coro::State_or_hashref next 3971{
415 CODE: 3972 struct coro *current = SvSTATE (coro_current);
416 3973
417 if (prev != next) 3974 if (ecb_expect_false (current == self))
418 { 3975 {
419 PUTBACK; 3976 coro_times_update ();
420 SAVE (aTHX_ prev); 3977 coro_times_add (SvSTATE (coro_current));
421
422 /* 3978 }
423 * this could be done in newprocess which would lead to 3979
424 * extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN) 3980 EXTEND (SP, 2);
425 * code here, but lazy allocation of stacks has also 3981 PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));
426 * some virtues and the overhead of the if() is nil. 3982 PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));
3983
3984 if (ecb_expect_false (current == self))
3985 coro_times_sub (SvSTATE (coro_current));
3986}
3987
3988void
3989swap_sv (Coro::State coro, SV *sva, SV *svb)
3990 CODE:
3991{
3992 struct coro *current = SvSTATE_current;
3993 AV *swap_sv;
3994 int i;
3995
3996 sva = SvRV (sva);
3997 svb = SvRV (svb);
3998
3999 if (current == coro)
4000 SWAP_SVS_LEAVE (current);
4001
4002 if (!coro->swap_sv)
4003 coro->swap_sv = newAV ();
4004
4005 swap_sv = coro->swap_sv;
4006
4007 for (i = AvFILLp (swap_sv) - 1; i >= 0; i -= 2)
427 */ 4008 {
428 if (next->mainstack) 4009 SV *a = AvARRAY (swap_sv)[i ];
4010 SV *b = AvARRAY (swap_sv)[i + 1];
4011
4012 if (a == sva && b == svb)
429 { 4013 {
430 LOAD (aTHX_ next); 4014 SvREFCNT_dec_NN (a);
431 next->mainstack = 0; /* unnecessary but much cleaner */ 4015 SvREFCNT_dec_NN (b);
432 SPAGAIN;
433 }
434 else
435 {
436 /*
437 * emulate part of the perl startup here.
438 */
439 UNOP myop;
440 4016
441 init_stacks (); /* from perl.c */ 4017 for (; i <= AvFILLp (swap_sv) - 2; i++)
442 PL_op = (OP *)&myop; 4018 AvARRAY (swap_sv)[i] = AvARRAY (swap_sv)[i + 2];
443 /*PL_curcop = 0;*/
444 GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445 4019
446 SPAGAIN; 4020 AvFILLp (swap_sv) -= 2;
447 Zero(&myop, 1, UNOP);
448 myop.op_next = Nullop;
449 myop.op_flags = OPf_WANT_VOID;
450 4021
451 PUSHMARK(SP); 4022 goto removed;
452 XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453 PUTBACK;
454 /*
455 * the next line is slightly wrong, as PL_op->op_next
456 * is actually being executed so we skip the first op.
457 * that doesn't matter, though, since it is only
458 * pp_nextstate and we never return...
459 */
460 PL_op = Perl_pp_entersub(aTHX);
461 SPAGAIN;
462
463 ENTER;
464 } 4023 }
465 } 4024 }
466 4025
4026 av_push (swap_sv, SvREFCNT_inc_NN (sva));
4027 av_push (swap_sv, SvREFCNT_inc_NN (svb));
4028
4029 removed:
4030
4031 if (current == coro)
4032 SWAP_SVS_ENTER (current);
4033}
4034
4035
4036MODULE = Coro::State PACKAGE = Coro
4037
4038BOOT:
4039{
4040 if (SVt_LAST > 32)
4041 croak ("Coro internal error: SVt_LAST > 32, swap_sv might need adjustment");
4042
4043 sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
4044 sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
4045 cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);
4046 coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);
4047 av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
4048 av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);
4049 sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);
4050 sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);
4051
4052 sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
4053 sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);
4054 cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);
4055 CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */
4056
4057 coro_stash = gv_stashpv ("Coro", TRUE);
4058
4059 newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));
4060 newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));
4061 newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
4062 newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (CORO_PRIO_LOW));
4063 newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (CORO_PRIO_IDLE));
4064 newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (CORO_PRIO_MIN));
4065
4066 {
4067 SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
4068
4069 coroapi.schedule = api_schedule;
4070 coroapi.schedule_to = api_schedule_to;
4071 coroapi.cede = api_cede;
4072 coroapi.cede_notself = api_cede_notself;
4073 coroapi.ready = api_ready;
4074 coroapi.is_ready = api_is_ready;
4075 coroapi.nready = coro_nready;
4076 coroapi.current = coro_current;
4077
4078 coroapi.enterleave_hook = api_enterleave_hook;
4079 coroapi.enterleave_unhook = api_enterleave_unhook;
4080 coroapi.enterleave_scope_hook = api_enterleave_scope_hook;
4081
4082 /*GCoroAPI = &coroapi;*/
4083 sv_setiv (sv, PTR2IV (&coroapi));
4084 SvREADONLY_on (sv);
4085 }
4086}
4087
4088SV *
4089async (...)
4090 PROTOTYPE: &@
4091 CODE:
4092 RETVAL = coro_new (aTHX_ coro_stash, &ST (0), items, 1);
4093 api_ready (aTHX_ RETVAL);
4094 OUTPUT:
4095 RETVAL
4096
467void 4097void
468DESTROY(coro) 4098_destroy (Coro::State coro)
469 Coro::State coro 4099 CODE:
4100 /* used by the manager thread */
4101 coro_state_destroy (aTHX_ coro);
4102
4103void
4104on_destroy (Coro::State coro, SV *cb)
4105 CODE:
4106 coro_push_on_destroy (aTHX_ coro, newSVsv (cb));
4107
4108void
4109join (...)
4110 CODE:
4111 CORO_EXECUTE_SLF_XS (slf_init_join);
4112
4113void
4114terminate (...)
4115 CODE:
4116 CORO_EXECUTE_SLF_XS (slf_init_terminate);
4117
4118void
4119cancel (...)
4120 CODE:
4121 CORO_EXECUTE_SLF_XS (slf_init_cancel);
4122
4123int
4124safe_cancel (Coro::State self, ...)
4125 C_ARGS: aTHX_ self, &ST (1), items - 1
4126
4127void
4128schedule (...)
4129 CODE:
4130 CORO_EXECUTE_SLF_XS (slf_init_schedule);
4131
4132void
4133schedule_to (...)
4134 CODE:
4135 CORO_EXECUTE_SLF_XS (slf_init_schedule_to);
4136
4137void
4138cede_to (...)
4139 CODE:
4140 CORO_EXECUTE_SLF_XS (slf_init_cede_to);
4141
4142void
4143cede (...)
4144 CODE:
4145 CORO_EXECUTE_SLF_XS (slf_init_cede);
4146
4147void
4148cede_notself (...)
4149 CODE:
4150 CORO_EXECUTE_SLF_XS (slf_init_cede_notself);
4151
4152void
4153_set_current (SV *current)
4154 PROTOTYPE: $
4155 CODE:
4156 SvREFCNT_dec_NN (SvRV (coro_current));
4157 SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
4158
4159void
4160_set_readyhook (SV *hook)
4161 PROTOTYPE: $
470 CODE: 4162 CODE:
471 4163 SvREFCNT_dec (coro_readyhook);
472 if (coro->mainstack) 4164 SvGETMAGIC (hook);
4165 if (SvOK (hook))
4166 {
4167 coro_readyhook = newSVsv (hook);
4168 CORO_READYHOOK = invoke_sv_ready_hook_helper;
4169 }
4170 else
473 { 4171 {
474 struct coro temp; 4172 coro_readyhook = 0;
4173 CORO_READYHOOK = 0;
4174 }
475 4175
4176int
4177prio (Coro::State coro, int newprio = 0)
4178 PROTOTYPE: $;$
4179 ALIAS:
4180 nice = 1
4181 CODE:
4182{
4183 RETVAL = coro->prio;
4184
4185 if (items > 1)
4186 {
4187 if (ix)
4188 newprio = coro->prio - newprio;
4189
4190 if (newprio < CORO_PRIO_MIN) newprio = CORO_PRIO_MIN;
4191 if (newprio > CORO_PRIO_MAX) newprio = CORO_PRIO_MAX;
4192
4193 coro->prio = newprio;
4194 }
4195}
4196 OUTPUT:
4197 RETVAL
4198
4199SV *
4200ready (SV *self)
4201 PROTOTYPE: $
4202 CODE:
4203 RETVAL = boolSV (api_ready (aTHX_ self));
4204 OUTPUT:
4205 RETVAL
4206
4207int
4208nready (...)
4209 PROTOTYPE:
4210 CODE:
4211 RETVAL = coro_nready;
4212 OUTPUT:
4213 RETVAL
4214
4215void
4216suspend (Coro::State self)
4217 PROTOTYPE: $
4218 CODE:
4219 self->flags |= CF_SUSPENDED;
4220
4221void
4222resume (Coro::State self)
4223 PROTOTYPE: $
4224 CODE:
4225 self->flags &= ~CF_SUSPENDED;
4226
4227void
4228_pool_handler (...)
4229 CODE:
4230 CORO_EXECUTE_SLF_XS (slf_init_pool_handler);
4231
4232void
4233async_pool (SV *cv, ...)
4234 PROTOTYPE: &@
4235 PPCODE:
4236{
4237 HV *hv = (HV *)av_pop (av_async_pool);
4238 AV *av = newAV ();
4239 SV *cb = ST (0);
4240 int i;
4241
4242 av_extend (av, items - 2);
4243 for (i = 1; i < items; ++i)
4244 av_push (av, SvREFCNT_inc_NN (ST (i)));
4245
4246 if ((SV *)hv == &PL_sv_undef)
4247 {
4248 SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1);
4249 hv = (HV *)SvREFCNT_inc_NN (SvRV (sv));
4250 SvREFCNT_dec_NN (sv);
4251 }
4252
4253 {
4254 struct coro *coro = SvSTATE_hv (hv);
4255
4256 assert (!coro->invoke_cb);
4257 assert (!coro->invoke_av);
4258 coro->invoke_cb = SvREFCNT_inc (cb);
4259 coro->invoke_av = av;
4260 }
4261
4262 api_ready (aTHX_ (SV *)hv);
4263
4264 if (GIMME_V != G_VOID)
4265 XPUSHs (sv_2mortal (newRV_noinc ((SV *)hv)));
4266 else
4267 SvREFCNT_dec_NN (hv);
4268}
4269
4270SV *
4271rouse_cb ()
4272 PROTOTYPE:
4273 CODE:
4274 RETVAL = coro_new_rouse_cb (aTHX);
4275 OUTPUT:
4276 RETVAL
4277
4278void
4279rouse_wait (...)
4280 PROTOTYPE: ;$
4281 PPCODE:
4282 CORO_EXECUTE_SLF_XS (slf_init_rouse_wait);
4283
4284void
4285on_enter (SV *block)
4286 ALIAS:
4287 on_leave = 1
4288 PROTOTYPE: &
4289 CODE:
4290{
4291 struct coro *coro = SvSTATE_current;
4292 AV **avp = ix ? &coro->on_leave : &coro->on_enter;
4293
4294 block = s_get_cv_croak (block);
4295
4296 if (!*avp)
4297 *avp = newAV ();
4298
4299 av_push (*avp, SvREFCNT_inc (block));
4300
4301 if (!ix)
4302 on_enterleave_call (aTHX_ block);
4303
4304 LEAVE; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */
4305 SAVEDESTRUCTOR_X (ix ? coro_pop_on_leave : coro_pop_on_enter, (void *)coro);
4306 ENTER; /* pp_entersub unfortunately forces an ENTER/LEAVE around XS calls */
4307}
4308
4309
4310MODULE = Coro::State PACKAGE = PerlIO::cede
4311
4312BOOT:
4313 PerlIO_define_layer (aTHX_ &PerlIO_cede);
4314
4315
4316MODULE = Coro::State PACKAGE = Coro::Semaphore
4317
4318SV *
4319new (SV *klass, SV *count = 0)
4320 CODE:
4321{
4322 int semcnt = 1;
4323
4324 if (count)
4325 {
4326 SvGETMAGIC (count);
4327
4328 if (SvOK (count))
4329 semcnt = SvIV (count);
4330 }
4331
4332 RETVAL = sv_bless (
4333 coro_waitarray_new (aTHX_ semcnt),
4334 GvSTASH (CvGV (cv))
4335 );
4336}
4337 OUTPUT:
4338 RETVAL
4339
4340# helper for Coro::Channel and others
4341SV *
4342_alloc (int count)
4343 CODE:
4344 RETVAL = coro_waitarray_new (aTHX_ count);
4345 OUTPUT:
4346 RETVAL
4347
4348SV *
4349count (SV *self)
4350 CODE:
4351 RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]);
4352 OUTPUT:
4353 RETVAL
4354
4355void
4356up (SV *self)
4357 CODE:
4358 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), 1);
4359
4360void
4361adjust (SV *self, int adjust)
4362 CODE:
4363 coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), adjust);
4364
4365void
4366down (...)
4367 CODE:
4368 CORO_EXECUTE_SLF_XS (slf_init_semaphore_down);
4369
4370void
4371wait (...)
4372 CODE:
4373 CORO_EXECUTE_SLF_XS (slf_init_semaphore_wait);
4374
4375void
4376try (SV *self)
4377 PPCODE:
4378{
4379 AV *av = (AV *)SvRV (self);
4380 SV *count_sv = AvARRAY (av)[0];
4381 IV count = SvIVX (count_sv);
4382
4383 if (count > 0)
4384 {
4385 --count;
4386 SvIVX (count_sv) = count;
4387 XSRETURN_YES;
4388 }
4389 else
4390 XSRETURN_NO;
4391}
4392
4393void
4394waiters (SV *self)
4395 PPCODE:
4396{
4397 AV *av = (AV *)SvRV (self);
4398 int wcount = AvFILLp (av) + 1 - 1;
4399
4400 if (GIMME_V == G_SCALAR)
4401 XPUSHs (sv_2mortal (newSViv (wcount)));
4402 else
4403 {
4404 int i;
4405 EXTEND (SP, wcount);
4406 for (i = 1; i <= wcount; ++i)
4407 PUSHs (sv_2mortal (newRV_inc (AvARRAY (av)[i])));
4408 }
4409}
4410
4411MODULE = Coro::State PACKAGE = Coro::SemaphoreSet
4412
4413void
4414_may_delete (SV *sem, int count, unsigned int extra_refs)
4415 PPCODE:
4416{
4417 AV *av = (AV *)SvRV (sem);
4418
4419 if (SvREFCNT ((SV *)av) == 1 + extra_refs
4420 && AvFILLp (av) == 0 /* no waiters, just count */
4421 && SvIV (AvARRAY (av)[0]) == count)
4422 XSRETURN_YES;
4423
4424 XSRETURN_NO;
4425}
4426
4427MODULE = Coro::State PACKAGE = Coro::Signal
4428
4429SV *
4430new (SV *klass)
4431 CODE:
4432 RETVAL = sv_bless (
4433 coro_waitarray_new (aTHX_ 0),
4434 GvSTASH (CvGV (cv))
4435 );
4436 OUTPUT:
4437 RETVAL
4438
4439void
4440wait (...)
4441 CODE:
4442 CORO_EXECUTE_SLF_XS (slf_init_signal_wait);
4443
4444void
4445broadcast (SV *self)
4446 CODE:
4447{
4448 AV *av = (AV *)SvRV (self);
4449 coro_signal_wake (aTHX_ av, AvFILLp (av));
4450}
4451
4452void
4453send (SV *self)
4454 CODE:
4455{
4456 AV *av = (AV *)SvRV (self);
4457
4458 if (AvFILLp (av))
4459 coro_signal_wake (aTHX_ av, 1);
4460 else
4461 SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
4462}
4463
4464IV
4465awaited (SV *self)
4466 CODE:
4467 RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
4468 OUTPUT:
4469 RETVAL
4470
4471
4472MODULE = Coro::State PACKAGE = Coro::AnyEvent
4473
4474BOOT:
4475 sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
4476
4477void
4478_schedule (...)
4479 CODE:
4480{
4481 static int incede;
4482
4483 api_cede_notself (aTHX);
4484
4485 ++incede;
4486 while (coro_nready >= incede && api_cede (aTHX))
4487 ;
4488
4489 sv_setsv (sv_activity, &PL_sv_undef);
4490 if (coro_nready >= incede)
4491 {
4492 PUSHMARK (SP);
476 PUTBACK; 4493 PUTBACK;
477 SAVE(aTHX_ (&temp)); 4494 call_pv ("Coro::AnyEvent::_activity", G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
478 LOAD(aTHX_ coro);
479
480 destroy_stacks ();
481 SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483 LOAD((&temp));
484 SPAGAIN;
485 } 4495 }
486 4496
487 SvREFCNT_dec (coro->args); 4497 --incede;
488 Safefree (coro); 4498}
489 4499
490 4500
4501MODULE = Coro::State PACKAGE = Coro::AIO
4502
4503void
4504_register (char *target, char *proto, SV *req)
4505 CODE:
4506{
4507 SV *req_cv = s_get_cv_croak (req);
4508 /* newXSproto doesn't return the CV on 5.8 */
4509 CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);
4510 sv_setpv ((SV *)slf_cv, proto);
4511 sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);
4512}
4513
4514MODULE = Coro::State PACKAGE = Coro::Select
4515
4516void
4517patch_pp_sselect ()
4518 CODE:
4519 if (!coro_old_pp_sselect)
4520 {
4521 coro_select_select = (SV *)get_cv ("Coro::Select::select", 0);
4522 coro_old_pp_sselect = PL_ppaddr [OP_SSELECT];
4523 PL_ppaddr [OP_SSELECT] = coro_pp_sselect;
4524 }
4525
4526void
4527unpatch_pp_sselect ()
4528 CODE:
4529 if (coro_old_pp_sselect)
4530 {
4531 PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
4532 coro_old_pp_sselect = 0;
4533 }
4534
4535MODULE = Coro::State PACKAGE = Coro::Util
4536
4537void
4538_exit (int code)
4539 CODE:
4540 _exit (code);
4541
4542NV
4543time ()
4544 CODE:
4545 RETVAL = nvtime (aTHX);
4546 OUTPUT:
4547 RETVAL
4548
4549NV
4550gettimeofday ()
4551 PPCODE:
4552{
4553 UV tv [2];
4554 u2time (aTHX_ tv);
4555 EXTEND (SP, 2);
4556 PUSHs (sv_2mortal (newSVuv (tv [0])));
4557 PUSHs (sv_2mortal (newSVuv (tv [1])));
4558}
4559

Diff Legend

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