ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.349 by root, Wed Jun 10 00:47:24 2009 UTC vs.
Revision 1.438 by root, Mon Nov 18 10:27:53 2013 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
1	#include "libcoro/coro.c"	6	#include "libcoro/coro.c"
2		7
3	#define PERL_NO_GET_CONTEXT	8	#define PERL_NO_GET_CONTEXT
4	#define PERL_EXT	9	#define PERL_EXT
5		10
6	#include "EXTERN.h"	11	#include "EXTERN.h"
7	#include "perl.h"	12	#include "perl.h"
8	#include "XSUB.h"	13	#include "XSUB.h"
9	#include "perliol.h"	14	#include "perliol.h"
10		15
11	#include "patchlevel.h"	16	#include "schmorp.h"
12		17
		18	#define ECB_NO_THREADS 1
		19	#include "ecb.h"
		20
		21	#include <stddef.h>
13	#include <stdio.h>	22	#include <stdio.h>
14	#include <errno.h>	23	#include <errno.h>
15	#include <assert.h>	24	#include <assert.h>
16		25
17	#ifdef WIN32	26	#ifndef SVs_PADSTALE
		27	# define SVs_PADSTALE 0
		28	#endif
		29
		30	#ifdef PadARRAY
		31	# define NEWPADAPI 1
		32	# define newPADLIST(var) (Newz (0, var, 1, PADLIST), Newx (PadlistARRAY (var), 2, PAD *))
		33	#else
		34	typedef AV PADNAMELIST;
		35	# if !PERL_VERSION_ATLEAST(5,8,0)
		36	typedef AV PADLIST;
		37	typedef AV PAD;
		38	# endif
		39	# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
		40	# define PadlistMAX(pl) AvFILLp (pl)
		41	# define PadlistNAMES(pl) (*PadlistARRAY (pl))
		42	# define PadARRAY AvARRAY
		43	# define PadMAX AvFILLp
		44	# define newPADLIST(var) ((var) = newAV (), av_extend (var, 1))
		45	#endif
		46
		47	/* 5.19.something has replaced SVt_BIND by SVt_INVLIST */
		48	/* we just alias it to SVt_IV, as that is sufficient for swap_sv for now */
		49	#if PERL_VERSION_ATLEAST(5,19,0)
		50	# define SVt_BIND SVt_IV
		51	#endif
		52
		53	#if defined(_WIN32)
		54	# undef HAS_GETTIMEOFDAY
