ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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