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

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

Diff Legend

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