ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.352 by root, Sat Jun 20 08:58:50 2009 UTC vs.
Revision 1.440 by root, Sat Feb 22 14:12:45 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) = 0;
…		…
953	/* this newly created coroutine might be run on an existing cctx which most	1163	/* 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.	1164	* likely was suspended in pp_slf, so we have to emulate entering pp_slf here.
955	*/	1165	*/
956	slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */	1166	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 */	1167	slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */
		1168	slf_frame.destroy = 0;
958		1169
959	/* and we have to provide the pp_slf op in any case, so pp_slf can skip it */	1170	/* 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;	1171	init_perl_op.op_next = PL_op;
961	coro_setup_op.op_type = OP_ENTERSUB;	1172	init_perl_op.op_type = OP_ENTERSUB;
962	coro_setup_op.op_ppaddr = pp_slf;	1173	init_perl_op.op_ppaddr = pp_slf;
963	/* no flags etc. required, as an init function won't be called */	1174	/* no flags etc. required, as an init function won't be called */
964		1175
965	PL_op = (OP *)&coro_setup_op;	1176	PL_op = (OP *)&init_perl_op;
966		1177
967	/* copy throw, in case it was set before coro_setup */	1178	/* copy throw, in case it was set before init_perl */
968	CORO_THROW = coro->except;	1179	CORO_THROW = coro->except;
		1180
		1181	SWAP_SVS (coro);
		1182
		1183	if (ecb_expect_false (enable_times))
		1184	{
		1185	coro_times_update ();
		1186	coro_times_sub (coro);
		1187	}
969	}	1188	}
970		1189
971	static void	1190	static void
972	coro_unwind_stacks (pTHX)	1191	coro_unwind_stacks (pTHX)
973	{	1192	{
…		…
988	dounwind (-1);	1207	dounwind (-1);
989	}	1208	}
990	}	1209	}
991		1210
992	static void	1211	static void
993	coro_destruct_perl (pTHX_ struct coro *coro)	1212	destroy_perl (pTHX_ struct coro *coro)
994	{	1213	{
995	SV *svf [9];	1214	SV *svf [9];
996		1215
997	{	1216	{
		1217	SV *old_current = SvRV (coro_current);
998	struct coro *current = SvSTATE_current;	1218	struct coro *current = SvSTATE (old_current);
999		1219
1000	assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));	1220	assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));
1001		1221
1002	save_perl (aTHX_ current);	1222	save_perl (aTHX_ current);
		1223
		1224	/* this will cause transfer_check to croak on block*/
		1225	SvRV_set (coro_current, (SV *)coro->hv);
		1226
1003	load_perl (aTHX_ coro);	1227	load_perl (aTHX_ coro);
1004		1228
1005	coro_unwind_stacks (aTHX);	1229	coro_unwind_stacks (aTHX);
		1230
		1231	/* restore swapped sv's */
		1232	SWAP_SVS (coro);
		1233
1006	coro_destruct_stacks (aTHX);	1234	coro_destruct_stacks (aTHX);
1007		1235
1008	// now save some sv's to be free'd later	1236	/* now save some sv's to be free'd later */
1009	svf [0] = GvSV (PL_defgv);	1237	svf [0] = GvSV (PL_defgv);
1010	svf [1] = (SV *)GvAV (PL_defgv);	1238	svf [1] = (SV *)GvAV (PL_defgv);
1011	svf [2] = GvSV (PL_errgv);	1239	svf [2] = GvSV (PL_errgv);
1012	svf [3] = (SV *)PL_defoutgv;	1240	svf [3] = (SV *)PL_defoutgv;
1013	svf [4] = PL_rs;	1241	svf [4] = PL_rs;
…		…
1015	svf [6] = (SV *)GvHV (PL_hintgv);	1243	svf [6] = (SV *)GvHV (PL_hintgv);
1016	svf [7] = PL_diehook;	1244	svf [7] = PL_diehook;
1017	svf [8] = PL_warnhook;	1245	svf [8] = PL_warnhook;
1018	assert (9 == sizeof (svf) / sizeof (*svf));	1246	assert (9 == sizeof (svf) / sizeof (*svf));
1019		1247
		1248	SvRV_set (coro_current, old_current);
		1249
