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

Diff Legend

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