18	# undef setjmp	55	# undef setjmp
19	# undef longjmp	56	# undef longjmp
20	# undef _exit	57	# undef _exit
21	# define setjmp _setjmp /* deep magic */	58	# define setjmp _setjmp /* deep magic */
22	#else	59	#else
23	# include <inttypes.h> /* most portable stdint.h */	60	# include <inttypes.h> /* most portable stdint.h */
24	#endif	61	#endif
25		62
26	#ifdef HAVE_MMAP
27	# include <unistd.h>
28	# include <sys/mman.h>
29	# ifndef MAP_ANONYMOUS
30	# ifdef MAP_ANON
31	# define MAP_ANONYMOUS MAP_ANON
32	# else
33	# undef HAVE_MMAP
34	# endif
35	# endif
36	# include <limits.h>
37	# ifndef PAGESIZE
38	# define PAGESIZE pagesize
39	# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
40	static long pagesize;
41	# else
42	# define BOOT_PAGESIZE (void)0
43	# endif
44	#else
45	# define PAGESIZE 0
46	# define BOOT_PAGESIZE (void)0
47	#endif
48
49	#if CORO_USE_VALGRIND
50	# include <valgrind/valgrind.h>
51	#endif
52
53	/* the maximum number of idle cctx that will be pooled */	63	/* the maximum number of idle cctx that will be pooled */
54	static int cctx_max_idle = 4;	64	static int cctx_max_idle = 4;
55		65
56	#define PERL_VERSION_ATLEAST(a,b,c) \	66	#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)
57	(PERL_REVISION > (a) \	67	# define HAS_SCOPESTACK_NAME 1
58	|| (PERL_REVISION == (a) \
59	&& (PERL_VERSION > (b) \
60	|| (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))
61
62	#if !PERL_VERSION_ATLEAST (5,6,0)
63	# ifndef PL_ppaddr
64	# define PL_ppaddr ppaddr
65	# endif
66	# ifndef call_sv
67	# define call_sv perl_call_sv
68	# endif
69	# ifndef get_sv
70	# define get_sv perl_get_sv
71	# endif
72	# ifndef get_cv
73	# define get_cv perl_get_cv
74	# endif
75	# ifndef IS_PADGV
76	# define IS_PADGV(v) 0
77	# endif
78	# ifndef IS_PADCONST
79	# define IS_PADCONST(v) 0
80	# endif
81	#endif
82
83	/* 5.11 */
84	#ifndef CxHASARGS
85	# define CxHASARGS(cx) (cx)->blk_sub.hasargs
86	#endif
87
88	/* 5.10.0 */
89	#ifndef SvREFCNT_inc_NN
90	# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
91	#endif
92
93	/* 5.8.8 */
94	#ifndef GV_NOTQUAL
95	# define GV_NOTQUAL 0
96	#endif
97	#ifndef newSV
98	# define newSV(l) NEWSV(0,l)
99	#endif
100	#ifndef CvISXSUB_on
101	# define CvISXSUB_on(cv) (void)cv
102	#endif
103	#ifndef CvISXSUB
104	# define CvISXSUB(cv) (CvXSUB (cv) ? TRUE : FALSE)
105	#endif
106	#ifndef Newx
107	# define Newx(ptr,nitems,type) New (0,ptr,nitems,type)
108	#endif
109
110	/* 5.8.7 */
111	#ifndef SvRV_set
112	# define SvRV_set(s,v) SvRV(s) = (v)
113	#endif
114
115	#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
116	# undef CORO_STACKGUARD
117	#endif
118
119	#ifndef CORO_STACKGUARD
120	# define CORO_STACKGUARD 0
121	#endif	68	#endif
122		69
123	/* prefer perl internal functions over our own? */	70	/* prefer perl internal functions over our own? */
124	#ifndef CORO_PREFER_PERL_FUNCTIONS	71	#ifndef CORO_PREFER_PERL_FUNCTIONS
125	# define CORO_PREFER_PERL_FUNCTIONS 0	72	# define CORO_PREFER_PERL_FUNCTIONS 0
…		…
135	# define STACKLEVEL ((void *)&stacklevel)	82	# define STACKLEVEL ((void *)&stacklevel)
136	#endif	83	#endif
137		84
138	#define IN_DESTRUCT PL_dirty	85	#define IN_DESTRUCT PL_dirty
139		86
140	#if __GNUC__ >= 3
141	# define attribute(x) __attribute__(x)
142	# define expect(expr,value) __builtin_expect ((expr),(value))
143	# define INLINE static inline
144	#else
145	# define attribute(x)
146	# define expect(expr,value) (expr)
147	# define INLINE static
148	#endif
149
150	#define expect_false(expr) expect ((expr) != 0, 0)
151	#define expect_true(expr) expect ((expr) != 0, 1)
152
153	#define NOINLINE attribute ((noinline))
154
155	#include "CoroAPI.h"	87	#include "CoroAPI.h"
156	#define GCoroAPI (&coroapi) /* very sneaky */	88	#define GCoroAPI (&coroapi) /* very sneaky */
157		89
158	#ifdef USE_ITHREADS	90	#ifdef USE_ITHREADS
159	# if CORO_PTHREAD	91	# if CORO_PTHREAD
160	static void *coro_thx;	92	static void *coro_thx;
161	# endif	93	# endif
162	#endif	94	#endif
163		95
		96	#ifdef __linux
		97	# include <time.h> /* for timespec */
		98	# include <syscall.h> /* for SYS_* */
		99	# ifdef SYS_clock_gettime
		100	# define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts))
		101	# define CORO_CLOCK_MONOTONIC 1
		102	# define CORO_CLOCK_THREAD_CPUTIME_ID 3
		103	# endif
		104	#endif
		105
164	static double (*nvtime)(); /* so why doesn't it take void? */	106	static double (*nvtime)(); /* so why doesn't it take void? */
		107	static void (*u2time)(pTHX_ UV ret[2]);
165		108
166	/* we hijack an hopefully unused CV flag for our purposes */	109	/* we hijack an hopefully unused CV flag for our purposes */
167	#define CVf_SLF 0x4000	110	#define CVf_SLF 0x4000
168	static OP *pp_slf (pTHX);	111	static OP *pp_slf (pTHX);
		112	static void slf_destroy (pTHX_ struct coro *coro);
169		113
170	static U32 cctx_gen;	114	static U32 cctx_gen;
171	static size_t cctx_stacksize = CORO_STACKSIZE;	115	static size_t cctx_stacksize = CORO_STACKSIZE;
172	static struct CoroAPI coroapi;	116	static struct CoroAPI coroapi;
173	static AV *main_mainstack; /* used to differentiate between $main and others */	117	static AV *main_mainstack; /* used to differentiate between $main and others */
…		…
190	static SV *sv_pool_size;	134	static SV *sv_pool_size;
191	static SV *sv_async_pool_idle; /* description string */	135	static SV *sv_async_pool_idle; /* description string */
192	static AV *av_async_pool; /* idle pool */	136	static AV *av_async_pool; /* idle pool */
193	static SV *sv_Coro; /* class string */	137	static SV *sv_Coro; /* class string */
194	static CV *cv_pool_handler;	138	static CV *cv_pool_handler;
195	static CV *cv_coro_state_new;
196		139
197	/* Coro::AnyEvent */	140	/* Coro::AnyEvent */
198	static SV *sv_activity;	141	static SV *sv_activity;
199		142
		143	/* enable processtime/realtime profiling */
		144	static char enable_times;
		145	typedef U32 coro_ts[2];
		146	static coro_ts time_real, time_cpu;
		147	static char times_valid;
		148
200	static struct coro_cctx *cctx_first;	149	static struct coro_cctx *cctx_first;
201	static int cctx_count, cctx_idle;	150	static int cctx_count, cctx_idle;
202		151
203	enum {	152	enum
		153	{
204	CC_MAPPED = 0x01,	154	CC_MAPPED = 0x01,
205	CC_NOREUSE = 0x02, /* throw this away after tracing */	155	CC_NOREUSE = 0x02, /* throw this away after tracing */
206	CC_TRACE = 0x04,	156	CC_TRACE = 0x04,
207	CC_TRACE_SUB = 0x08, /* trace sub calls */	157	CC_TRACE_SUB = 0x08, /* trace sub calls */
208	CC_TRACE_LINE = 0x10, /* trace each statement */	158	CC_TRACE_LINE = 0x10, /* trace each statement */
…		…
213	typedef struct coro_cctx	163	typedef struct coro_cctx
214	{	164	{
215	struct coro_cctx *next;	165	struct coro_cctx *next;
216		166
217	/* the stack */	167	/* the stack */
218	void *sptr;	168	struct coro_stack stack;
219	size_t ssize;
220		169
221	/* cpu state */	170	/* cpu state */
222	void *idle_sp; /* sp of top-level transfer/schedule/cede call */	171	void *idle_sp; /* sp of top-level transfer/schedule/cede call */
		172	#ifndef NDEBUG
223	JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */	173	JMPENV *idle_te; /* same as idle_sp, but for top_env */
		174	#endif
224	JMPENV *top_env;	175	JMPENV *top_env;
225	coro_context cctx;	176	coro_context cctx;
226		177
227	U32 gen;	178	U32 gen;
228	#if CORO_USE_VALGRIND	179	#if CORO_USE_VALGRIND
229	int valgrind_id;	180	int valgrind_id;
230	#endif	181	#endif
231	unsigned char flags;	182	unsigned char flags;
232	} coro_cctx;	183	} coro_cctx;
233		184
234	coro_cctx *cctx_current; /* the currently running cctx */	185	static coro_cctx *cctx_current; /* the currently running cctx */
235		186
236	/*****************************************************************************/	187	/*****************************************************************************/
237		188
		189	static MGVTBL coro_state_vtbl;
		190
238	enum {	191	enum
		192	{
239	CF_RUNNING = 0x0001, /* coroutine is running */	193	CF_RUNNING = 0x0001, /* coroutine is running */
240	CF_READY = 0x0002, /* coroutine is ready */	194	CF_READY = 0x0002, /* coroutine is ready */
241	CF_NEW = 0x0004, /* has never been switched to */	195	CF_NEW = 0x0004, /* has never been switched to */
242	CF_DESTROYED = 0x0008, /* coroutine data has been freed */	196	CF_ZOMBIE = 0x0008, /* coroutine data has been freed */
243	CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */	197	CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */
		198	CF_NOCANCEL = 0x0020, /* cannot cancel, set slf_frame.data to 1 (hackish) */
244	};	199	};
245		200
246	/* the structure where most of the perl state is stored, overlaid on the cxstack */	201	/* the structure where most of the perl state is stored, overlaid on the cxstack */
247	typedef struct	202	typedef struct
248	{	203	{
249	SV *defsv;
250	AV *defav;
251	SV *errsv;
252	SV *irsgv;
253	HV *hinthv;
254	#define VAR(name,type) type name;	204	#define VARx(name,expr,type) type name;
255	# include "state.h"	205	#include "state.h"
256	#undef VAR
257	} perl_slots;	206	} perl_slots;
258		207
		208	/* how many context stack entries do we need for perl_slots */
259	#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))	209	#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
260		210
261	/* this is a structure representing a perl-level coroutine */	211	/* this is a structure representing a perl-level coroutine */
262	struct coro {	212	struct coro
		213	{
263	/* the C coroutine allocated to this perl coroutine, if any */	214	/* the C coroutine allocated to this perl coroutine, if any */
264	coro_cctx *cctx;	215	coro_cctx *cctx;
265		216
266	/* ready queue */	217	/* ready queue */
267	struct coro *next_ready;	218	struct coro *next_ready;
…		…
269	/* state data */	220	/* state data */
270	struct CoroSLF slf_frame; /* saved slf frame */	221	struct CoroSLF slf_frame; /* saved slf frame */
271	AV *mainstack;	222	AV *mainstack;
272	perl_slots *slot; /* basically the saved sp */	223	perl_slots *slot; /* basically the saved sp */
273		224
274	CV *startcv; /* the CV to execute */	225	CV *startcv; /* the CV to execute */
275	AV *args; /* data associated with this coroutine (initial args) */	226	AV *args; /* data associated with this coroutine (initial args) */
276	int refcnt; /* coroutines are refcounted, yes */
277	int flags; /* CF_ flags */	227	int flags; /* CF_ flags */
278	HV *hv; /* the perl hash associated with this coro, if any */	228	HV *hv; /* the perl hash associated with this coro, if any */
279	void (*on_destroy)(pTHX_ struct coro *coro);
280		229
281	/* statistics */	230	/* statistics */
282	int usecount; /* number of transfers to this coro */	231	int usecount; /* number of transfers to this coro */
283		232
284	/* coro process data */	233	/* coro process data */
285	int prio;	234	int prio;
286	SV *except; /* exception to be thrown */	235	SV *except; /* exception to be thrown */
287	SV *rouse_cb;	236	SV *rouse_cb; /* last rouse callback */
		237	AV *on_destroy; /* callbacks or coros to notify on destroy */
		238	AV *status; /* the exit status list */
288		239
289	/* async_pool */	240	/* async_pool */
290	SV *saved_deffh;	241	SV *saved_deffh;
291	SV *invoke_cb;	242	SV *invoke_cb;
292	AV *invoke_av;	243	AV *invoke_av;
293		244
294	/* on_enter/on_leave */	245	/* on_enter/on_leave */
295	AV *on_enter;	246	AV *on_enter;
296	AV *on_leave;	247	AV *on_leave;
297		248
		249	/* swap_sv */
		250	AV *swap_sv;
		251
		252	/* times */
		253	coro_ts t_cpu, t_real;
		254
298	/* linked list */	255	/* linked list */
299	struct coro *next, *prev;	256	struct coro *next, *prev;
300	};	257	};
301		258
302	typedef struct coro *Coro__State;	259	typedef struct coro *Coro__State;
303	typedef struct coro *Coro__State_or_hashref;	260	typedef struct coro *Coro__State_or_hashref;
304		261
305	/* the following variables are effectively part of the perl context */	262	/* the following variables are effectively part of the perl context */
306	/* and get copied between struct coro and these variables */	263	/* and get copied between struct coro and these variables */
307	/* the mainr easonw e don't support windows process emulation */	264	/* the main reason we don't support windows process emulation */
308	static struct CoroSLF slf_frame; /* the current slf frame */	265	static struct CoroSLF slf_frame; /* the current slf frame */
309		266
310	/** Coro ********************************************************************/	267	/** Coro ********************************************************************/
311		268
312	#define PRIO_MAX 3	269	#define CORO_PRIO_MAX 3
313	#define PRIO_HIGH 1	270	#define CORO_PRIO_HIGH 1
314	#define PRIO_NORMAL 0	271	#define CORO_PRIO_NORMAL 0
315	#define PRIO_LOW -1	272	#define CORO_PRIO_LOW -1
316	#define PRIO_IDLE -3	273	#define CORO_PRIO_IDLE -3
317	#define PRIO_MIN -4	274	#define CORO_PRIO_MIN -4
318		275
319	/* for Coro.pm */	276	/* for Coro.pm */
320	static SV *coro_current;	277	static SV *coro_current;
321	static SV *coro_readyhook;	278	static SV *coro_readyhook;
322	static struct coro *coro_ready [PRIO_MAX - PRIO_MIN + 1][2]; /* head|tail */	279	static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */
323	static CV *cv_coro_run, *cv_coro_terminate;	280	static CV *cv_coro_run;
324	static struct coro *coro_first;	281	static struct coro *coro_first;
325	#define coro_nready coroapi.nready	282	#define coro_nready coroapi.nready
326		283
		284	/** JIT *********************************************************************/
		285
		286	#if CORO_JIT
		287	/* APPLE doesn't have mmap though */
		288	#define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__)
		289	#ifndef CORO_JIT_TYPE
		290	#if ECB_AMD64 && CORO_JIT_UNIXY
		291	#define CORO_JIT_TYPE "amd64-unix"
		292	#elif __i386 && CORO_JIT_UNIXY
		293	#define CORO_JIT_TYPE "x86-unix"
		294	#endif
		295	#endif
		296	#endif
		297
		298	#if !defined(CORO_JIT_TYPE) || _POSIX_MEMORY_PROTECTION <= 0
		299	#undef CORO_JIT
		300	#endif
		301
		302	#if CORO_JIT
		303	typedef void (*load_save_perl_slots_type)(perl_slots *);
		304	static load_save_perl_slots_type load_perl_slots, save_perl_slots;
		305	#endif
		306
		307	/** Coro::Select ************************************************************/
		308
		309	static OP *(*coro_old_pp_sselect) (pTHX);
		310	static SV *coro_select_select;
		311
		312	/* horrible hack, but if it works... */
		313	static OP *
		314	coro_pp_sselect (pTHX)
		315	{
		316	dSP;
		317	PUSHMARK (SP - 4); /* fake argument list */
		318	XPUSHs (coro_select_select);
		319	PUTBACK;
		320
		321	/* entersub is an UNOP, select a LISTOP... keep your fingers crossed */
		322	PL_op->op_flags |= OPf_STACKED;
		323	PL_op->op_private = 0;
		324	return PL_ppaddr [OP_ENTERSUB](aTHX);
		325	}
		326
		327	/** time stuff **************************************************************/
		328
		329	#ifdef HAS_GETTIMEOFDAY
		330
		331	ecb_inline void
		332	coro_u2time (pTHX_ UV ret[2])
		333	{
		334	struct timeval tv;
		335	gettimeofday (&tv, 0);
		336
		337	ret [0] = tv.tv_sec;
		338	ret [1] = tv.tv_usec;
		339	}
		340
		341	ecb_inline double
		342	coro_nvtime (void)
		343	{
		344	struct timeval tv;
		345	gettimeofday (&tv, 0);
		346
		347	return tv.tv_sec + tv.tv_usec * 1e-6;
		348	}
		349
		350	ecb_inline void
		351	time_init (pTHX)
		352	{
		353	nvtime = coro_nvtime;
		354	u2time = coro_u2time;
		355	}
		356
		357	#else
		358
		359	ecb_inline void
		360	time_init (pTHX)
		361	{
		362	SV **svp;
		363
		364	require_pv ("Time/HiRes.pm");
		365
		366	svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
		367
		368	if (!svp) croak ("Time::HiRes is required, but missing. Caught");
		369	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught");
		370
		371	nvtime = INT2PTR (double (*)(), SvIV (*svp));
		372
		373	svp = hv_fetch (PL_modglobal, "Time::U2time", 12, 0);
		374	u2time = INT2PTR (void (*)(pTHX_ UV ret[2]), SvIV (*svp));
		375	}
		376
		377	#endif
		378
327	/** lowlevel stuff **********************************************************/	379	/** lowlevel stuff **********************************************************/
328		380
329	static SV *	381	static SV * ecb_noinline
330	coro_get_sv (pTHX_ const char *name, int create)	382	coro_get_sv (pTHX_ const char *name, int create)
331	{	383	{
332	#if PERL_VERSION_ATLEAST (5,10,0)	384	#if PERL_VERSION_ATLEAST (5,10,0)
333	/* silence stupid and wrong 5.10 warning that I am unable to switch off */	385	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
334	get_sv (name, create);	386	get_sv (name, create);
335	#endif	387	#endif
336	return get_sv (name, create);	388	return get_sv (name, create);
337	}	389	}
338		390
339	static AV *	391	static AV * ecb_noinline
340	coro_get_av (pTHX_ const char *name, int create)	392	coro_get_av (pTHX_ const char *name, int create)
341	{	393	{
342	#if PERL_VERSION_ATLEAST (5,10,0)	394	#if PERL_VERSION_ATLEAST (5,10,0)
343	/* silence stupid and wrong 5.10 warning that I am unable to switch off */	395	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
344	get_av (name, create);	396	get_av (name, create);
345	#endif	397	#endif
346	return get_av (name, create);	398	return get_av (name, create);
347	}	399	}
348		400
349	static HV *	401	static HV * ecb_noinline
350	coro_get_hv (pTHX_ const char *name, int create)	402	coro_get_hv (pTHX_ const char *name, int create)
351	{	403	{
352	#if PERL_VERSION_ATLEAST (5,10,0)	404	#if PERL_VERSION_ATLEAST (5,10,0)
353	/* silence stupid and wrong 5.10 warning that I am unable to switch off */	405	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
354	get_hv (name, create);	406	get_hv (name, create);
355	#endif	407	#endif
356	return get_hv (name, create);	408	return get_hv (name, create);
357	}	409	}
358		410
359	/* may croak */	411	ecb_inline void
360	INLINE CV *	412	coro_times_update (void)
361	coro_sv_2cv (pTHX_ SV *sv)
362	{	413	{
363	HV *st;	414	#ifdef coro_clock_gettime
364	GV *gvp;	415	struct timespec ts;
365	CV *cv = sv_2cv (sv, &st, &gvp, 0);
366		416
367	if (!cv)	417	ts.tv_sec = ts.tv_nsec = 0;
368	croak ("code reference expected");	418	coro_clock_gettime (CORO_CLOCK_THREAD_CPUTIME_ID, &ts);
		419	time_cpu [0] = ts.tv_sec; time_cpu [1] = ts.tv_nsec;
369		420
370	return cv;	421	ts.tv_sec = ts.tv_nsec = 0;
		422	coro_clock_gettime (CORO_CLOCK_MONOTONIC, &ts);
		423	time_real [0] = ts.tv_sec; time_real [1] = ts.tv_nsec;
		424	#else
		425	dTHX;
		426	UV tv[2];
		427
		428	u2time (aTHX_ tv);
		429	time_real [0] = tv [0];
		430	time_real [1] = tv [1] * 1000;
		431	#endif
		432	}
		433
		434	ecb_inline void
		435	coro_times_add (struct coro *c)
		436	{
		437	c->t_real [1] += time_real [1];
		438	if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; }
		439	c->t_real [0] += time_real [0];
		440
		441	c->t_cpu [1] += time_cpu [1];
		442	if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; }
		443	c->t_cpu [0] += time_cpu [0];
		444	}
		445
		446	ecb_inline void
		447	coro_times_sub (struct coro *c)
		448	{
		449	if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; }
		450	c->t_real [1] -= time_real [1];
		451	c->t_real [0] -= time_real [0];
		452
		453	if (c->t_cpu [1] < time_cpu [1]) { c->t_cpu [1] += 1000000000; --c->t_cpu [0]; }
		454	c->t_cpu [1] -= time_cpu [1];
		455	c->t_cpu [0] -= time_cpu [0];
371	}	456	}
372		457
373	/*****************************************************************************/	458	/*****************************************************************************/
374	/* magic glue */	459	/* magic glue */
375		460
376	#define CORO_MAGIC_type_cv 26	461	#define CORO_MAGIC_type_cv 26
377	#define CORO_MAGIC_type_state PERL_MAGIC_ext	462	#define CORO_MAGIC_type_state PERL_MAGIC_ext
378		463
379	#define CORO_MAGIC_NN(sv, type) \	464	#define CORO_MAGIC_NN(sv, type) \
380	(expect_true (SvMAGIC (sv)->mg_type == type) \	465	(ecb_expect_true (SvMAGIC (sv)->mg_type == type) \
381	? SvMAGIC (sv) \	466	? SvMAGIC (sv) \
382	: mg_find (sv, type))	467	: mg_find (sv, type))
383		468
384	#define CORO_MAGIC(sv, type) \	469	#define CORO_MAGIC(sv, type) \
385	(expect_true (SvMAGIC (sv)) \	470	(ecb_expect_true (SvMAGIC (sv)) \
386	? CORO_MAGIC_NN (sv, type) \	471	? CORO_MAGIC_NN (sv, type) \
387	: 0)	472	: 0)
388		473
389	#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)	474	#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
390	#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)	475	#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)
391		476
392	INLINE struct coro *	477	ecb_inline MAGIC *
		478	SvSTATEhv_p (pTHX_ SV *coro)
		479	{
		480	MAGIC *mg;
		481
		482	if (ecb_expect_true (
		483	SvTYPE (coro) == SVt_PVHV
		484	&& (mg = CORO_MAGIC_state (coro))
		485	&& mg->mg_virtual == &coro_state_vtbl
		486	))
		487	return mg;
		488
		489	return 0;
		490	}
		491
		492	ecb_inline struct coro *
393	SvSTATE_ (pTHX_ SV *coro)	493	SvSTATE_ (pTHX_ SV *coro)
394	{	494	{
395	HV *stash;
396	MAGIC *mg;	495	MAGIC *mg;
397		496
398	if (SvROK (coro))	497	if (SvROK (coro))
399	coro = SvRV (coro);	498	coro = SvRV (coro);
400		499
401	if (expect_false (SvTYPE (coro) != SVt_PVHV))	500	mg = SvSTATEhv_p (aTHX_ coro);
		501	if (!mg)
402	croak ("Coro::State object required");	502	croak ("Coro::State object required");
403		503
404	stash = SvSTASH (coro);
405	if (expect_false (stash != coro_stash && stash != coro_state_stash))
406	{
407	/* very slow, but rare, check */
408	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
409	croak ("Coro::State object required");
410	}
411
412	mg = CORO_MAGIC_state (coro);
413	return (struct coro *)mg->mg_ptr;	504	return (struct coro *)mg->mg_ptr;
414	}	505	}
415		506
416	#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))	507	#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
417		508
…		…
420	#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))	511	#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))
421		512
422	/*****************************************************************************/	513	/*****************************************************************************/
423	/* padlist management and caching */	514	/* padlist management and caching */
424		515
425	static AV *	516	ecb_inline PADLIST *
426	coro_derive_padlist (pTHX_ CV *cv)	517	coro_derive_padlist (pTHX_ CV *cv)
427	{	518	{
428	AV *padlist = CvPADLIST (cv);	519	PADLIST *padlist = CvPADLIST (cv);
429	AV *newpadlist, *newpad;	520	PADLIST *newpadlist;
		521	PAD *newpad;
		522	PADOFFSET off = PadlistMAX (padlist) + 1;
430		523
431	newpadlist = newAV ();	524	#if NEWPADAPI
		525
		526	/* if we had the original CvDEPTH, we might be able to steal the CvDEPTH+1 entry instead */
		527	/* 20131102194744.GA6705@schmorp.de, 20131102195825.2013.qmail@lists-nntp.develooper.com */
		528	while (!PadlistARRAY (padlist)[off - 1])
		529	--off;
		530
		531	Perl_pad_push (aTHX_ padlist, off);
		532
		533	newpad = PadlistARRAY (padlist)[off];
		534	PadlistARRAY (padlist)[off] = 0;
		535
		536	#else
		537
		538	#if PERL_VERSION_ATLEAST (5,10,0)
		539	Perl_pad_push (aTHX_ padlist, off);
		540	#else
		541	Perl_pad_push (aTHX_ padlist, off, 1);
		542	#endif
		543
		544	newpad = PadlistARRAY (padlist)[off];
		545	PadlistMAX (padlist) = off - 1;
		546
		547	#endif
		548
		549	newPADLIST (newpadlist);
		550	#if !PERL_VERSION_ATLEAST(5,15,3)
		551	/* Padlists are AvREAL as of 5.15.3. See perl bug #98092 and perl commit 7d953ba. */
432	AvREAL_off (newpadlist);	552	AvREAL_off (newpadlist);
433	#if PERL_VERSION_ATLEAST (5,10,0)
434	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
435	#else
436	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
437	#endif	553	#endif
438	newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
439	--AvFILLp (padlist);
440		554
441	av_store (newpadlist, 0, SvREFCNT_inc_NN (AvARRAY (padlist)[0]));	555	/* Already extended to 2 elements by newPADLIST. */
442	av_store (newpadlist, 1, (SV *)newpad);	556	PadlistMAX (newpadlist) = 1;
		557	PadlistNAMES (newpadlist) = (PADNAMELIST *)SvREFCNT_inc_NN (PadlistNAMES (padlist));
		558	PadlistARRAY (newpadlist)[1] = newpad;
443		559
444	return newpadlist;	560	return newpadlist;
445	}	561	}
446		562
447	static void	563	ecb_inline void
448	free_padlist (pTHX_ AV *padlist)	564	free_padlist (pTHX_ PADLIST *padlist)
449	{	565	{
450	/* may be during global destruction */	566	/* may be during global destruction */
451	if (!IN_DESTRUCT)	567	if (!IN_DESTRUCT)
452	{	568	{
453	I32 i = AvFILLp (padlist);	569	I32 i = PadlistMAX (padlist);
454		570
455	while (i > 0) /* special-case index 0 */	571	while (i > 0) /* special-case index 0 */
456	{	572	{
457	/* we try to be extra-careful here */	573	/* we try to be extra-careful here */
458	AV *av = (AV *)AvARRAY (padlist)[i--];	574	PAD *pad = PadlistARRAY (padlist)[i--];
459	I32 j = AvFILLp (av);
460		575
		576	if (pad)
		577	{
		578	I32 j = PadMAX (pad);
		579
461	while (j >= 0)	580	while (j >= 0)
462	SvREFCNT_dec (AvARRAY (av)[j--]);	581	SvREFCNT_dec (PadARRAY (pad)[j--]);
463		582
464	AvFILLp (av) = -1;	583	PadMAX (pad) = -1;
465	SvREFCNT_dec (av);	584	SvREFCNT_dec (pad);
		585	}
466	}	586	}
467		587
468	SvREFCNT_dec (AvARRAY (padlist)[0]);	588	SvREFCNT_dec (PadlistNAMES (padlist));
469		589
		590	#if NEWPADAPI
		591	Safefree (PadlistARRAY (padlist));
		592	Safefree (padlist);
		593	#else
470	AvFILLp (padlist) = -1;	594	AvFILLp (padlist) = -1;
		595	AvREAL_off (padlist);
471	SvREFCNT_dec ((SV*)padlist);	596	SvREFCNT_dec ((SV*)padlist);
		597	#endif
472	}	598	}
473	}	599	}
474		600
475	static int	601	static int
476	coro_cv_free (pTHX_ SV *sv, MAGIC *mg)	602	coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
477	{	603	{
478	AV *padlist;	604	PADLIST *padlist;
479	AV *av = (AV *)mg->mg_obj;	605	PADLIST **padlists = (PADLIST **)(mg->mg_ptr + sizeof(size_t));
		606	size_t len = *(size_t *)mg->mg_ptr;
480		607
481	/* casting is fun. */	608	/* perl manages to free our internal AV and _then_ call us */
482	while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))	609	if (IN_DESTRUCT)
		610	return 0;
		611
		612	while (len--)
483	free_padlist (aTHX_ padlist);	613	free_padlist (aTHX_ padlists[len]);
484
485	SvREFCNT_dec (av); /* sv_magicext increased the refcount */
486		614
487	return 0;	615	return 0;
488	}	616	}
489		617
490	static MGVTBL coro_cv_vtbl = {	618	static MGVTBL coro_cv_vtbl = {
491	0, 0, 0, 0,	619	0, 0, 0, 0,
492	coro_cv_free	620	coro_cv_free
493	};	621	};
494		622
495	/* the next two functions merely cache the padlists */	623	/* the next two functions merely cache the padlists */
496	static void	624	ecb_inline void
497	get_padlist (pTHX_ CV *cv)	625	get_padlist (pTHX_ CV *cv)
498	{	626	{
499	MAGIC *mg = CORO_MAGIC_cv (cv);	627	MAGIC *mg = CORO_MAGIC_cv (cv);
500	AV *av;	628	size_t *lenp;
501		629
502	if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))	630	if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr)))
503	CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];	631	CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp];
504	else	632	else
505	{	633	{
506	#if CORO_PREFER_PERL_FUNCTIONS	634	#if CORO_PREFER_PERL_FUNCTIONS
507	/* this is probably cleaner? but also slower! */	635	/* this is probably cleaner? but also slower! */
508	/* in practise, it seems to be less stable */	636	/* in practise, it seems to be less stable */
…		…
514	CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);	642	CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);
515	#endif	643	#endif
516	}	644	}
517	}	645	}
518		646
519	static void	647	ecb_inline void
520	put_padlist (pTHX_ CV *cv)	648	put_padlist (pTHX_ CV *cv)
521	{	649	{
522	MAGIC *mg = CORO_MAGIC_cv (cv);	650	MAGIC *mg = CORO_MAGIC_cv (cv);
523	AV *av;
524		651
525	if (expect_false (!mg))	652	if (ecb_expect_false (!mg))
		653	{
526	mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);	654	mg = sv_magicext ((SV *)cv, 0, CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
		655	Newz (0, mg->mg_ptr ,sizeof (size_t) + sizeof (PADLIST *), char);
		656	mg->mg_len = 1; /* so mg_free frees mg_ptr */
		657	}
		658	else
		659	Renew (mg->mg_ptr,
		660	sizeof(size_t) + (*(size_t *)mg->mg_ptr + 1) * sizeof(PADLIST *),
		661	char);
527		662
528	av = (AV *)mg->mg_obj;	663	((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv);
529
530	if (expect_false (AvFILLp (av) >= AvMAX (av)))
531	av_extend (av, AvFILLp (av) + 1);
532
533	AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
534	}	664	}
535		665
536	/** load & save, init *******************************************************/	666	/** load & save, init *******************************************************/
		667
		668	ecb_inline void
		669	swap_sv (SV *a, SV *b)
		670	{
		671	const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
		672	SV tmp;
		673
		674	/* swap sv_any */
		675	SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
		676
		677	/* swap sv_flags */
		678	SvFLAGS (&tmp) = SvFLAGS (a);
		679	SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
		680	SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
		681
		682	#if PERL_VERSION_ATLEAST (5,10,0)
		683	/* perl 5.10 and later complicates this _quite_ a bit, but it also
		684	* is much faster, so no quarrels here. alternatively, we could
		685	* sv_upgrade to avoid this.
		686	*/
		687	{
		688	/* swap sv_u */
		689	tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
		690
		691	/* if SvANY points to the head, we need to adjust the pointers,
		692	* as the pointer for a still points to b, and maybe vice versa.
		693	*/
		694	#define svany_in_head(type) \
		695	(((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type)))
		696
		697	if (svany_in_head (SvTYPE (a)))
		698	SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
		699
		700	if (svany_in_head (SvTYPE (b)))
		701	SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
		702	}
		703	#endif
		704	}
		705
		706	/* swap sv heads, at least logically */
		707	static void
		708	swap_svs (pTHX_ Coro__State c)
		709	{
		710	int i;
		711
		712	for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
		713	swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
		714	}
		715
		716	#define SWAP_SVS(coro) \
		717	if (ecb_expect_false ((coro)->swap_sv)) \
		718	swap_svs (aTHX_ (coro))
537		719
538	static void	720	static void
539	on_enterleave_call (pTHX_ SV *cb);	721	on_enterleave_call (pTHX_ SV *cb);
540		722
541	static void	723	static void
…		…
544	perl_slots *slot = c->slot;	726	perl_slots *slot = c->slot;
545	c->slot = 0;	727	c->slot = 0;
546		728
547	PL_mainstack = c->mainstack;	729	PL_mainstack = c->mainstack;
548		730
549	GvSV (PL_defgv) = slot->defsv;	731	#if CORO_JIT
550	GvAV (PL_defgv) = slot->defav;	732	load_perl_slots (slot);
551	GvSV (PL_errgv) = slot->errsv;	733	#else
552	GvSV (irsgv) = slot->irsgv;
553	GvHV (PL_hintgv) = slot->hinthv;
554
555	#define VAR(name,type) PL_ ## name = slot->name;	734	#define VARx(name,expr,type) expr = slot->name;
556	# include "state.h"	735	#include "state.h"
557	#undef VAR	736	#endif
558		737
559	{	738	{
560	dSP;	739	dSP;
561		740
562	CV *cv;	741	CV *cv;
563		742
564	/* now do the ugly restore mess */	743	/* now do the ugly restore mess */
565	while (expect_true (cv = (CV *)POPs))	744	while (ecb_expect_true (cv = (CV *)POPs))
566	{	745	{
567	put_padlist (aTHX_ cv); /* mark this padlist as available */	746	put_padlist (aTHX_ cv); /* mark this padlist as available */
568	CvDEPTH (cv) = PTR2IV (POPs);	747	CvDEPTH (cv) = PTR2IV (POPs);
569	CvPADLIST (cv) = (AV *)POPs;	748	CvPADLIST (cv) = (PADLIST *)POPs;
570	}	749	}
571		750
572	PUTBACK;	751	PUTBACK;
573	}	752	}
574		753
575	slf_frame = c->slf_frame;	754	slf_frame = c->slf_frame;
576	CORO_THROW = c->except;	755	CORO_THROW = c->except;
577		756
		757	if (ecb_expect_false (enable_times))
		758	{
		759	if (ecb_expect_false (!times_valid))
		760	coro_times_update ();
		761
		762	coro_times_sub (c);
		763	}
		764
578	if (expect_false (c->on_enter))	765	if (ecb_expect_false (c->on_enter))
579	{	766	{
580	int i;	767	int i;
581		768
582	for (i = 0; i <= AvFILLp (c->on_enter); ++i)	769	for (i = 0; i <= AvFILLp (c->on_enter); ++i)
583	on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);	770	on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);
584	}	771	}
		772
		773	SWAP_SVS (c);