1020	load_perl (aTHX_ current);	1250	load_perl (aTHX_ current);
1021	}	1251	}
1022		1252
1023	{	1253	{
1024	int i;	1254	unsigned int i;
1025		1255
1026	for (i = 0; i < sizeof (svf) / sizeof (*svf); ++i)	1256	for (i = 0; i < sizeof (svf) / sizeof (*svf); ++i)
1027	SvREFCNT_dec (svf [i]);	1257	SvREFCNT_dec (svf [i]);
1028		1258
1029	SvREFCNT_dec (coro->saved_deffh);	1259	SvREFCNT_dec (coro->saved_deffh);
…		…
1031	SvREFCNT_dec (coro->invoke_cb);	1261	SvREFCNT_dec (coro->invoke_cb);
1032	SvREFCNT_dec (coro->invoke_av);	1262	SvREFCNT_dec (coro->invoke_av);
1033	}	1263	}
1034	}	1264	}
1035		1265
1036	INLINE void	1266	ecb_inline void
1037	free_coro_mortal (pTHX)	1267	free_coro_mortal (pTHX)
1038	{	1268	{
1039	if (expect_true (coro_mortal))	1269	if (ecb_expect_true (coro_mortal))
1040	{	1270	{
1041	SvREFCNT_dec (coro_mortal);	1271	SvREFCNT_dec ((SV *)coro_mortal);
1042	coro_mortal = 0;	1272	coro_mortal = 0;
1043	}	1273	}
1044	}	1274	}
1045		1275
1046	static int	1276	static int
…		…
1179		1409
1180	return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */	1410	return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */
1181	}	1411	}
1182		1412
1183	/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */	1413	/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */
1184	static void NOINLINE	1414	static void ecb_noinline
1185	cctx_prepare (pTHX)	1415	cctx_prepare (pTHX)
1186	{	1416	{
1187	PL_top_env = &PL_start_env;	1417	PL_top_env = &PL_start_env;
1188		1418
1189	if (cctx_current->flags & CC_TRACE)	1419	if (cctx_current->flags & CC_TRACE)
…		…
1200	slf_frame.prepare = slf_prepare_set_stacklevel;	1430	slf_frame.prepare = slf_prepare_set_stacklevel;
1201	slf_frame.check = slf_check_set_stacklevel;	1431	slf_frame.check = slf_check_set_stacklevel;
1202	}	1432	}
1203		1433
1204	/* the tail of transfer: execute stuff we can only do after a transfer */	1434	/* the tail of transfer: execute stuff we can only do after a transfer */
1205	INLINE void	1435	ecb_inline void
1206	transfer_tail (pTHX)	1436	transfer_tail (pTHX)
1207	{	1437	{
1208	free_coro_mortal (aTHX);	1438	free_coro_mortal (aTHX);
		1439	}
		1440
		1441	/* try to exit the same way perl's main function would do */
		1442	/* we do not bother resetting the environment or other things *7
		1443	/* that are not, uhm, essential */
		1444	/* this obviously also doesn't work when perl is embedded */
		1445	static void ecb_noinline ecb_cold
		1446	perlish_exit (pTHX)
		1447	{
		1448	int exitstatus = perl_destruct (PL_curinterp);
		1449	perl_free (PL_curinterp);
		1450	exit (exitstatus);
1209	}	1451	}
1210		1452
1211	/*	1453	/*
1212	* this is a _very_ stripped down perl interpreter ;)	1454	* this is a _very_ stripped down perl interpreter ;)
1213	*/	1455	*/
…		…
1235	/* somebody or something will hit me for both perl_run and PL_restartop */	1477	/* somebody or something will hit me for both perl_run and PL_restartop */
1236	PL_restartop = PL_op;	1478	PL_restartop = PL_op;
1237	perl_run (PL_curinterp);	1479	perl_run (PL_curinterp);
1238	/*	1480	/*
1239	* Unfortunately, there is no way to get at the return values of the	1481	* Unfortunately, there is no way to get at the return values of the
1240	* coro body here, as perl_run destroys these	1482	* coro body here, as perl_run destroys these. Likewise, we cannot catch
		1483	* runtime errors here, as this is just a random interpreter, not a thread.
1241	*/	1484	*/
1242		1485
1243	/*	1486	/*
1244	* If perl-run returns we assume exit() was being called or the coro	1487	* If perl-run returns we assume exit() was being called or the coro
1245	* fell off the end, which seems to be the only valid (non-bug)	1488	* fell off the end, which seems to be the only valid (non-bug)
1246	* reason for perl_run to return. We try to exit by jumping to the	1489	* reason for perl_run to return. We try to mimic whatever perl is normally
1247	* bootstrap-time "top" top_env, as we cannot restore the "main"	1490	* doing in that case. YMMV.
1248	* coroutine as Coro has no such concept.
1249	* This actually isn't valid with the pthread backend, but OSes requiring
1250	* that backend are too broken to do it in a standards-compliant way.
1251	*/	1491	*/
1252	PL_top_env = main_top_env;	1492	perlish_exit (aTHX);
1253	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
1254	}	1493	}
1255	}	1494	}
1256		1495
1257	static coro_cctx *	1496	static coro_cctx *
1258	cctx_new ()	1497	cctx_new (void)
1259	{	1498	{
1260	coro_cctx *cctx;	1499	coro_cctx *cctx;
1261		1500
1262	++cctx_count;	1501	++cctx_count;
1263	New (0, cctx, 1, coro_cctx);	1502	New (0, cctx, 1, coro_cctx);
…		…
1269	return cctx;	1508	return cctx;
1270	}	1509	}
1271		1510
1272	/* create a new cctx only suitable as source */	1511	/* create a new cctx only suitable as source */
1273	static coro_cctx *	1512	static coro_cctx *
1274	cctx_new_empty ()	1513	cctx_new_empty (void)
1275	{	1514	{
1276	coro_cctx *cctx = cctx_new ();	1515	coro_cctx *cctx = cctx_new ();
1277		1516
1278	cctx->sptr = 0;	1517	cctx->stack.sptr = 0;
1279	coro_create (&cctx->cctx, 0, 0, 0, 0);	1518	coro_create (&cctx->cctx, 0, 0, 0, 0);
1280		1519
1281	return cctx;	1520	return cctx;
1282	}	1521	}
1283		1522
1284	/* create a new cctx suitable as destination/running a perl interpreter */	1523	/* create a new cctx suitable as destination/running a perl interpreter */
1285	static coro_cctx *	1524	static coro_cctx *
1286	cctx_new_run ()	1525	cctx_new_run (void)
1287	{	1526	{
1288	coro_cctx *cctx = cctx_new ();	1527	coro_cctx *cctx = cctx_new ();
1289	void *stack_start;
1290	size_t stack_size;
1291		1528
1292	#if HAVE_MMAP	1529	if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
1293	cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
1294	/* mmap supposedly does allocate-on-write for us */
1295	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
1296
1297	if (cctx->sptr != (void *)-1)
1298	{
1299	#if CORO_STACKGUARD
1300	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
1301	#endif
1302	stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE;
1303	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
1304	cctx->flags |= CC_MAPPED;
1305	}	1530	{
1306	else
1307	#endif
1308	{
1309	cctx->ssize = cctx_stacksize * (long)sizeof (long);
1310	New (0, cctx->sptr, cctx_stacksize, long);
1311
1312	if (!cctx->sptr)
1313	{
1314	perror ("FATAL: unable to allocate stack for coroutine, exiting.");	1531	perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1315	_exit (EXIT_FAILURE);	1532	_exit (EXIT_FAILURE);
1316	}
1317
1318	stack_start = cctx->sptr;
1319	stack_size = cctx->ssize;
1320	}	1533	}
1321		1534
1322	#if CORO_USE_VALGRIND
1323	cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size);
1324	#endif
1325
1326	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);	1535	coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze);
1327		1536
1328	return cctx;	1537	return cctx;
1329	}	1538	}
1330		1539
1331	static void	1540	static void
1332	cctx_destroy (coro_cctx *cctx)	1541	cctx_destroy (coro_cctx *cctx)
1333	{	1542	{
1334	if (!cctx)	1543	if (!cctx)
1335	return;	1544	return;
1336		1545
1337	assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));//D temporary?	1546	assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
1338		1547
1339	--cctx_count;	1548	--cctx_count;
1340	coro_destroy (&cctx->cctx);	1549	coro_destroy (&cctx->cctx);
1341		1550
1342	/* coro_transfer creates new, empty cctx's */	1551	coro_stack_free (&cctx->stack);
1343	if (cctx->sptr)
1344	{
1345	#if CORO_USE_VALGRIND
1346	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1347	#endif
1348
1349	#if HAVE_MMAP
1350	if (cctx->flags & CC_MAPPED)
1351	munmap (cctx->sptr, cctx->ssize);
1352	else
1353	#endif
1354	Safefree (cctx->sptr);
1355	}
1356		1552
1357	Safefree (cctx);	1553	Safefree (cctx);
1358	}	1554	}
1359		1555
1360	/* wether this cctx should be destructed */	1556	/* wether this cctx should be destructed */
1361	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))	1557	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1362		1558
1363	static coro_cctx *	1559	static coro_cctx *
1364	cctx_get (pTHX)	1560	cctx_get (pTHX)
1365	{	1561	{
1366	while (expect_true (cctx_first))	1562	while (ecb_expect_true (cctx_first))
1367	{	1563	{
1368	coro_cctx *cctx = cctx_first;	1564	coro_cctx *cctx = cctx_first;
1369	cctx_first = cctx->next;	1565	cctx_first = cctx->next;
1370	--cctx_idle;	1566	--cctx_idle;
1371		1567
1372	if (expect_true (!CCTX_EXPIRED (cctx)))	1568	if (ecb_expect_true (!CCTX_EXPIRED (cctx)))
1373	return cctx;	1569	return cctx;
1374		1570
1375	cctx_destroy (cctx);	1571	cctx_destroy (cctx);
1376	}	1572	}
1377		1573
…		…
1379	}	1575	}
1380		1576
1381	static void	1577	static void
1382	cctx_put (coro_cctx *cctx)	1578	cctx_put (coro_cctx *cctx)
1383	{	1579	{
1384	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr));	1580	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr));
1385		1581
1386	/* free another cctx if overlimit */	1582	/* free another cctx if overlimit */
1387	if (expect_false (cctx_idle >= cctx_max_idle))	1583	if (ecb_expect_false (cctx_idle >= cctx_max_idle))
1388	{	1584	{
1389	coro_cctx *first = cctx_first;	1585	coro_cctx *first = cctx_first;
1390	cctx_first = first->next;	1586	cctx_first = first->next;
1391	--cctx_idle;	1587	--cctx_idle;
1392		1588
…		…
1403	static void	1599	static void
1404	transfer_check (pTHX_ struct coro *prev, struct coro *next)	1600	transfer_check (pTHX_ struct coro *prev, struct coro *next)
1405	{	1601	{
1406	/* TODO: throwing up here is considered harmful */	1602	/* TODO: throwing up here is considered harmful */
1407		1603
1408	if (expect_true (prev != next))	1604	if (ecb_expect_true (prev != next))
1409	{	1605	{
1410	if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))	1606	if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1411	croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");	1607	croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");
1412		1608
1413	if (expect_false (next->flags & (CF_RUNNING | CF_DESTROYED | CF_SUSPENDED)))	1609	if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED)))
1414	croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");	1610	croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");
1415		1611
1416	#if !PERL_VERSION_ATLEAST (5,10,0)	1612	#if !PERL_VERSION_ATLEAST (5,10,0)
1417	if (expect_false (PL_lex_state != LEX_NOTPARSING))	1613	if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING))
1418	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");	1614	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");
1419	#endif	1615	#endif
1420	}	1616	}
1421	}	1617	}
1422		1618
1423	/* always use the TRANSFER macro */	1619	/* always use the TRANSFER macro */
1424	static void NOINLINE /* noinline so we have a fixed stackframe */	1620	static void ecb_noinline /* noinline so we have a fixed stackframe */
1425	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)	1621	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1426	{	1622	{
1427	dSTACKLEVEL;	1623	dSTACKLEVEL;
1428		1624
1429	/* sometimes transfer is only called to set idle_sp */	1625	/* sometimes transfer is only called to set idle_sp */
1430	if (expect_false (!prev))	1626	if (ecb_expect_false (!prev))
1431	{	1627	{
1432	cctx_current->idle_sp = STACKLEVEL;	1628	cctx_current->idle_sp = STACKLEVEL;
1433	assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */	1629	assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1434	}	1630	}
1435	else if (expect_true (prev != next))	1631	else if (ecb_expect_true (prev != next))
1436	{	1632	{
1437	coro_cctx *cctx_prev;	1633	coro_cctx *cctx_prev;
1438		1634
1439	if (expect_false (prev->flags & CF_NEW))	1635	if (ecb_expect_false (prev->flags & CF_NEW))
1440	{	1636	{
1441	/* create a new empty/source context */	1637	/* create a new empty/source context */
1442	prev->flags &= ~CF_NEW;	1638	prev->flags &= ~CF_NEW;
1443	prev->flags |= CF_RUNNING;	1639	prev->flags |= CF_RUNNING;
1444	}	1640	}
…		…
1447	next->flags |= CF_RUNNING;	1643	next->flags |= CF_RUNNING;
1448		1644
1449	/* first get rid of the old state */	1645	/* first get rid of the old state */
1450	save_perl (aTHX_ prev);	1646	save_perl (aTHX_ prev);
1451		1647
1452	if (expect_false (next->flags & CF_NEW))	1648	if (ecb_expect_false (next->flags & CF_NEW))
1453	{	1649	{
1454	/* need to start coroutine */	1650	/* need to start coroutine */
1455	next->flags &= ~CF_NEW;	1651	next->flags &= ~CF_NEW;
1456	/* setup coroutine call */	1652	/* setup coroutine call */
1457	coro_setup (aTHX_ next);	1653	init_perl (aTHX_ next);
1458	}	1654	}
1459	else	1655	else
1460	load_perl (aTHX_ next);	1656	load_perl (aTHX_ next);
1461		1657
1462	/* possibly untie and reuse the cctx */	1658	/* possibly untie and reuse the cctx */
1463	if (expect_true (	1659	if (ecb_expect_true (
1464	cctx_current->idle_sp == STACKLEVEL	1660	cctx_current->idle_sp == STACKLEVEL
1465	&& !(cctx_current->flags & CC_TRACE)	1661	&& !(cctx_current->flags & CC_TRACE)
1466	&& !force_cctx	1662	&& !force_cctx
1467	))	1663	))
1468	{	1664	{
1469	/* I assume that stacklevel is a stronger indicator than PL_top_env changes */	1665	/* I assume that stacklevel is a stronger indicator than PL_top_env changes */
1470	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));	1666	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));
1471		1667
1472	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */	1668	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */
1473	/* without this the next cctx_get might destroy the running cctx while still in use */	1669	/* without this the next cctx_get might destroy the running cctx while still in use */
1474	if (expect_false (CCTX_EXPIRED (cctx_current)))	1670	if (ecb_expect_false (CCTX_EXPIRED (cctx_current)))
1475	if (expect_true (!next->cctx))	1671	if (ecb_expect_true (!next->cctx))
1476	next->cctx = cctx_get (aTHX);	1672	next->cctx = cctx_get (aTHX);
1477		1673
1478	cctx_put (cctx_current);	1674	cctx_put (cctx_current);
1479	}	1675	}
1480	else	1676	else
1481	prev->cctx = cctx_current;	1677	prev->cctx = cctx_current;
1482		1678
1483	++next->usecount;	1679	++next->usecount;
1484		1680
1485	cctx_prev = cctx_current;	1681	cctx_prev = cctx_current;
1486	cctx_current = expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);	1682	cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);
1487		1683
1488	next->cctx = 0;	1684	next->cctx = 0;
1489		1685
1490	if (expect_false (cctx_prev != cctx_current))	1686	if (ecb_expect_false (cctx_prev != cctx_current))
1491	{	1687	{
1492	cctx_prev->top_env = PL_top_env;	1688	cctx_prev->top_env = PL_top_env;
1493	PL_top_env = cctx_current->top_env;	1689	PL_top_env = cctx_current->top_env;
1494	coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);	1690	coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);
1495	}	1691	}
…		…
1501	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))	1697	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1502	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)	1698	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1503		1699
1504	/** high level stuff ********************************************************/	1700	/** high level stuff ********************************************************/
1505		1701
		1702	/* this function is actually Coro, not Coro::State, but we call it from here */
		1703	/* because it is convenient - but it hasn't been declared yet for that reason */
1506	static int	1704	static void
		1705	coro_call_on_destroy (pTHX_ struct coro *coro);
		1706
		1707	static void
