ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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