585	}	774	}
586		775
587	static void	776	static void
588	save_perl (pTHX_ Coro__State c)	777	save_perl (pTHX_ Coro__State c)
589	{	778	{
		779	SWAP_SVS (c);
		780
590	if (expect_false (c->on_leave))	781	if (ecb_expect_false (c->on_leave))
591	{	782	{
592	int i;	783	int i;
593		784
594	for (i = AvFILLp (c->on_leave); i >= 0; --i)	785	for (i = AvFILLp (c->on_leave); i >= 0; --i)
595	on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]);	786	on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]);
		787	}
		788
		789	times_valid = 0;
		790
		791	if (ecb_expect_false (enable_times))
		792	{
		793	coro_times_update (); times_valid = 1;
		794	coro_times_add (c);
596	}	795	}
597		796
598	c->except = CORO_THROW;	797	c->except = CORO_THROW;
599	c->slf_frame = slf_frame;	798	c->slf_frame = slf_frame;
600		799
…		…
611		810
612	XPUSHs (Nullsv);	811	XPUSHs (Nullsv);
613	/* this loop was inspired by pp_caller */	812	/* this loop was inspired by pp_caller */
614	for (;;)	813	for (;;)
615	{	814	{
616	while (expect_true (cxix >= 0))	815	while (ecb_expect_true (cxix >= 0))
617	{	816	{
618	PERL_CONTEXT *cx = &ccstk[cxix--];	817	PERL_CONTEXT *cx = &ccstk[cxix--];
619		818
620	if (expect_true (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT))	819	if (ecb_expect_true (CxTYPE (cx) == CXt_SUB) || ecb_expect_false (CxTYPE (cx) == CXt_FORMAT))
621	{	820	{
622	CV *cv = cx->blk_sub.cv;	821	CV *cv = cx->blk_sub.cv;
623		822
624	if (expect_true (CvDEPTH (cv)))	823	if (ecb_expect_true (CvDEPTH (cv)))
625	{	824	{
626	EXTEND (SP, 3);	825	EXTEND (SP, 3);
627	PUSHs ((SV *)CvPADLIST (cv));	826	PUSHs ((SV *)CvPADLIST (cv));
628	PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));	827	PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
629	PUSHs ((SV *)cv);	828	PUSHs ((SV *)cv);
…		…
632	get_padlist (aTHX_ cv);	831	get_padlist (aTHX_ cv);
633	}	832	}
634	}	833	}
635	}	834	}
636		835
637	if (expect_true (top_si->si_type == PERLSI_MAIN))	836	if (ecb_expect_true (top_si->si_type == PERLSI_MAIN))
638	break;	837	break;
639		838
640	top_si = top_si->si_prev;	839	top_si = top_si->si_prev;
641	ccstk = top_si->si_cxstack;	840	ccstk = top_si->si_cxstack;
642	cxix = top_si->si_cxix;	841	cxix = top_si->si_cxix;
…		…
644		843
645	PUTBACK;	844	PUTBACK;
646	}	845	}
647		846
648	/* allocate some space on the context stack for our purposes */	847	/* allocate some space on the context stack for our purposes */
649	/* we manually unroll here, as usually 2 slots is enough */	848	if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max))
650	if (SLOT_COUNT >= 1) CXINC;
651	if (SLOT_COUNT >= 2) CXINC;
652	if (SLOT_COUNT >= 3) CXINC;
653	{	849	{
654	int i;	850	unsigned int i;
		851
655	for (i = 3; i < SLOT_COUNT; ++i)	852	for (i = 0; i < SLOT_COUNT; ++i)
656	CXINC;	853	CXINC;
657	}	854
658	cxstack_ix -= SLOT_COUNT; /* undo allocation */	855	cxstack_ix -= SLOT_COUNT; /* undo allocation */
		856	}
659		857
660	c->mainstack = PL_mainstack;	858	c->mainstack = PL_mainstack;
661		859
662	{	860	{
663	perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);	861	perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
664		862
665	slot->defav = GvAV (PL_defgv);	863	#if CORO_JIT
666	slot->defsv = DEFSV;	864	save_perl_slots (slot);
667	slot->errsv = ERRSV;	865	#else
668	slot->irsgv = GvSV (irsgv);
669	slot->hinthv = GvHV (PL_hintgv);
670
671	#define VAR(name,type) slot->name = PL_ ## name;	866	#define VARx(name,expr,type) slot->name = expr;
672	# include "state.h"	867	#include "state.h"
673	#undef VAR	868	#endif
674	}	869	}
675	}	870	}
676		871
677	/*	872	/*
678	* allocate various perl stacks. This is almost an exact copy	873	* allocate various perl stacks. This is almost an exact copy
…		…
684	# define coro_init_stacks(thx) init_stacks ()	879	# define coro_init_stacks(thx) init_stacks ()
685	#else	880	#else
686	static void	881	static void
687	coro_init_stacks (pTHX)	882	coro_init_stacks (pTHX)
688	{	883	{
689	PL_curstackinfo = new_stackinfo(32, 8);	884	PL_curstackinfo = new_stackinfo(32, 4 + SLOT_COUNT); /* 3 is minimum due to perl rounding down in scope.c:GROW() */
690	PL_curstackinfo->si_type = PERLSI_MAIN;	885	PL_curstackinfo->si_type = PERLSI_MAIN;
691	PL_curstack = PL_curstackinfo->si_stack;	886	PL_curstack = PL_curstackinfo->si_stack;
692	PL_mainstack = PL_curstack; /* remember in case we switch stacks */	887	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
693		888
694	PL_stack_base = AvARRAY(PL_curstack);	889	PL_stack_base = AvARRAY(PL_curstack);
…		…
709	#endif	904	#endif
710		905
711	New(54,PL_scopestack,8,I32);	906	New(54,PL_scopestack,8,I32);
712	PL_scopestack_ix = 0;	907	PL_scopestack_ix = 0;
713	PL_scopestack_max = 8;	908	PL_scopestack_max = 8;
		909	#if HAS_SCOPESTACK_NAME
		910	New(54,PL_scopestack_name,8,const char*);
		911	#endif
714		912
715	New(54,PL_savestack,24,ANY);	913	New(54,PL_savestack,24,ANY);
716	PL_savestack_ix = 0;	914	PL_savestack_ix = 0;
717	PL_savestack_max = 24;	915	PL_savestack_max = 24;
718		916
…		…
746	}	944	}
747		945
748	Safefree (PL_tmps_stack);	946	Safefree (PL_tmps_stack);
749	Safefree (PL_markstack);	947	Safefree (PL_markstack);
750	Safefree (PL_scopestack);	948	Safefree (PL_scopestack);
		949	#if HAS_SCOPESTACK_NAME
		950	Safefree (PL_scopestack_name);
		951	#endif