1507	coro_state_destroy (pTHX_ struct coro *coro)	1708	coro_state_destroy (pTHX_ struct coro *coro)
1508	{	1709	{
1509	if (coro->flags & CF_DESTROYED)	1710	if (coro->flags & CF_ZOMBIE)
1510	return 0;	1711	return;
1511		1712
1512	if (coro->on_destroy && !PL_dirty)
1513	coro->on_destroy (aTHX_ coro);	1713	slf_destroy (aTHX_ coro);
1514		1714
1515	coro->flags |= CF_DESTROYED;	1715	coro->flags |= CF_ZOMBIE;
1516		1716
1517	if (coro->flags & CF_READY)	1717	if (coro->flags & CF_READY)
1518	{	1718	{
1519	/* reduce nready, as destroying a ready coro effectively unreadies it */	1719	/* reduce nready, as destroying a ready coro effectively unreadies it */
1520	/* alternative: look through all ready queues and remove the coro */	1720	/* alternative: look through all ready queues and remove the coro */
1521	--coro_nready;	1721	--coro_nready;
1522	}	1722	}
1523	else	1723	else
1524	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */	1724	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
		1725
		1726	if (coro->next) coro->next->prev = coro->prev;
		1727	if (coro->prev) coro->prev->next = coro->next;
		1728	if (coro == coro_first) coro_first = coro->next;
1525		1729
1526	if (coro->mainstack	1730	if (coro->mainstack
1527	&& coro->mainstack != main_mainstack	1731	&& coro->mainstack != main_mainstack
1528	&& coro->slot	1732	&& coro->slot
1529	&& !PL_dirty)	1733	&& !PL_dirty)
1530	coro_destruct_perl (aTHX_ coro);	1734	destroy_perl (aTHX_ coro);
1531		1735
1532	cctx_destroy (coro->cctx);	1736	cctx_destroy (coro->cctx);
1533	SvREFCNT_dec (coro->startcv);	1737	SvREFCNT_dec (coro->startcv);
1534	SvREFCNT_dec (coro->args);	1738	SvREFCNT_dec (coro->args);
		1739	SvREFCNT_dec (coro->swap_sv);
1535	SvREFCNT_dec (CORO_THROW);	1740	SvREFCNT_dec (CORO_THROW);
1536		1741
1537	if (coro->next) coro->next->prev = coro->prev;	1742	coro_call_on_destroy (aTHX_ coro);
1538	if (coro->prev) coro->prev->next = coro->next;
1539	if (coro == coro_first) coro_first = coro->next;
1540		1743
1541	return 1;	1744	/* more destruction mayhem in coro_state_free */
1542	}	1745	}
1543		1746
1544	static int	1747	static int
1545	coro_state_free (pTHX_ SV *sv, MAGIC *mg)	1748	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1546	{	1749	{
1547	struct coro *coro = (struct coro *)mg->mg_ptr;	1750	struct coro *coro = (struct coro *)mg->mg_ptr;
1548	mg->mg_ptr = 0;	1751	mg->mg_ptr = 0;
1549		1752
1550	coro->hv = 0;
1551
1552	if (--coro->refcnt < 0)
1553	{
1554	coro_state_destroy (aTHX_ coro);	1753	coro_state_destroy (aTHX_ coro);
		1754	SvREFCNT_dec (coro->on_destroy);
		1755	SvREFCNT_dec (coro->status);
		1756
1555	Safefree (coro);	1757	Safefree (coro);
1556	}
1557		1758
1558	return 0;	1759	return 0;
1559	}	1760	}
1560		1761
1561	static int	1762	static int ecb_cold
1562	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)	1763	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1563	{	1764	{
1564	struct coro *coro = (struct coro *)mg->mg_ptr;	1765	/* called when perl clones the current process the slow way (windows process emulation) */
1565		1766	/* WE SIMply nuke the pointers in the copy, causing perl to croak */
1566	++coro->refcnt;	1767	mg->mg_ptr = 0;
		1768	mg->mg_virtual = 0;
1567		1769
1568	return 0;	1770	return 0;
1569	}	1771	}
1570		1772
1571	static MGVTBL coro_state_vtbl = {	1773	static MGVTBL coro_state_vtbl = {
…		…
1594		1796
1595	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);	1797	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
1596	TRANSFER (ta, 1);	1798	TRANSFER (ta, 1);
1597	}	1799	}
1598		1800
1599	/*****************************************************************************/
1600	/* gensub: simple closure generation utility */
1601
1602	#define GENSUB_ARG CvXSUBANY (cv).any_ptr
1603
1604	/* create a closure from XS, returns a code reference */
1605	/* the arg can be accessed via GENSUB_ARG from the callback */
1606	/* the callback must use dXSARGS/XSRETURN */
1607	static SV *
1608	gensub (pTHX_ void (*xsub)(pTHX_ CV *), void *arg)
1609	{
1610	CV *cv = (CV *)newSV (0);
1611
1612	sv_upgrade ((SV *)cv, SVt_PVCV);
1613
1614	CvANON_on (cv);
1615	CvISXSUB_on (cv);
1616	CvXSUB (cv) = xsub;
1617	GENSUB_ARG = arg;
1618
1619	return newRV_noinc ((SV *)cv);
1620	}
1621
1622	/** Coro ********************************************************************/	1801	/** Coro ********************************************************************/
1623		1802
1624	INLINE void	1803	ecb_inline void
1625	coro_enq (pTHX_ struct coro *coro)	1804	coro_enq (pTHX_ struct coro *coro)
1626	{	1805	{
1627	struct coro **ready = coro_ready [coro->prio - PRIO_MIN];	1806	struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
1628		1807
1629	SvREFCNT_inc_NN (coro->hv);	1808	SvREFCNT_inc_NN (coro->hv);
1630		1809
1631	coro->next_ready = 0;	1810	coro->next_ready = 0;
1632	*(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;	1811	*(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
1633	ready [1] = coro;	1812	ready [1] = coro;
1634	}	1813	}
1635		1814
1636	INLINE struct coro *	1815	ecb_inline struct coro *
1637	coro_deq (pTHX)	1816	coro_deq (pTHX)
1638	{	1817	{
1639	int prio;	1818	int prio;
1640		1819
1641	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )	1820	for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
1642	{	1821	{
1643	struct coro **ready = coro_ready [prio];	1822	struct coro **ready = coro_ready [prio];
1644		1823
1645	if (ready [0])	1824	if (ready [0])
1646	{	1825	{
…		…
1651	}	1830	}
1652		1831
1653	return 0;	1832	return 0;
1654	}	1833	}
1655		1834
		1835	static void
		1836	invoke_sv_ready_hook_helper (void)
		1837	{
		1838	dTHX;
		1839	dSP;
		1840
		1841	ENTER;
		1842	SAVETMPS;
		1843
		1844	PUSHMARK (SP);
		1845	PUTBACK;
		1846	call_sv (coro_readyhook, G_VOID | G_DISCARD);
		1847
		1848	FREETMPS;
		1849	LEAVE;
		1850	}
		1851
1656	static int	1852	static int
1657	api_ready (pTHX_ SV *coro_sv)	1853	api_ready (pTHX_ SV *coro_sv)
1658	{	1854	{
1659	struct coro *coro;
1660	SV *sv_hook;
1661	void (*xs_hook)(void);
1662
1663	coro = SvSTATE (coro_sv);	1855	struct coro *coro = SvSTATE (coro_sv);
1664		1856
1665	if (coro->flags & CF_READY)	1857	if (coro->flags & CF_READY)
1666	return 0;	1858	return 0;
1667		1859
1668	coro->flags |= CF_READY;	1860	coro->flags |= CF_READY;
1669		1861
1670	sv_hook = coro_nready ? 0 : coro_readyhook;
1671	xs_hook = coro_nready ? 0 : coroapi.readyhook;
1672
1673	coro_enq (aTHX_ coro);	1862	coro_enq (aTHX_ coro);
1674	++coro_nready;
1675		1863
1676	if (sv_hook)	1864	if (!coro_nready++)
1677	{	1865	if (coroapi.readyhook)
1678	dSP;	1866	coroapi.readyhook ();
1679
1680	ENTER;
1681	SAVETMPS;
1682
1683	PUSHMARK (SP);
1684	PUTBACK;
1685	call_sv (sv_hook, G_VOID | G_DISCARD);
1686
1687	FREETMPS;
1688	LEAVE;
1689	}
1690
1691	if (xs_hook)
1692	xs_hook ();
1693		1867
1694	return 1;	1868	return 1;
1695	}	1869	}
1696		1870
1697	static int	1871	static int
…		…
1699	{	1873	{
1700	return !!(SvSTATE (coro_sv)->flags & CF_READY);	1874	return !!(SvSTATE (coro_sv)->flags & CF_READY);
1701	}	1875	}
1702		1876
1703	/* expects to own a reference to next->hv */	1877	/* expects to own a reference to next->hv */
1704	INLINE void	1878	ecb_inline void
1705	prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)	1879	prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)
1706	{	1880	{
1707	SV *prev_sv = SvRV (coro_current);	1881	SV *prev_sv = SvRV (coro_current);
1708		1882
1709	ta->prev = SvSTATE_hv (prev_sv);	1883	ta->prev = SvSTATE_hv (prev_sv);
…		…
1722	{	1896	{
1723	for (;;)	1897	for (;;)
1724	{	1898	{
1725	struct coro *next = coro_deq (aTHX);	1899	struct coro *next = coro_deq (aTHX);
1726		1900
1727	if (expect_true (next))	1901	if (ecb_expect_true (next))
1728	{	1902	{
1729	/* cannot transfer to destroyed coros, skip and look for next */	1903	/* cannot transfer to destroyed coros, skip and look for next */
1730	if (expect_false (next->flags & (CF_DESTROYED | CF_SUSPENDED)))	1904	if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED)))
1731	SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */	1905	SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */
1732	else	1906	else
1733	{	1907	{
1734	next->flags &= ~CF_READY;	1908	next->flags &= ~CF_READY;
1735	--coro_nready;	1909	--coro_nready;
…		…
1742	{	1916	{
1743	/* nothing to schedule: call the idle handler */	1917	/* nothing to schedule: call the idle handler */
1744	if (SvROK (sv_idle)	1918	if (SvROK (sv_idle)
1745	&& SvOBJECT (SvRV (sv_idle)))	1919	&& SvOBJECT (SvRV (sv_idle)))
1746	{	1920	{
		1921	if (SvRV (sv_idle) == SvRV (coro_current))
		1922	{
		1923	require_pv ("Carp");
		1924
		1925	{
		1926	dSP;
		1927
		1928	ENTER;
		1929	SAVETMPS;
		1930
		1931	PUSHMARK (SP);
		1932	XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::IDLE blocked itself - did you try to block inside an event loop callback? Caught", 0)));
		1933	PUTBACK;
		1934	call_pv ("Carp::confess", G_VOID | G_DISCARD);
		1935
		1936	FREETMPS;
		1937	LEAVE;
		1938	}
		1939	}
		1940
1747	++coro_nready; /* hack so that api_ready doesn't invoke ready hook */	1941	++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
1748	api_ready (aTHX_ SvRV (sv_idle));	1942	api_ready (aTHX_ SvRV (sv_idle));
1749	--coro_nready;	1943	--coro_nready;
1750	}	1944	}
1751	else	1945	else
1752	{	1946	{
		1947	/* TODO: deprecated, remove, cannot work reliably *//*D*/
1753	dSP;	1948	dSP;
1754		1949
1755	ENTER;	1950	ENTER;
1756	SAVETMPS;	1951	SAVETMPS;
1757		1952
…		…
1764	}	1959	}
1765	}	1960	}
1766	}	1961	}
1767	}	1962	}
1768		1963
1769	INLINE void	1964	ecb_inline void
1770	prepare_cede (pTHX_ struct coro_transfer_args *ta)	1965	prepare_cede (pTHX_ struct coro_transfer_args *ta)
1771	{	1966	{
1772	api_ready (aTHX_ coro_current);	1967	api_ready (aTHX_ coro_current);
1773	prepare_schedule (aTHX_ ta);	1968	prepare_schedule (aTHX_ ta);
1774	}	1969	}
1775		1970
1776	INLINE void	1971	ecb_inline void
1777	prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)	1972	prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
1778	{	1973	{
1779	SV *prev = SvRV (coro_current);	1974	SV *prev = SvRV (coro_current);
1780		1975
1781	if (coro_nready)	1976	if (coro_nready)
…		…
1811	{	2006	{
1812	struct coro_transfer_args ta;	2007	struct coro_transfer_args ta;
1813		2008
1814	prepare_cede (aTHX_ &ta);	2009	prepare_cede (aTHX_ &ta);
1815		2010
1816	if (expect_true (ta.prev != ta.next))	2011	if (ecb_expect_true (ta.prev != ta.next))
1817	{	2012	{
1818	TRANSFER (ta, 1);	2013	TRANSFER (ta, 1);
1819	return 1;	2014	return 1;
1820	}	2015	}
1821	else	2016	else
…		…
1864	coro->slot->runops = RUNOPS_DEFAULT;	2059	coro->slot->runops = RUNOPS_DEFAULT;
1865	}	2060	}
1866	}	2061	}
1867		2062
1868	static void	2063	static void
		2064	coro_push_av (pTHX_ AV *av, I32 gimme_v)
		2065	{
		2066	if (AvFILLp (av) >= 0 && gimme_v != G_VOID)
		2067	{
		2068	dSP;
		2069
		2070	if (gimme_v == G_SCALAR)
		2071	XPUSHs (AvARRAY (av)[AvFILLp (av)]);
		2072	else
		2073	{
		2074	int i;
		2075	EXTEND (SP, AvFILLp (av) + 1);
		2076
		2077	for (i = 0; i <= AvFILLp (av); ++i)
		2078	PUSHs (AvARRAY (av)[i]);
		2079	}
		2080
		2081	PUTBACK;
		2082	}
		2083	}
		2084
		2085	static void
		2086	coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)
		2087	{
		2088	if (!coro->on_destroy)
		2089	coro->on_destroy = newAV ();
		2090
		2091	av_push (coro->on_destroy, cb);
		2092	}
		2093
		2094	static void
		2095	slf_destroy_join (pTHX_ struct CoroSLF *frame)
		2096	{
		2097	SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv);
		2098	}
		2099
		2100	static int
		2101	slf_check_join (pTHX_ struct CoroSLF *frame)
		2102	{
		2103	struct coro *coro = (struct coro *)frame->data;
		2104
		2105	if (!coro->status)
		2106	return 1;
		2107
		2108	frame->destroy = 0;
		2109
		2110	coro_push_av (aTHX_ coro->status, GIMME_V);
		2111
		2112	SvREFCNT_dec ((SV *)coro->hv);
		2113
		2114	return 0;
		2115	}
		2116
		2117	static void
		2118	slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2119	{
		2120	struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef);
		2121
		2122	if (items > 1)
		2123	croak ("join called with too many arguments");
		2124
		2125	if (coro->status)
		2126	frame->prepare = prepare_nop;
		2127	else
		2128	{
		2129	coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current)));
		2130	frame->prepare = prepare_schedule;
		2131	}
		2132
		2133	frame->check = slf_check_join;
		2134	frame->destroy = slf_destroy_join;
		2135	frame->data = (void *)coro;
		2136	SvREFCNT_inc (coro->hv);
		2137	}
		2138
		2139	static void
