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

Diff Legend

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