751	Safefree (PL_savestack);	952	Safefree (PL_savestack);
752	#if !PERL_VERSION_ATLEAST (5,10,0)	953	#if !PERL_VERSION_ATLEAST (5,10,0)
753	Safefree (PL_retstack);	954	Safefree (PL_retstack);
754	#endif	955	#endif
755	}	956	}
…		…
801	#endif	1002	#endif
802		1003
803	/*	1004	/*
804	* This overrides the default magic get method of %SIG elements.	1005	* This overrides the default magic get method of %SIG elements.
805	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook	1006	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook
806	* and instead of trying to save and restore the hash elements, we just provide	1007	* and instead of trying to save and restore the hash elements (extremely slow),
807	* readback here.	1008	* we just provide our own readback here.
808	*/	1009	*/
809	static int	1010	static int ecb_cold
810	coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)	1011	coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
811	{	1012	{
812	const char *s = MgPV_nolen_const (mg);	1013	const char *s = MgPV_nolen_const (mg);
813		1014
814	if (*s == '_')	1015	if (*s == '_')
815	{	1016	{
816	SV **svp = 0;	1017	SV **svp = 0;
817		1018
818	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;	1019	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
819	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;	1020	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
820		1021
821	if (svp)	1022	if (svp)
822	{	1023	{
823	sv_setsv (sv, *svp ? *svp : &PL_sv_undef);	1024	SV *ssv;
		1025
		1026	if (!*svp)
		1027	ssv = &PL_sv_undef;
		1028	else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
		1029	ssv = sv_2mortal (newRV_inc (*svp));
		1030	else
		1031	ssv = *svp;
		1032
		1033	sv_setsv (sv, ssv);
824	return 0;	1034	return 0;
825	}	1035	}
826	}	1036	}
827		1037
828	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;	1038	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
829	}	1039	}
830		1040
831	static int	1041	static int ecb_cold
832	coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)	1042	coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
833	{	1043	{
834	const char *s = MgPV_nolen_const (mg);	1044	const char *s = MgPV_nolen_const (mg);
835		1045
836	if (*s == '_')	1046	if (*s == '_')
…		…
850	}	1060	}
851		1061
852	return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;	1062	return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
853	}	1063	}
854		1064
855	static int	1065	static int ecb_cold
856	coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)	1066	coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
857	{	1067	{
858	const char *s = MgPV_nolen_const (mg);	1068	const char *s = MgPV_nolen_const (mg);
859		1069
860	if (*s == '_')	1070	if (*s == '_')
…		…
893	slf_check_repeat (pTHX_ struct CoroSLF *frame)	1103	slf_check_repeat (pTHX_ struct CoroSLF *frame)
894	{	1104	{
895	return 1;	1105	return 1;
896	}	1106	}
897		1107
898	static UNOP coro_setup_op;	1108	static UNOP init_perl_op;
899		1109
900	static void NOINLINE /* noinline to keep it out of the transfer fast path */	1110	ecb_noinline static void /* noinline to keep it out of the transfer fast path */
901	coro_setup (pTHX_ struct coro *coro)	1111	init_perl (pTHX_ struct coro *coro)
902	{	1112	{
903	/*	1113	/*
904	* emulate part of the perl startup here.	1114	* emulate part of the perl startup here.
905	*/	1115	*/
906	coro_init_stacks (aTHX);	1116	coro_init_stacks (aTHX);
…		…
913	PL_comppad_name_fill = 0;	1123	PL_comppad_name_fill = 0;
914	PL_comppad_name_floor = 0;	1124	PL_comppad_name_floor = 0;
915	PL_curpm = 0;	1125	PL_curpm = 0;
916	PL_curpad = 0;	1126	PL_curpad = 0;
917	PL_localizing = 0;	1127	PL_localizing = 0;
918	PL_dirty = 0;
919	PL_restartop = 0;	1128	PL_restartop = 0;
920	#if PERL_VERSION_ATLEAST (5,10,0)	1129	#if PERL_VERSION_ATLEAST (5,10,0)
921	PL_parser = 0;	1130	PL_parser = 0;
922	#endif	1131	#endif
923	PL_hints = 0;	1132	PL_hints = 0;
924		1133
925	/* recreate the die/warn hooks */	1134	/* recreate the die/warn hooks */
926	PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );	1135	PL_diehook = SvREFCNT_inc (rv_diehook);
927	PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);	1136	PL_warnhook = SvREFCNT_inc (rv_warnhook);
928		1137
929	GvSV (PL_defgv) = newSV (0);	1138	GvSV (PL_defgv) = newSV (0);
930	GvAV (PL_defgv) = coro->args; coro->args = 0;	1139	GvAV (PL_defgv) = coro->args; coro->args = 0;
931	GvSV (PL_errgv) = newSV (0);	1140	GvSV (PL_errgv) = newSV (0);
932	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);	1141	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
933	GvHV (PL_hintgv) = 0;	1142	GvHV (PL_hintgv) = 0;
…		…
953	/* this newly created coroutine might be run on an existing cctx which most	1162	/* this newly created coroutine might be run on an existing cctx which most
954	* likely was suspended in pp_slf, so we have to emulate entering pp_slf here.	1163	* likely was suspended in pp_slf, so we have to emulate entering pp_slf here.
955	*/	1164	*/
956	slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */	1165	slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */
957	slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */	1166	slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */
		1167	slf_frame.destroy = 0;
958		1168
959	/* and we have to provide the pp_slf op in any case, so pp_slf can skip it */	1169	/* and we have to provide the pp_slf op in any case, so pp_slf can skip it */
960	coro_setup_op.op_next = PL_op;	1170	init_perl_op.op_next = PL_op;
961	coro_setup_op.op_type = OP_ENTERSUB;	1171	init_perl_op.op_type = OP_ENTERSUB;
962	coro_setup_op.op_ppaddr = pp_slf;	1172	init_perl_op.op_ppaddr = pp_slf;
963	/* no flags etc. required, as an init function won't be called */	1173	/* no flags etc. required, as an init function won't be called */
964		1174
965	PL_op = (OP *)&coro_setup_op;	1175	PL_op = (OP *)&init_perl_op;
966		1176
967	/* copy throw, in case it was set before coro_setup */	1177	/* copy throw, in case it was set before init_perl */
968	CORO_THROW = coro->except;	1178	CORO_THROW = coro->except;
		1179
		1180	SWAP_SVS (coro);
		1181
		1182	if (ecb_expect_false (enable_times))
		1183	{
		1184	coro_times_update ();
		1185	coro_times_sub (coro);
		1186	}
969	}	1187	}
970		1188
971	static void	1189	static void
972	coro_unwind_stacks (pTHX)	1190	coro_unwind_stacks (pTHX)
973	{	1191	{
…		…
988	dounwind (-1);	1206	dounwind (-1);
989	}	1207	}
990	}	1208	}
991		1209
992	static void	1210	static void
993	coro_destruct_perl (pTHX_ struct coro *coro)	1211	destroy_perl (pTHX_ struct coro *coro)
994	{	1212	{
		1213	SV *svf [9];
		1214
		1215	{
		1216	SV *old_current = SvRV (coro_current);
		1217	struct coro *current = SvSTATE (old_current);
		1218
		1219	assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));
		1220
		1221	save_perl (aTHX_ current);
		1222
		1223	/* this will cause transfer_check to croak on block*/
		1224	SvRV_set (coro_current, (SV *)coro->hv);
		1225
		1226	load_perl (aTHX_ coro);
		1227
995	coro_unwind_stacks (aTHX);	1228	coro_unwind_stacks (aTHX);
996		1229
997	SvREFCNT_dec (GvSV (PL_defgv));	1230	/* restore swapped sv's */
998	SvREFCNT_dec (GvAV (PL_defgv));	1231	SWAP_SVS (coro);
999	SvREFCNT_dec (GvSV (PL_errgv));
1000	SvREFCNT_dec (PL_defoutgv);
1001	SvREFCNT_dec (PL_rs);
1002	SvREFCNT_dec (GvSV (irsgv));
1003	SvREFCNT_dec (GvHV (PL_hintgv));
1004		1232
1005	SvREFCNT_dec (PL_diehook);	1233	coro_destruct_stacks (aTHX);
1006	SvREFCNT_dec (PL_warnhook);	1234
		1235	/* now save some sv's to be free'd later */
		1236	svf [0] = GvSV (PL_defgv);
		1237	svf [1] = (SV *)GvAV (PL_defgv);
		1238	svf [2] = GvSV (PL_errgv);
		1239	svf [3] = (SV *)PL_defoutgv;
		1240	svf [4] = PL_rs;
		1241	svf [5] = GvSV (irsgv);
		1242	svf [6] = (SV *)GvHV (PL_hintgv);
		1243	svf [7] = PL_diehook;
		1244	svf [8] = PL_warnhook;
		1245	assert (9 == sizeof (svf) / sizeof (*svf));
		1246
		1247	SvRV_set (coro_current, old_current);
		1248
		1249	load_perl (aTHX_ current);
1007		1250	}
		1251
		1252	{
		1253	unsigned int i;
		1254
		1255	for (i = 0; i < sizeof (svf) / sizeof (*svf); ++i)
		1256	SvREFCNT_dec (svf [i]);
		1257
1008	SvREFCNT_dec (coro->saved_deffh);	1258	SvREFCNT_dec (coro->saved_deffh);
1009	SvREFCNT_dec (coro->rouse_cb);	1259	SvREFCNT_dec (coro->rouse_cb);
1010	SvREFCNT_dec (coro->invoke_cb);	1260	SvREFCNT_dec (coro->invoke_cb);
1011	SvREFCNT_dec (coro->invoke_av);	1261	SvREFCNT_dec (coro->invoke_av);
1012		1262	}
1013	coro_destruct_stacks (aTHX);
1014	}	1263	}
1015		1264
1016	INLINE void	1265	ecb_inline void
1017	free_coro_mortal (pTHX)	1266	free_coro_mortal (pTHX)
1018	{	1267	{
1019	if (expect_true (coro_mortal))	1268	if (ecb_expect_true (coro_mortal))
1020	{	1269	{
1021	SvREFCNT_dec (coro_mortal);	1270	SvREFCNT_dec ((SV *)coro_mortal);
1022	coro_mortal = 0;	1271	coro_mortal = 0;
1023	}	1272	}
1024	}	1273	}
1025		1274
1026	static int	1275	static int
…		…
1159		1408
1160	return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */	1409	return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */
1161	}	1410	}
1162		1411
1163	/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */	1412	/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */
1164	static void NOINLINE	1413	static void ecb_noinline
1165	cctx_prepare (pTHX)	1414	cctx_prepare (pTHX)
1166	{	1415	{
1167	PL_top_env = &PL_start_env;	1416	PL_top_env = &PL_start_env;
1168		1417
1169	if (cctx_current->flags & CC_TRACE)	1418	if (cctx_current->flags & CC_TRACE)
…		…
1180	slf_frame.prepare = slf_prepare_set_stacklevel;	1429	slf_frame.prepare = slf_prepare_set_stacklevel;
1181	slf_frame.check = slf_check_set_stacklevel;	1430	slf_frame.check = slf_check_set_stacklevel;
1182	}	1431	}
1183		1432
1184	/* the tail of transfer: execute stuff we can only do after a transfer */	1433	/* the tail of transfer: execute stuff we can only do after a transfer */
1185	INLINE void	1434	ecb_inline void
1186	transfer_tail (pTHX)	1435	transfer_tail (pTHX)
1187	{	1436	{
1188	free_coro_mortal (aTHX);	1437	free_coro_mortal (aTHX);
		1438	}
		1439
		1440	/* try to exit the same way perl's main function would do */
		1441	/* we do not bother resetting the environment or other things *7
		1442	/* that are not, uhm, essential */
		1443	/* this obviously also doesn't work when perl is embedded */
		1444	static void ecb_noinline ecb_cold
		1445	perlish_exit (pTHX)
		1446	{
		1447	int exitstatus = perl_destruct (PL_curinterp);
		1448	perl_free (PL_curinterp);
		1449	exit (exitstatus);
1189	}	1450	}
1190		1451
1191	/*	1452	/*
1192	* this is a _very_ stripped down perl interpreter ;)	1453	* this is a _very_ stripped down perl interpreter ;)
1193	*/	1454	*/
…		…
1215	/* somebody or something will hit me for both perl_run and PL_restartop */	1476	/* somebody or something will hit me for both perl_run and PL_restartop */
1216	PL_restartop = PL_op;	1477	PL_restartop = PL_op;
1217	perl_run (PL_curinterp);	1478	perl_run (PL_curinterp);
1218	/*	1479	/*
1219	* Unfortunately, there is no way to get at the return values of the	1480	* Unfortunately, there is no way to get at the return values of the
1220	* coro body here, as perl_run destroys these	1481	* coro body here, as perl_run destroys these. Likewise, we cannot catch
		1482	* runtime errors here, as this is just a random interpreter, not a thread.
1221	*/	1483	*/
1222		1484
1223	/*	1485	/*
1224	* If perl-run returns we assume exit() was being called or the coro	1486	* If perl-run returns we assume exit() was being called or the coro
1225	* fell off the end, which seems to be the only valid (non-bug)	1487	* fell off the end, which seems to be the only valid (non-bug)
1226	* reason for perl_run to return. We try to exit by jumping to the	1488	* reason for perl_run to return. We try to mimic whatever perl is normally
1227	* bootstrap-time "top" top_env, as we cannot restore the "main"	1489	* doing in that case. YMMV.
1228	* coroutine as Coro has no such concept.
1229	* This actually isn't valid with the pthread backend, but OSes requiring
1230	* that backend are too broken to do it in a standards-compliant way.
1231	*/	1490	*/
1232	PL_top_env = main_top_env;	1491	perlish_exit (aTHX);
1233	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
1234	}	1492	}
1235	}	1493	}
1236		1494
1237	static coro_cctx *	1495	static coro_cctx *
1238	cctx_new ()	1496	cctx_new (void)
1239	{	1497	{
1240	coro_cctx *cctx;	1498	coro_cctx *cctx;
1241		1499
1242	++cctx_count;	1500	++cctx_count;
1243	New (0, cctx, 1, coro_cctx);	1501	New (0, cctx, 1, coro_cctx);
…		…
1249	return cctx;	1507	return cctx;
1250	}	1508	}
1251		1509
1252	/* create a new cctx only suitable as source */	1510	/* create a new cctx only suitable as source */
1253	static coro_cctx *	1511	static coro_cctx *
1254	cctx_new_empty ()	1512	cctx_new_empty (void)
1255	{	1513	{
1256	coro_cctx *cctx = cctx_new ();	1514	coro_cctx *cctx = cctx_new ();
1257		1515
1258	cctx->sptr = 0;	1516	cctx->stack.sptr = 0;
1259	coro_create (&cctx->cctx, 0, 0, 0, 0);	1517	coro_create (&cctx->cctx, 0, 0, 0, 0);
1260		1518
1261	return cctx;	1519	return cctx;
1262	}	1520	}
1263		1521
1264	/* create a new cctx suitable as destination/running a perl interpreter */	1522	/* create a new cctx suitable as destination/running a perl interpreter */
1265	static coro_cctx *	1523	static coro_cctx *
1266	cctx_new_run ()	1524	cctx_new_run (void)
1267	{	1525	{
1268	coro_cctx *cctx = cctx_new ();	1526	coro_cctx *cctx = cctx_new ();
1269	void *stack_start;
1270	size_t stack_size;
1271		1527
1272	#if HAVE_MMAP	1528	if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
1273	cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
1274	/* mmap supposedly does allocate-on-write for us */
1275	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
1276
1277	if (cctx->sptr != (void *)-1)
1278	{
1279	#if CORO_STACKGUARD
1280	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
1281	#endif
1282	stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE;
1283	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
1284	cctx->flags |= CC_MAPPED;
1285	}	1529	{
1286	else
1287	#endif
1288	{
1289	cctx->ssize = cctx_stacksize * (long)sizeof (long);
1290	New (0, cctx->sptr, cctx_stacksize, long);
1291
1292	if (!cctx->sptr)
1293	{
1294	perror ("FATAL: unable to allocate stack for coroutine, exiting.");	1530	perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1295	_exit (EXIT_FAILURE);	1531	_exit (EXIT_FAILURE);
1296	}
1297
1298	stack_start = cctx->sptr;
1299	stack_size = cctx->ssize;
1300	}	1532	}
1301		1533
1302	#if CORO_USE_VALGRIND
1303	cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size);
1304	#endif
1305
1306	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);	1534	coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze);
1307		1535
1308	return cctx;	1536	return cctx;
1309	}	1537	}
1310		1538
1311	static void	1539	static void
1312	cctx_destroy (coro_cctx *cctx)	1540	cctx_destroy (coro_cctx *cctx)
1313	{	1541	{
1314	if (!cctx)	1542	if (!cctx)
1315	return;	1543	return;
1316		1544
1317	assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));//D temporary?	1545	assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
1318		1546
1319	--cctx_count;	1547	--cctx_count;
1320	coro_destroy (&cctx->cctx);	1548	coro_destroy (&cctx->cctx);
1321		1549
1322	/* coro_transfer creates new, empty cctx's */	1550	coro_stack_free (&cctx->stack);
1323	if (cctx->sptr)
1324	{
1325	#if CORO_USE_VALGRIND
1326	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1327	#endif
1328
1329	#if HAVE_MMAP
1330	if (cctx->flags & CC_MAPPED)
1331	munmap (cctx->sptr, cctx->ssize);
1332	else
1333	#endif
1334	Safefree (cctx->sptr);
1335	}
1336		1551
1337	Safefree (cctx);	1552	Safefree (cctx);
1338	}	1553	}
1339		1554
1340	/* wether this cctx should be destructed */	1555	/* wether this cctx should be destructed */
1341	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))	1556	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1342		1557
1343	static coro_cctx *	1558	static coro_cctx *
1344	cctx_get (pTHX)	1559	cctx_get (pTHX)
1345	{	1560	{
1346	while (expect_true (cctx_first))	1561	while (ecb_expect_true (cctx_first))
1347	{	1562	{
1348	coro_cctx *cctx = cctx_first;	1563	coro_cctx *cctx = cctx_first;
1349	cctx_first = cctx->next;	1564	cctx_first = cctx->next;
1350	--cctx_idle;	1565	--cctx_idle;
1351		1566
1352	if (expect_true (!CCTX_EXPIRED (cctx)))	1567	if (ecb_expect_true (!CCTX_EXPIRED (cctx)))
1353	return cctx;	1568	return cctx;
1354		1569
1355	cctx_destroy (cctx);	1570	cctx_destroy (cctx);
1356	}	1571	}
1357		1572
…		…
1359	}	1574	}
1360		1575
1361	static void	1576	static void
1362	cctx_put (coro_cctx *cctx)	1577	cctx_put (coro_cctx *cctx)
1363	{	1578	{
1364	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr));	1579	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr));
1365		1580
1366	/* free another cctx if overlimit */	1581	/* free another cctx if overlimit */
1367	if (expect_false (cctx_idle >= cctx_max_idle))	1582	if (ecb_expect_false (cctx_idle >= cctx_max_idle))
1368	{	1583	{
1369	coro_cctx *first = cctx_first;	1584	coro_cctx *first = cctx_first;
1370	cctx_first = first->next;	1585	cctx_first = first->next;
1371	--cctx_idle;	1586	--cctx_idle;
1372		1587
…		…
1383	static void	1598	static void
1384	transfer_check (pTHX_ struct coro *prev, struct coro *next)	1599	transfer_check (pTHX_ struct coro *prev, struct coro *next)
1385	{	1600	{
1386	/* TODO: throwing up here is considered harmful */	1601	/* TODO: throwing up here is considered harmful */
1387		1602
1388	if (expect_true (prev != next))	1603	if (ecb_expect_true (prev != next))
1389	{	1604	{
1390	if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))	1605	if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1391	croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");	1606	croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");
1392		1607
1393	if (expect_false (next->flags & (CF_RUNNING | CF_DESTROYED | CF_SUSPENDED)))	1608	if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED)))
1394	croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");	1609	croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");
1395		1610
1396	#if !PERL_VERSION_ATLEAST (5,10,0)	1611	#if !PERL_VERSION_ATLEAST (5,10,0)
1397	if (expect_false (PL_lex_state != LEX_NOTPARSING))	1612	if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING))
1398	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");	1613	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");
1399	#endif	1614	#endif
1400	}	1615	}
1401	}	1616	}
1402		1617
1403	/* always use the TRANSFER macro */	1618	/* always use the TRANSFER macro */
1404	static void NOINLINE /* noinline so we have a fixed stackframe */	1619	static void ecb_noinline /* noinline so we have a fixed stackframe */
1405	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)	1620	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1406	{	1621	{
1407	dSTACKLEVEL;	1622	dSTACKLEVEL;
1408		1623
1409	/* sometimes transfer is only called to set idle_sp */	1624	/* sometimes transfer is only called to set idle_sp */
1410	if (expect_false (!prev))	1625	if (ecb_expect_false (!prev))
1411	{	1626	{
1412	cctx_current->idle_sp = STACKLEVEL;	1627	cctx_current->idle_sp = STACKLEVEL;
1413	assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */	1628	assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1414	}	1629	}
1415	else if (expect_true (prev != next))	1630	else if (ecb_expect_true (prev != next))
1416	{	1631	{
1417	coro_cctx *cctx_prev;	1632	coro_cctx *cctx_prev;
1418		1633
1419	if (expect_false (prev->flags & CF_NEW))	1634	if (ecb_expect_false (prev->flags & CF_NEW))
1420	{	1635	{
1421	/* create a new empty/source context */	1636	/* create a new empty/source context */
1422	prev->flags &= ~CF_NEW;	1637	prev->flags &= ~CF_NEW;
1423	prev->flags |= CF_RUNNING;	1638	prev->flags |= CF_RUNNING;
1424	}	1639	}
…		…
1427	next->flags |= CF_RUNNING;	1642	next->flags |= CF_RUNNING;
1428		1643
1429	/* first get rid of the old state */	1644	/* first get rid of the old state */
1430	save_perl (aTHX_ prev);	1645	save_perl (aTHX_ prev);
1431		1646
1432	if (expect_false (next->flags & CF_NEW))	1647	if (ecb_expect_false (next->flags & CF_NEW))
1433	{	1648	{
1434	/* need to start coroutine */	1649	/* need to start coroutine */
1435	next->flags &= ~CF_NEW;	1650	next->flags &= ~CF_NEW;
1436	/* setup coroutine call */	1651	/* setup coroutine call */
1437	coro_setup (aTHX_ next);	1652	init_perl (aTHX_ next);
1438	}	1653	}
1439	else	1654	else
1440	load_perl (aTHX_ next);	1655	load_perl (aTHX_ next);
1441		1656
1442	/* possibly untie and reuse the cctx */	1657	/* possibly untie and reuse the cctx */
1443	if (expect_true (	1658	if (ecb_expect_true (
1444	cctx_current->idle_sp == STACKLEVEL	1659	cctx_current->idle_sp == STACKLEVEL
1445	&& !(cctx_current->flags & CC_TRACE)	1660	&& !(cctx_current->flags & CC_TRACE)
1446	&& !force_cctx	1661	&& !force_cctx
1447	))	1662	))
1448	{	1663	{
1449	/* I assume that stacklevel is a stronger indicator than PL_top_env changes */	1664	/* I assume that stacklevel is a stronger indicator than PL_top_env changes */
1450	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));	1665	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));
1451		1666
1452	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */	1667	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */
1453	/* without this the next cctx_get might destroy the running cctx while still in use */	1668	/* without this the next cctx_get might destroy the running cctx while still in use */
1454	if (expect_false (CCTX_EXPIRED (cctx_current)))	1669	if (ecb_expect_false (CCTX_EXPIRED (cctx_current)))
1455	if (expect_true (!next->cctx))	1670	if (ecb_expect_true (!next->cctx))
1456	next->cctx = cctx_get (aTHX);	1671	next->cctx = cctx_get (aTHX);
1457		1672
1458	cctx_put (cctx_current);	1673	cctx_put (cctx_current);
1459	}	1674	}
1460	else	1675	else
1461	prev->cctx = cctx_current;	1676	prev->cctx = cctx_current;
1462		1677
1463	++next->usecount;	1678	++next->usecount;
1464		1679
1465	cctx_prev = cctx_current;	1680	cctx_prev = cctx_current;
1466	cctx_current = expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);	1681	cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);
1467		1682
1468	next->cctx = 0;	1683	next->cctx = 0;
1469		1684
1470	if (expect_false (cctx_prev != cctx_current))	1685	if (ecb_expect_false (cctx_prev != cctx_current))
1471	{	1686	{
1472	cctx_prev->top_env = PL_top_env;	1687	cctx_prev->top_env = PL_top_env;
1473	PL_top_env = cctx_current->top_env;	1688	PL_top_env = cctx_current->top_env;
1474	coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);	1689	coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);
1475	}	1690	}
…		…
1481	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))	1696	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1482	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)	1697	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1483		1698
1484	/** high level stuff ********************************************************/	1699	/** high level stuff ********************************************************/
1485		1700
		1701	/* this function is actually Coro, not Coro::State, but we call it from here */
		1702	/* because it is convenient - but it hasn't been declared yet for that reason */
1486	static int	1703	static void
		1704	coro_call_on_destroy (pTHX_ struct coro *coro);
		1705
		1706	static void