1869	coro_call_on_destroy (pTHX_ struct coro *coro)	2140	coro_call_on_destroy (pTHX_ struct coro *coro)
1870	{	2141	{
1871	SV **on_destroyp = hv_fetch (coro->hv, "_on_destroy", sizeof ("_on_destroy") - 1, 0);	2142	AV *od = coro->on_destroy;
1872	SV **statusp = hv_fetch (coro->hv, "_status", sizeof ("_status") - 1, 0);
1873		2143
1874	if (on_destroyp)	2144	if (!od)
1875	{	2145	return;
1876	AV *on_destroy = (AV *)SvRV (*on_destroyp);
1877		2146
		2147	coro->on_destroy = 0;
		2148	sv_2mortal ((SV *)od);
		2149
1878	while (AvFILLp (on_destroy) >= 0)	2150	while (AvFILLp (od) >= 0)
		2151	{
		2152	SV *cb = sv_2mortal (av_pop (od));
		2153
		2154	/* coro hv's (and only hv's at the moment) are supported as well */
		2155	if (SvSTATEhv_p (aTHX_ cb))
		2156	api_ready (aTHX_ cb);
		2157	else
1879	{	2158	{
1880	dSP; /* don't disturb outer sp */	2159	dSP; /* don't disturb outer sp */
1881	SV *cb = av_pop (on_destroy);
1882
1883	PUSHMARK (SP);	2160	PUSHMARK (SP);
1884		2161
1885	if (statusp)	2162	if (coro->status)
1886	{	2163	{
1887	int i;	2164	PUTBACK;
1888	AV *status = (AV *)SvRV (*statusp);	2165	coro_push_av (aTHX_ coro->status, G_ARRAY);
1889	EXTEND (SP, AvFILLp (status) + 1);	2166	SPAGAIN;
1890
1891	for (i = 0; i <= AvFILLp (status); ++i)
1892	PUSHs (AvARRAY (status)[i]);
1893	}	2167	}
1894		2168
1895	PUTBACK;	2169	PUTBACK;
1896	call_sv (sv_2mortal (cb), G_VOID | G_DISCARD);	2170	call_sv (cb, G_VOID | G_DISCARD);
1897	}	2171	}
1898	}	2172	}
1899	}	2173	}
1900		2174
1901	static void	2175	static void
1902	slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2176	coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
1903	{	2177	{
		2178	AV *av;
		2179
		2180	if (coro->status)
		2181	{
		2182	av = coro->status;
		2183	av_clear (av);
		2184	}
		2185	else
		2186	av = coro->status = newAV ();
		2187
		2188	/* items are actually not so common, so optimise for this case */
		2189	if (items)
		2190	{
1904	int i;	2191	int i;
1905	HV *hv = (HV *)SvRV (coro_current);
1906	AV *av = newAV ();
1907		2192
1908	av_extend (av, items - 1);	2193	av_extend (av, items - 1);
		2194
1909	for (i = 0; i < items; ++i)	2195	for (i = 0; i < items; ++i)
1910	av_push (av, SvREFCNT_inc_NN (arg [i]));	2196	av_push (av, SvREFCNT_inc_NN (arg [i]));
		2197	}
		2198	}
1911		2199
1912	hv_store (hv, "_status", sizeof ("_status") - 1, newRV_noinc ((SV *)av), 0);	2200	static void
1913		2201	slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv)
		2202	{
1914	av_push (av_destroy, (SV *)newRV_inc ((SV *)hv)); /* RVinc for perl */	2203	av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */
1915	api_ready (aTHX_ sv_manager);	2204	api_ready (aTHX_ sv_manager);
1916		2205
1917	frame->prepare = prepare_schedule;	2206	frame->prepare = prepare_schedule;
1918	frame->check = slf_check_repeat;	2207	frame->check = slf_check_repeat;
1919		2208
1920	/* as a minor optimisation, we could unwind all stacks here */	2209	/* as a minor optimisation, we could unwind all stacks here */
1921	/* but that puts extra pressure on pp_slf, and is not worth much */	2210	/* but that puts extra pressure on pp_slf, and is not worth much */
1922	/*coro_unwind_stacks (aTHX);*/	2211	/*coro_unwind_stacks (aTHX);*/
		2212	}
		2213
		2214	static void
		2215	slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2216	{
		2217	HV *coro_hv = (HV *)SvRV (coro_current);
		2218
		2219	coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items);
		2220	slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
		2221	}
		2222
		2223	static void
		2224	slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2225	{
		2226	HV *coro_hv;
		2227	struct coro *coro;
		2228
		2229	if (items <= 0)
		2230	croak ("Coro::cancel called without coro object,");
		2231
		2232	coro = SvSTATE (arg [0]);
		2233	coro_hv = coro->hv;
		2234
		2235	coro_set_status (aTHX_ coro, arg + 1, items - 1);
		2236
		2237	if (ecb_expect_false (coro->flags & CF_NOCANCEL))
		2238	{
		2239	/* coro currently busy cancelling something, so just notify it */
		2240	coro->slf_frame.data = (void *)coro;
		2241
		2242	frame->prepare = prepare_nop;
		2243	frame->check = slf_check_nop;
		2244	}
		2245	else if (coro_hv == (HV *)SvRV (coro_current))
		2246	{
		2247	/* cancelling the current coro is allowed, and equals terminate */
		2248	slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
		2249	}
		2250	else
		2251	{
		2252	struct coro *self = SvSTATE_current;
		2253
		2254	/* otherwise we cancel directly, purely for speed reasons
		2255	* unfortunately, this requires some magic trickery, as
		2256	* somebody else could cancel us, so we have to fight the cancellation.
		2257	* this is ugly, and hopefully fully worth the extra speed.
		2258	* besides, I can't get the slow-but-safe version working...
		2259	*/
		2260	slf_frame.data = 0;
		2261	self->flags |= CF_NOCANCEL;
		2262	coro_state_destroy (aTHX_ coro);
		2263	self->flags &= ~CF_NOCANCEL;
		2264
		2265	if (slf_frame.data)
		2266	{
		2267	/* while we were busy we have been cancelled, so terminate */
		2268	slf_init_terminate_cancel_common (aTHX_ frame, self->hv);
		2269	}
		2270	else
		2271	{
		2272	frame->prepare = prepare_nop;
		2273	frame->check = slf_check_nop;
		2274	}
		2275	}
		2276	}
		2277
		2278	static int
		2279	slf_check_safe_cancel (pTHX_ struct CoroSLF *frame)
		2280	{
		2281	frame->prepare = 0;
		2282	coro_unwind_stacks (aTHX);
		2283
		2284	slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current));
		2285
		2286	return 1;
		2287	}
		2288
		2289	static int
		2290	safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)
		2291	{
		2292	if (coro->cctx)
		2293	croak ("coro inside C callback, unable to cancel at this time, caught");
		2294
		2295	if (coro->flags & CF_NEW)
		2296	{
		2297	coro_set_status (aTHX_ coro, arg, items);
		2298	coro_state_destroy (aTHX_ coro);
		2299	}
		2300	else
		2301	{
		2302	if (!coro->slf_frame.prepare)
		2303	croak ("coro outside an SLF function, unable to cancel at this time, caught");
		2304
		2305	slf_destroy (aTHX_ coro);
		2306
		2307	coro_set_status (aTHX_ coro, arg, items);
		2308	coro->slf_frame.prepare = prepare_nop;
		2309	coro->slf_frame.check = slf_check_safe_cancel;
		2310
		2311	api_ready (aTHX_ (SV *)coro->hv);
		2312	}
		2313
		2314	return 1;
1923	}	2315	}
1924		2316
1925	/*****************************************************************************/	2317	/*****************************************************************************/
1926	/* async pool handler */	2318	/* async pool handler */
1927		2319
…		…
1958	slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2350	slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1959	{	2351	{
1960	HV *hv = (HV *)SvRV (coro_current);	2352	HV *hv = (HV *)SvRV (coro_current);
1961	struct coro *coro = SvSTATE_hv ((SV *)hv);	2353	struct coro *coro = SvSTATE_hv ((SV *)hv);
1962		2354
1963	if (expect_true (coro->saved_deffh))	2355	if (ecb_expect_true (coro->saved_deffh))
1964	{	2356	{
1965	/* subsequent iteration */	2357	/* subsequent iteration */
1966	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;	2358	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1967	coro->saved_deffh = 0;	2359	coro->saved_deffh = 0;
1968		2360
1969	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)	2361	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
1970	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))	2362	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1971	{	2363	{
1972	coro->invoke_cb = SvREFCNT_inc_NN ((SV *)cv_coro_terminate);	2364	slf_init_terminate_cancel_common (aTHX_ frame, hv);
1973	coro->invoke_av = newAV ();	2365	return;
1974
1975	frame->prepare = prepare_nop;
1976	}	2366	}
1977	else	2367	else
1978	{	2368	{
1979	av_clear (GvAV (PL_defgv));	2369	av_clear (GvAV (PL_defgv));
1980	hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);	2370	hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
…		…
2005		2395
2006	static void	2396	static void
2007	coro_rouse_callback (pTHX_ CV *cv)	2397	coro_rouse_callback (pTHX_ CV *cv)
2008	{	2398	{
2009	dXSARGS;	2399	dXSARGS;
2010	SV *data = (SV *)GENSUB_ARG;	2400	SV *data = (SV *)S_GENSUB_ARG;
2011		2401
2012	if (SvTYPE (SvRV (data)) != SVt_PVAV)	2402	if (SvTYPE (SvRV (data)) != SVt_PVAV)
2013	{	2403	{
2014	/* first call, set args */	2404	/* first call, set args */
2015	SV *coro = SvRV (data);	2405	SV *coro = SvRV (data);
…		…
2030		2420
2031	static int	2421	static int
2032	slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)	2422	slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
2033	{	2423	{
2034	SV *data = (SV *)frame->data;	2424	SV *data = (SV *)frame->data;
2035		2425
2036	if (CORO_THROW)	2426	if (CORO_THROW)
2037	return 0;	2427	return 0;
2038		2428
2039	if (SvTYPE (SvRV (data)) != SVt_PVAV)	2429	if (SvTYPE (SvRV (data)) != SVt_PVAV)
2040	return 1;	2430	return 1;
…		…
2076	cb = sv_2mortal (coro->rouse_cb);	2466	cb = sv_2mortal (coro->rouse_cb);
2077	coro->rouse_cb = 0;	2467	coro->rouse_cb = 0;
2078	}	2468	}
2079		2469
2080	if (!SvROK (cb)	2470	if (!SvROK (cb)
2081	|| SvTYPE (SvRV (cb)) != SVt_PVCV	2471	|| SvTYPE (SvRV (cb)) != SVt_PVCV
2082	|| CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)	2472	|| CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
2083	croak ("Coro::rouse_wait called with illegal callback argument,");	2473	croak ("Coro::rouse_wait called with illegal callback argument,");
2084		2474
2085	{	2475	{
2086	CV *cv = (CV *)SvRV (cb); /* for GENSUB_ARG */	2476	CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
2087	SV *data = (SV *)GENSUB_ARG;	2477	SV *data = (SV *)S_GENSUB_ARG;
2088		2478
2089	frame->data = (void *)data;	2479	frame->data = (void *)data;
2090	frame->prepare = SvTYPE (SvRV (data)) == SVt_PVAV ? prepare_nop : prepare_schedule;	2480	frame->prepare = SvTYPE (SvRV (data)) == SVt_PVAV ? prepare_nop : prepare_schedule;
2091	frame->check = slf_check_rouse_wait;	2481	frame->check = slf_check_rouse_wait;
2092	}	2482	}
…		…
2096	coro_new_rouse_cb (pTHX)	2486	coro_new_rouse_cb (pTHX)
2097	{	2487	{
2098	HV *hv = (HV *)SvRV (coro_current);	2488	HV *hv = (HV *)SvRV (coro_current);
2099	struct coro *coro = SvSTATE_hv (hv);	2489	struct coro *coro = SvSTATE_hv (hv);
2100	SV *data = newRV_inc ((SV *)hv);	2490	SV *data = newRV_inc ((SV *)hv);
2101	SV *cb = gensub (aTHX_ coro_rouse_callback, (void *)data);	2491	SV *cb = s_gensub (aTHX_ coro_rouse_callback, (void *)data);
2102		2492
2103	sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0);	2493	sv_magicext (SvRV (cb), data, CORO_MAGIC_type_rouse, 0, 0, 0);
2104	SvREFCNT_dec (data); /* magicext increases the refcount */	2494	SvREFCNT_dec (data); /* magicext increases the refcount */
2105		2495
2106	SvREFCNT_dec (coro->rouse_cb);	2496	SvREFCNT_dec (coro->rouse_cb);
…		…
2203	static void	2593	static void
2204	slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2594	slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2205	{	2595	{
2206	frame->prepare = prepare_cede_notself;	2596	frame->prepare = prepare_cede_notself;
2207	frame->check = slf_check_nop;	2597	frame->check = slf_check_nop;
		2598	}
		2599
		2600	/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
		2601	static void
		2602	slf_destroy (pTHX_ struct coro *coro)
		2603	{
		2604	/* this callback is reserved for slf functions needing to do cleanup */
		2605	if (coro->slf_frame.destroy && coro->slf_frame.prepare && !PL_dirty)
		2606	coro->slf_frame.destroy (aTHX_ &coro->slf_frame);
		2607
		2608	/*
		2609	* The on_destroy above most likely is from an SLF call.
		2610	* Since by definition the SLF call will not finish when we destroy
		2611	* the coro, we will have to force-finish it here, otherwise
		2612	* cleanup functions cannot call SLF functions.
		2613	*/
		2614	coro->slf_frame.prepare = 0;
2208	}	2615	}
2209		2616
2210	/*	2617	/*
2211	* these not obviously related functions are all rolled into one	2618	* these not obviously related functions are all rolled into one
2212	* function to increase chances that they all will call transfer with the same	2619	* function to increase chances that they all will call transfer with the same
…		…
2219	I32 checkmark; /* mark SP to see how many elements check has pushed */	2626	I32 checkmark; /* mark SP to see how many elements check has pushed */
2220		2627
2221	/* set up the slf frame, unless it has already been set-up */	2628	/* set up the slf frame, unless it has already been set-up */
2222	/* the latter happens when a new coro has been started */	2629	/* the latter happens when a new coro has been started */
2223	/* or when a new cctx was attached to an existing coroutine */	2630	/* or when a new cctx was attached to an existing coroutine */
2224	if (expect_true (!slf_frame.prepare))	2631	if (ecb_expect_true (!slf_frame.prepare))
2225	{	2632	{
2226	/* first iteration */	2633	/* first iteration */
2227	dSP;	2634	dSP;
2228	SV **arg = PL_stack_base + TOPMARK + 1;	2635	SV **arg = PL_stack_base + TOPMARK + 1;
2229	int items = SP - arg; /* args without function object */	2636	int items = SP - arg; /* args without function object */
…		…
2270	while (slf_frame.check (aTHX_ &slf_frame));	2677	while (slf_frame.check (aTHX_ &slf_frame));
2271		2678
2272	slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */	2679	slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */
2273		2680
2274	/* exception handling */	2681	/* exception handling */
2275	if (expect_false (CORO_THROW))	2682	if (ecb_expect_false (CORO_THROW))
2276	{	2683	{
2277	SV *exception = sv_2mortal (CORO_THROW);	2684	SV *exception = sv_2mortal (CORO_THROW);
2278		2685
2279	CORO_THROW = 0;	2686	CORO_THROW = 0;
2280	sv_setsv (ERRSV, exception);	2687	sv_setsv (ERRSV, exception);
2281	croak (0);	2688	croak (0);
2282	}	2689	}
2283		2690
2284	/* return value handling - mostly like entersub */	2691	/* return value handling - mostly like entersub */
2285	/* make sure we put something on the stack in scalar context */	2692	/* make sure we put something on the stack in scalar context */
2286	if (GIMME_V == G_SCALAR)	2693	if (GIMME_V == G_SCALAR
		2694	&& ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1))
2287	{	2695	{
2288	dSP;	2696	dSP;
2289	SV **bot = PL_stack_base + checkmark;	2697	SV **bot = PL_stack_base + checkmark;
2290		2698
2291	if (sp == bot) /* too few, push undef */	2699	if (sp == bot) /* too few, push undef */
2292	bot [1] = &PL_sv_undef;	2700	bot [1] = &PL_sv_undef;
2293	else if (sp != bot + 1) /* too many, take last one */	2701	else /* too many, take last one */
2294	bot [1] = *sp;	2702	bot [1] = *sp;
2295		2703
2296	SP = bot + 1;	2704	SP = bot + 1;
2297		2705
2298	PUTBACK;	2706	PUTBACK;
…		…
2331	if (PL_op->op_flags & OPf_STACKED)	2739	if (PL_op->op_flags & OPf_STACKED)
2332	{	2740	{
2333	if (items > slf_arga)	2741	if (items > slf_arga)
2334	{	2742	{
2335	slf_arga = items;	2743	slf_arga = items;
2336	free (slf_argv);	2744	Safefree (slf_argv);
2337	slf_argv = malloc (slf_arga * sizeof (SV *));	2745	New (0, slf_argv, slf_arga, SV *);
2338	}	2746	}
2339		2747
2340	slf_argc = items;	2748	slf_argc = items;
2341		2749
2342	for (i = 0; i < items; ++i)	2750	for (i = 0; i < items; ++i)
…		…
2405	{	2813	{
2406	PerlIOBuf base;	2814	PerlIOBuf base;
2407	NV next, every;	2815	NV next, every;
2408	} PerlIOCede;	2816	} PerlIOCede;
2409		2817
2410	static IV	2818	static IV ecb_cold
2411	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)	2819	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2412	{	2820	{
2413	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);	2821	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2414		2822
2415	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;	2823	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
2416	self->next = nvtime () + self->every;	2824	self->next = nvtime () + self->every;
2417		2825
2418	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);	2826	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
2419	}	2827	}
2420		2828
2421	static SV *	2829	static SV * ecb_cold
2422	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)	2830	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
2423	{	2831	{
2424	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);	2832	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2425		2833
2426	return newSVnv (self->every);	2834	return newSVnv (self->every);
…		…
2477	/* Coro::Semaphore & Coro::Signal */	2885	/* Coro::Semaphore & Coro::Signal */
2478		2886
2479	static SV *	2887	static SV *
2480	coro_waitarray_new (pTHX_ int count)	2888	coro_waitarray_new (pTHX_ int count)
2481	{	2889	{
2482	/* a semaphore contains a counter IV in $sem->[0] and any waiters after that */	2890	/* a waitarray=semaphore contains a counter IV in $sem->[0] and any waiters after that */
2483	AV *av = newAV ();	2891	AV *av = newAV ();
2484	SV **ary;	2892	SV **ary;
2485		2893
2486	/* unfortunately, building manually saves memory */	2894	/* unfortunately, building manually saves memory */
2487	Newx (ary, 2, SV *);	2895	Newx (ary, 2, SV *);
…		…
2538	SvREFCNT_dec (cb);	2946	SvREFCNT_dec (cb);
2539	}	2947	}
2540	}	2948	}
2541		2949
2542	static void	2950	static void
2543	coro_semaphore_on_destroy (pTHX_ struct coro *coro)	2951	coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
2544	{	2952	{
2545	/* call $sem->adjust (0) to possibly wake up some other waiters */	2953	/* call $sem->adjust (0) to possibly wake up some other waiters */
2546	coro_semaphore_adjust (aTHX_ (AV *)coro->slf_frame.data, 0);	2954	coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0);
2547	}	2955	}
2548		2956
2549	static int	2957	static int
2550	slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)	2958	slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)
2551	{	2959	{
2552	AV *av = (AV *)frame->data;	2960	AV *av = (AV *)frame->data;
2553	SV *count_sv = AvARRAY (av)[0];	2961	SV *count_sv = AvARRAY (av)[0];
		2962	SV *coro_hv = SvRV (coro_current);
2554		2963
2555	/* if we are about to throw, don't actually acquire the lock, just throw */	2964	/* if we are about to throw, don't actually acquire the lock, just throw */
2556	if (CORO_THROW)	2965	if (CORO_THROW)
2557	return 0;	2966	return 0;
2558	else if (SvIVX (count_sv) > 0)	2967	else if (SvIVX (count_sv) > 0)
2559	{	2968	{
2560	SvSTATE_current->on_destroy = 0;	2969	frame->destroy = 0;
2561		2970
2562	if (acquire)	2971	if (acquire)
2563	SvIVX (count_sv) = SvIVX (count_sv) - 1;	2972	SvIVX (count_sv) = SvIVX (count_sv) - 1;
2564	else	2973	else
2565	coro_semaphore_adjust (aTHX_ av, 0);	2974	coro_semaphore_adjust (aTHX_ av, 0);
…		…
2570	{	2979	{
2571	int i;	2980	int i;
2572	/* if we were woken up but can't down, we look through the whole */	2981	/* if we were woken up but can't down, we look through the whole */
2573	/* waiters list and only add us if we aren't in there already */	2982	/* waiters list and only add us if we aren't in there already */
2574	/* this avoids some degenerate memory usage cases */	2983	/* this avoids some degenerate memory usage cases */
2575		2984	for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */
2576	for (i = 1; i <= AvFILLp (av); ++i)
2577	if (AvARRAY (av)[i] == SvRV (coro_current))	2985	if (AvARRAY (av)[i] == coro_hv)
2578	return 1;	2986	return 1;
2579		2987
2580	av_push (av, SvREFCNT_inc (SvRV (coro_current)));	2988	av_push (av, SvREFCNT_inc (coro_hv));
2581	return 1;	2989	return 1;
2582	}	2990	}
2583	}	2991	}
2584		2992
2585	static int	2993	static int
…		…
2608	{	3016	{
2609	av_push (av, SvREFCNT_inc (SvRV (coro_current)));	3017	av_push (av, SvREFCNT_inc (SvRV (coro_current)));
2610		3018
2611	frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));	3019	frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
2612	frame->prepare = prepare_schedule;	3020	frame->prepare = prepare_schedule;
2613
2614	/* to avoid race conditions when a woken-up coro gets terminated */	3021	/* to avoid race conditions when a woken-up coro gets terminated */
2615	/* we arrange for a temporary on_destroy that calls adjust (0) */	3022	/* we arrange for a temporary on_destroy that calls adjust (0) */
2616	SvSTATE_current->on_destroy = coro_semaphore_on_destroy;	3023	frame->destroy = coro_semaphore_destroy;
2617	}	3024	}
2618	}	3025	}
2619		3026
2620	static void	3027	static void
2621	slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	3028	slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
…		…
2629	{	3036	{
2630	if (items >= 2)	3037	if (items >= 2)
2631	{	3038	{
2632	/* callback form */	3039	/* callback form */
2633	AV *av = (AV *)SvRV (arg [0]);	3040	AV *av = (AV *)SvRV (arg [0]);
2634	CV *cb_cv = coro_sv_2cv (aTHX_ arg [1]);	3041	SV *cb_cv = s_get_cv_croak (arg [1]);
2635		3042
2636	av_push (av, (SV *)SvREFCNT_inc_NN (cb_cv));	3043	av_push (av, SvREFCNT_inc_NN (cb_cv));
2637		3044
2638	if (SvIVX (AvARRAY (av)[0]) > 0)	3045	if (SvIVX (AvARRAY (av)[0]) > 0)
2639	coro_semaphore_adjust (aTHX_ av, 0);	3046	coro_semaphore_adjust (aTHX_ av, 0);
2640		3047
2641	frame->prepare = prepare_nop;	3048	frame->prepare = prepare_nop;
…		…
2665	AvARRAY (av)[0] = AvARRAY (av)[1];	3072	AvARRAY (av)[0] = AvARRAY (av)[1];
2666	AvARRAY (av)[1] = cb;	3073	AvARRAY (av)[1] = cb;
2667		3074
2668	cb = av_shift (av);	3075	cb = av_shift (av);
2669		3076
		3077	if (SvTYPE (cb) == SVt_PVCV)
		3078	{
		3079	dSP;
		3080	PUSHMARK (SP);
		3081	XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
		3082	PUTBACK;
		3083	call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
		3084	}
		3085	else
		3086	{
2670	api_ready (aTHX_ cb);	3087	api_ready (aTHX_ cb);
2671	sv_setiv (cb, 0); /* signal waiter */	3088	sv_setiv (cb, 0); /* signal waiter */
		3089	}
		3090
2672	SvREFCNT_dec (cb);	3091	SvREFCNT_dec (cb);
2673		3092
2674	--count;	3093	--count;
2675	}	3094	}
2676	}	3095	}
…		…
2685	static void	3104	static void
2686	slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	3105	slf_init_signal_wait (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2687	{	3106	{
2688	AV *av = (AV *)SvRV (arg [0]);	3107	AV *av = (AV *)SvRV (arg [0]);
2689		3108
		3109	if (items >= 2)
		3110	{
		3111	SV *cb_cv = s_get_cv_croak (arg [1]);
		3112	av_push (av, SvREFCNT_inc_NN (cb_cv));
		3113
2690	if (SvIVX (AvARRAY (av)[0]))	3114	if (SvIVX (AvARRAY (av)[0]))
		3115	coro_signal_wake (aTHX_ av, 1); /* must be the only waiter */
		3116
		3117	frame->prepare = prepare_nop;
		3118	frame->check = slf_check_nop;
		3119	}
		3120	else if (SvIVX (AvARRAY (av)[0]))
2691	{	3121	{
2692	SvIVX (AvARRAY (av)[0]) = 0;	3122	SvIVX (AvARRAY (av)[0]) = 0;
2693	frame->prepare = prepare_nop;	3123	frame->prepare = prepare_nop;
2694	frame->check = slf_check_nop;	3124	frame->check = slf_check_nop;
2695	}	3125	}
2696	else	3126	else
2697	{	3127	{
2698	SV *waiter = newRV_inc (SvRV (coro_current)); /* owned by signal av */	3128	SV *waiter = newSVsv (coro_current); /* owned by signal av */
2699		3129
2700	av_push (av, waiter);	3130	av_push (av, waiter);
2701		3131
2702	frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */	3132	frame->data = (void *)sv_2mortal (SvREFCNT_inc_NN (waiter)); /* owned by process */
2703	frame->prepare = prepare_schedule;	3133	frame->prepare = prepare_schedule;
…		…
2721		3151
2722	static void	3152	static void
2723	coro_aio_callback (pTHX_ CV *cv)	3153	coro_aio_callback (pTHX_ CV *cv)
2724	{	3154	{
2725	dXSARGS;	3155	dXSARGS;
2726	AV *state = (AV *)GENSUB_ARG;	3156	AV *state = (AV *)S_GENSUB_ARG;
2727	SV *coro = av_pop (state);	3157	SV *coro = av_pop (state);
2728	SV *data_sv = newSV (sizeof (struct io_state));	3158	SV *data_sv = newSV (sizeof (struct io_state));
2729		3159
2730	av_extend (state, items - 1);	3160	av_extend (state, items - 1);
2731		3161
…		…
2767	/* it quickly returns */	3197	/* it quickly returns */
2768	if (CORO_THROW)	3198	if (CORO_THROW)
2769	return 0;	3199	return 0;
2770		3200
2771	/* one element that is an RV? repeat! */	3201	/* one element that is an RV? repeat! */
2772	if (AvFILLp (state) == 0 && SvROK (AvARRAY (state)[0]))	3202	if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
2773	return 1;	3203	return 1;
2774		3204
2775	/* restore status */	3205	/* restore status */
2776	{	3206	{
2777	SV *data_sv = av_pop (state);	3207	SV *data_sv = av_pop (state);
…		…
2816	dSP;	3246	dSP;
2817		3247
2818	static SV *prio_cv;	3248	static SV *prio_cv;
2819	static SV *prio_sv;	3249	static SV *prio_sv;
2820		3250
2821	if (expect_false (!prio_cv))	3251	if (ecb_expect_false (!prio_cv))
2822	{	3252	{
2823	prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);	3253	prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);
2824	prio_sv = newSViv (0);	3254	prio_sv = newSViv (0);
2825	}	3255	}
2826		3256
…		…
2845		3275
2846	for (i = 0; i < items; ++i)	3276	for (i = 0; i < items; ++i)
2847	PUSHs (arg [i]);	3277	PUSHs (arg [i]);
2848		3278
2849	/* now push the callback closure */	3279	/* now push the callback closure */
2850	PUSHs (sv_2mortal (gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));	3280	PUSHs (sv_2mortal (s_gensub (aTHX_ coro_aio_callback, (void *)SvREFCNT_inc_NN ((SV *)state))));
2851		3281
2852	/* now call the AIO function - we assume our request is uncancelable */	3282	/* now call the AIO function - we assume our request is uncancelable */
2853	PUTBACK;	3283	PUTBACK;
2854	call_sv ((SV *)req, G_VOID | G_DISCARD);	3284	call_sv ((SV *)req, G_VOID | G_DISCARD);
2855	}	3285	}
2856		3286
2857	/* now that the requets is going, we loop toll we have a result */	3287	/* now that the request is going, we loop till we have a result */
2858	frame->data = (void *)state;	3288	frame->data = (void *)state;
2859	frame->prepare = prepare_schedule;	3289	frame->prepare = prepare_schedule;
2860	frame->check = slf_check_aio_req;	3290	frame->check = slf_check_aio_req;
2861	}	3291	}
2862		3292
…		…
2872		3302
2873	/*****************************************************************************/	3303	/*****************************************************************************/
2874		3304
2875	#if CORO_CLONE	3305	#if CORO_CLONE
2876	# include "clone.c"	3306	# include "clone.c"
		3307	#endif
		3308
		3309	/*****************************************************************************/
		3310
		3311	static SV *
		3312	coro_new (pTHX_ HV *stash, SV **argv, int argc, int is_coro)
		3313	{
		3314	SV *coro_sv;
		3315	struct coro *coro;
		3316	MAGIC *mg;
		3317	HV *hv;
		3318	SV *cb;
		3319	int i;
		3320
		3321	if (argc > 0)
		3322	{
		3323	cb = s_get_cv_croak (argv [0]);
		3324
		3325	if (!is_coro)
		3326	{
		3327	if (CvISXSUB (cb))
		3328	croak ("Coro::State doesn't support XS functions as coroutine start, caught");
		3329
		3330	if (!CvROOT (cb))
		3331	croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught");
		3332	}
		3333	}
		3334
		3335	Newz (0, coro, 1, struct coro);
		3336	coro->args = newAV ();
		3337	coro->flags = CF_NEW;
		3338
		3339	if (coro_first) coro_first->prev = coro;
		3340	coro->next = coro_first;
		3341	coro_first = coro;
		3342
		3343	coro->hv = hv = newHV ();
		3344	mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
		3345	mg->mg_flags |= MGf_DUP;
		3346	coro_sv = sv_bless (newRV_noinc ((SV *)hv), stash);
		3347
		3348	if (argc > 0)
		3349	{
		3350	av_extend (coro->args, argc + is_coro - 1);
		3351
		3352	if (is_coro)
		3353	{
		3354	av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb));
		3355	cb = (SV *)cv_coro_run;
		3356	}
		3357
		3358	coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb);
		3359
		3360	for (i = 1; i < argc; i++)
		3361	av_push (coro->args, newSVsv (argv [i]));
		3362	}
		3363
		3364	return coro_sv;
		3365	}
		3366
		3367	#ifndef __cplusplus
		3368	ecb_cold XS(boot_Coro__State);
		3369	#endif
		3370
		3371	#if CORO_JIT
		3372
		3373	static void ecb_noinline ecb_cold
		3374	pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)
		3375	{
		3376	dSP;
		3377	AV *av = newAV ();
		3378
		3379	av_store (av, 3, newSVuv (d));
		3380	av_store (av, 2, newSVuv (c));
		3381	av_store (av, 1, newSVuv (b));
		3382	av_store (av, 0, newSVuv (a));
		3383
		3384	XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		3385
		3386	PUTBACK;
		3387	}
		3388
		3389	static void ecb_noinline ecb_cold
		3390	jit_init (pTHX)
		3391	{
		3392	dSP;
		3393	SV *load, *save;
		3394	char *map_base;
		3395	char *load_ptr, *save_ptr;
		3396	STRLEN load_len, save_len, map_len;
		3397	int count;
		3398
		3399	eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
		3400
		3401	PUSHMARK (SP);
		3402	#define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
		3403	#include "state.h"
		3404	count = call_pv ("Coro::State::_jit", G_ARRAY);
		3405	SPAGAIN;
		3406
		3407	save = POPs; save_ptr = SvPVbyte (save, save_len);
		3408	load = POPs; load_ptr = SvPVbyte (load, load_len);
		3409
		3410	map_len = load_len + save_len + 16;
		3411
		3412	map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
		3413
		3414	assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED));
		3415
		3416	load_perl_slots = (load_save_perl_slots_type)map_base;
		3417	memcpy (map_base, load_ptr, load_len);
		3418
		3419	map_base += (load_len + 15) & ~15;
		3420
		3421	save_perl_slots = (load_save_perl_slots_type)map_base;
		3422	memcpy (map_base, save_ptr, save_len);
		3423
		3424	/* we are good citizens and try to make the page read-only, so the evil evil */
		3425	/* hackers might have it a bit more difficult */
		3426	mprotect (map_base, map_len, PROT_READ | PROT_EXEC);
		3427
		3428	PUTBACK;
		3429	eval_pv ("undef &Coro::State::_jit", 1);
		3430	}
		3431
