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

Diff Legend

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