1487	coro_state_destroy (pTHX_ struct coro *coro)	1707	coro_state_destroy (pTHX_ struct coro *coro)
1488	{	1708	{
1489	if (coro->flags & CF_DESTROYED)	1709	if (coro->flags & CF_ZOMBIE)
1490	return 0;	1710	return;
1491		1711
1492	if (coro->on_destroy && !PL_dirty)
1493	coro->on_destroy (aTHX_ coro);	1712	slf_destroy (aTHX_ coro);
1494		1713
1495	coro->flags |= CF_DESTROYED;	1714	coro->flags |= CF_ZOMBIE;
1496		1715
1497	if (coro->flags & CF_READY)	1716	if (coro->flags & CF_READY)
1498	{	1717	{
1499	/* reduce nready, as destroying a ready coro effectively unreadies it */	1718	/* reduce nready, as destroying a ready coro effectively unreadies it */
1500	/* alternative: look through all ready queues and remove the coro */	1719	/* alternative: look through all ready queues and remove the coro */
1501	--coro_nready;	1720	--coro_nready;
1502	}	1721	}
1503	else	1722	else
1504	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */	1723	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
		1724
		1725	if (coro->next) coro->next->prev = coro->prev;
		1726	if (coro->prev) coro->prev->next = coro->next;
		1727	if (coro == coro_first) coro_first = coro->next;
1505		1728
1506	if (coro->mainstack	1729	if (coro->mainstack
1507	&& coro->mainstack != main_mainstack	1730	&& coro->mainstack != main_mainstack
1508	&& coro->slot	1731	&& coro->slot
1509	&& !PL_dirty)	1732	&& !PL_dirty)
1510	{
1511	struct coro *current = SvSTATE_current;
1512
1513	assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));
1514
1515	save_perl (aTHX_ current);
1516	load_perl (aTHX_ coro);
1517
1518	coro_destruct_perl (aTHX_ coro);	1733	destroy_perl (aTHX_ coro);
1519
1520	load_perl (aTHX_ current);
1521
1522	coro->slot = 0;
1523	}
1524		1734
1525	cctx_destroy (coro->cctx);	1735	cctx_destroy (coro->cctx);
1526	SvREFCNT_dec (coro->startcv);	1736	SvREFCNT_dec (coro->startcv);
1527	SvREFCNT_dec (coro->args);	1737	SvREFCNT_dec (coro->args);
		1738	SvREFCNT_dec (coro->swap_sv);
1528	SvREFCNT_dec (CORO_THROW);	1739	SvREFCNT_dec (CORO_THROW);
1529		1740
1530	if (coro->next) coro->next->prev = coro->prev;	1741	coro_call_on_destroy (aTHX_ coro);
1531	if (coro->prev) coro->prev->next = coro->next;
1532	if (coro == coro_first) coro_first = coro->next;
1533		1742
1534	return 1;	1743	/* more destruction mayhem in coro_state_free */
1535	}	1744	}
1536		1745
1537	static int	1746	static int
1538	coro_state_free (pTHX_ SV *sv, MAGIC *mg)	1747	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1539	{	1748	{
1540	struct coro *coro = (struct coro *)mg->mg_ptr;	1749	struct coro *coro = (struct coro *)mg->mg_ptr;
1541	mg->mg_ptr = 0;	1750	mg->mg_ptr = 0;
1542		1751
1543	coro->hv = 0;
1544
1545	if (--coro->refcnt < 0)
1546	{
1547	coro_state_destroy (aTHX_ coro);	1752	coro_state_destroy (aTHX_ coro);
		1753	SvREFCNT_dec (coro->on_destroy);
		1754	SvREFCNT_dec (coro->status);
		1755
1548	Safefree (coro);	1756	Safefree (coro);
1549	}
1550		1757
1551	return 0;	1758	return 0;
1552	}	1759	}
1553		1760
1554	static int	1761	static int ecb_cold
1555	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)	1762	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1556	{	1763	{
1557	struct coro *coro = (struct coro *)mg->mg_ptr;	1764	/* called when perl clones the current process the slow way (windows process emulation) */
1558		1765	/* WE SIMply nuke the pointers in the copy, causing perl to croak */
1559	++coro->refcnt;	1766	mg->mg_ptr = 0;
		1767	mg->mg_virtual = 0;
1560		1768
1561	return 0;	1769	return 0;
1562	}	1770	}
1563		1771
1564	static MGVTBL coro_state_vtbl = {	1772	static MGVTBL coro_state_vtbl = {
…		…
1587		1795
1588	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);	1796	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1589	TRANSFER (ta, 1);	1797	TRANSFER (ta, 1);
1590	}	1798	}
1591		1799
1592	/*****************************************************************************/
1593	/* gensub: simple closure generation utility */
1594
1595	#define GENSUB_ARG CvXSUBANY (cv).any_ptr
1596
1597	/* create a closure from XS, returns a code reference */
1598	/* the arg can be accessed via GENSUB_ARG from the callback */
1599	/* the callback must use dXSARGS/XSRETURN */
1600	static SV *
1601	gensub (pTHX_ void (*xsub)(pTHX_ CV *), void *arg)
1602	{
1603	CV *cv = (CV *)newSV (0);
1604
1605	sv_upgrade ((SV *)cv, SVt_PVCV);
1606
1607	CvANON_on (cv);
1608	CvISXSUB_on (cv);
1609	CvXSUB (cv) = xsub;
1610	GENSUB_ARG = arg;
1611
1612	return newRV_noinc ((SV *)cv);
1613	}
1614
1615	/** Coro ********************************************************************/	1800	/** Coro ********************************************************************/
1616		1801
1617	INLINE void	1802	ecb_inline void
1618	coro_enq (pTHX_ struct coro *coro)	1803	coro_enq (pTHX_ struct coro *coro)
1619	{	1804	{
1620	struct coro **ready = coro_ready [coro->prio - PRIO_MIN];	1805	struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
1621		1806
1622	SvREFCNT_inc_NN (coro->hv);	1807	SvREFCNT_inc_NN (coro->hv);
1623		1808
1624	coro->next_ready = 0;	1809	coro->next_ready = 0;
1625	*(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;	1810	*(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
1626	ready [1] = coro;	1811	ready [1] = coro;
1627	}	1812	}
1628		1813
1629	INLINE struct coro *	1814	ecb_inline struct coro *
1630	coro_deq (pTHX)	1815	coro_deq (pTHX)
1631	{	1816	{
1632	int prio;	1817	int prio;
1633		1818
1634	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )	1819	for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
1635	{	1820	{
1636	struct coro **ready = coro_ready [prio];	1821	struct coro **ready = coro_ready [prio];
1637		1822
1638	if (ready [0])	1823	if (ready [0])
1639	{	1824	{
…		…
1644	}	1829	}
1645		1830
1646	return 0;	1831	return 0;
1647	}	1832	}
1648		1833
		1834	static void
		1835	invoke_sv_ready_hook_helper (void)
		1836	{
		1837	dTHX;
		1838	dSP;
		1839
		1840	ENTER;
		1841	SAVETMPS;
		1842
		1843	PUSHMARK (SP);
		1844	PUTBACK;
		1845	call_sv (coro_readyhook, G_VOID | G_DISCARD);
		1846
		1847	FREETMPS;
		1848	LEAVE;
		1849	}
		1850
1649	static int	1851	static int
1650	api_ready (pTHX_ SV *coro_sv)	1852	api_ready (pTHX_ SV *coro_sv)
1651	{	1853	{
1652	struct coro *coro;
1653	SV *sv_hook;
1654	void (*xs_hook)(void);
1655
1656	coro = SvSTATE (coro_sv);	1854	struct coro *coro = SvSTATE (coro_sv);
1657		1855
1658	if (coro->flags & CF_READY)	1856	if (coro->flags & CF_READY)
1659	return 0;	1857	return 0;
1660		1858
1661	coro->flags |= CF_READY;	1859	coro->flags |= CF_READY;
1662		1860
1663	sv_hook = coro_nready ? 0 : coro_readyhook;
1664	xs_hook = coro_nready ? 0 : coroapi.readyhook;
1665
1666	coro_enq (aTHX_ coro);	1861	coro_enq (aTHX_ coro);
1667	++coro_nready;
1668		1862
1669	if (sv_hook)	1863	if (!coro_nready++)
1670	{	1864	if (coroapi.readyhook)
1671	dSP;	1865	coroapi.readyhook ();
1672
1673	ENTER;
1674	SAVETMPS;
1675
1676	PUSHMARK (SP);
1677	PUTBACK;
1678	call_sv (sv_hook, G_VOID | G_DISCARD);
1679
1680	FREETMPS;
1681	LEAVE;
1682	}
1683
1684	if (xs_hook)
1685	xs_hook ();
1686		1866
1687	return 1;	1867	return 1;
1688	}	1868	}
1689		1869
1690	static int	1870	static int
…		…
1692	{	1872	{
1693	return !!(SvSTATE (coro_sv)->flags & CF_READY);	1873	return !!(SvSTATE (coro_sv)->flags & CF_READY);
1694	}	1874	}
1695		1875
1696	/* expects to own a reference to next->hv */	1876	/* expects to own a reference to next->hv */
1697	INLINE void	1877	ecb_inline void
1698	prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)	1878	prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)
1699	{	1879	{
1700	SV *prev_sv = SvRV (coro_current);	1880	SV *prev_sv = SvRV (coro_current);
1701		1881
1702	ta->prev = SvSTATE_hv (prev_sv);	1882	ta->prev = SvSTATE_hv (prev_sv);
…		…
1715	{	1895	{
1716	for (;;)	1896	for (;;)
1717	{	1897	{
1718	struct coro *next = coro_deq (aTHX);	1898	struct coro *next = coro_deq (aTHX);
1719		1899
1720	if (expect_true (next))	1900	if (ecb_expect_true (next))
1721	{	1901	{
1722	/* cannot transfer to destroyed coros, skip and look for next */	1902	/* cannot transfer to destroyed coros, skip and look for next */
1723	if (expect_false (next->flags & (CF_DESTROYED | CF_SUSPENDED)))	1903	if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED)))
1724	SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */	1904	SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */
1725	else	1905	else
1726	{	1906	{
1727	next->flags &= ~CF_READY;	1907	next->flags &= ~CF_READY;
1728	--coro_nready;	1908	--coro_nready;
…		…
1735	{	1915	{
1736	/* nothing to schedule: call the idle handler */	1916	/* nothing to schedule: call the idle handler */
1737	if (SvROK (sv_idle)	1917	if (SvROK (sv_idle)
1738	&& SvOBJECT (SvRV (sv_idle)))	1918	&& SvOBJECT (SvRV (sv_idle)))
1739	{	1919	{
		1920	if (SvRV (sv_idle) == SvRV (coro_current))
		1921	croak ("FATAL: $Coro::IDLE blocked itself - did you try to block inside an event loop callback? Caught");
		1922
1740	++coro_nready; /* hack so that api_ready doesn't invoke ready hook */	1923	++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
1741	api_ready (aTHX_ SvRV (sv_idle));	1924	api_ready (aTHX_ SvRV (sv_idle));
1742	--coro_nready;	1925	--coro_nready;
1743	}	1926	}
1744	else	1927	else
1745	{	1928	{
		1929	/* TODO: deprecated, remove, cannot work reliably *//*D*/
1746	dSP;	1930	dSP;
1747		1931
1748	ENTER;	1932	ENTER;
1749	SAVETMPS;	1933	SAVETMPS;
1750		1934
…		…
1757	}	1941	}
1758	}	1942	}
1759	}	1943	}
1760	}	1944	}
1761		1945
1762	INLINE void	1946	ecb_inline void
1763	prepare_cede (pTHX_ struct coro_transfer_args *ta)	1947	prepare_cede (pTHX_ struct coro_transfer_args *ta)
1764	{	1948	{
1765	api_ready (aTHX_ coro_current);	1949	api_ready (aTHX_ coro_current);
1766	prepare_schedule (aTHX_ ta);	1950	prepare_schedule (aTHX_ ta);
1767	}	1951	}
1768		1952
1769	INLINE void	1953	ecb_inline void
1770	prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)	1954	prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
1771	{	1955	{
1772	SV *prev = SvRV (coro_current);	1956	SV *prev = SvRV (coro_current);
1773		1957
1774	if (coro_nready)	1958	if (coro_nready)
…		…
1804	{	1988	{
1805	struct coro_transfer_args ta;	1989	struct coro_transfer_args ta;
1806		1990
1807	prepare_cede (aTHX_ &ta);	1991	prepare_cede (aTHX_ &ta);
1808		1992
1809	if (expect_true (ta.prev != ta.next))	1993	if (ecb_expect_true (ta.prev != ta.next))
1810	{	1994	{
1811	TRANSFER (ta, 1);	1995	TRANSFER (ta, 1);
1812	return 1;	1996	return 1;
1813	}	1997	}
1814	else	1998	else
…		…
1857	coro->slot->runops = RUNOPS_DEFAULT;	2041	coro->slot->runops = RUNOPS_DEFAULT;
1858	}	2042	}
1859	}	2043	}
1860		2044
1861	static void	2045	static void
		2046	coro_push_av (pTHX_ AV *av, I32 gimme_v)
		2047	{
		2048	if (AvFILLp (av) >= 0 && gimme_v != G_VOID)
		2049	{
		2050	dSP;
		2051
		2052	if (gimme_v == G_SCALAR)
		2053	XPUSHs (AvARRAY (av)[AvFILLp (av)]);
		2054	else
		2055	{
		2056	int i;
		2057	EXTEND (SP, AvFILLp (av) + 1);
		2058
		2059	for (i = 0; i <= AvFILLp (av); ++i)
		2060	PUSHs (AvARRAY (av)[i]);
		2061	}
		2062
		2063	PUTBACK;
		2064	}
		2065	}
		2066
		2067	static void
		2068	coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)
		2069	{
		2070	if (!coro->on_destroy)
		2071	coro->on_destroy = newAV ();
		2072
		2073	av_push (coro->on_destroy, cb);
		2074	}
		2075
		2076	static void
		2077	slf_destroy_join (pTHX_ struct CoroSLF *frame)
		2078	{
		2079	SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv);
		2080	}
		2081
		2082	static int
		2083	slf_check_join (pTHX_ struct CoroSLF *frame)
		2084	{
		2085	struct coro *coro = (struct coro *)frame->data;
		2086
		2087	if (!coro->status)
		2088	return 1;
		2089
		2090	frame->destroy = 0;
		2091
		2092	coro_push_av (aTHX_ coro->status, GIMME_V);
		2093
		2094	SvREFCNT_dec ((SV *)coro->hv);
		2095
		2096	return 0;
		2097	}
		2098
		2099	static void
		2100	slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2101	{
		2102	struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef);
		2103
		2104	if (items > 1)
		2105	croak ("join called with too many arguments");
		2106
		2107	if (coro->status)
		2108	frame->prepare = prepare_nop;
		2109	else
		2110	{
		2111	coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current)));
		2112	frame->prepare = prepare_schedule;
		2113	}
		2114
		2115	frame->check = slf_check_join;
		2116	frame->destroy = slf_destroy_join;
		2117	frame->data = (void *)coro;
		2118	SvREFCNT_inc (coro->hv);
		2119	}
		2120
		2121	static void