2877	#endif	3432	#endif
2878		3433
2879	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_	3434	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
2880		3435
2881	PROTOTYPES: DISABLE	3436	PROTOTYPES: DISABLE
…		…
2885	#ifdef USE_ITHREADS	3440	#ifdef USE_ITHREADS
2886	# if CORO_PTHREAD	3441	# if CORO_PTHREAD
2887	coro_thx = PERL_GET_CONTEXT;	3442	coro_thx = PERL_GET_CONTEXT;
2888	# endif	3443	# endif
2889	#endif	3444	#endif
2890	BOOT_PAGESIZE;	3445	/* perl defines these to check for existance first, but why it doesn't */
		3446	/* just create them one at init time is not clear to me, except for */
		3447	/* programs trying to delete them, but... */
		3448	/* anyway, we declare this as invalid and make sure they are initialised here */
		3449	DEFSV;
		3450	ERRSV;
2891		3451
2892	cctx_current = cctx_new_empty ();	3452	cctx_current = cctx_new_empty ();
2893		3453
2894	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);	3454	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
2895	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);	3455	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
…		…
2935	coroapi.prepare_nop = prepare_nop;	3495	coroapi.prepare_nop = prepare_nop;
2936	coroapi.prepare_schedule = prepare_schedule;	3496	coroapi.prepare_schedule = prepare_schedule;
2937	coroapi.prepare_cede = prepare_cede;	3497	coroapi.prepare_cede = prepare_cede;
2938	coroapi.prepare_cede_notself = prepare_cede_notself;	3498	coroapi.prepare_cede_notself = prepare_cede_notself;
2939		3499
2940	{	3500	time_init (aTHX);
2941	SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
2942		3501
2943	if (!svp) croak ("Time::HiRes is required");
2944	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
2945
2946	nvtime = INT2PTR (double (*)(), SvIV (*svp));
2947	}
2948
2949	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));	3502	assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));
		3503	#if CORO_JIT
		3504	PUTBACK;
		3505	jit_init (aTHX);
		3506	SPAGAIN;
		3507	#endif