1862	coro_call_on_destroy (pTHX_ struct coro *coro)	2122	coro_call_on_destroy (pTHX_ struct coro *coro)
1863	{	2123	{
1864	SV **on_destroyp = hv_fetch (coro->hv, "_on_destroy", sizeof ("_on_destroy") - 1, 0);	2124	AV *od = coro->on_destroy;
1865	SV **statusp = hv_fetch (coro->hv, "_status", sizeof ("_status") - 1, 0);
1866		2125
1867	if (on_destroyp)	2126	if (!od)
1868	{	2127	return;
1869	AV *on_destroy = (AV *)SvRV (*on_destroyp);
1870		2128
		2129	coro->on_destroy = 0;
		2130	sv_2mortal ((SV *)od);
		2131
1871	while (AvFILLp (on_destroy) >= 0)	2132	while (AvFILLp (od) >= 0)
		2133	{
		2134	SV *cb = sv_2mortal (av_pop (od));
		2135
		2136	/* coro hv's (and only hv's at the moment) are supported as well */
		2137	if (SvSTATEhv_p (aTHX_ cb))
		2138	api_ready (aTHX_ cb);
		2139	else
1872	{	2140	{
1873	dSP; /* don't disturb outer sp */	2141	dSP; /* don't disturb outer sp */
1874	SV *cb = av_pop (on_destroy);
1875
1876	PUSHMARK (SP);	2142	PUSHMARK (SP);
1877		2143
1878	if (statusp)	2144	if (coro->status)
1879	{	2145	{
1880	int i;	2146	PUTBACK;
1881	AV *status = (AV *)SvRV (*statusp);	2147	coro_push_av (aTHX_ coro->status, G_ARRAY);
1882	EXTEND (SP, AvFILLp (status) + 1);	2148	SPAGAIN;
1883
1884	for (i = 0; i <= AvFILLp (status); ++i)
1885	PUSHs (AvARRAY (status)[i]);
1886	}	2149	}
1887		2150
1888	PUTBACK;	2151	PUTBACK;
1889	call_sv (sv_2mortal (cb), G_VOID | G_DISCARD);	2152	call_sv (cb, G_VOID | G_DISCARD);
1890	}	2153	}
1891	}	2154	}
1892	}	2155	}
1893		2156
1894	static void	2157	static void
1895	slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2158	coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
1896	{	2159	{
		2160	AV *av;
		2161
		2162	if (coro->status)
		2163	{
		2164	av = coro->status;
		2165	av_clear (av);
		2166	}
		2167	else
		2168	av = coro->status = newAV ();
		2169
		2170	/* items are actually not so common, so optimise for this case */
		2171	if (items)
		2172	{
1897	int i;	2173	int i;
1898	HV *hv = (HV *)SvRV (coro_current);
1899	AV *av = newAV ();
1900		2174
1901	av_extend (av, items - 1);	2175	av_extend (av, items - 1);
		2176
1902	for (i = 0; i < items; ++i)	2177	for (i = 0; i < items; ++i)
1903	av_push (av, SvREFCNT_inc_NN (arg [i]));	2178	av_push (av, SvREFCNT_inc_NN (arg [i]));
		2179	}
		2180	}
1904		2181
1905	hv_store (hv, "_status", sizeof ("_status") - 1, newRV_noinc ((SV *)av), 0);	2182	static void
1906		2183	slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv)
		2184	{
1907	av_push (av_destroy, (SV *)newRV_inc ((SV *)hv)); /* RVinc for perl */	2185	av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */
1908	api_ready (aTHX_ sv_manager);	2186	api_ready (aTHX_ sv_manager);
1909		2187
1910	frame->prepare = prepare_schedule;	2188	frame->prepare = prepare_schedule;
1911	frame->check = slf_check_repeat;	2189	frame->check = slf_check_repeat;
1912		2190
1913	/* as a minor optimisation, we could unwind all stacks here */	2191	/* as a minor optimisation, we could unwind all stacks here */
1914	/* but that puts extra pressure on pp_slf, and is not worth much */	2192	/* but that puts extra pressure on pp_slf, and is not worth much */
1915	/*coro_unwind_stacks (aTHX);*/	2193	/*coro_unwind_stacks (aTHX);*/
		2194	}
		2195
		2196	static void
		2197	slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2198	{
		2199	HV *coro_hv = (HV *)SvRV (coro_current);
		2200
		2201	coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items);
		2202	slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
		2203	}
		2204
		2205	static void
		2206	slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2207	{
		2208	HV *coro_hv;
		2209	struct coro *coro;
		2210
		2211	if (items <= 0)
		2212	croak ("Coro::cancel called without coro object,");
		2213
		2214	coro = SvSTATE (arg [0]);
		2215	coro_hv = coro->hv;
		2216
		2217	coro_set_status (aTHX_ coro, arg + 1, items - 1);
		2218
		2219	if (ecb_expect_false (coro->flags & CF_NOCANCEL))
		2220	{
		2221	/* coro currently busy cancelling something, so just notify it */
		2222	coro->slf_frame.data = (void *)coro;
		2223
		2224	frame->prepare = prepare_nop;
		2225	frame->check = slf_check_nop;
		2226	}
		2227	else if (coro_hv == (HV *)SvRV (coro_current))
		2228	{
		2229	/* cancelling the current coro is allowed, and equals terminate */
		2230	slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
		2231	}
		2232	else
		2233	{
		2234	struct coro *self = SvSTATE_current;
		2235
		2236	/* otherwise we cancel directly, purely for speed reasons
		2237	* unfortunately, this requires some magic trickery, as
		2238	* somebody else could cancel us, so we have to fight the cancellation.
		2239	* this is ugly, and hopefully fully worth the extra speed.
		2240	* besides, I can't get the slow-but-safe version working...
		2241	*/
		2242	slf_frame.data = 0;
		2243	self->flags |= CF_NOCANCEL;
		2244	coro_state_destroy (aTHX_ coro);
		2245	self->flags &= ~CF_NOCANCEL;
		2246
		2247	if (slf_frame.data)
		2248	{
		2249	/* while we were busy we have been cancelled, so terminate */
		2250	slf_init_terminate_cancel_common (aTHX_ frame, self->hv);
		2251	}
		2252	else
		2253	{
		2254	frame->prepare = prepare_nop;
		2255	frame->check = slf_check_nop;
		2256	}
		2257	}
		2258	}
		2259
		2260	static int
		2261	slf_check_safe_cancel (pTHX_ struct CoroSLF *frame)
		2262	{
		2263	frame->prepare = 0;
		2264	coro_unwind_stacks (aTHX);
		2265
		2266	slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current));
		2267
		2268	return 1;
		2269	}
		2270
		2271	static int
		2272	safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)
		2273	{
		2274	if (coro->cctx)
		2275	croak ("coro inside C callback, unable to cancel at this time, caught");
		2276
		2277	if (coro->flags & CF_NEW)
		2278	{
		2279	coro_set_status (aTHX_ coro, arg, items);
		2280	coro_state_destroy (aTHX_ coro);
		2281	}
		2282	else
		2283	{
		2284	if (!coro->slf_frame.prepare)
		2285	croak ("coro outside an SLF function, unable to cancel at this time, caught");
		2286
		2287	slf_destroy (aTHX_ coro);
		2288
		2289	coro_set_status (aTHX_ coro, arg, items);
		2290	coro->slf_frame.prepare = prepare_nop;
		2291	coro->slf_frame.check = slf_check_safe_cancel;
		2292
		2293	api_ready (aTHX_ (SV *)coro->hv);
		2294	}
		2295
		2296	return 1;
1916	}	2297	}
1917		2298
1918	/*****************************************************************************/	2299	/*****************************************************************************/
1919	/* async pool handler */	2300	/* async pool handler */
1920		2301
…		…
1951	slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2332	slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1952	{	2333	{
1953	HV *hv = (HV *)SvRV (coro_current);	2334	HV *hv = (HV *)SvRV (coro_current);
1954	struct coro *coro = SvSTATE_hv ((SV *)hv);	2335	struct coro *coro = SvSTATE_hv ((SV *)hv);
1955		2336
1956	if (expect_true (coro->saved_deffh))	2337	if (ecb_expect_true (coro->saved_deffh))
1957	{	2338	{
1958	/* subsequent iteration */	2339	/* subsequent iteration */
1959	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;	2340	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1960	coro->saved_deffh = 0;	2341	coro->saved_deffh = 0;
1961		2342
1962	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)	2343	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
1963	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))	2344	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1964	{	2345	{
1965	coro->invoke_cb = SvREFCNT_inc_NN ((SV *)cv_coro_terminate);	2346	slf_init_terminate_cancel_common (aTHX_ frame, hv);
1966	coro->invoke_av = newAV ();	2347	return;
1967
1968	frame->prepare = prepare_nop;
1969	}	2348	}
1970	else	2349	else
1971	{	2350	{
1972	av_clear (GvAV (PL_defgv));	2351	av_clear (GvAV (PL_defgv));
1973	hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);	2352	hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
…		…
1998		2377
1999	static void	2378	static void
2000	coro_rouse_callback (pTHX_ CV *cv)	2379	coro_rouse_callback (pTHX_ CV *cv)
2001	{	2380	{
2002	dXSARGS;	2381	dXSARGS;
2003	SV *data = (SV *)GENSUB_ARG;	2382	SV *data = (SV *)S_GENSUB_ARG;
2004		2383
2005	if (SvTYPE (SvRV (data)) != SVt_PVAV)	2384	if (SvTYPE (SvRV (data)) != SVt_PVAV)
2006	{	2385	{
2007	/* first call, set args */	2386	/* first call, set args */
2008	SV *coro = SvRV (data);	2387	SV *coro = SvRV (data);
…		…
2023		2402
2024	static int	2403	static int
2025	slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)	2404	slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
2026	{	2405	{
2027	SV *data = (SV *)frame->data;	2406	SV *data = (SV *)frame->data;
2028		2407
2029	if (CORO_THROW)	2408	if (CORO_THROW)
2030	return 0;	2409	return 0;
2031		2410
2032	if (SvTYPE (SvRV (data)) != SVt_PVAV)	2411	if (SvTYPE (SvRV (data)) != SVt_PVAV)
2033	return 1;	2412	return 1;
…		…
2069	cb = sv_2mortal (coro->rouse_cb);	2448	cb = sv_2mortal (coro->rouse_cb);
2070	coro->rouse_cb = 0;	2449	coro->rouse_cb = 0;
2071	}	2450	}
2072		2451
2073	if (!SvROK (cb)	2452	if (!SvROK (cb)
2074	|| SvTYPE (SvRV (cb)) != SVt_PVCV	2453	|| SvTYPE (SvRV (cb)) != SVt_PVCV
2075	|| CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)	2454	|| CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
2076	croak ("Coro::rouse_wait called with illegal callback argument,");	2455	croak ("Coro::rouse_wait called with illegal callback argument,");
2077		2456
2078	{	2457	{
2079	CV *cv = (CV *)SvRV (cb); /* for GENSUB_ARG */	2458	CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
2080	SV *data = (SV *)GENSUB_ARG;	2459	SV *data = (SV *)S_GENSUB_ARG;
2081		2460
2082	frame->data = (void *)data;	2461	frame->data = (void *)data;
2083	frame->prepare = SvTYPE (SvRV (data)) == SVt_PVAV ? prepare_nop : prepare_schedule;	2462	frame->prepare = SvTYPE (SvRV (data)) == SVt_PVAV ? prepare_nop : prepare_schedule;
2084	frame->check = slf_check_rouse_wait;	2463	frame->check = slf_check_rouse_wait;
2085	}	2464	}
…		…
2089	coro_new_rouse_cb (pTHX)	2468	coro_new_rouse_cb (pTHX)
2090	{	2469	{
2091	HV *hv = (HV *)SvRV (coro_current);	2470	HV *hv = (HV *)SvRV (coro_current);
2092	struct coro *coro = SvSTATE_hv (hv);	2471	struct coro *coro = SvSTATE_hv (hv);
2093	SV *data = newRV_inc ((SV *)hv);	2472	SV *data = newRV_inc ((SV *)hv);
2094	SV *cb = gensub (aTHX_ coro_rouse_callback, (void *)data);	2473	SV *cb = s_gensub (aTHX_ coro_rouse_callback, (void *)data);
2095		2474
2096	sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0);	2475	sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0);
2097	SvREFCNT_dec (data); /* magicext increases the refcount */	2476	SvREFCNT_dec (data); /* magicext increases the refcount */
2098		2477
2099	SvREFCNT_dec (coro->rouse_cb);	2478	SvREFCNT_dec (coro->rouse_cb);
…		…
2196	static void	2575	static void
2197	slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2576	slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2198	{	2577	{
2199	frame->prepare = prepare_cede_notself;	2578	frame->prepare = prepare_cede_notself;
2200	frame->check = slf_check_nop;	2579	frame->check = slf_check_nop;
		2580	}
		2581
		2582	/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
		2583	static void
		2584	slf_destroy (pTHX_ struct coro *coro)
		2585	{
		2586	/* this callback is reserved for slf functions needing to do cleanup */
		2587	if (coro->slf_frame.destroy && coro->slf_frame.prepare && !PL_dirty)
		2588	coro->slf_frame.destroy (aTHX_ &coro->slf_frame);
		2589
		2590	/*
		2591	* The on_destroy above most likely is from an SLF call.
		2592	* Since by definition the SLF call will not finish when we destroy
		2593	* the coro, we will have to force-finish it here, otherwise
		2594	* cleanup functions cannot call SLF functions.
		2595	*/
		2596	coro->slf_frame.prepare = 0;
2201	}	2597	}
2202		2598
2203	/*	2599	/*
2204	* these not obviously related functions are all rolled into one	2600	* these not obviously related functions are all rolled into one
2205	* function to increase chances that they all will call transfer with the same	2601	* function to increase chances that they all will call transfer with the same
…		…
2212	I32 checkmark; /* mark SP to see how many elements check has pushed */	2608	I32 checkmark; /* mark SP to see how many elements check has pushed */
2213		2609
2214	/* set up the slf frame, unless it has already been set-up */	2610	/* set up the slf frame, unless it has already been set-up */
2215	/* the latter happens when a new coro has been started */	2611	/* the latter happens when a new coro has been started */
2216	/* or when a new cctx was attached to an existing coroutine */	2612	/* or when a new cctx was attached to an existing coroutine */
2217	if (expect_true (!slf_frame.prepare))	2613	if (ecb_expect_true (!slf_frame.prepare))
2218	{	2614	{
2219	/* first iteration */	2615	/* first iteration */
2220	dSP;	2616	dSP;
2221	SV **arg = PL_stack_base + TOPMARK + 1;	2617	SV **arg = PL_stack_base + TOPMARK + 1;
2222	int items = SP - arg; /* args without function object */	2618	int items = SP - arg; /* args without function object */
…		…
2263	while (slf_frame.check (aTHX_ &slf_frame));	2659	while (slf_frame.check (aTHX_ &slf_frame));
2264		2660
2265	slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */	2661	slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */
2266		2662
2267	/* exception handling */	2663	/* exception handling */
2268	if (expect_false (CORO_THROW))	2664	if (ecb_expect_false (CORO_THROW))
2269	{	2665	{
2270	SV *exception = sv_2mortal (CORO_THROW);	2666	SV *exception = sv_2mortal (CORO_THROW);
2271		2667
2272	CORO_THROW = 0;	2668	CORO_THROW = 0;
2273	sv_setsv (ERRSV, exception);	2669	sv_setsv (ERRSV, exception);
2274	croak (0);	2670	croak (0);
2275	}	2671	}
2276		2672
2277	/* return value handling - mostly like entersub */	2673	/* return value handling - mostly like entersub */
2278	/* make sure we put something on the stack in scalar context */	2674	/* make sure we put something on the stack in scalar context */
2279	if (GIMME_V == G_SCALAR)	2675	if (GIMME_V == G_SCALAR
		2676	&& ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1))
2280	{	2677	{
2281	dSP;	2678	dSP;
2282	SV **bot = PL_stack_base + checkmark;	2679	SV **bot = PL_stack_base + checkmark;
2283		2680
2284	if (sp == bot) /* too few, push undef */	2681	if (sp == bot) /* too few, push undef */
2285	bot [1] = &PL_sv_undef;	2682	bot [1] = &PL_sv_undef;
2286	else if (sp != bot + 1) /* too many, take last one */	2683	else /* too many, take last one */
2287	bot [1] = *sp;	2684	bot [1] = *sp;
2288		2685
2289	SP = bot + 1;	2686	SP = bot + 1;
2290		2687
2291	PUTBACK;	2688	PUTBACK;
…		…
2324	if (PL_op->op_flags & OPf_STACKED)	2721	if (PL_op->op_flags & OPf_STACKED)
2325	{	2722	{
2326	if (items > slf_arga)	2723	if (items > slf_arga)
2327	{	2724	{
2328	slf_arga = items;	2725	slf_arga = items;
2329	free (slf_argv);	2726	Safefree (slf_argv);
2330	slf_argv = malloc (slf_arga * sizeof (SV *));	2727	New (0, slf_argv, slf_arga, SV *);
2331	}	2728	}
2332		2729
2333	slf_argc = items;	2730	slf_argc = items;
2334		2731
2335	for (i = 0; i < items; ++i)	2732	for (i = 0; i < items; ++i)
…		…
2398	{	2795	{
2399	PerlIOBuf base;	2796	PerlIOBuf base;
2400	NV next, every;	2797	NV next, every;
2401	} PerlIOCede;	2798	} PerlIOCede;
2402		2799
2403	static IV	2800	static IV ecb_cold
2404	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)	2801	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2405	{	2802	{
2406	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);	2803	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2407		2804
2408	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;	2805	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
2409	self->next = nvtime () + self->every;	2806	self->next = nvtime () + self->every;
2410		2807
2411	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);	2808	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
2412	}	2809	}
2413		2810
2414	static SV *	2811	static SV * ecb_cold
2415	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)	2812	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
2416	{	2813	{
2417	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);	2814	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2418		2815
2419	return newSVnv (self->every);	2816	return newSVnv (self->every);
…		…
2470	/* Coro::Semaphore & Coro::Signal */	2867	/* Coro::Semaphore & Coro::Signal */
2471		2868
2472	static SV *	2869	static SV *
2473	coro_waitarray_new (pTHX_ int count)	2870	coro_waitarray_new (pTHX_ int count)
2474	{	2871	{
2475	/* a semaphore contains a counter IV in $sem->[0] and any waiters after that */	2872	/* a waitarray=semaphore contains a counter IV in $sem->[0] and any waiters after that */
2476	AV *av = newAV ();	2873	AV *av = newAV ();
2477	SV **ary;	2874	SV **ary;
2478		2875
2479	/* unfortunately, building manually saves memory */	2876	/* unfortunately, building manually saves memory */
2480	Newx (ary, 2, SV *);	2877	Newx (ary, 2, SV *);
…		…
2531	SvREFCNT_dec (cb);	2928	SvREFCNT_dec (cb);
2532	}	2929	}
2533	}	2930	}
2534		2931
2535	static void	2932	static void
2536	coro_semaphore_on_destroy (pTHX_ struct coro *coro)	2933	coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
2537	{	2934	{
2538	/* call $sem->adjust (0) to possibly wake up some other waiters */	2935	/* call $sem->adjust (0) to possibly wake up some other waiters */
2539	coro_semaphore_adjust (aTHX_ (AV *)coro->slf_frame.data, 0);	2936	coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0);
2540	}	2937	}
2541		2938
2542	static int	2939	static int
2543	slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)	2940	slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)
2544	{	2941	{
2545	AV *av = (AV *)frame->data;	2942	AV *av = (AV *)frame->data;
2546	SV *count_sv = AvARRAY (av)[0];	2943	SV *count_sv = AvARRAY (av)[0];
		2944	SV *coro_hv = SvRV (coro_current);
2547		2945
2548	/* if we are about to throw, don't actually acquire the lock, just throw */	2946	/* if we are about to throw, don't actually acquire the lock, just throw */
2549	if (CORO_THROW)	2947	if (CORO_THROW)
2550	return 0;	2948	return 0;
2551	else if (SvIVX (count_sv) > 0)	2949	else if (SvIVX (count_sv) > 0)
2552	{	2950	{
2553	SvSTATE_current->on_destroy = 0;	2951	frame->destroy = 0;
2554		2952
2555	if (acquire)	2953	if (acquire)
2556	SvIVX (count_sv) = SvIVX (count_sv) - 1;	2954	SvIVX (count_sv) = SvIVX (count_sv) - 1;
2557	else	2955	else
2558	coro_semaphore_adjust (aTHX_ av, 0);	2956	coro_semaphore_adjust (aTHX_ av, 0);
…		…
2563	{	2961	{
2564	int i;	2962	int i;
2565	/* if we were woken up but can't down, we look through the whole */	2963	/* if we were woken up but can't down, we look through the whole */
2566	/* waiters list and only add us if we aren't in there already */	2964	/* waiters list and only add us if we aren't in there already */
2567	/* this avoids some degenerate memory usage cases */	2965	/* this avoids some degenerate memory usage cases */
2568		2966	for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */
2569	for (i = 1; i <= AvFILLp (av); ++i)
2570	if (AvARRAY (av)[i] == SvRV (coro_current))	2967	if (AvARRAY (av)[i] == coro_hv)
2571	return 1;	2968	return 1;
2572		2969
2573	av_push (av, SvREFCNT_inc (SvRV (coro_current)));	2970	av_push (av, SvREFCNT_inc (coro_hv));
2574	return 1;	2971	return 1;
2575	}	2972	}
2576	}	2973	}
2577		2974
2578	static int	2975	static int
…		…
2601	{	2998	{
2602	av_push (av, SvREFCNT_inc (SvRV (coro_current)));	2999	av_push (av, SvREFCNT_inc (SvRV (coro_current)));
2603		3000
2604	frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));	3001	frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
2605	frame->prepare = prepare_schedule;	3002	frame->prepare = prepare_schedule;
2606
2607	/* to avoid race conditions when a woken-up coro gets terminated */	3003	/* to avoid race conditions when a woken-up coro gets terminated */
2608	/* we arrange for a temporary on_destroy that calls adjust (0) */	3004	/* we arrange for a temporary on_destroy that calls adjust (0) */
2609	SvSTATE_current->on_destroy = coro_semaphore_on_destroy;	3005	frame->destroy = coro_semaphore_destroy;
2610	}	3006	}
2611	}	3007	}
2612		3008
2613	static void	3009	static void
2614	slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	3010	slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
…		…
2622	{	3018	{
2623	if (items >= 2)	3019	if (items >= 2)
2624	{	3020	{
2625	/* callback form */	3021	/* callback form */
2626	AV *av = (AV *)SvRV (arg [0]);	3022	AV *av = (AV *)SvRV (arg [0]);
2627	CV *cb_cv = coro_sv_2cv (aTHX_ arg [1]);	3023	SV *cb_cv = s_get_cv_croak (arg [1]);
2628		3024
2629	av_push (av, (SV *)SvREFCNT_inc_NN (cb_cv));	3025	av_push (av, SvREFCNT_inc_NN (cb_cv));
2630		3026
2631	if (SvIVX (AvARRAY (av)[0]) > 0)	3027	if (SvIVX (AvARRAY (av)[0]) > 0)
2632	coro_semaphore_adjust (aTHX_ av, 0);	3028	coro_semaphore_adjust (aTHX_ av, 0);
2633		3029
2634	frame->prepare = prepare_nop;	3030	frame->prepare = prepare_nop;
…		…
2658	AvARRAY (av)[0] = AvARRAY (av)[1];	3054	AvARRAY (av)[0] = AvARRAY (av)[1];
2659	AvARRAY (av)[1] = cb;	3055	AvARRAY (av)[1] = cb;
2660		3056
2661	cb = av_shift (av);	3057	cb = av_shift (av);
2662		3058
		3059	if (SvTYPE (cb) == SVt_PVCV)
		3060	{
		3061	dSP;
		3062	PUSHMARK (SP);
		3063	XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
		3064	PUTBACK;
		3065	call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
		3066	}
		3067	else
		3068	{
2663	api_ready (aTHX_ cb);	3069	api_ready (aTHX_ cb);
2664	sv_setiv (cb, 0); /* signal waiter */	3070	sv_setiv (cb, 0); /* signal waiter */
		3071	}
		3072
2665	SvREFCNT_dec (cb);	3073	SvREFCNT_dec (cb);
2666		3074
2667	--count;	3075	--count;
2668	}	3076	}
2669	}	3077	}
…		…
2678	static void	3086	static void
2679	slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	3087	slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2680	{	3088	{
2681	AV *av = (AV *)SvRV (arg [0]);	3089	AV *av = (AV *)SvRV (arg [0]);
2682		3090
		3091	if (items >= 2)
		3092	{
		3093	SV *cb_cv = s_get_cv_croak (arg [1]);
		3094	av_push (av, SvREFCNT_inc_NN (cb_cv));
		3095
2683	if (SvIVX (AvARRAY (av)[0]))	3096	if (SvIVX (AvARRAY (av)[0]))
		3097	coro_signal_wake (aTHX_ av, 1); /* must be the only waiter */
		3098
		3099	frame->prepare = prepare_nop;
		3100	frame->check = slf_check_nop;
		3101	}
		3102	else if (SvIVX (AvARRAY (av)[0]))
2684	{	3103	{
2685	SvIVX (AvARRAY (av)[0]) = 0;	3104	SvIVX (AvARRAY (av)[0]) = 0;
2686	frame->prepare = prepare_nop;	3105	frame->prepare = prepare_nop;
2687	frame->check = slf_check_nop;	3106	frame->check = slf_check_nop;
2688	}	3107	}
2689	else	3108	else
2690	{	3109	{
2691	SV *waiter = newRV_inc (SvRV (coro_current)); /* owned by signal av */	3110	SV *waiter = newSVsv (coro_current); /* owned by signal av */
2692		3111
2693	av_push (av, waiter);	3112	av_push (av, waiter);
2694		3113
2695	frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */	3114	frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */
2696	frame->prepare = prepare_schedule;	3115	frame->prepare = prepare_schedule;
…		…
2714		3133
2715	static void	3134	static void
2716	coro_aio_callback (pTHX_ CV *cv)	3135	coro_aio_callback (pTHX_ CV *cv)
2717	{	3136	{
2718	dXSARGS;	3137	dXSARGS;
2719	AV *state = (AV *)GENSUB_ARG;	3138	AV *state = (AV *)S_GENSUB_ARG;
2720	SV *coro = av_pop (state);	3139	SV *coro = av_pop (state);
2721	SV *data_sv = newSV (sizeof (struct io_state));	3140	SV *data_sv = newSV (sizeof (struct io_state));
2722		3141
2723	av_extend (state, items - 1);	3142	av_extend (state, items - 1);
2724		3143
…		…
2760	/* it quickly returns */	3179	/* it quickly returns */
2761	if (CORO_THROW)	3180	if (CORO_THROW)
2762	return 0;	3181	return 0;
2763		3182
2764	/* one element that is an RV? repeat! */	3183	/* one element that is an RV? repeat! */
2765	if (AvFILLp (state) == 0 && SvROK (AvARRAY (state)[0]))	3184	if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
2766	return 1;	3185	return 1;
2767		3186
2768	/* restore status */	3187	/* restore status */
2769	{	3188	{
2770	SV *data_sv = av_pop (state);	3189	SV *data_sv = av_pop (state);
…		…
2809	dSP;	3228	dSP;
2810		3229
2811	static SV *prio_cv;	3230	static SV *prio_cv;
2812	static SV *prio_sv;	3231	static SV *prio_sv;
2813		3232
2814	if (expect_false (!prio_cv))	3233	if (ecb_expect_false (!prio_cv))
2815	{	3234	{
2816	prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);	3235	prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);
2817	prio_sv = newSViv (0);	3236	prio_sv = newSViv (0);
2818	}	3237	}
2819		3238
…		…
2838		3257
2839	for (i = 0; i < items; ++i)	3258	for (i = 0; i < items; ++i)
2840	PUSHs (arg [i]);	3259	PUSHs (arg [i]);
2841		3260
2842	/* now push the callback closure */	3261	/* now push the callback closure */
2843	PUSHs (sv_2mortal (gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));	3262	PUSHs (sv_2mortal (s_gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));
2844		3263
2845	/* now call the AIO function - we assume our request is uncancelable */	3264	/* now call the AIO function - we assume our request is uncancelable */
2846	PUTBACK;	3265	PUTBACK;
2847	call_sv ((SV *)req, G_VOID | G_DISCARD);	3266	call_sv ((SV *)req, G_VOID | G_DISCARD);
2848	}	3267	}
2849		3268
2850	/* now that the requets is going, we loop toll we have a result */	3269	/* now that the request is going, we loop till we have a result */
2851	frame->data = (void *)state;	3270	frame->data = (void *)state;
2852	frame->prepare = prepare_schedule;	3271	frame->prepare = prepare_schedule;
2853	frame->check = slf_check_aio_req;	3272	frame->check = slf_check_aio_req;
2854	}	3273	}
2855		3274
…		…
2865		3284
2866	/*****************************************************************************/	3285	/*****************************************************************************/
2867		3286
2868	#if CORO_CLONE	3287	#if CORO_CLONE
2869	# include "clone.c"	3288	# include "clone.c"
		3289	#endif
		3290
		3291	/*****************************************************************************/
		3292
		3293	static SV *
		3294	coro_new (pTHX_ HV *stash, SV **argv, int argc, int is_coro)
		3295	{
		3296	SV *coro_sv;
		3297	struct coro *coro;
		3298	MAGIC *mg;
		3299	HV *hv;
		3300	SV *cb;
		3301	int i;
		3302
		3303	if (argc > 0)
		3304	{
		3305	cb = s_get_cv_croak (argv [0]);
		3306
		3307	if (!is_coro)
		3308	{
		3309	if (CvISXSUB (cb))
		3310	croak ("Coro::State doesn't support XS functions as coroutine start, caught");
		3311
		3312	if (!CvROOT (cb))
		3313	croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught");
		3314	}
		3315	}
		3316
		3317	Newz (0, coro, 1, struct coro);
		3318	coro->args = newAV ();
		3319	coro->flags = CF_NEW;
		3320
		3321	if (coro_first) coro_first->prev = coro;
		3322	coro->next = coro_first;
		3323	coro_first = coro;
		3324
		3325	coro->hv = hv = newHV ();
		3326	mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
		3327	mg->mg_flags |= MGf_DUP;
		3328	coro_sv = sv_bless (newRV_noinc ((SV *)hv), stash);
		3329
		3330	if (argc > 0)
		3331	{
		3332	av_extend (coro->args, argc + is_coro - 1);
		3333
		3334	if (is_coro)
		3335	{
		3336	av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb));
		3337	cb = (SV *)cv_coro_run;
		3338	}
		3339
		3340	coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb);
		3341
		3342	for (i = 1; i < argc; i++)
		3343	av_push (coro->args, newSVsv (argv [i]));
		3344	}
		3345
		3346	return coro_sv;
		3347	}
		3348
		3349	#ifndef __cplusplus
		3350	ecb_cold XS(boot_Coro__State);
		3351	#endif
		3352
		3353	#if CORO_JIT
		3354
		3355	static void ecb_noinline ecb_cold
		3356	pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)
		3357	{
		3358	dSP;
		3359	AV *av = newAV ();
		3360
		3361	av_store (av, 3, newSVuv (d));
		3362	av_store (av, 2, newSVuv (c));
		3363	av_store (av, 1, newSVuv (b));
		3364	av_store (av, 0, newSVuv (a));
		3365
		3366	XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		3367
		3368	PUTBACK;
		3369	}
		3370
		3371	static void ecb_noinline ecb_cold
		3372	jit_init (pTHX)
		3373	{
		3374	dSP;
		3375	SV *load, *save;
		3376	char *map_base;
		3377	char *load_ptr, *save_ptr;
		3378	STRLEN load_len, save_len, map_len;
		3379	int count;
		3380
		3381	eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
		3382
		3383	PUSHMARK (SP);
		3384	#define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
		3385	#include "state.h"
		3386	count = call_pv ("Coro::State::_jit", G_ARRAY);
		3387	SPAGAIN;
		3388
		3389	save = POPs; save_ptr = SvPVbyte (save, save_len);
		3390	load = POPs; load_ptr = SvPVbyte (load, load_len);
		3391
		3392	map_len = load_len + save_len + 16;
		3393
		3394	map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
		3395
		3396	assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED));
		3397
		3398	load_perl_slots = (load_save_perl_slots_type)map_base;
		3399	memcpy (map_base, load_ptr, load_len);
		3400
		3401	map_base += (load_len + 15) & ~15;
		3402
		3403	save_perl_slots = (load_save_perl_slots_type)map_base;
		3404	memcpy (map_base, save_ptr, save_len);
		3405
		3406	/* we are good citizens and try to make the page read-only, so the evil evil */
		3407	/* hackers might have it a bit more difficult */
		3408	mprotect (map_base, map_len, PROT_READ | PROT_EXEC);
		3409
		3410	PUTBACK;
		3411	eval_pv ("undef &Coro::State::_jit", 1);
		3412	}
		3413