2950	}	3508	}
2951		3509
2952	SV *	3510	SV *
2953	new (char *klass, ...)	3511	new (SV *klass, ...)
2954	ALIAS:	3512	ALIAS:
2955	Coro::new = 1	3513	Coro::new = 1
2956	CODE:	3514	CODE:
2957	{	3515	RETVAL = coro_new (aTHX_ ix ? coro_stash : coro_state_stash, &ST (1), items - 1, ix);
2958	struct coro *coro;	3516	OUTPUT:
2959	MAGIC *mg;
2960	HV *hv;
2961	CV *cb;
2962	int i;
2963
2964	if (items > 1)
2965	{
2966	cb = coro_sv_2cv (aTHX_ ST (1));
2967
2968	if (!ix)
2969	{
2970	if (CvISXSUB (cb))
2971	croak ("Coro::State doesn't support XS functions as coroutine start, caught");
2972
2973	if (!CvROOT (cb))
2974	croak ("Coro::State doesn't support autoloaded or undefined functions as coroutine start, caught");
2975	}
2976	}
2977
2978	Newz (0, coro, 1, struct coro);
2979	coro->args = newAV ();
2980	coro->flags = CF_NEW;
2981
2982	if (coro_first) coro_first->prev = coro;
2983	coro->next = coro_first;
2984	coro_first = coro;
2985
2986	coro->hv = hv = newHV ();
2987	mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
2988	mg->mg_flags |= MGf_DUP;
2989	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
2990
2991	if (items > 1)
2992	{
2993	av_extend (coro->args, items - 1 + ix - 1);
2994
2995	if (ix)
2996	{
2997	av_push (coro->args, SvREFCNT_inc_NN ((SV *)cb));
2998	cb = cv_coro_run;
2999	}
3000
3001	coro->startcv = (CV *)SvREFCNT_inc_NN ((SV *)cb);
3002
3003	for (i = 2; i < items; i++)
3004	av_push (coro->args, newSVsv (ST (i)));
3005	}
3006	}
3007	OUTPUT:
3008	RETVAL	3517	RETVAL
3009		3518
3010	void	3519	void
3011	transfer (...)	3520	transfer (...)
3012	PROTOTYPE: $$	3521	PROTOTYPE: $$
3013	CODE:	3522	CODE:
3014	CORO_EXECUTE_SLF_XS (slf_init_transfer);	3523	CORO_EXECUTE_SLF_XS (slf_init_transfer);
3015
3016	bool
3017	_destroy (SV *coro_sv)
3018	CODE:
3019	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
3020	OUTPUT:
3021	RETVAL
3022
3023	void
3024	_exit (int code)
3025	PROTOTYPE: $
3026	CODE:
3027	_exit (code);
3028		3524
3029	SV *	3525	SV *
3030	clone (Coro::State coro)	3526	clone (Coro::State coro)
3031	CODE:	3527	CODE:
3032	{	3528	{
…		…
3087	void	3583	void
3088	list ()	3584	list ()
3089	PROTOTYPE:	3585	PROTOTYPE:
3090	PPCODE:	3586	PPCODE:
3091	{	3587	{
3092	struct coro *coro;	3588	struct coro *coro;
3093	for (coro = coro_first; coro; coro = coro->next)	3589	for (coro = coro_first; coro; coro = coro->next)
3094	if (coro->hv)	3590	if (coro->hv)
3095	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));	3591	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
3096	}	3592	}
3097		3593
…		…
3102	CODE:	3598	CODE:
3103	{	3599	{
3104	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))	3600	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
3105	{	3601	{
3106	struct coro *current = SvSTATE_current;	3602	struct coro *current = SvSTATE_current;
		3603	struct CoroSLF slf_save;
3107		3604
3108	if (current != coro)	3605	if (current != coro)
3109	{	3606	{
3110	PUTBACK;	3607	PUTBACK;
3111	save_perl (aTHX_ current);	3608	save_perl (aTHX_ current);
3112	load_perl (aTHX_ coro);	3609	load_perl (aTHX_ coro);
		3610	/* the coro is most likely in an active SLF call.
		3611	* while not strictly required (the code we execute is
		3612	* not allowed to call any SLF functions), it's cleaner
		3613	* to reinitialise the slf_frame and restore it later.
		3614	* This might one day allow us to actually do SLF calls
		3615	* from code executed here.
		3616	*/
		3617	slf_save = slf_frame;
		3618	slf_frame.prepare = 0;
3113	SPAGAIN;	3619	SPAGAIN;
3114	}	3620	}
3115		3621
3116	PUSHSTACK;	3622	PUSHSTACK;
3117		3623
…		…
3127	SPAGAIN;	3633	SPAGAIN;
3128		3634
3129	if (current != coro)	3635	if (current != coro)
3130	{	3636	{
3131	PUTBACK;	3637	PUTBACK;
		3638	slf_frame = slf_save;
3132	save_perl (aTHX_ coro);	3639	save_perl (aTHX_ coro);
3133	load_perl (aTHX_ current);	3640	load_perl (aTHX_ current);
3134	SPAGAIN;	3641	SPAGAIN;
3135	}	3642	}
3136	}	3643	}
…		…
3141	PROTOTYPE: $	3648	PROTOTYPE: $
3142	ALIAS:	3649	ALIAS:
3143	is_ready = CF_READY	3650	is_ready = CF_READY
3144	is_running = CF_RUNNING	3651	is_running = CF_RUNNING
3145	is_new = CF_NEW	3652	is_new = CF_NEW
3146	is_destroyed = CF_DESTROYED	3653	is_destroyed = CF_ZOMBIE
		3654	is_zombie = CF_ZOMBIE
3147	is_suspended = CF_SUSPENDED	3655	is_suspended = CF_SUSPENDED
3148	CODE:	3656	CODE:
3149	RETVAL = boolSV (coro->flags & ix);	3657	RETVAL = boolSV (coro->flags & ix);
3150	OUTPUT:	3658	OUTPUT:
3151	RETVAL	3659	RETVAL
3152		3660
3153	void	3661	void
3154	throw (Coro::State self, SV *throw = &PL_sv_undef)	3662	throw (SV *self, SV *exception = &PL_sv_undef)
3155	PROTOTYPE: $;$	3663	PROTOTYPE: $;$
3156	CODE:	3664	CODE:
3157	{	3665	{
		3666	struct coro *coro = SvSTATE (self);
3158	struct coro *current = SvSTATE_current;	3667	struct coro *current = SvSTATE_current;
3159	SV **throwp = self == current ? &CORO_THROW : &self->except;	3668	SV **exceptionp = coro == current ? &CORO_THROW : &coro->except;
3160	SvREFCNT_dec (*throwp);	3669	SvREFCNT_dec (*exceptionp);
3161	*throwp = SvOK (throw) ? newSVsv (throw) : 0;	3670	SvGETMAGIC (exception);
		3671	*exceptionp = SvOK (exception) ? newSVsv (exception) : 0;
		3672
		3673	api_ready (aTHX_ self);
3162	}	3674	}
3163		3675
3164	void	3676	void
3165	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)	3677	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
3166	PROTOTYPE: $;$	3678	PROTOTYPE: $;$
…		…
3221		3733
3222	void	3734	void
3223	cancel (Coro::State self)	3735	cancel (Coro::State self)
3224	CODE:	3736	CODE:
3225	coro_state_destroy (aTHX_ self);	3737	coro_state_destroy (aTHX_ self);
3226	coro_call_on_destroy (aTHX_ self); /* actually only for Coro objects */	3738
		3739	SV *
		3740	enable_times (int enabled = enable_times)
		3741	CODE:
		3742	{
		3743	RETVAL = boolSV (enable_times);
		3744
		3745	if (enabled != enable_times)
		3746	{
		3747	enable_times = enabled;
		3748
		3749	coro_times_update ();
		3750	(enabled ? coro_times_sub : coro_times_add)(SvSTATE (coro_current));
		3751	}
		3752	}
		3753	OUTPUT:
		3754	RETVAL
		3755
		3756	void
		3757	times (Coro::State self)
		3758	PPCODE:
		3759	{
		3760	struct coro *current = SvSTATE (coro_current);
		3761
		3762	if (ecb_expect_false (current == self))
		3763	{
		3764	coro_times_update ();
		3765	coro_times_add (SvSTATE (coro_current));
		3766	}
		3767
		3768	EXTEND (SP, 2);
		3769	PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));
		3770	PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));
		3771
		3772	if (ecb_expect_false (current == self))
		3773	coro_times_sub (SvSTATE (coro_current));
		3774	}
		3775
		3776	void
		3777	swap_sv (Coro::State coro, SV *sv, SV *swapsv)
		3778	CODE:
		3779	{
		3780	struct coro *current = SvSTATE_current;
		3781
		3782	if (current == coro)
		3783	SWAP_SVS (current);
		3784
		3785	if (!coro->swap_sv)
		3786	coro->swap_sv = newAV ();
		3787
		3788	av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (sv )));
		3789	av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (swapsv)));
		3790
		3791	if (current == coro)
		3792	SWAP_SVS (current);
		3793	}
3227		3794
3228		3795
3229	MODULE = Coro::State PACKAGE = Coro	3796	MODULE = Coro::State PACKAGE = Coro
3230		3797
3231	BOOT:	3798	BOOT:
3232	{	3799	{
3233	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);	3800	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
3234	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);	3801	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
3235	cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);	3802	cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);
3236	cv_coro_terminate = get_cv ( "Coro::terminate" , GV_ADD);
3237	coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);	3803	coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);
3238	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);	3804	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
3239	av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);	3805	av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);
3240	sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);	3806	sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);
3241	sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);	3807	sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);
3242		3808
3243	sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);	3809	sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
3244	sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);	3810	sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);
3245	cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);	3811	cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);
3246	cv_coro_state_new = get_cv ("Coro::State::new", 0); SvREADONLY_on (cv_coro_state_new);	3812	CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */
3247		3813
3248	coro_stash = gv_stashpv ("Coro", TRUE);	3814	coro_stash = gv_stashpv ("Coro", TRUE);
3249		3815
3250	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));	3816	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));
3251	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));	3817	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));
3252	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));	3818	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
3253	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));	3819	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (CORO_PRIO_LOW));
3254	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));	3820	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (CORO_PRIO_IDLE));
3255	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));	3821	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (CORO_PRIO_MIN));
3256		3822
3257	{	3823	{
3258	SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);	3824	SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
3259		3825
3260	coroapi.schedule = api_schedule;	3826	coroapi.schedule = api_schedule;
…		…
3270	sv_setiv (sv, (IV)&coroapi);	3836	sv_setiv (sv, (IV)&coroapi);
3271	SvREADONLY_on (sv);	3837	SvREADONLY_on (sv);
3272	}	3838	}
3273	}	3839	}
3274		3840
		3841	SV *
		3842	async (...)
		3843	PROTOTYPE: &@
		3844	CODE:
		3845	RETVAL = coro_new (aTHX_ coro_stash, &ST (0), items, 1);
		3846	api_ready (aTHX_ RETVAL);
		3847	OUTPUT:
		3848	RETVAL
		3849
		3850	void
		3851	_destroy (Coro::State coro)
		3852	CODE:
		3853	/* used by the manager thread */
		3854	coro_state_destroy (aTHX_ coro);
		3855
		3856	void
		3857	on_destroy (Coro::State coro, SV *cb)
		3858	CODE:
		3859	coro_push_on_destroy (aTHX_ coro, newSVsv (cb));
		3860
		3861	void
		3862	join (...)
		3863	CODE:
		3864	CORO_EXECUTE_SLF_XS (slf_init_join);
		3865