2870	#endif	3414	#endif
2871		3415
2872	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_	3416	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
2873		3417
2874	PROTOTYPES: DISABLE	3418	PROTOTYPES: DISABLE
…		…
2878	#ifdef USE_ITHREADS	3422	#ifdef USE_ITHREADS
2879	# if CORO_PTHREAD	3423	# if CORO_PTHREAD
2880	coro_thx = PERL_GET_CONTEXT;	3424	coro_thx = PERL_GET_CONTEXT;
2881	# endif	3425	# endif
2882	#endif	3426	#endif
2883	BOOT_PAGESIZE;	3427	/* perl defines these to check for existance first, but why it doesn't */
		3428	/* just create them one at init time is not clear to me, except for */
		3429	/* programs trying to delete them, but... */
		3430	/* anyway, we declare this as invalid and make sure they are initialised here */
		3431	DEFSV;
		3432	ERRSV;
2884		3433
2885	cctx_current = cctx_new_empty ();	3434	cctx_current = cctx_new_empty ();
2886		3435
2887	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);	3436	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
2888	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);	3437	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
…		…
2928	coroapi.prepare_nop = prepare_nop;	3477	coroapi.prepare_nop = prepare_nop;
2929	coroapi.prepare_schedule = prepare_schedule;	3478	coroapi.prepare_schedule = prepare_schedule;
2930	coroapi.prepare_cede = prepare_cede;	3479	coroapi.prepare_cede = prepare_cede;
2931	coroapi.prepare_cede_notself = prepare_cede_notself;	3480	coroapi.prepare_cede_notself = prepare_cede_notself;
2932		3481
2933	{	3482	time_init (aTHX);
2934	SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
2935		3483
2936	if (!svp) croak ("Time::HiRes is required");
2937	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
2938
2939	nvtime = INT2PTR (double (*)(), SvIV (*svp));
2940	}
2941
2942	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));	3484	assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));
		3485	#if CORO_JIT
		3486	PUTBACK;
		3487	jit_init (aTHX);
		3488	SPAGAIN;
		3489	#endif
2943	}	3490	}
2944		3491
2945	SV *	3492	SV *
2946	new (char *klass, ...)	3493	new (SV *klass, ...)
2947	ALIAS:	3494	ALIAS:
2948	Coro::new = 1	3495	Coro::new = 1
2949	CODE:	3496	CODE:
2950	{	3497	RETVAL = coro_new (aTHX_ ix ? coro_stash : coro_state_stash, &ST (1), items - 1, ix);
2951	struct coro *coro;	3498	OUTPUT:
2952	MAGIC *mg;
2953	HV *hv;
2954	CV *cb;
2955	int i;
2956
2957	if (items > 1)
2958	{
2959	cb = coro_sv_2cv (aTHX_ ST (1));
2960
2961	if (!ix)
2962	{
2963	if (CvISXSUB (cb))
2964	croak ("Coro::State doesn't support XS functions as coroutine start, caught");
2965
2966	if (!CvROOT (cb))
2967	croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught");
2968	}
2969	}
2970
2971	Newz (0, coro, 1, struct coro);
2972	coro->args = newAV ();
2973	coro->flags = CF_NEW;
2974
2975	if (coro_first) coro_first->prev = coro;
2976	coro->next = coro_first;
2977	coro_first = coro;
2978
2979	coro->hv = hv = newHV ();
2980	mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
2981	mg->mg_flags |= MGf_DUP;
2982	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
2983
2984	if (items > 1)
2985	{
2986	av_extend (coro->args, items - 1 + ix - 1);
2987
2988	if (ix)
2989	{
2990	av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb));
2991	cb = cv_coro_run;
2992	}
2993
2994	coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb);
2995
2996	for (i = 2; i < items; i++)
2997	av_push (coro->args, newSVsv (ST (i)));
2998	}
2999	}
3000	OUTPUT:
3001	RETVAL	3499	RETVAL
3002		3500
3003	void	3501	void
3004	transfer (...)	3502	transfer (...)
3005	PROTOTYPE: $$	3503	PROTOTYPE: $$
3006	CODE:	3504	CODE:
3007	CORO_EXECUTE_SLF_XS (slf_init_transfer);	3505	CORO_EXECUTE_SLF_XS (slf_init_transfer);
3008
3009	bool
3010	_destroy (SV *coro_sv)
3011	CODE:
3012	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
3013	OUTPUT:
3014	RETVAL
3015
3016	void
3017	_exit (int code)
3018	PROTOTYPE: $
3019	CODE:
3020	_exit (code);
3021		3506
3022	SV *	3507	SV *
3023	clone (Coro::State coro)	3508	clone (Coro::State coro)
3024	CODE:	3509	CODE:
3025	{	3510	{
…		…
3080	void	3565	void
3081	list ()	3566	list ()
3082	PROTOTYPE:	3567	PROTOTYPE:
3083	PPCODE:	3568	PPCODE:
3084	{	3569	{
3085	struct coro *coro;	3570	struct coro *coro;
3086	for (coro = coro_first; coro; coro = coro->next)	3571	for (coro = coro_first; coro; coro = coro->next)
3087	if (coro->hv)	3572	if (coro->hv)
3088	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));	3573	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
3089	}	3574	}
3090		3575
…		…
3095	CODE:	3580	CODE:
3096	{	3581	{
3097	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))	3582	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
3098	{	3583	{
3099	struct coro *current = SvSTATE_current;	3584	struct coro *current = SvSTATE_current;
		3585	struct CoroSLF slf_save;
3100		3586
3101	if (current != coro)	3587	if (current != coro)
3102	{	3588	{
3103	PUTBACK;	3589	PUTBACK;
3104	save_perl (aTHX_ current);	3590	save_perl (aTHX_ current);
3105	load_perl (aTHX_ coro);	3591	load_perl (aTHX_ coro);
		3592	/* the coro is most likely in an active SLF call.
		3593	* while not strictly required (the code we execute is
		3594	* not allowed to call any SLF functions), it's cleaner
		3595	* to reinitialise the slf_frame and restore it later.
		3596	* This might one day allow us to actually do SLF calls
		3597	* from code executed here.
		3598	*/
		3599	slf_save = slf_frame;
		3600	slf_frame.prepare = 0;
3106	SPAGAIN;	3601	SPAGAIN;
3107	}	3602	}
3108		3603
3109	PUSHSTACK;	3604	PUSHSTACK;
3110		3605
…		…
3120	SPAGAIN;	3615	SPAGAIN;
3121		3616
3122	if (current != coro)	3617	if (current != coro)
3123	{	3618	{
3124	PUTBACK;	3619	PUTBACK;
		3620	slf_frame = slf_save;
3125	save_perl (aTHX_ coro);	3621	save_perl (aTHX_ coro);
3126	load_perl (aTHX_ current);	3622	load_perl (aTHX_ current);
3127	SPAGAIN;	3623	SPAGAIN;
3128	}	3624	}
3129	}	3625	}
…		…
3134	PROTOTYPE: $	3630	PROTOTYPE: $
3135	ALIAS:	3631	ALIAS:
3136	is_ready = CF_READY	3632	is_ready = CF_READY
3137	is_running = CF_RUNNING	3633	is_running = CF_RUNNING
3138	is_new = CF_NEW	3634	is_new = CF_NEW
3139	is_destroyed = CF_DESTROYED	3635	is_destroyed = CF_ZOMBIE
		3636	is_zombie = CF_ZOMBIE
3140	is_suspended = CF_SUSPENDED	3637	is_suspended = CF_SUSPENDED
3141	CODE:	3638	CODE:
3142	RETVAL = boolSV (coro->flags & ix);	3639	RETVAL = boolSV (coro->flags & ix);
3143	OUTPUT:	3640	OUTPUT:
3144	RETVAL	3641	RETVAL
3145		3642
3146	void	3643	void
3147	throw (Coro::State self, SV *throw = &PL_sv_undef)	3644	throw (SV *self, SV *exception = &PL_sv_undef)
3148	PROTOTYPE: $;$	3645	PROTOTYPE: $;$
3149	CODE:	3646	CODE:
3150	{	3647	{
		3648	struct coro *coro = SvSTATE (self);
3151	struct coro *current = SvSTATE_current;	3649	struct coro *current = SvSTATE_current;
3152	SV **throwp = self == current ? &CORO_THROW : &self->except;	3650	SV **exceptionp = coro == current ? &CORO_THROW : &coro->except;
3153	SvREFCNT_dec (*throwp);	3651	SvREFCNT_dec (*exceptionp);
3154	*throwp = SvOK (throw) ? newSVsv (throw) : 0;	3652	SvGETMAGIC (exception);
		3653	*exceptionp = SvOK (exception) ? newSVsv (exception) : 0;
		3654
		3655	api_ready (aTHX_ self);
3155	}	3656	}
3156		3657
3157	void	3658	void
3158	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)	3659	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
3159	PROTOTYPE: $;$	3660	PROTOTYPE: $;$
…		…
3214		3715
3215	void	3716	void
3216	cancel (Coro::State self)	3717	cancel (Coro::State self)
3217	CODE:	3718	CODE:
3218	coro_state_destroy (aTHX_ self);	3719	coro_state_destroy (aTHX_ self);
3219	coro_call_on_destroy (aTHX_ self); /* actually only for Coro objects */	3720
		3721	SV *
		3722	enable_times (int enabled = enable_times)
		3723	CODE:
		3724	{
		3725	RETVAL = boolSV (enable_times);
		3726
		3727	if (enabled != enable_times)
		3728	{
		3729	enable_times = enabled;
		3730
		3731	coro_times_update ();
		3732	(enabled ? coro_times_sub : coro_times_add)(SvSTATE (coro_current));
		3733	}
		3734	}
		3735	OUTPUT:
		3736	RETVAL
		3737
		3738	void
		3739	times (Coro::State self)
		3740	PPCODE:
		3741	{
		3742	struct coro *current = SvSTATE (coro_current);
		3743
		3744	if (ecb_expect_false (current == self))
		3745	{
		3746	coro_times_update ();
		3747	coro_times_add (SvSTATE (coro_current));
		3748	}
		3749
		3750	EXTEND (SP, 2);
		3751	PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));
		3752	PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));
		3753
		3754	if (ecb_expect_false (current == self))
		3755	coro_times_sub (SvSTATE (coro_current));
		3756	}
		3757
		3758	void
		3759	swap_sv (Coro::State coro, SV *sv, SV *swapsv)
		3760	CODE:
		3761	{
		3762	struct coro *current = SvSTATE_current;
		3763
		3764	if (current == coro)
		3765	SWAP_SVS (current);
		3766
		3767	if (!coro->swap_sv)
		3768	coro->swap_sv = newAV ();
		3769
		3770	av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (sv )));
		3771	av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (swapsv)));
		3772
		3773	if (current == coro)
		3774	SWAP_SVS (current);
		3775	}
3220		3776
3221		3777
3222	MODULE = Coro::State PACKAGE = Coro	3778	MODULE = Coro::State PACKAGE = Coro
3223		3779
3224	BOOT:	3780	BOOT:
3225	{	3781	{
3226	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);	3782	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
3227	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);	3783	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
3228	cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);	3784	cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);
3229	cv_coro_terminate = get_cv ( "Coro::terminate" , GV_ADD);
3230	coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);	3785	coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);
3231	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);	3786	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
3232	av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);	3787	av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);
3233	sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);	3788	sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);
3234	sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);	3789	sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);
3235		3790
3236	sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);	3791	sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
3237	sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);	3792	sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);
3238	cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);	3793	cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);
3239	cv_coro_state_new = get_cv ("Coro::State::new", 0); SvREADONLY_on (cv_coro_state_new);	3794	CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */
3240		3795
3241	coro_stash = gv_stashpv ("Coro", TRUE);	3796	coro_stash = gv_stashpv ("Coro", TRUE);
3242		3797
3243	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));	3798	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));
3244	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));	3799	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));
3245	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));	3800	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
3246	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));	3801	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (CORO_PRIO_LOW));
3247	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));	3802	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (CORO_PRIO_IDLE));
3248	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));	3803	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (CORO_PRIO_MIN));
3249		3804
3250	{	3805	{
3251	SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);	3806	SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
3252		3807
3253	coroapi.schedule = api_schedule;	3808	coroapi.schedule = api_schedule;
…		…
3263	sv_setiv (sv, (IV)&coroapi);	3818	sv_setiv (sv, (IV)&coroapi);
3264	SvREADONLY_on (sv);	3819	SvREADONLY_on (sv);
3265	}	3820	}
3266	}	3821	}
3267		3822
		3823	SV *
		3824	async (...)
		3825	PROTOTYPE: &@
		3826	CODE:
		3827	RETVAL = coro_new (aTHX_ coro_stash, &ST (0), items, 1);
		3828	api_ready (aTHX_ RETVAL);
		3829	OUTPUT:
		3830	RETVAL
		3831
		3832	void
		3833	_destroy (Coro::State coro)
		3834	CODE:
		3835	/* used by the manager thread */
		3836	coro_state_destroy (aTHX_ coro);
		3837
		3838	void
		3839	on_destroy (Coro::State coro, SV *cb)
		3840	CODE:
		3841	coro_push_on_destroy (aTHX_ coro, newSVsv (cb));
		3842
		3843	void
		3844	join (...)
		3845	CODE:
		3846	CORO_EXECUTE_SLF_XS (slf_init_join);
		3847
3268	void	3848	void
3269	terminate (...)	3849	terminate (...)
3270	CODE:	3850	CODE:
3271	CORO_EXECUTE_SLF_XS (slf_init_terminate);	3851	CORO_EXECUTE_SLF_XS (slf_init_terminate);
		3852
		3853	void
		3854	cancel (...)
		3855	CODE:
		3856	CORO_EXECUTE_SLF_XS (slf_init_cancel);
		3857
		3858	int
		3859	safe_cancel (Coro::State self, ...)
		3860	C_ARGS: aTHX_ self, &ST (1), items - 1
3272		3861
3273	void	3862	void
3274	schedule (...)	3863	schedule (...)
3275	CODE:	3864	CODE:
3276	CORO_EXECUTE_SLF_XS (slf_init_schedule);	3865	CORO_EXECUTE_SLF_XS (slf_init_schedule);
…		…
3305	void	3894	void
3306	_set_readyhook (SV *hook)	3895	_set_readyhook (SV *hook)
3307	PROTOTYPE: $	3896	PROTOTYPE: $
3308	CODE:	3897	CODE:
3309	SvREFCNT_dec (coro_readyhook);	3898	SvREFCNT_dec (coro_readyhook);
		3899	SvGETMAGIC (hook);
		3900	if (SvOK (hook))
		3901	{
3310	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;	3902	coro_readyhook = newSVsv (hook);
		3903	CORO_READYHOOK = invoke_sv_ready_hook_helper;
		3904	}
		3905	else
		3906	{
		3907	coro_readyhook = 0;
		3908	CORO_READYHOOK = 0;
		3909	}
3311		3910
3312	int	3911	int
3313	prio (Coro::State coro, int newprio = 0)	3912	prio (Coro::State coro, int newprio = 0)
3314	PROTOTYPE: $;$	3913	PROTOTYPE: $;$
3315	ALIAS:	3914	ALIAS:
…		…
3321	if (items > 1)	3920	if (items > 1)
3322	{	3921	{
3323	if (ix)	3922	if (ix)
3324	newprio = coro->prio - newprio;	3923	newprio = coro->prio - newprio;
3325		3924
3326	if (newprio < PRIO_MIN) newprio = PRIO_MIN;	3925	if (newprio < CORO_PRIO_MIN) newprio = CORO_PRIO_MIN;
3327	if (newprio > PRIO_MAX) newprio = PRIO_MAX;	3926	if (newprio > CORO_PRIO_MAX) newprio = CORO_PRIO_MAX;
3328		3927
3329	coro->prio = newprio;	3928	coro->prio = newprio;
3330	}	3929	}
3331	}	3930	}
3332	OUTPUT:	3931	OUTPUT:
…		…
3379	for (i = 1; i < items; ++i)	3978	for (i = 1; i < items; ++i)
3380	av_push (av, SvREFCNT_inc_NN (ST (i)));	3979	av_push (av, SvREFCNT_inc_NN (ST (i)));
3381		3980
3382	if ((SV *)hv == &PL_sv_undef)	3981	if ((SV *)hv == &PL_sv_undef)
3383	{	3982	{
3384	PUSHMARK (SP);	3983	SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1);
3385	EXTEND (SP, 2);
3386	PUSHs (sv_Coro);
3387	PUSHs ((SV *)cv_pool_handler);
3388	PUTBACK;
3389	call_sv ((SV *)cv_coro_state_new, G_SCALAR);
3390	SPAGAIN;
3391
3392	hv = (HV *)SvREFCNT_inc_NN (SvRV (POPs));	3984	hv = (HV *)SvREFCNT_inc_NN (SvRV (sv));
		3985	SvREFCNT_dec (sv);
3393	}	3986	}
3394		3987
3395	{	3988	{
3396	struct coro *coro = SvSTATE_hv (hv);	3989	struct coro *coro = SvSTATE_hv (hv);
3397		3990
…		…
3429	on_leave = 1	4022	on_leave = 1
3430	PROTOTYPE: &	4023	PROTOTYPE: &
3431	CODE:	4024	CODE:
3432	{	4025	{
3433	struct coro *coro = SvSTATE_current;	4026	struct coro *coro = SvSTATE_current;
3434	AV **avp = ix ? &coro->on_leave : &coro->on_enter;	4027	AV **avp = ix ? &coro->on_leave : &coro->on_enter;
3435		4028
3436	block = (SV *)coro_sv_2cv (aTHX_ block);	4029	block = s_get_cv_croak (block);
3437		4030
3438	if (!*avp)	4031	if (!*avp)
3439	*avp = newAV ();	4032	*avp = newAV ();
3440		4033
3441	av_push (*avp, SvREFCNT_inc (block));	4034	av_push (*avp, SvREFCNT_inc (block));
…		…
3458	MODULE = Coro::State PACKAGE = Coro::Semaphore	4051	MODULE = Coro::State PACKAGE = Coro::Semaphore
3459		4052
3460	SV *	4053	SV *
3461	new (SV *klass, SV *count = 0)	4054	new (SV *klass, SV *count = 0)
3462	CODE:	4055	CODE:
		4056	{
		4057	int semcnt = 1;
		4058
		4059	if (count)
		4060	{
		4061	SvGETMAGIC (count);
		4062
		4063	if (SvOK (count))
		4064	semcnt = SvIV (count);
		4065	}
		4066
3463	RETVAL = sv_bless (	4067	RETVAL = sv_bless (
3464	coro_waitarray_new (aTHX_ count && SvOK (count) ? SvIV (count) : 1),	4068	coro_waitarray_new (aTHX_ semcnt),
3465	GvSTASH (CvGV (cv))	4069	GvSTASH (CvGV (cv))
3466	);	4070	);
		4071	}
3467	OUTPUT:	4072	OUTPUT:
3468	RETVAL	4073	RETVAL
3469		4074
3470	# helper for Coro::Channel and others	4075	# helper for Coro::Channel and others
3471	SV *	4076	SV *
…		…
3517	XSRETURN_NO;	4122	XSRETURN_NO;
3518	}	4123	}
3519		4124
3520	void	4125	void
3521	waiters (SV *self)	4126	waiters (SV *self)
3522	PPCODE:	4127	PPCODE:
3523	{	4128	{
3524	AV *av = (AV *)SvRV (self);	4129	AV *av = (AV *)SvRV (self);
3525	int wcount = AvFILLp (av) + 1 - 1;	4130	int wcount = AvFILLp (av) + 1 - 1;
3526		4131
3527	if (GIMME_V == G_SCALAR)	4132	if (GIMME_V == G_SCALAR)
…		…
3536	}	4141	}
3537		4142
3538	MODULE = Coro::State PACKAGE = Coro::SemaphoreSet	4143	MODULE = Coro::State PACKAGE = Coro::SemaphoreSet
3539		4144
3540	void	4145	void
3541	_may_delete (SV *sem, int count, int extra_refs)	4146	_may_delete (SV *sem, int count, unsigned int extra_refs)
3542	PPCODE:	4147	PPCODE:
3543	{	4148	{
3544	AV *av = (AV *)SvRV (sem);	4149	AV *av = (AV *)SvRV (sem);
3545		4150
3546	if (SvREFCNT ((SV *)av) == 1 + extra_refs	4151	if (SvREFCNT ((SV *)av) == 1 + extra_refs
3547	&& AvFILLp (av) == 0 /* no waiters, just count */	4152	&& AvFILLp (av) == 0 /* no waiters, just count */
3548	&& SvIV (AvARRAY (av)[0]) == count)	4153	&& SvIV (AvARRAY (av)[0]) == count)
3549	XSRETURN_YES;	4154	XSRETURN_YES;
…		…
3570		4175
3571	void	4176	void
3572	broadcast (SV *self)	4177	broadcast (SV *self)
3573	CODE:	4178	CODE:
3574	{	4179	{
3575	AV *av = (AV *)SvRV (self);	4180	AV *av = (AV *)SvRV (self);
3576	coro_signal_wake (aTHX_ av, AvFILLp (av));	4181	coro_signal_wake (aTHX_ av, AvFILLp (av));
3577	}	4182	}
3578		4183
3579	void	4184	void
3580	send (SV *self)	4185	send (SV *self)
…		…
3588	SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */	4193	SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
3589	}	4194	}
3590		4195
3591	IV	4196	IV
3592	awaited (SV *self)	4197	awaited (SV *self)
3593	CODE:	4198	CODE:
3594	RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;	4199	RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
3595	OUTPUT:	4200	OUTPUT:
3596	RETVAL	4201	RETVAL
3597		4202
3598		4203
…		…
3603		4208
3604	void	4209	void
3605	_schedule (...)	4210	_schedule (...)
3606	CODE:	4211	CODE:
3607	{	4212	{
3608	static int incede;	4213	static int incede;
3609		4214
3610	api_cede_notself (aTHX);	4215	api_cede_notself (aTHX);
3611		4216
3612	++incede;	4217	++incede;
3613	while (coro_nready >= incede && api_cede (aTHX))	4218	while (coro_nready >= incede && api_cede (aTHX))
…		…
3629		4234
3630	void	4235	void
3631	_register (char *target, char *proto, SV *req)	4236	_register (char *target, char *proto, SV *req)
3632	CODE:	4237	CODE:
3633	{	4238	{
3634	CV *req_cv = coro_sv_2cv (aTHX_ req);	4239	SV *req_cv = s_get_cv_croak (req);
3635	/* newXSproto doesn't return the CV on 5.8 */	4240	/* newXSproto doesn't return the CV on 5.8 */
3636	CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);	4241	CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);
3637	sv_setpv ((SV *)slf_cv, proto);	4242	sv_setpv ((SV *)slf_cv, proto);
3638	sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);	4243	sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);
3639	}	4244	}
3640		4245
		4246	MODULE = Coro::State PACKAGE = Coro::Select
		4247
		4248	void
		4249	patch_pp_sselect ()
		4250	CODE:
		4251	if (!coro_old_pp_sselect)
		4252	{
		4253	coro_select_select = (SV *)get_cv ("Coro::Select::select", 0);
		4254	coro_old_pp_sselect = PL_ppaddr [OP_SSELECT];
		4255	PL_ppaddr [OP_SSELECT] = coro_pp_sselect;
		4256	}
		4257
		4258	void
		4259	unpatch_pp_sselect ()
		4260	CODE:
		4261	if (coro_old_pp_sselect)
		4262	{
		4263	PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
		4264	coro_old_pp_sselect = 0;
		4265	}
		4266
		4267	MODULE = Coro::State PACKAGE = Coro::Util
		4268
		4269	void
		4270	_exit (int code)
		4271	CODE:
		4272	_exit (code);
		4273
		4274	NV
		4275	time ()
		4276	CODE:
		4277	RETVAL = nvtime (aTHX);
		4278	OUTPUT:
		4279	RETVAL
		4280
		4281	NV
		4282	gettimeofday ()
		4283	PPCODE:
		4284	{
		4285	UV tv [2];
		4286	u2time (aTHX_ tv);
		4287	EXTEND (SP, 2);
		4288	PUSHs (sv_2mortal (newSVuv (tv [0])));
		4289	PUSHs (sv_2mortal (newSVuv (tv [1])));
		4290	}
		4291

Diff Legend

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