3275	void	3866	void
3276	terminate (...)	3867	terminate (...)
3277	CODE:	3868	CODE:
3278	CORO_EXECUTE_SLF_XS (slf_init_terminate);	3869	CORO_EXECUTE_SLF_XS (slf_init_terminate);
		3870
		3871	void
		3872	cancel (...)
		3873	CODE:
		3874	CORO_EXECUTE_SLF_XS (slf_init_cancel);
		3875
		3876	int
		3877	safe_cancel (Coro::State self, ...)
		3878	C_ARGS: aTHX_ self, &ST (1), items - 1
3279		3879
3280	void	3880	void
3281	schedule (...)	3881	schedule (...)
3282	CODE:	3882	CODE:
3283	CORO_EXECUTE_SLF_XS (slf_init_schedule);	3883	CORO_EXECUTE_SLF_XS (slf_init_schedule);
…		…
3312	void	3912	void
3313	_set_readyhook (SV *hook)	3913	_set_readyhook (SV *hook)
3314	PROTOTYPE: $	3914	PROTOTYPE: $
3315	CODE:	3915	CODE:
3316	SvREFCNT_dec (coro_readyhook);	3916	SvREFCNT_dec (coro_readyhook);
		3917	SvGETMAGIC (hook);
		3918	if (SvOK (hook))
		3919	{
3317	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;	3920	coro_readyhook = newSVsv (hook);
		3921	CORO_READYHOOK = invoke_sv_ready_hook_helper;
		3922	}
		3923	else
		3924	{
		3925	coro_readyhook = 0;
		3926	CORO_READYHOOK = 0;
		3927	}
3318		3928
3319	int	3929	int
3320	prio (Coro::State coro, int newprio = 0)	3930	prio (Coro::State coro, int newprio = 0)
3321	PROTOTYPE: $;$	3931	PROTOTYPE: $;$
3322	ALIAS:	3932	ALIAS:
…		…
3328	if (items > 1)	3938	if (items > 1)
3329	{	3939	{
3330	if (ix)	3940	if (ix)
3331	newprio = coro->prio - newprio;	3941	newprio = coro->prio - newprio;
3332		3942
3333	if (newprio < PRIO_MIN) newprio = PRIO_MIN;	3943	if (newprio < CORO_PRIO_MIN) newprio = CORO_PRIO_MIN;
3334	if (newprio > PRIO_MAX) newprio = PRIO_MAX;	3944	if (newprio > CORO_PRIO_MAX) newprio = CORO_PRIO_MAX;
3335		3945
3336	coro->prio = newprio;	3946	coro->prio = newprio;
3337	}	3947	}
3338	}	3948	}
3339	OUTPUT:	3949	OUTPUT:
…		…
3386	for (i = 1; i < items; ++i)	3996	for (i = 1; i < items; ++i)
3387	av_push (av, SvREFCNT_inc_NN (ST (i)));	3997	av_push (av, SvREFCNT_inc_NN (ST (i)));
3388		3998
3389	if ((SV *)hv == &PL_sv_undef)	3999	if ((SV *)hv == &PL_sv_undef)
3390	{	4000	{
3391	PUSHMARK (SP);	4001	SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1);
3392	EXTEND (SP, 2);
3393	PUSHs (sv_Coro);
3394	PUSHs ((SV *)cv_pool_handler);
3395	PUTBACK;
3396	call_sv ((SV *)cv_coro_state_new, G_SCALAR);
3397	SPAGAIN;
3398
3399	hv = (HV *)SvREFCNT_inc_NN (SvRV (POPs));	4002	hv = (HV *)SvREFCNT_inc_NN (SvRV (sv));
		4003	SvREFCNT_dec (sv);
3400	}	4004	}
3401		4005
3402	{	4006	{
3403	struct coro *coro = SvSTATE_hv (hv);	4007	struct coro *coro = SvSTATE_hv (hv);
3404		4008
…		…
3436	on_leave = 1	4040	on_leave = 1
3437	PROTOTYPE: &	4041	PROTOTYPE: &
3438	CODE:	4042	CODE:
3439	{	4043	{
3440	struct coro *coro = SvSTATE_current;	4044	struct coro *coro = SvSTATE_current;
3441	AV **avp = ix ? &coro->on_leave : &coro->on_enter;	4045	AV **avp = ix ? &coro->on_leave : &coro->on_enter;
3442		4046
3443	block = (SV *)coro_sv_2cv (aTHX_ block);	4047	block = s_get_cv_croak (block);
3444		4048
3445	if (!*avp)	4049	if (!*avp)
3446	*avp = newAV ();	4050	*avp = newAV ();
3447		4051
3448	av_push (*avp, SvREFCNT_inc (block));	4052	av_push (*avp, SvREFCNT_inc (block));
…		…
3465	MODULE = Coro::State PACKAGE = Coro::Semaphore	4069	MODULE = Coro::State PACKAGE = Coro::Semaphore
3466		4070
3467	SV *	4071	SV *
3468	new (SV *klass, SV *count = 0)	4072	new (SV *klass, SV *count = 0)
3469	CODE:	4073	CODE:
		4074	{
		4075	int semcnt = 1;
		4076
		4077	if (count)
		4078	{
		4079	SvGETMAGIC (count);
		4080
		4081	if (SvOK (count))
		4082	semcnt = SvIV (count);
		4083	}
		4084
3470	RETVAL = sv_bless (	4085	RETVAL = sv_bless (
3471	coro_waitarray_new (aTHX_ count && SvOK (count) ? SvIV (count) : 1),	4086	coro_waitarray_new (aTHX_ semcnt),
3472	GvSTASH (CvGV (cv))	4087	GvSTASH (CvGV (cv))
3473	);	4088	);
		4089	}
3474	OUTPUT:	4090	OUTPUT:
3475	RETVAL	4091	RETVAL
3476		4092
3477	# helper for Coro::Channel and others	4093	# helper for Coro::Channel and others
3478	SV *	4094	SV *
…		…
3524	XSRETURN_NO;	4140	XSRETURN_NO;
3525	}	4141	}
3526		4142
3527	void	4143	void
3528	waiters (SV *self)	4144	waiters (SV *self)
3529	PPCODE:	4145	PPCODE:
3530	{	4146	{
3531	AV *av = (AV *)SvRV (self);	4147	AV *av = (AV *)SvRV (self);
3532	int wcount = AvFILLp (av) + 1 - 1;	4148	int wcount = AvFILLp (av) + 1 - 1;
3533		4149
3534	if (GIMME_V == G_SCALAR)	4150	if (GIMME_V == G_SCALAR)
…		…
3543	}	4159	}
3544		4160
3545	MODULE = Coro::State PACKAGE = Coro::SemaphoreSet	4161	MODULE = Coro::State PACKAGE = Coro::SemaphoreSet
3546		4162
3547	void	4163	void
3548	_may_delete (SV *sem, int count, int extra_refs)	4164	_may_delete (SV *sem, int count, unsigned int extra_refs)
3549	PPCODE:	4165	PPCODE:
3550	{	4166	{
3551	AV *av = (AV *)SvRV (sem);	4167	AV *av = (AV *)SvRV (sem);
3552		4168
3553	if (SvREFCNT ((SV *)av) == 1 + extra_refs	4169	if (SvREFCNT ((SV *)av) == 1 + extra_refs
3554	&& AvFILLp (av) == 0 /* no waiters, just count */	4170	&& AvFILLp (av) == 0 /* no waiters, just count */
3555	&& SvIV (AvARRAY (av)[0]) == count)	4171	&& SvIV (AvARRAY (av)[0]) == count)
3556	XSRETURN_YES;	4172	XSRETURN_YES;
…		…
3577		4193
3578	void	4194	void
3579	broadcast (SV *self)	4195	broadcast (SV *self)
3580	CODE:	4196	CODE:
3581	{	4197	{
3582	AV *av = (AV *)SvRV (self);	4198	AV *av = (AV *)SvRV (self);
3583	coro_signal_wake (aTHX_ av, AvFILLp (av));	4199	coro_signal_wake (aTHX_ av, AvFILLp (av));
3584	}	4200	}
3585		4201
3586	void	4202	void
3587	send (SV *self)	4203	send (SV *self)
…		…
3595	SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */	4211	SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
3596	}	4212	}
3597		4213
3598	IV	4214	IV
3599	awaited (SV *self)	4215	awaited (SV *self)
3600	CODE:	4216	CODE:
3601	RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;	4217	RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
3602	OUTPUT:	4218	OUTPUT:
3603	RETVAL	4219	RETVAL
3604		4220
3605		4221
…		…
3610		4226
3611	void	4227	void
3612	_schedule (...)	4228	_schedule (...)
3613	CODE:	4229	CODE:
3614	{	4230	{
3615	static int incede;	4231	static int incede;
3616		4232
3617	api_cede_notself (aTHX);	4233	api_cede_notself (aTHX);
3618		4234
3619	++incede;	4235	++incede;
3620	while (coro_nready >= incede && api_cede (aTHX))	4236	while (coro_nready >= incede && api_cede (aTHX))
…		…
3636		4252
3637	void	4253	void
3638	_register (char *target, char *proto, SV *req)	4254	_register (char *target, char *proto, SV *req)
3639	CODE:	4255	CODE:
3640	{	4256	{
3641	CV *req_cv = coro_sv_2cv (aTHX_ req);	4257	SV *req_cv = s_get_cv_croak (req);
3642	/* newXSproto doesn't return the CV on 5.8 */	4258	/* newXSproto doesn't return the CV on 5.8 */
3643	CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);	4259	CV *slf_cv = newXS (target, coro_aio_req_xs, __FILE__);
3644	sv_setpv ((SV *)slf_cv, proto);	4260	sv_setpv ((SV *)slf_cv, proto);
3645	sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);	4261	sv_magicext ((SV *)slf_cv, (SV *)req_cv, CORO_MAGIC_type_aio, 0, 0, 0);
3646	}	4262	}
3647		4263
		4264	MODULE = Coro::State PACKAGE = Coro::Select
		4265
		4266	void
		4267	patch_pp_sselect ()
		4268	CODE:
		4269	if (!coro_old_pp_sselect)
		4270	{
		4271	coro_select_select = (SV *)get_cv ("Coro::Select::select", 0);
		4272	coro_old_pp_sselect = PL_ppaddr [OP_SSELECT];
		4273	PL_ppaddr [OP_SSELECT] = coro_pp_sselect;
		4274	}
		4275
		4276	void
		4277	unpatch_pp_sselect ()
		4278	CODE:
		4279	if (coro_old_pp_sselect)
		4280	{
		4281	PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
		4282	coro_old_pp_sselect = 0;
		4283	}
		4284
		4285	MODULE = Coro::State PACKAGE = Coro::Util
		4286
		4287	void
		4288	_exit (int code)
		4289	CODE:
		4290	_exit (code);
		4291
		4292	NV
		4293	time ()
		4294	CODE:
		4295	RETVAL = nvtime (aTHX);
		4296	OUTPUT:
		4297	RETVAL
		4298
		4299	NV
		4300	gettimeofday ()
		4301	PPCODE:
		4302	{
		4303	UV tv [2];
		4304	u2time (aTHX_ tv);
		4305	EXTEND (SP, 2);
		4306	PUSHs (sv_2mortal (newSVuv (tv [0])));
		4307	PUSHs (sv_2mortal (newSVuv (tv [1])));
		4308	}
		4309

Diff Legend

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