ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.373 by root, Thu Oct 1 23:51:33 2009 UTC vs.
Revision 1.439 by root, Tue Nov 19 05:16:01 2013 UTC

		1	/* this works around a bug in mingw32 providing a non-working setjmp */
		2	#define USE_NO_MINGW_SETJMP_TWO_ARGS
		3
		4	#define NDEBUG 1 /* perl usually disables NDEBUG later */
		5
1	#include "libcoro/coro.c"	6	#include "libcoro/coro.c"
2		7
3	#define PERL_NO_GET_CONTEXT	8	#define PERL_NO_GET_CONTEXT
4	#define PERL_EXT	9	#define PERL_EXT
5		10
…		…
8	#include "XSUB.h"	13	#include "XSUB.h"
9	#include "perliol.h"	14	#include "perliol.h"
10		15
11	#include "schmorp.h"	16	#include "schmorp.h"
12		17
		18	#define ECB_NO_THREADS 1
		19	#include "ecb.h"
		20
		21	#include <stddef.h>
13	#include <stdio.h>	22	#include <stdio.h>
14	#include <errno.h>	23	#include <errno.h>
15	#include <assert.h>	24	#include <assert.h>
16		25
17	#ifdef WIN32	26	#ifndef SVs_PADSTALE
		27	# define SVs_PADSTALE 0
		28	#endif
		29
		30	#ifdef PadARRAY
		31	# define NEWPADAPI 1
		32	# define newPADLIST(var) (Newz (0, var, 1, PADLIST), Newx (PadlistARRAY (var), 2, PAD *))
		33	#else
		34	typedef AV PADNAMELIST;
		35	# if !PERL_VERSION_ATLEAST(5,8,0)
		36	typedef AV PADLIST;
		37	typedef AV PAD;
		38	# endif
		39	# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
		40	# define PadlistMAX(pl) AvFILLp (pl)
		41	# define PadlistNAMES(pl) (*PadlistARRAY (pl))
		42	# define PadARRAY AvARRAY
		43	# define PadMAX AvFILLp
		44	# define newPADLIST(var) ((var) = newAV (), av_extend (var, 1))
		45	#endif
		46
		47	/* 5.19.something has replaced SVt_BIND by SVt_INVLIST */
		48	/* we just alias it to SVt_IV, as that is sufficient for swap_sv for now */
		49	#if PERL_VERSION_ATLEAST(5,19,0)
		50	# define SVt_BIND SVt_IV
		51	#endif
		52
		53	#if defined(_WIN32)
		54	# undef HAS_GETTIMEOFDAY
18	# undef setjmp	55	# undef setjmp
19	# undef longjmp	56	# undef longjmp
20	# undef _exit	57	# undef _exit
21	# define setjmp _setjmp /* deep magic */	58	# define setjmp _setjmp /* deep magic */
22	#else	59	#else
23	# include <inttypes.h> /* most portable stdint.h */	60	# include <inttypes.h> /* most portable stdint.h */
24	#endif	61	#endif
25		62
26	#ifdef HAVE_MMAP
27	# include <unistd.h>
28	# include <sys/mman.h>
29	# ifndef MAP_ANONYMOUS
30	# ifdef MAP_ANON
31	# define MAP_ANONYMOUS MAP_ANON
32	# else
33	# undef HAVE_MMAP
34	# endif
35	# endif
36	# include <limits.h>
37	# ifndef PAGESIZE
38	# define PAGESIZE pagesize
39	# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
40	static long pagesize;
41	# else
42	# define BOOT_PAGESIZE (void)0
43	# endif
44	#else
45	# define PAGESIZE 0
46	# define BOOT_PAGESIZE (void)0
47	#endif
48
49	#if CORO_USE_VALGRIND
50	# include <valgrind/valgrind.h>
51	#endif
52
53	/* the maximum number of idle cctx that will be pooled */	63	/* the maximum number of idle cctx that will be pooled */
54	static int cctx_max_idle = 4;	64	static int cctx_max_idle = 4;
55		65
56	#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64	66	#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)
57	# undef CORO_STACKGUARD	67	# define HAS_SCOPESTACK_NAME 1
58	#endif
59
60	#ifndef CORO_STACKGUARD
61	# define CORO_STACKGUARD 0
62	#endif	68	#endif
63		69
64	/* prefer perl internal functions over our own? */	70	/* prefer perl internal functions over our own? */
65	#ifndef CORO_PREFER_PERL_FUNCTIONS	71	#ifndef CORO_PREFER_PERL_FUNCTIONS
66	# define CORO_PREFER_PERL_FUNCTIONS 0	72	# define CORO_PREFER_PERL_FUNCTIONS 0
…		…
76	# define STACKLEVEL ((void *)&stacklevel)	82	# define STACKLEVEL ((void *)&stacklevel)
77	#endif	83	#endif
78		84
79	#define IN_DESTRUCT PL_dirty	85	#define IN_DESTRUCT PL_dirty
80		86
81	#if __GNUC__ >= 3
82	# define attribute(x) __attribute__(x)
83	# define expect(expr,value) __builtin_expect ((expr), (value))
84	# define INLINE static inline
85	#else
86	# define attribute(x)
87	# define expect(expr,value) (expr)
88	# define INLINE static
89	#endif
90
91	#define expect_false(expr) expect ((expr) != 0, 0)
92	#define expect_true(expr) expect ((expr) != 0, 1)
93
94	#define NOINLINE attribute ((noinline))
95
96	#include "CoroAPI.h"	87	#include "CoroAPI.h"
97	#define GCoroAPI (&coroapi) /* very sneaky */	88	#define GCoroAPI (&coroapi) /* very sneaky */
98		89
99	#ifdef USE_ITHREADS	90	#ifdef USE_ITHREADS
100	# if CORO_PTHREAD	91	# if CORO_PTHREAD
…		…
116	static void (*u2time)(pTHX_ UV ret[2]);	107	static void (*u2time)(pTHX_ UV ret[2]);
117		108
118	/* we hijack an hopefully unused CV flag for our purposes */	109	/* we hijack an hopefully unused CV flag for our purposes */
119	#define CVf_SLF 0x4000	110	#define CVf_SLF 0x4000
120	static OP *pp_slf (pTHX);	111	static OP *pp_slf (pTHX);
		112	static void slf_destroy (pTHX_ struct coro *coro);
121		113
122	static U32 cctx_gen;	114	static U32 cctx_gen;
123	static size_t cctx_stacksize = CORO_STACKSIZE;	115	static size_t cctx_stacksize = CORO_STACKSIZE;
124	static struct CoroAPI coroapi;	116	static struct CoroAPI coroapi;
125	static AV *main_mainstack; /* used to differentiate between $main and others */	117	static AV *main_mainstack; /* used to differentiate between $main and others */
…		…
155	static char times_valid;	147	static char times_valid;
156		148
157	static struct coro_cctx *cctx_first;	149	static struct coro_cctx *cctx_first;
158	static int cctx_count, cctx_idle;	150	static int cctx_count, cctx_idle;
159		151
160	enum {	152	enum
		153	{
161	CC_MAPPED = 0x01,	154	CC_MAPPED = 0x01,
162	CC_NOREUSE = 0x02, /* throw this away after tracing */	155	CC_NOREUSE = 0x02, /* throw this away after tracing */
163	CC_TRACE = 0x04,	156	CC_TRACE = 0x04,
164	CC_TRACE_SUB = 0x08, /* trace sub calls */	157	CC_TRACE_SUB = 0x08, /* trace sub calls */
165	CC_TRACE_LINE = 0x10, /* trace each statement */	158	CC_TRACE_LINE = 0x10, /* trace each statement */
…		…
170	typedef struct coro_cctx	163	typedef struct coro_cctx
171	{	164	{
172	struct coro_cctx *next;	165	struct coro_cctx *next;
173		166
174	/* the stack */	167	/* the stack */
175	void *sptr;	168	struct coro_stack stack;
176	size_t ssize;
177		169
178	/* cpu state */	170	/* cpu state */
179	void *idle_sp; /* sp of top-level transfer/schedule/cede call */	171	void *idle_sp; /* sp of top-level transfer/schedule/cede call */
		172	#ifndef NDEBUG
180	JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */	173	JMPENV *idle_te; /* same as idle_sp, but for top_env */
		174	#endif
181	JMPENV *top_env;	175	JMPENV *top_env;
182	coro_context cctx;	176	coro_context cctx;
183		177
184	U32 gen;	178	U32 gen;
185	#if CORO_USE_VALGRIND	179	#if CORO_USE_VALGRIND
186	int valgrind_id;	180	int valgrind_id;
187	#endif	181	#endif
188	unsigned char flags;	182	unsigned char flags;
189	} coro_cctx;	183	} coro_cctx;
190		184
191	coro_cctx *cctx_current; /* the currently running cctx */	185	static coro_cctx *cctx_current; /* the currently running cctx */
192		186
193	/*****************************************************************************/	187	/*****************************************************************************/
194		188
		189	static MGVTBL coro_state_vtbl;
		190
195	enum {	191	enum
		192	{
196	CF_RUNNING = 0x0001, /* coroutine is running */	193	CF_RUNNING = 0x0001, /* coroutine is running */
197	CF_READY = 0x0002, /* coroutine is ready */	194	CF_READY = 0x0002, /* coroutine is ready */
198	CF_NEW = 0x0004, /* has never been switched to */	195	CF_NEW = 0x0004, /* has never been switched to */
199	CF_DESTROYED = 0x0008, /* coroutine data has been freed */	196	CF_ZOMBIE = 0x0008, /* coroutine data has been freed */
200	CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */	197	CF_SUSPENDED = 0x0010, /* coroutine can't be scheduled */
		198	CF_NOCANCEL = 0x0020, /* cannot cancel, set slf_frame.data to 1 (hackish) */
201	};	199	};
202		200
203	/* the structure where most of the perl state is stored, overlaid on the cxstack */	201	/* the structure where most of the perl state is stored, overlaid on the cxstack */
204	typedef struct	202	typedef struct
205	{	203	{
206	SV *defsv;
207	AV *defav;
208	SV *errsv;
209	SV *irsgv;
210	HV *hinthv;
211	#define VAR(name,type) type name;	204	#define VARx(name,expr,type) type name;
212	# include "state.h"	205	#include "state.h"
213	#undef VAR
214	} perl_slots;	206	} perl_slots;
215		207
		208	/* how many context stack entries do we need for perl_slots */
216	#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))	209	#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
217		210
218	/* this is a structure representing a perl-level coroutine */	211	/* this is a structure representing a perl-level coroutine */
219	struct coro {	212	struct coro
		213	{
220	/* the C coroutine allocated to this perl coroutine, if any */	214	/* the C coroutine allocated to this perl coroutine, if any */
221	coro_cctx *cctx;	215	coro_cctx *cctx;
222		216
223	/* ready queue */	217	/* ready queue */
224	struct coro *next_ready;	218	struct coro *next_ready;
…		…
226	/* state data */	220	/* state data */
227	struct CoroSLF slf_frame; /* saved slf frame */	221	struct CoroSLF slf_frame; /* saved slf frame */
228	AV *mainstack;	222	AV *mainstack;
229	perl_slots *slot; /* basically the saved sp */	223	perl_slots *slot; /* basically the saved sp */
230		224
231	CV *startcv; /* the CV to execute */	225	CV *startcv; /* the CV to execute */
232	AV *args; /* data associated with this coroutine (initial args) */	226	AV *args; /* data associated with this coroutine (initial args) */
233	int refcnt; /* coroutines are refcounted, yes */
234	int flags; /* CF_ flags */	227	int flags; /* CF_ flags */
235	HV *hv; /* the perl hash associated with this coro, if any */	228	HV *hv; /* the perl hash associated with this coro, if any */
236	void (*on_destroy)(pTHX_ struct coro *coro);
237		229
238	/* statistics */	230	/* statistics */
239	int usecount; /* number of transfers to this coro */	231	int usecount; /* number of transfers to this coro */
240		232
241	/* coro process data */	233	/* coro process data */
242	int prio;	234	int prio;
243	SV *except; /* exception to be thrown */	235	SV *except; /* exception to be thrown */
244	SV *rouse_cb;	236	SV *rouse_cb; /* last rouse callback */
		237	AV *on_destroy; /* callbacks or coros to notify on destroy */
		238	AV *status; /* the exit status list */
245		239
246	/* async_pool */	240	/* async_pool */
247	SV *saved_deffh;	241	SV *saved_deffh;
248	SV *invoke_cb;	242	SV *invoke_cb;
249	AV *invoke_av;	243	AV *invoke_av;
250		244
251	/* on_enter/on_leave */	245	/* on_enter/on_leave */
252	AV *on_enter;	246	AV *on_enter;
253	AV *on_leave;	247	AV *on_leave;
254		248
		249	/* swap_sv */
		250	AV *swap_sv;
		251
255	/* times */	252	/* times */
256	coro_ts t_cpu, t_real;	253	coro_ts t_cpu, t_real;
257		254
258	/* linked list */	255	/* linked list */
259	struct coro *next, *prev;	256	struct coro *next, *prev;
…		…
262	typedef struct coro *Coro__State;	259	typedef struct coro *Coro__State;
263	typedef struct coro *Coro__State_or_hashref;	260	typedef struct coro *Coro__State_or_hashref;
264		261
265	/* the following variables are effectively part of the perl context */	262	/* the following variables are effectively part of the perl context */
266	/* and get copied between struct coro and these variables */	263	/* and get copied between struct coro and these variables */
267	/* the mainr easonw e don't support windows process emulation */	264	/* the main reason we don't support windows process emulation */
268	static struct CoroSLF slf_frame; /* the current slf frame */	265	static struct CoroSLF slf_frame; /* the current slf frame */
269		266
270	/** Coro ********************************************************************/	267	/** Coro ********************************************************************/
271		268
272	#define CORO_PRIO_MAX 3	269	#define CORO_PRIO_MAX 3
…		…
278		275
279	/* for Coro.pm */	276	/* for Coro.pm */
280	static SV *coro_current;	277	static SV *coro_current;
281	static SV *coro_readyhook;	278	static SV *coro_readyhook;
282	static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */	279	static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */
283	static CV *cv_coro_run, *cv_coro_terminate;	280	static CV *cv_coro_run;
284	static struct coro *coro_first;	281	static struct coro *coro_first;
285	#define coro_nready coroapi.nready	282	#define coro_nready coroapi.nready
		283
		284	/** JIT *********************************************************************/
		285
		286	#if CORO_JIT
		287	/* APPLE doesn't have mmap though */
		288	#define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__)
		289	#ifndef CORO_JIT_TYPE
		290	#if ECB_AMD64 && CORO_JIT_UNIXY
		291	#define CORO_JIT_TYPE "amd64-unix"
		292	#elif __i386 && CORO_JIT_UNIXY
		293	#define CORO_JIT_TYPE "x86-unix"
		294	#endif
		295	#endif
		296	#endif
		297
		298	#if !defined(CORO_JIT_TYPE) || _POSIX_MEMORY_PROTECTION <= 0
		299	#undef CORO_JIT
		300	#endif
		301
		302	#if CORO_JIT
		303	typedef void (*load_save_perl_slots_type)(perl_slots *);
		304	static load_save_perl_slots_type load_perl_slots, save_perl_slots;
		305	#endif
286		306
287	/** Coro::Select ************************************************************/	307	/** Coro::Select ************************************************************/
288		308
289	static OP *(*coro_old_pp_sselect) (pTHX);	309	static OP *(*coro_old_pp_sselect) (pTHX);
290	static SV *coro_select_select;	310	static SV *coro_select_select;
…		…
302	PL_op->op_flags |= OPf_STACKED;	322	PL_op->op_flags |= OPf_STACKED;
303	PL_op->op_private = 0;	323	PL_op->op_private = 0;
304	return PL_ppaddr [OP_ENTERSUB](aTHX);	324	return PL_ppaddr [OP_ENTERSUB](aTHX);
305	}	325	}
306		326
		327	/** time stuff **************************************************************/
		328
		329	#ifdef HAS_GETTIMEOFDAY
		330
		331	ecb_inline void
		332	coro_u2time (pTHX_ UV ret[2])
		333	{
		334	struct timeval tv;
		335	gettimeofday (&tv, 0);
		336
		337	ret [0] = tv.tv_sec;
		338	ret [1] = tv.tv_usec;
		339	}
		340
		341	ecb_inline double
		342	coro_nvtime (void)
		343	{
		344	struct timeval tv;
		345	gettimeofday (&tv, 0);
		346
		347	return tv.tv_sec + tv.tv_usec * 1e-6;
		348	}
		349
		350	ecb_inline void
		351	time_init (pTHX)
		352	{
		353	nvtime = coro_nvtime;
		354	u2time = coro_u2time;
		355	}
		356
		357	#else
		358
		359	ecb_inline void
		360	time_init (pTHX)
		361	{
		362	SV **svp;
		363
		364	require_pv ("Time/HiRes.pm");
		365
		366	svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
		367
		368	if (!svp) croak ("Time::HiRes is required, but missing. Caught");
		369	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught");
		370
		371	nvtime = INT2PTR (double (*)(), SvIV (*svp));
		372
		373	svp = hv_fetch (PL_modglobal, "Time::U2time", 12, 0);
		374	u2time = INT2PTR (void (*)(pTHX_ UV ret[2]), SvIV (*svp));
		375	}
		376
		377	#endif
		378
307	/** lowlevel stuff **********************************************************/	379	/** lowlevel stuff **********************************************************/
308		380
309	static SV *	381	static SV * ecb_noinline
310	coro_get_sv (pTHX_ const char *name, int create)	382	coro_get_sv (pTHX_ const char *name, int create)
311	{	383	{
312	#if PERL_VERSION_ATLEAST (5,10,0)	384	#if PERL_VERSION_ATLEAST (5,10,0)
313	/* silence stupid and wrong 5.10 warning that I am unable to switch off */	385	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
314	get_sv (name, create);	386	get_sv (name, create);
315	#endif	387	#endif
316	return get_sv (name, create);	388	return get_sv (name, create);
317	}	389	}
318		390
319	static AV *	391	static AV * ecb_noinline
320	coro_get_av (pTHX_ const char *name, int create)	392	coro_get_av (pTHX_ const char *name, int create)
321	{	393	{
322	#if PERL_VERSION_ATLEAST (5,10,0)	394	#if PERL_VERSION_ATLEAST (5,10,0)
323	/* silence stupid and wrong 5.10 warning that I am unable to switch off */	395	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
324	get_av (name, create);	396	get_av (name, create);
325	#endif	397	#endif
326	return get_av (name, create);	398	return get_av (name, create);
327	}	399	}
328		400
329	static HV *	401	static HV * ecb_noinline
330	coro_get_hv (pTHX_ const char *name, int create)	402	coro_get_hv (pTHX_ const char *name, int create)
331	{	403	{
332	#if PERL_VERSION_ATLEAST (5,10,0)	404	#if PERL_VERSION_ATLEAST (5,10,0)
333	/* silence stupid and wrong 5.10 warning that I am unable to switch off */	405	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
334	get_hv (name, create);	406	get_hv (name, create);
335	#endif	407	#endif
336	return get_hv (name, create);	408	return get_hv (name, create);
337	}	409	}
338		410
339	INLINE void	411	ecb_inline void
340	coro_times_update ()	412	coro_times_update (void)
341	{	413	{
342	#ifdef coro_clock_gettime	414	#ifdef coro_clock_gettime
343	struct timespec ts;	415	struct timespec ts;
344		416
345	ts.tv_sec = ts.tv_nsec = 0;	417	ts.tv_sec = ts.tv_nsec = 0;
…		…
357	time_real [0] = tv [0];	429	time_real [0] = tv [0];
358	time_real [1] = tv [1] * 1000;	430	time_real [1] = tv [1] * 1000;
359	#endif	431	#endif
360	}	432	}
361		433
362	INLINE void	434	ecb_inline void
363	coro_times_add (struct coro *c)	435	coro_times_add (struct coro *c)
364	{	436	{
365	c->t_real [1] += time_real [1];	437	c->t_real [1] += time_real [1];
366	if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; }	438	if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; }
367	c->t_real [0] += time_real [0];	439	c->t_real [0] += time_real [0];
…		…
369	c->t_cpu [1] += time_cpu [1];	441	c->t_cpu [1] += time_cpu [1];
370	if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; }	442	if (c->t_cpu [1] > 1000000000) { c->t_cpu [1] -= 1000000000; ++c->t_cpu [0]; }
371	c->t_cpu [0] += time_cpu [0];	443	c->t_cpu [0] += time_cpu [0];
372	}	444	}
373		445
374	INLINE void	446	ecb_inline void
375	coro_times_sub (struct coro *c)	447	coro_times_sub (struct coro *c)
376	{	448	{
377	if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; }	449	if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; }
378	c->t_real [1] -= time_real [1];	450	c->t_real [1] -= time_real [1];
379	c->t_real [0] -= time_real [0];	451	c->t_real [0] -= time_real [0];
…		…
387	/* magic glue */	459	/* magic glue */
388		460
389	#define CORO_MAGIC_type_cv 26	461	#define CORO_MAGIC_type_cv 26
390	#define CORO_MAGIC_type_state PERL_MAGIC_ext	462	#define CORO_MAGIC_type_state PERL_MAGIC_ext
391		463
392	#define CORO_MAGIC_NN(sv, type) \	464	#define CORO_MAGIC_NN(sv, type) \
393	(expect_true (SvMAGIC (sv)->mg_type == type) \	465	(ecb_expect_true (SvMAGIC (sv)->mg_type == type) \
394	? SvMAGIC (sv) \	466	? SvMAGIC (sv) \
395	: mg_find (sv, type))	467	: mg_find (sv, type))
396		468
397	#define CORO_MAGIC(sv, type) \	469	#define CORO_MAGIC(sv, type) \
398	(expect_true (SvMAGIC (sv)) \	470	(ecb_expect_true (SvMAGIC (sv)) \
399	? CORO_MAGIC_NN (sv, type) \	471	? CORO_MAGIC_NN (sv, type) \
400	: 0)	472	: 0)
401		473
402	#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)	474	#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
403	#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)	475	#define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state)
404		476
405	INLINE struct coro *	477	ecb_inline MAGIC *
		478	SvSTATEhv_p (pTHX_ SV *coro)
		479	{
		480	MAGIC *mg;
		481
		482	if (ecb_expect_true (
		483	SvTYPE (coro) == SVt_PVHV
		484	&& (mg = CORO_MAGIC_state (coro))
		485	&& mg->mg_virtual == &coro_state_vtbl
		486	))
		487	return mg;
		488
		489	return 0;
		490	}
		491
		492	ecb_inline struct coro *
406	SvSTATE_ (pTHX_ SV *coro)	493	SvSTATE_ (pTHX_ SV *coro)
407	{	494	{
408	HV *stash;
409	MAGIC *mg;	495	MAGIC *mg;
410		496
411	if (SvROK (coro))	497	if (SvROK (coro))
412	coro = SvRV (coro);	498	coro = SvRV (coro);
413		499
414	if (expect_false (SvTYPE (coro) != SVt_PVHV))	500	mg = SvSTATEhv_p (aTHX_ coro);
		501	if (!mg)
415	croak ("Coro::State object required");	502	croak ("Coro::State object required");
416		503
417	stash = SvSTASH (coro);
418	if (expect_false (stash != coro_stash && stash != coro_state_stash))
419	{
420	/* very slow, but rare, check */
421	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
422	croak ("Coro::State object required");
423	}
424
425	mg = CORO_MAGIC_state (coro);
426	return (struct coro *)mg->mg_ptr;	504	return (struct coro *)mg->mg_ptr;
427	}	505	}
428		506
429	#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))	507	#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
430		508
…		…
433	#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))	511	#define SvSTATE_current SvSTATE_hv (SvRV (coro_current))
434		512
435	/*****************************************************************************/	513	/*****************************************************************************/
436	/* padlist management and caching */	514	/* padlist management and caching */
437		515
438	static AV *	516	ecb_inline PADLIST *
439	coro_derive_padlist (pTHX_ CV *cv)	517	coro_derive_padlist (pTHX_ CV *cv)
440	{	518	{
441	AV *padlist = CvPADLIST (cv);	519	PADLIST *padlist = CvPADLIST (cv);
442	AV *newpadlist, *newpad;	520	PADLIST *newpadlist;
		521	PAD *newpad;
		522	PADOFFSET off = PadlistMAX (padlist) + 1;
443		523
444	newpadlist = newAV ();	524	#if NEWPADAPI
		525
		526	/* if we had the original CvDEPTH, we might be able to steal the CvDEPTH+1 entry instead */
		527	/* 20131102194744.GA6705@schmorp.de, 20131102195825.2013.qmail@lists-nntp.develooper.com */
		528	while (!PadlistARRAY (padlist)[off - 1])
		529	--off;
		530
		531	Perl_pad_push (aTHX_ padlist, off);
		532
		533	newpad = PadlistARRAY (padlist)[off];
		534	PadlistARRAY (padlist)[off] = 0;
		535
		536	#else
		537
		538	#if PERL_VERSION_ATLEAST (5,10,0)
		539	Perl_pad_push (aTHX_ padlist, off);
		540	#else
		541	Perl_pad_push (aTHX_ padlist, off, 1);
		542	#endif
		543
		544	newpad = PadlistARRAY (padlist)[off];
		545	PadlistMAX (padlist) = off - 1;
		546
		547	#endif
		548
		549	newPADLIST (newpadlist);
		550	#if !PERL_VERSION_ATLEAST(5,15,3)
		551	/* Padlists are AvREAL as of 5.15.3. See perl bug #98092 and perl commit 7d953ba. */
445	AvREAL_off (newpadlist);	552	AvREAL_off (newpadlist);
446	#if PERL_VERSION_ATLEAST (5,10,0)
447	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
448	#else
449	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
450	#endif	553	#endif
451	newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
452	--AvFILLp (padlist);
453		554
454	av_store (newpadlist, 0, SvREFCNT_inc_NN (AvARRAY (padlist)[0]));	555	/* Already extended to 2 elements by newPADLIST. */
455	av_store (newpadlist, 1, (SV *)newpad);	556	PadlistMAX (newpadlist) = 1;
		557	PadlistNAMES (newpadlist) = (PADNAMELIST *)SvREFCNT_inc_NN (PadlistNAMES (padlist));
		558	PadlistARRAY (newpadlist)[1] = newpad;
456		559
457	return newpadlist;	560	return newpadlist;
458	}	561	}
459		562
460	static void	563	ecb_inline void
461	free_padlist (pTHX_ AV *padlist)	564	free_padlist (pTHX_ PADLIST *padlist)
462	{	565	{
463	/* may be during global destruction */	566	/* may be during global destruction */
464	if (!IN_DESTRUCT)	567	if (!IN_DESTRUCT)
465	{	568	{
466	I32 i = AvFILLp (padlist);	569	I32 i = PadlistMAX (padlist);
467		570
468	while (i > 0) /* special-case index 0 */	571	while (i > 0) /* special-case index 0 */
469	{	572	{
470	/* we try to be extra-careful here */	573	/* we try to be extra-careful here */
471	AV *av = (AV *)AvARRAY (padlist)[i--];	574	PAD *pad = PadlistARRAY (padlist)[i--];
472	I32 j = AvFILLp (av);
473		575
		576	if (pad)
		577	{
		578	I32 j = PadMAX (pad);
		579
474	while (j >= 0)	580	while (j >= 0)
475	SvREFCNT_dec (AvARRAY (av)[j--]);	581	SvREFCNT_dec (PadARRAY (pad)[j--]);
476		582
477	AvFILLp (av) = -1;	583	PadMAX (pad) = -1;
478	SvREFCNT_dec (av);	584	SvREFCNT_dec (pad);
		585	}
479	}	586	}
480		587
481	SvREFCNT_dec (AvARRAY (padlist)[0]);	588	SvREFCNT_dec (PadlistNAMES (padlist));
482		589
		590	#if NEWPADAPI
		591	Safefree (PadlistARRAY (padlist));
		592	Safefree (padlist);
		593	#else
483	AvFILLp (padlist) = -1;	594	AvFILLp (padlist) = -1;
		595	AvREAL_off (padlist);
484	SvREFCNT_dec ((SV*)padlist);	596	SvREFCNT_dec ((SV*)padlist);
		597	#endif
485	}	598	}
486	}	599	}
487		600
488	static int	601	static int
489	coro_cv_free (pTHX_ SV *sv, MAGIC *mg)	602	coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
490	{	603	{
491	AV *padlist;	604	PADLIST *padlist;
492	AV *av = (AV *)mg->mg_obj;	605	PADLIST **padlists = (PADLIST **)(mg->mg_ptr + sizeof(size_t));
		606	size_t len = *(size_t *)mg->mg_ptr;
493		607
494	/* perl manages to free our internal AV and _then_ call us */	608	/* perl manages to free our internal AV and _then_ call us */
495	if (IN_DESTRUCT)	609	if (IN_DESTRUCT)
496	return 0;	610	return 0;
497		611
498	/* casting is fun. */	612	while (len--)
499	while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
500	free_padlist (aTHX_ padlist);	613	free_padlist (aTHX_ padlists[len]);
501
502	SvREFCNT_dec (av); /* sv_magicext increased the refcount */
503		614
504	return 0;	615	return 0;
505	}	616	}
506		617
507	static MGVTBL coro_cv_vtbl = {	618	static MGVTBL coro_cv_vtbl = {
508	0, 0, 0, 0,	619	0, 0, 0, 0,
509	coro_cv_free	620	coro_cv_free
510	};	621	};
511		622
512	/* the next two functions merely cache the padlists */	623	/* the next two functions merely cache the padlists */
513	static void	624	ecb_inline void
514	get_padlist (pTHX_ CV *cv)	625	get_padlist (pTHX_ CV *cv)
515	{	626	{
516	MAGIC *mg = CORO_MAGIC_cv (cv);	627	MAGIC *mg = CORO_MAGIC_cv (cv);
517	AV *av;	628	size_t *lenp;
518		629
519	if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))	630	if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr)))
520	CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];	631	CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp];
521	else	632	else
522	{	633	{
523	#if CORO_PREFER_PERL_FUNCTIONS	634	#if CORO_PREFER_PERL_FUNCTIONS
524	/* this is probably cleaner? but also slower! */	635	/* this is probably cleaner? but also slower! */
525	/* in practise, it seems to be less stable */	636	/* in practise, it seems to be less stable */
…		…
531	CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);	642	CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);
532	#endif	643	#endif
533	}	644	}
534	}	645	}
535		646
536	static void	647	ecb_inline void
537	put_padlist (pTHX_ CV *cv)	648	put_padlist (pTHX_ CV *cv)
538	{	649	{
539	MAGIC *mg = CORO_MAGIC_cv (cv);	650	MAGIC *mg = CORO_MAGIC_cv (cv);
540	AV *av;
541		651
542	if (expect_false (!mg))	652	if (ecb_expect_false (!mg))
		653	{
543	mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);	654	mg = sv_magicext ((SV *)cv, 0, CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
		655	Newz (0, mg->mg_ptr ,sizeof (size_t) + sizeof (PADLIST *), char);
		656	mg->mg_len = 1; /* so mg_free frees mg_ptr */
		657	}
		658	else
		659	Renew (mg->mg_ptr,
		660	sizeof(size_t) + (*(size_t *)mg->mg_ptr + 1) * sizeof(PADLIST *),
		661	char);
544		662
545	av = (AV *)mg->mg_obj;	663	((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv);
546
547	if (expect_false (AvFILLp (av) >= AvMAX (av)))
548	av_extend (av, AvFILLp (av) + 1);
549
550	AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
551	}	664	}
552		665
553	/** load & save, init *******************************************************/	666	/** load & save, init *******************************************************/
		667
		668	ecb_inline void
		669	swap_sv (SV *a, SV *b)
		670	{
		671	const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */
		672	SV tmp;
		673
		674	/* swap sv_any */
		675	SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp);
		676
		677	/* swap sv_flags */
		678	SvFLAGS (&tmp) = SvFLAGS (a);
		679	SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep);
		680	SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep);
		681
		682	#if PERL_VERSION_ATLEAST (5,10,0)
		683	/* perl 5.10 and later complicates this _quite_ a bit, but it also
		684	* is much faster, so no quarrels here. alternatively, we could
		685	* sv_upgrade to avoid this.
		686	*/
		687	{
		688	/* swap sv_u */
		689	tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u;
		690
		691	/* if SvANY points to the head, we need to adjust the pointers,
		692	* as the pointer for a still points to b, and maybe vice versa.
		693	*/
		694	#define svany_in_head(type) \
		695	(((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type)))
		696
		697	if (svany_in_head (SvTYPE (a)))
		698	SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a);
		699
		700	if (svany_in_head (SvTYPE (b)))
		701	SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
		702	}
		703	#endif
		704	}
		705
		706	/* swap sv heads, at least logically */
		707	static void
		708	swap_svs (pTHX_ Coro__State c)
		709	{
		710	int i;
		711
		712	for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
		713	swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
		714	}
		715
		716	#define SWAP_SVS(coro) \
		717	if (ecb_expect_false ((coro)->swap_sv)) \
		718	swap_svs (aTHX_ (coro))
554		719
555	static void	720	static void
556	on_enterleave_call (pTHX_ SV *cb);	721	on_enterleave_call (pTHX_ SV *cb);
557		722
558	static void	723	static void
…		…
561	perl_slots *slot = c->slot;	726	perl_slots *slot = c->slot;
562	c->slot = 0;	727	c->slot = 0;
563		728
564	PL_mainstack = c->mainstack;	729	PL_mainstack = c->mainstack;
565		730
566	GvSV (PL_defgv) = slot->defsv;	731	#if CORO_JIT
567	GvAV (PL_defgv) = slot->defav;	732	load_perl_slots (slot);
568	GvSV (PL_errgv) = slot->errsv;	733	#else
569	GvSV (irsgv) = slot->irsgv;
570	GvHV (PL_hintgv) = slot->hinthv;
571
572	#define VAR(name,type) PL_ ## name = slot->name;	734	#define VARx(name,expr,type) expr = slot->name;
573	# include "state.h"	735	#include "state.h"
574	#undef VAR	736	#endif
575		737
576	{	738	{
577	dSP;	739	dSP;
578		740
579	CV *cv;	741	CV *cv;
580		742
581	/* now do the ugly restore mess */	743	/* now do the ugly restore mess */
582	while (expect_true (cv = (CV *)POPs))	744	while (ecb_expect_true (cv = (CV *)POPs))
583	{	745	{
584	put_padlist (aTHX_ cv); /* mark this padlist as available */	746	put_padlist (aTHX_ cv); /* mark this padlist as available */
585	CvDEPTH (cv) = PTR2IV (POPs);	747	CvDEPTH (cv) = PTR2IV (POPs);
586	CvPADLIST (cv) = (AV *)POPs;	748	CvPADLIST (cv) = (PADLIST *)POPs;
587	}	749	}
588		750
589	PUTBACK;	751	PUTBACK;
590	}	752	}
591		753
592	slf_frame = c->slf_frame;	754	slf_frame = c->slf_frame;
593	CORO_THROW = c->except;	755	CORO_THROW = c->except;
594		756
595	if (expect_false (enable_times))	757	if (ecb_expect_false (enable_times))
596	{	758	{
597	if (expect_false (!times_valid))	759	if (ecb_expect_false (!times_valid))
598	coro_times_update ();	760	coro_times_update ();
599		761
600	coro_times_sub (c);	762	coro_times_sub (c);
601	}	763	}
602		764
603	if (expect_false (c->on_enter))	765	if (ecb_expect_false (c->on_enter))
604	{	766	{
605	int i;	767	int i;
606		768
607	for (i = 0; i <= AvFILLp (c->on_enter); ++i)	769	for (i = 0; i <= AvFILLp (c->on_enter); ++i)
608	on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);	770	on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);
609	}	771	}
		772
		773	SWAP_SVS (c);
610	}	774	}
611		775
612	static void	776	static void
613	save_perl (pTHX_ Coro__State c)	777	save_perl (pTHX_ Coro__State c)
614	{	778	{
		779	SWAP_SVS (c);
		780
615	if (expect_false (c->on_leave))	781	if (ecb_expect_false (c->on_leave))
616	{	782	{
617	int i;	783	int i;
618		784
619	for (i = AvFILLp (c->on_leave); i >= 0; --i)	785	for (i = AvFILLp (c->on_leave); i >= 0; --i)
620	on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]);	786	on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]);
621	}	787	}
622		788
623	times_valid = 0;	789	times_valid = 0;
624		790
625	if (expect_false (enable_times))	791	if (ecb_expect_false (enable_times))
626	{	792	{
627	coro_times_update (); times_valid = 1;	793	coro_times_update (); times_valid = 1;
628	coro_times_add (c);	794	coro_times_add (c);
629	}	795	}
630		796
…		…
644		810
645	XPUSHs (Nullsv);	811	XPUSHs (Nullsv);
646	/* this loop was inspired by pp_caller */	812	/* this loop was inspired by pp_caller */
647	for (;;)	813	for (;;)
648	{	814	{
649	while (expect_true (cxix >= 0))	815	while (ecb_expect_true (cxix >= 0))
650	{	816	{
651	PERL_CONTEXT *cx = &ccstk[cxix--];	817	PERL_CONTEXT *cx = &ccstk[cxix--];
652		818
653	if (expect_true (CxTYPE (cx) == CXt_SUB) || expect_false (CxTYPE (cx) == CXt_FORMAT))	819	if (ecb_expect_true (CxTYPE (cx) == CXt_SUB) || ecb_expect_false (CxTYPE (cx) == CXt_FORMAT))
654	{	820	{
655	CV *cv = cx->blk_sub.cv;	821	CV *cv = cx->blk_sub.cv;
656		822
657	if (expect_true (CvDEPTH (cv)))	823	if (ecb_expect_true (CvDEPTH (cv)))
658	{	824	{
659	EXTEND (SP, 3);	825	EXTEND (SP, 3);
660	PUSHs ((SV *)CvPADLIST (cv));	826	PUSHs ((SV *)CvPADLIST (cv));
661	PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));	827	PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
662	PUSHs ((SV *)cv);	828	PUSHs ((SV *)cv);
…		…
665	get_padlist (aTHX_ cv);	831	get_padlist (aTHX_ cv);
666	}	832	}
667	}	833	}
668	}	834	}
669		835
670	if (expect_true (top_si->si_type == PERLSI_MAIN))	836	if (ecb_expect_true (top_si->si_type == PERLSI_MAIN))
671	break;	837	break;
672		838
673	top_si = top_si->si_prev;	839	top_si = top_si->si_prev;
674	ccstk = top_si->si_cxstack;	840	ccstk = top_si->si_cxstack;
675	cxix = top_si->si_cxix;	841	cxix = top_si->si_cxix;
…		…
677		843
678	PUTBACK;	844	PUTBACK;
679	}	845	}
680		846
681	/* allocate some space on the context stack for our purposes */	847	/* allocate some space on the context stack for our purposes */
682	/* we manually unroll here, as usually 2 slots is enough */	848	if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max))
683	if (SLOT_COUNT >= 1) CXINC;
684	if (SLOT_COUNT >= 2) CXINC;
685	if (SLOT_COUNT >= 3) CXINC;
686	{	849	{
687	unsigned int i;	850	unsigned int i;
		851
688	for (i = 3; i < SLOT_COUNT; ++i)	852	for (i = 0; i < SLOT_COUNT; ++i)
689	CXINC;	853	CXINC;
690	}	854
691	cxstack_ix -= SLOT_COUNT; /* undo allocation */	855	cxstack_ix -= SLOT_COUNT; /* undo allocation */
		856	}
692		857
693	c->mainstack = PL_mainstack;	858	c->mainstack = PL_mainstack;
694		859
695	{	860	{
696	perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);	861	perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
697		862
698	slot->defav = GvAV (PL_defgv);	863	#if CORO_JIT
699	slot->defsv = DEFSV;	864	save_perl_slots (slot);
700	slot->errsv = ERRSV;	865	#else
701	slot->irsgv = GvSV (irsgv);
702	slot->hinthv = GvHV (PL_hintgv);
703
704	#define VAR(name,type) slot->name = PL_ ## name;	866	#define VARx(name,expr,type) slot->name = expr;
705	# include "state.h"	867	#include "state.h"
706	#undef VAR	868	#endif
707	}	869	}
708	}	870	}
709		871
710	/*	872	/*
711	* allocate various perl stacks. This is almost an exact copy	873	* allocate various perl stacks. This is almost an exact copy
…		…
717	# define coro_init_stacks(thx) init_stacks ()	879	# define coro_init_stacks(thx) init_stacks ()
718	#else	880	#else
719	static void	881	static void
720	coro_init_stacks (pTHX)	882	coro_init_stacks (pTHX)
721	{	883	{
722	PL_curstackinfo = new_stackinfo(32, 8);	884	PL_curstackinfo = new_stackinfo(32, 4 + SLOT_COUNT); /* 3 is minimum due to perl rounding down in scope.c:GROW() */
723	PL_curstackinfo->si_type = PERLSI_MAIN;	885	PL_curstackinfo->si_type = PERLSI_MAIN;
724	PL_curstack = PL_curstackinfo->si_stack;	886	PL_curstack = PL_curstackinfo->si_stack;
725	PL_mainstack = PL_curstack; /* remember in case we switch stacks */	887	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
726		888
727	PL_stack_base = AvARRAY(PL_curstack);	889	PL_stack_base = AvARRAY(PL_curstack);
…		…
742	#endif	904	#endif
743		905
744	New(54,PL_scopestack,8,I32);	906	New(54,PL_scopestack,8,I32);
745	PL_scopestack_ix = 0;	907	PL_scopestack_ix = 0;
746	PL_scopestack_max = 8;	908	PL_scopestack_max = 8;
		909	#if HAS_SCOPESTACK_NAME
		910	New(54,PL_scopestack_name,8,const char*);
		911	#endif
747		912
748	New(54,PL_savestack,24,ANY);	913	New(54,PL_savestack,24,ANY);
749	PL_savestack_ix = 0;	914	PL_savestack_ix = 0;
750	PL_savestack_max = 24;	915	PL_savestack_max = 24;
751		916
…		…
779	}	944	}
780		945
781	Safefree (PL_tmps_stack);	946	Safefree (PL_tmps_stack);
782	Safefree (PL_markstack);	947	Safefree (PL_markstack);
783	Safefree (PL_scopestack);	948	Safefree (PL_scopestack);
		949	#if HAS_SCOPESTACK_NAME
		950	Safefree (PL_scopestack_name);
		951	#endif
784	Safefree (PL_savestack);	952	Safefree (PL_savestack);
785	#if !PERL_VERSION_ATLEAST (5,10,0)	953	#if !PERL_VERSION_ATLEAST (5,10,0)
786	Safefree (PL_retstack);	954	Safefree (PL_retstack);
787	#endif	955	#endif
788	}	956	}
…		…
834	#endif	1002	#endif
835		1003
836	/*	1004	/*
837	* This overrides the default magic get method of %SIG elements.	1005	* This overrides the default magic get method of %SIG elements.
838	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook	1006	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook
839	* and instead of trying to save and restore the hash elements, we just provide	1007	* and instead of trying to save and restore the hash elements (extremely slow),
840	* readback here.	1008	* we just provide our own readback here.
841	*/	1009	*/
842	static int	1010	static int ecb_cold
843	coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)	1011	coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
844	{	1012	{
845	const char *s = MgPV_nolen_const (mg);	1013	const char *s = MgPV_nolen_const (mg);
846		1014
847	if (*s == '_')	1015	if (*s == '_')
848	{	1016	{
849	SV **svp = 0;	1017	SV **svp = 0;
850		1018
851	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;	1019	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
852	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;	1020	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
853		1021
854	if (svp)	1022	if (svp)
855	{	1023	{
856	sv_setsv (sv, *svp ? *svp : &PL_sv_undef);	1024	SV *ssv;
		1025
		1026	if (!*svp)
		1027	ssv = &PL_sv_undef;
		1028	else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
		1029	ssv = sv_2mortal (newRV_inc (*svp));
		1030	else
		1031	ssv = *svp;
		1032
		1033	sv_setsv (sv, ssv);
857	return 0;	1034	return 0;
858	}	1035	}
859	}	1036	}
860		1037
861	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;	1038	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
862	}	1039	}
863		1040
864	static int	1041	static int ecb_cold
865	coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)	1042	coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
866	{	1043	{
867	const char *s = MgPV_nolen_const (mg);	1044	const char *s = MgPV_nolen_const (mg);
868		1045
869	if (*s == '_')	1046	if (*s == '_')
…		…
883	}	1060	}
884		1061
885	return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;	1062	return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
886	}	1063	}
887		1064
888	static int	1065	static int ecb_cold
889	coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)	1066	coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
890	{	1067	{
891	const char *s = MgPV_nolen_const (mg);	1068	const char *s = MgPV_nolen_const (mg);
892		1069
893	if (*s == '_')	1070	if (*s == '_')
…		…
926	slf_check_repeat (pTHX_ struct CoroSLF *frame)	1103	slf_check_repeat (pTHX_ struct CoroSLF *frame)
927	{	1104	{
928	return 1;	1105	return 1;
929	}	1106	}
930		1107
931	static UNOP coro_setup_op;	1108	static UNOP init_perl_op;
932		1109
933	static void NOINLINE /* noinline to keep it out of the transfer fast path */	1110	ecb_noinline static void /* noinline to keep it out of the transfer fast path */
934	coro_setup (pTHX_ struct coro *coro)	1111	init_perl (pTHX_ struct coro *coro)
935	{	1112	{
936	/*	1113	/*
937	* emulate part of the perl startup here.	1114	* emulate part of the perl startup here.
938	*/	1115	*/
939	coro_init_stacks (aTHX);	1116	coro_init_stacks (aTHX);
…		…
946	PL_comppad_name_fill = 0;	1123	PL_comppad_name_fill = 0;
947	PL_comppad_name_floor = 0;	1124	PL_comppad_name_floor = 0;
948	PL_curpm = 0;	1125	PL_curpm = 0;
949	PL_curpad = 0;	1126	PL_curpad = 0;
950	PL_localizing = 0;	1127	PL_localizing = 0;
951	PL_dirty = 0;
952	PL_restartop = 0;	1128	PL_restartop = 0;
953	#if PERL_VERSION_ATLEAST (5,10,0)	1129	#if PERL_VERSION_ATLEAST (5,10,0)
954	PL_parser = 0;	1130	PL_parser = 0;
955	#endif	1131	#endif
956	PL_hints = 0;	1132	PL_hints = 0;
957		1133
958	/* recreate the die/warn hooks */	1134	/* recreate the die/warn hooks */
959	PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );	1135	PL_diehook = SvREFCNT_inc (rv_diehook);
960	PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);	1136	PL_warnhook = SvREFCNT_inc (rv_warnhook);
961		1137
962	GvSV (PL_defgv) = newSV (0);	1138	GvSV (PL_defgv) = newSV (0);
963	GvAV (PL_defgv) = coro->args; coro->args = 0;	1139	GvAV (PL_defgv) = coro->args; coro->args = 0;
964	GvSV (PL_errgv) = newSV (0);	1140	GvSV (PL_errgv) = newSV (0);
965	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);	1141	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
966	GvHV (PL_hintgv) = 0;	1142	GvHV (PL_hintgv) = 0;
…		…
986	/* this newly created coroutine might be run on an existing cctx which most	1162	/* this newly created coroutine might be run on an existing cctx which most
987	* likely was suspended in pp_slf, so we have to emulate entering pp_slf here.	1163	* likely was suspended in pp_slf, so we have to emulate entering pp_slf here.
988	*/	1164	*/
989	slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */	1165	slf_frame.prepare = prepare_nop; /* provide a nop function for an eventual pp_slf */
990	slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */	1166	slf_frame.check = slf_check_nop; /* signal pp_slf to not repeat */
		1167	slf_frame.destroy = 0;
991		1168
992	/* and we have to provide the pp_slf op in any case, so pp_slf can skip it */	1169	/* and we have to provide the pp_slf op in any case, so pp_slf can skip it */
993	coro_setup_op.op_next = PL_op;	1170	init_perl_op.op_next = PL_op;
994	coro_setup_op.op_type = OP_ENTERSUB;	1171	init_perl_op.op_type = OP_ENTERSUB;
995	coro_setup_op.op_ppaddr = pp_slf;	1172	init_perl_op.op_ppaddr = pp_slf;
996	/* no flags etc. required, as an init function won't be called */	1173	/* no flags etc. required, as an init function won't be called */
997		1174
998	PL_op = (OP *)&coro_setup_op;	1175	PL_op = (OP *)&init_perl_op;
999		1176
1000	/* copy throw, in case it was set before coro_setup */	1177	/* copy throw, in case it was set before init_perl */
1001	CORO_THROW = coro->except;	1178	CORO_THROW = coro->except;
1002		1179
		1180	SWAP_SVS (coro);
		1181
1003	if (expect_false (enable_times))	1182	if (ecb_expect_false (enable_times))
1004	{	1183	{
1005	coro_times_update ();	1184	coro_times_update ();
1006	coro_times_sub (coro);	1185	coro_times_sub (coro);
1007	}	1186	}
1008	}	1187	}
…		…
1027	dounwind (-1);	1206	dounwind (-1);
1028	}	1207	}
1029	}	1208	}
1030		1209
1031	static void	1210	static void
1032	coro_destruct_perl (pTHX_ struct coro *coro)	1211	destroy_perl (pTHX_ struct coro *coro)
1033	{	1212	{
1034	SV *svf [9];	1213	SV *svf [9];
1035		1214
1036	{	1215	{
		1216	SV *old_current = SvRV (coro_current);
1037	struct coro *current = SvSTATE_current;	1217	struct coro *current = SvSTATE (old_current);
1038		1218
1039	assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));	1219	assert (("FATAL: tried to destroy currently running coroutine", coro->mainstack != PL_mainstack));
1040		1220
1041	save_perl (aTHX_ current);	1221	save_perl (aTHX_ current);
		1222
		1223	/* this will cause transfer_check to croak on block*/
		1224	SvRV_set (coro_current, (SV *)coro->hv);
		1225
1042	load_perl (aTHX_ coro);	1226	load_perl (aTHX_ coro);
1043		1227
1044	coro_unwind_stacks (aTHX);	1228	coro_unwind_stacks (aTHX);
		1229
		1230	/* restore swapped sv's */
		1231	SWAP_SVS (coro);
		1232
1045	coro_destruct_stacks (aTHX);	1233	coro_destruct_stacks (aTHX);
1046		1234
1047	// now save some sv's to be free'd later	1235	/* now save some sv's to be free'd later */
1048	svf [0] = GvSV (PL_defgv);	1236	svf [0] = GvSV (PL_defgv);
1049	svf [1] = (SV *)GvAV (PL_defgv);	1237	svf [1] = (SV *)GvAV (PL_defgv);
1050	svf [2] = GvSV (PL_errgv);	1238	svf [2] = GvSV (PL_errgv);
1051	svf [3] = (SV *)PL_defoutgv;	1239	svf [3] = (SV *)PL_defoutgv;
1052	svf [4] = PL_rs;	1240	svf [4] = PL_rs;
…		…
1054	svf [6] = (SV *)GvHV (PL_hintgv);	1242	svf [6] = (SV *)GvHV (PL_hintgv);
1055	svf [7] = PL_diehook;	1243	svf [7] = PL_diehook;
1056	svf [8] = PL_warnhook;	1244	svf [8] = PL_warnhook;
1057	assert (9 == sizeof (svf) / sizeof (*svf));	1245	assert (9 == sizeof (svf) / sizeof (*svf));
1058		1246
		1247	SvRV_set (coro_current, old_current);
		1248
1059	load_perl (aTHX_ current);	1249	load_perl (aTHX_ current);
1060	}	1250	}
1061		1251
1062	{	1252	{
1063	unsigned int i;	1253	unsigned int i;
…		…
1070	SvREFCNT_dec (coro->invoke_cb);	1260	SvREFCNT_dec (coro->invoke_cb);
1071	SvREFCNT_dec (coro->invoke_av);	1261	SvREFCNT_dec (coro->invoke_av);
1072	}	1262	}
1073	}	1263	}
1074		1264
1075	INLINE void	1265	ecb_inline void
1076	free_coro_mortal (pTHX)	1266	free_coro_mortal (pTHX)
1077	{	1267	{
1078	if (expect_true (coro_mortal))	1268	if (ecb_expect_true (coro_mortal))
1079	{	1269	{
1080	SvREFCNT_dec (coro_mortal);	1270	SvREFCNT_dec ((SV *)coro_mortal);
1081	coro_mortal = 0;	1271	coro_mortal = 0;
1082	}	1272	}
1083	}	1273	}
1084		1274
1085	static int	1275	static int
…		…
1218		1408
1219	return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */	1409	return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */
1220	}	1410	}
1221		1411
1222	/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */	1412	/* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */
1223	static void NOINLINE	1413	static void ecb_noinline
1224	cctx_prepare (pTHX)	1414	cctx_prepare (pTHX)
1225	{	1415	{
1226	PL_top_env = &PL_start_env;	1416	PL_top_env = &PL_start_env;
1227		1417
1228	if (cctx_current->flags & CC_TRACE)	1418	if (cctx_current->flags & CC_TRACE)
…		…
1239	slf_frame.prepare = slf_prepare_set_stacklevel;	1429	slf_frame.prepare = slf_prepare_set_stacklevel;
1240	slf_frame.check = slf_check_set_stacklevel;	1430	slf_frame.check = slf_check_set_stacklevel;
1241	}	1431	}
1242		1432
1243	/* the tail of transfer: execute stuff we can only do after a transfer */	1433	/* the tail of transfer: execute stuff we can only do after a transfer */
1244	INLINE void	1434	ecb_inline void
1245	transfer_tail (pTHX)	1435	transfer_tail (pTHX)
1246	{	1436	{
1247	free_coro_mortal (aTHX);	1437	free_coro_mortal (aTHX);
		1438	}
		1439
		1440	/* try to exit the same way perl's main function would do */
		1441	/* we do not bother resetting the environment or other things *7
		1442	/* that are not, uhm, essential */
		1443	/* this obviously also doesn't work when perl is embedded */
		1444	static void ecb_noinline ecb_cold
		1445	perlish_exit (pTHX)
		1446	{
		1447	int exitstatus = perl_destruct (PL_curinterp);
		1448	perl_free (PL_curinterp);
		1449	exit (exitstatus);
1248	}	1450	}
1249		1451
1250	/*	1452	/*
1251	* this is a _very_ stripped down perl interpreter ;)	1453	* this is a _very_ stripped down perl interpreter ;)
1252	*/	1454	*/
…		…
1281	*/	1483	*/
1282		1484
1283	/*	1485	/*
1284	* If perl-run returns we assume exit() was being called or the coro	1486	* If perl-run returns we assume exit() was being called or the coro
1285	* fell off the end, which seems to be the only valid (non-bug)	1487	* fell off the end, which seems to be the only valid (non-bug)
1286	* reason for perl_run to return. We try to exit by jumping to the	1488	* reason for perl_run to return. We try to mimic whatever perl is normally
1287	* bootstrap-time "top" top_env, as we cannot restore the "main"	1489	* doing in that case. YMMV.
1288	* coroutine as Coro has no such concept.
1289	* This actually isn't valid with the pthread backend, but OSes requiring
1290	* that backend are too broken to do it in a standards-compliant way.
1291	*/	1490	*/
1292	PL_top_env = main_top_env;	1491	perlish_exit (aTHX);
1293	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
1294	}	1492	}
1295	}	1493	}
1296		1494
1297	static coro_cctx *	1495	static coro_cctx *
1298	cctx_new ()	1496	cctx_new (void)
1299	{	1497	{
1300	coro_cctx *cctx;	1498	coro_cctx *cctx;
1301		1499
1302	++cctx_count;	1500	++cctx_count;
1303	New (0, cctx, 1, coro_cctx);	1501	New (0, cctx, 1, coro_cctx);
…		…
1309	return cctx;	1507	return cctx;
1310	}	1508	}
1311		1509
1312	/* create a new cctx only suitable as source */	1510	/* create a new cctx only suitable as source */
1313	static coro_cctx *	1511	static coro_cctx *
1314	cctx_new_empty ()	1512	cctx_new_empty (void)
1315	{	1513	{
1316	coro_cctx *cctx = cctx_new ();	1514	coro_cctx *cctx = cctx_new ();
1317		1515
1318	cctx->sptr = 0;	1516	cctx->stack.sptr = 0;
1319	coro_create (&cctx->cctx, 0, 0, 0, 0);	1517	coro_create (&cctx->cctx, 0, 0, 0, 0);
1320		1518
1321	return cctx;	1519	return cctx;
1322	}	1520	}
1323		1521
1324	/* create a new cctx suitable as destination/running a perl interpreter */	1522	/* create a new cctx suitable as destination/running a perl interpreter */
1325	static coro_cctx *	1523	static coro_cctx *
1326	cctx_new_run ()	1524	cctx_new_run (void)
1327	{	1525	{
1328	coro_cctx *cctx = cctx_new ();	1526	coro_cctx *cctx = cctx_new ();
1329	void *stack_start;
1330	size_t stack_size;
1331		1527
1332	#if HAVE_MMAP	1528	if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
1333	cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
1334	/* mmap supposedly does allocate-on-write for us */
1335	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
1336
1337	if (cctx->sptr != (void *)-1)
1338	{
1339	#if CORO_STACKGUARD
1340	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
1341	#endif
1342	stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE;
1343	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
1344	cctx->flags |= CC_MAPPED;
1345	}	1529	{
1346	else
1347	#endif
1348	{
1349	cctx->ssize = cctx_stacksize * (long)sizeof (long);
1350	New (0, cctx->sptr, cctx_stacksize, long);
1351
1352	if (!cctx->sptr)
1353	{
1354	perror ("FATAL: unable to allocate stack for coroutine, exiting.");	1530	perror ("FATAL: unable to allocate stack for coroutine, exiting.");
1355	_exit (EXIT_FAILURE);	1531	_exit (EXIT_FAILURE);
1356	}
1357
1358	stack_start = cctx->sptr;
1359	stack_size = cctx->ssize;
1360	}	1532	}
1361		1533
1362	#if CORO_USE_VALGRIND
1363	cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size);
1364	#endif
1365
1366	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);	1534	coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze);
1367		1535
1368	return cctx;	1536	return cctx;
1369	}	1537	}
1370		1538
1371	static void	1539	static void
1372	cctx_destroy (coro_cctx *cctx)	1540	cctx_destroy (coro_cctx *cctx)
1373	{	1541	{
1374	if (!cctx)	1542	if (!cctx)
1375	return;	1543	return;
1376		1544
1377	assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));//D temporary?	1545	assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
1378		1546
1379	--cctx_count;	1547	--cctx_count;
1380	coro_destroy (&cctx->cctx);	1548	coro_destroy (&cctx->cctx);
1381		1549
1382	/* coro_transfer creates new, empty cctx's */	1550	coro_stack_free (&cctx->stack);
1383	if (cctx->sptr)
1384	{
1385	#if CORO_USE_VALGRIND
1386	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
1387	#endif
1388
1389	#if HAVE_MMAP
1390	if (cctx->flags & CC_MAPPED)
1391	munmap (cctx->sptr, cctx->ssize);
1392	else
1393	#endif
1394	Safefree (cctx->sptr);
1395	}
1396		1551
1397	Safefree (cctx);	1552	Safefree (cctx);
1398	}	1553	}
1399		1554
1400	/* wether this cctx should be destructed */	1555	/* wether this cctx should be destructed */
1401	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))	1556	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
1402		1557
1403	static coro_cctx *	1558	static coro_cctx *
1404	cctx_get (pTHX)	1559	cctx_get (pTHX)
1405	{	1560	{
1406	while (expect_true (cctx_first))	1561	while (ecb_expect_true (cctx_first))
1407	{	1562	{
1408	coro_cctx *cctx = cctx_first;	1563	coro_cctx *cctx = cctx_first;
1409	cctx_first = cctx->next;	1564	cctx_first = cctx->next;
1410	--cctx_idle;	1565	--cctx_idle;
1411		1566
1412	if (expect_true (!CCTX_EXPIRED (cctx)))	1567	if (ecb_expect_true (!CCTX_EXPIRED (cctx)))
1413	return cctx;	1568	return cctx;
1414		1569
1415	cctx_destroy (cctx);	1570	cctx_destroy (cctx);
1416	}	1571	}
1417		1572
…		…
1419	}	1574	}
1420		1575
1421	static void	1576	static void
1422	cctx_put (coro_cctx *cctx)	1577	cctx_put (coro_cctx *cctx)
1423	{	1578	{
1424	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr));	1579	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr));
1425		1580
1426	/* free another cctx if overlimit */	1581	/* free another cctx if overlimit */
1427	if (expect_false (cctx_idle >= cctx_max_idle))	1582	if (ecb_expect_false (cctx_idle >= cctx_max_idle))
1428	{	1583	{
1429	coro_cctx *first = cctx_first;	1584	coro_cctx *first = cctx_first;
1430	cctx_first = first->next;	1585	cctx_first = first->next;
1431	--cctx_idle;	1586	--cctx_idle;
1432		1587
…		…
1443	static void	1598	static void
1444	transfer_check (pTHX_ struct coro *prev, struct coro *next)	1599	transfer_check (pTHX_ struct coro *prev, struct coro *next)
1445	{	1600	{
1446	/* TODO: throwing up here is considered harmful */	1601	/* TODO: throwing up here is considered harmful */
1447		1602
1448	if (expect_true (prev != next))	1603	if (ecb_expect_true (prev != next))
1449	{	1604	{
1450	if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))	1605	if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
1451	croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");	1606	croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,");
1452		1607
1453	if (expect_false (next->flags & (CF_RUNNING | CF_DESTROYED | CF_SUSPENDED)))	1608	if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED)))
1454	croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");	1609	croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,");
1455		1610
1456	#if !PERL_VERSION_ATLEAST (5,10,0)	1611	#if !PERL_VERSION_ATLEAST (5,10,0)
1457	if (expect_false (PL_lex_state != LEX_NOTPARSING))	1612	if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING))
1458	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");	1613	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,");
1459	#endif	1614	#endif
1460	}	1615	}
1461	}	1616	}
1462		1617
1463	/* always use the TRANSFER macro */	1618	/* always use the TRANSFER macro */
1464	static void NOINLINE /* noinline so we have a fixed stackframe */	1619	static void ecb_noinline /* noinline so we have a fixed stackframe */
1465	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)	1620	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
1466	{	1621	{
1467	dSTACKLEVEL;	1622	dSTACKLEVEL;
1468		1623
1469	/* sometimes transfer is only called to set idle_sp */	1624	/* sometimes transfer is only called to set idle_sp */
1470	if (expect_false (!prev))	1625	if (ecb_expect_false (!prev))
1471	{	1626	{
1472	cctx_current->idle_sp = STACKLEVEL;	1627	cctx_current->idle_sp = STACKLEVEL;
1473	assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */	1628	assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
1474	}	1629	}
1475	else if (expect_true (prev != next))	1630	else if (ecb_expect_true (prev != next))
1476	{	1631	{
1477	coro_cctx *cctx_prev;	1632	coro_cctx *cctx_prev;
1478		1633
1479	if (expect_false (prev->flags & CF_NEW))	1634	if (ecb_expect_false (prev->flags & CF_NEW))
1480	{	1635	{
1481	/* create a new empty/source context */	1636	/* create a new empty/source context */
1482	prev->flags &= ~CF_NEW;	1637	prev->flags &= ~CF_NEW;
1483	prev->flags |= CF_RUNNING;	1638	prev->flags |= CF_RUNNING;
1484	}	1639	}
…		…
1487	next->flags |= CF_RUNNING;	1642	next->flags |= CF_RUNNING;
1488		1643
1489	/* first get rid of the old state */	1644	/* first get rid of the old state */
1490	save_perl (aTHX_ prev);	1645	save_perl (aTHX_ prev);
1491		1646
1492	if (expect_false (next->flags & CF_NEW))	1647	if (ecb_expect_false (next->flags & CF_NEW))
1493	{	1648	{
1494	/* need to start coroutine */	1649	/* need to start coroutine */
1495	next->flags &= ~CF_NEW;	1650	next->flags &= ~CF_NEW;
1496	/* setup coroutine call */	1651	/* setup coroutine call */
1497	coro_setup (aTHX_ next);	1652	init_perl (aTHX_ next);
1498	}	1653	}
1499	else	1654	else
1500	load_perl (aTHX_ next);	1655	load_perl (aTHX_ next);
1501		1656
1502	/* possibly untie and reuse the cctx */	1657	/* possibly untie and reuse the cctx */
1503	if (expect_true (	1658	if (ecb_expect_true (
1504	cctx_current->idle_sp == STACKLEVEL	1659	cctx_current->idle_sp == STACKLEVEL
1505	&& !(cctx_current->flags & CC_TRACE)	1660	&& !(cctx_current->flags & CC_TRACE)
1506	&& !force_cctx	1661	&& !force_cctx
1507	))	1662	))
1508	{	1663	{
1509	/* I assume that stacklevel is a stronger indicator than PL_top_env changes */	1664	/* I assume that stacklevel is a stronger indicator than PL_top_env changes */
1510	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));	1665	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));
1511		1666
1512	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */	1667	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */
1513	/* without this the next cctx_get might destroy the running cctx while still in use */	1668	/* without this the next cctx_get might destroy the running cctx while still in use */
1514	if (expect_false (CCTX_EXPIRED (cctx_current)))	1669	if (ecb_expect_false (CCTX_EXPIRED (cctx_current)))
1515	if (expect_true (!next->cctx))	1670	if (ecb_expect_true (!next->cctx))
1516	next->cctx = cctx_get (aTHX);	1671	next->cctx = cctx_get (aTHX);
1517		1672
1518	cctx_put (cctx_current);	1673	cctx_put (cctx_current);
1519	}	1674	}
1520	else	1675	else
1521	prev->cctx = cctx_current;	1676	prev->cctx = cctx_current;
1522		1677
1523	++next->usecount;	1678	++next->usecount;
1524		1679
1525	cctx_prev = cctx_current;	1680	cctx_prev = cctx_current;
1526	cctx_current = expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);	1681	cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX);
1527		1682
1528	next->cctx = 0;	1683	next->cctx = 0;
1529		1684
1530	if (expect_false (cctx_prev != cctx_current))	1685	if (ecb_expect_false (cctx_prev != cctx_current))
1531	{	1686	{
1532	cctx_prev->top_env = PL_top_env;	1687	cctx_prev->top_env = PL_top_env;
1533	PL_top_env = cctx_current->top_env;	1688	PL_top_env = cctx_current->top_env;
1534	coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);	1689	coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);
1535	}	1690	}
…		…
1541	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))	1696	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
1542	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)	1697	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
1543		1698
1544	/** high level stuff ********************************************************/	1699	/** high level stuff ********************************************************/
1545		1700
		1701	/* this function is actually Coro, not Coro::State, but we call it from here */
		1702	/* because it is convenient - but it hasn't been declared yet for that reason */
1546	static int	1703	static void
		1704	coro_call_on_destroy (pTHX_ struct coro *coro);
		1705
		1706	static void
1547	coro_state_destroy (pTHX_ struct coro *coro)	1707	coro_state_destroy (pTHX_ struct coro *coro)
1548	{	1708	{
1549	if (coro->flags & CF_DESTROYED)	1709	if (coro->flags & CF_ZOMBIE)
1550	return 0;	1710	return;
1551		1711
1552	if (coro->on_destroy && !PL_dirty)
1553	coro->on_destroy (aTHX_ coro);	1712	slf_destroy (aTHX_ coro);
1554		1713
1555	coro->flags |= CF_DESTROYED;	1714	coro->flags |= CF_ZOMBIE;
1556		1715
1557	if (coro->flags & CF_READY)	1716	if (coro->flags & CF_READY)
1558	{	1717	{
1559	/* reduce nready, as destroying a ready coro effectively unreadies it */	1718	/* reduce nready, as destroying a ready coro effectively unreadies it */
1560	/* alternative: look through all ready queues and remove the coro */	1719	/* alternative: look through all ready queues and remove the coro */
1561	--coro_nready;	1720	--coro_nready;
1562	}	1721	}
1563	else	1722	else
1564	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */	1723	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
		1724
		1725	if (coro->next) coro->next->prev = coro->prev;
		1726	if (coro->prev) coro->prev->next = coro->next;
		1727	if (coro == coro_first) coro_first = coro->next;
1565		1728
1566	if (coro->mainstack	1729	if (coro->mainstack
1567	&& coro->mainstack != main_mainstack	1730	&& coro->mainstack != main_mainstack
1568	&& coro->slot	1731	&& coro->slot
1569	&& !PL_dirty)	1732	&& !PL_dirty)
1570	coro_destruct_perl (aTHX_ coro);	1733	destroy_perl (aTHX_ coro);
1571		1734
1572	cctx_destroy (coro->cctx);	1735	cctx_destroy (coro->cctx);
1573	SvREFCNT_dec (coro->startcv);	1736	SvREFCNT_dec (coro->startcv);
1574	SvREFCNT_dec (coro->args);	1737	SvREFCNT_dec (coro->args);
		1738	SvREFCNT_dec (coro->swap_sv);
1575	SvREFCNT_dec (CORO_THROW);	1739	SvREFCNT_dec (CORO_THROW);
1576		1740
1577	if (coro->next) coro->next->prev = coro->prev;	1741	coro_call_on_destroy (aTHX_ coro);
1578	if (coro->prev) coro->prev->next = coro->next;
1579	if (coro == coro_first) coro_first = coro->next;
1580		1742
1581	return 1;	1743	/* more destruction mayhem in coro_state_free */
1582	}	1744	}
1583		1745
1584	static int	1746	static int
1585	coro_state_free (pTHX_ SV *sv, MAGIC *mg)	1747	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
1586	{	1748	{
1587	struct coro *coro = (struct coro *)mg->mg_ptr;	1749	struct coro *coro = (struct coro *)mg->mg_ptr;
1588	mg->mg_ptr = 0;	1750	mg->mg_ptr = 0;
1589		1751
1590	coro->hv = 0;
1591
1592	if (--coro->refcnt < 0)
1593	{
1594	coro_state_destroy (aTHX_ coro);	1752	coro_state_destroy (aTHX_ coro);
		1753	SvREFCNT_dec (coro->on_destroy);
		1754	SvREFCNT_dec (coro->status);
		1755
1595	Safefree (coro);	1756	Safefree (coro);
1596	}
1597		1757
1598	return 0;	1758	return 0;
1599	}	1759	}
1600		1760
1601	static int	1761	static int ecb_cold
1602	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)	1762	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
1603	{	1763	{
1604	struct coro *coro = (struct coro *)mg->mg_ptr;	1764	/* called when perl clones the current process the slow way (windows process emulation) */
1605		1765	/* WE SIMply nuke the pointers in the copy, causing perl to croak */
1606	++coro->refcnt;	1766	mg->mg_ptr = 0;
		1767	mg->mg_virtual = 0;
1607		1768
1608	return 0;	1769	return 0;
1609	}	1770	}
1610		1771
1611	static MGVTBL coro_state_vtbl = {	1772	static MGVTBL coro_state_vtbl = {
…		…
1636	TRANSFER (ta, 1);	1797	TRANSFER (ta, 1);
1637	}	1798	}
1638		1799
1639	/** Coro ********************************************************************/	1800	/** Coro ********************************************************************/
1640		1801
1641	INLINE void	1802	ecb_inline void
1642	coro_enq (pTHX_ struct coro *coro)	1803	coro_enq (pTHX_ struct coro *coro)
1643	{	1804	{
1644	struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];	1805	struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
1645		1806
1646	SvREFCNT_inc_NN (coro->hv);	1807	SvREFCNT_inc_NN (coro->hv);
…		…
1648	coro->next_ready = 0;	1809	coro->next_ready = 0;
1649	*(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;	1810	*(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
1650	ready [1] = coro;	1811	ready [1] = coro;
1651	}	1812	}
1652		1813
1653	INLINE struct coro *	1814	ecb_inline struct coro *
1654	coro_deq (pTHX)	1815	coro_deq (pTHX)
1655	{	1816	{
1656	int prio;	1817	int prio;
1657		1818
1658	for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )	1819	for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
…		…
1711	{	1872	{
1712	return !!(SvSTATE (coro_sv)->flags & CF_READY);	1873	return !!(SvSTATE (coro_sv)->flags & CF_READY);
1713	}	1874	}
1714		1875
1715	/* expects to own a reference to next->hv */	1876	/* expects to own a reference to next->hv */
1716	INLINE void	1877	ecb_inline void
1717	prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)	1878	prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next)
1718	{	1879	{
1719	SV *prev_sv = SvRV (coro_current);	1880	SV *prev_sv = SvRV (coro_current);
1720		1881
1721	ta->prev = SvSTATE_hv (prev_sv);	1882	ta->prev = SvSTATE_hv (prev_sv);
…		…
1734	{	1895	{
1735	for (;;)	1896	for (;;)
1736	{	1897	{
1737	struct coro *next = coro_deq (aTHX);	1898	struct coro *next = coro_deq (aTHX);
1738		1899
1739	if (expect_true (next))	1900	if (ecb_expect_true (next))
1740	{	1901	{
1741	/* cannot transfer to destroyed coros, skip and look for next */	1902	/* cannot transfer to destroyed coros, skip and look for next */
1742	if (expect_false (next->flags & (CF_DESTROYED | CF_SUSPENDED)))	1903	if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED)))
1743	SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */	1904	SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */
1744	else	1905	else
1745	{	1906	{
1746	next->flags &= ~CF_READY;	1907	next->flags &= ~CF_READY;
1747	--coro_nready;	1908	--coro_nready;
…		…
1754	{	1915	{
1755	/* nothing to schedule: call the idle handler */	1916	/* nothing to schedule: call the idle handler */
1756	if (SvROK (sv_idle)	1917	if (SvROK (sv_idle)
1757	&& SvOBJECT (SvRV (sv_idle)))	1918	&& SvOBJECT (SvRV (sv_idle)))
1758	{	1919	{
		1920	if (SvRV (sv_idle) == SvRV (coro_current))
		1921	{
		1922	require_pv ("Carp");
		1923
		1924	{
		1925	dSP;
		1926
		1927	ENTER;
		1928	SAVETMPS;
		1929
		1930	PUSHMARK (SP);
		1931	XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::IDLE blocked itself - did you try to block inside an event loop callback? Caught", 0)));
		1932	PUTBACK;
		1933	call_pv ("Carp::confess", G_VOID | G_DISCARD);
		1934
		1935	FREETMPS;
		1936	LEAVE;
		1937	}
		1938	}
		1939
1759	++coro_nready; /* hack so that api_ready doesn't invoke ready hook */	1940	++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
1760	api_ready (aTHX_ SvRV (sv_idle));	1941	api_ready (aTHX_ SvRV (sv_idle));
1761	--coro_nready;	1942	--coro_nready;
1762	}	1943	}
1763	else	1944	else
…		…
1777	}	1958	}
1778	}	1959	}
1779	}	1960	}
1780	}	1961	}
1781		1962
1782	INLINE void	1963	ecb_inline void
1783	prepare_cede (pTHX_ struct coro_transfer_args *ta)	1964	prepare_cede (pTHX_ struct coro_transfer_args *ta)
1784	{	1965	{
1785	api_ready (aTHX_ coro_current);	1966	api_ready (aTHX_ coro_current);
1786	prepare_schedule (aTHX_ ta);	1967	prepare_schedule (aTHX_ ta);
1787	}	1968	}
1788		1969
1789	INLINE void	1970	ecb_inline void
1790	prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)	1971	prepare_cede_notself (pTHX_ struct coro_transfer_args *ta)
1791	{	1972	{
1792	SV *prev = SvRV (coro_current);	1973	SV *prev = SvRV (coro_current);
1793		1974
1794	if (coro_nready)	1975	if (coro_nready)
…		…
1824	{	2005	{
1825	struct coro_transfer_args ta;	2006	struct coro_transfer_args ta;
1826		2007
1827	prepare_cede (aTHX_ &ta);	2008	prepare_cede (aTHX_ &ta);
1828		2009
1829	if (expect_true (ta.prev != ta.next))	2010	if (ecb_expect_true (ta.prev != ta.next))
1830	{	2011	{
1831	TRANSFER (ta, 1);	2012	TRANSFER (ta, 1);
1832	return 1;	2013	return 1;
1833	}	2014	}
1834	else	2015	else
…		…
1877	coro->slot->runops = RUNOPS_DEFAULT;	2058	coro->slot->runops = RUNOPS_DEFAULT;
1878	}	2059	}
1879	}	2060	}
1880		2061
1881	static void	2062	static void
		2063	coro_push_av (pTHX_ AV *av, I32 gimme_v)
		2064	{
		2065	if (AvFILLp (av) >= 0 && gimme_v != G_VOID)
		2066	{
		2067	dSP;
		2068
		2069	if (gimme_v == G_SCALAR)
		2070	XPUSHs (AvARRAY (av)[AvFILLp (av)]);
		2071	else
		2072	{
		2073	int i;
		2074	EXTEND (SP, AvFILLp (av) + 1);
		2075
		2076	for (i = 0; i <= AvFILLp (av); ++i)
		2077	PUSHs (AvARRAY (av)[i]);
		2078	}
		2079
		2080	PUTBACK;
		2081	}
		2082	}
		2083
		2084	static void
		2085	coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)
		2086	{
		2087	if (!coro->on_destroy)
		2088	coro->on_destroy = newAV ();
		2089
		2090	av_push (coro->on_destroy, cb);
		2091	}
		2092
		2093	static void
		2094	slf_destroy_join (pTHX_ struct CoroSLF *frame)
		2095	{
		2096	SvREFCNT_dec ((SV *)((struct coro *)frame->data)->hv);
		2097	}
		2098
		2099	static int
		2100	slf_check_join (pTHX_ struct CoroSLF *frame)
		2101	{
		2102	struct coro *coro = (struct coro *)frame->data;
		2103
		2104	if (!coro->status)
		2105	return 1;
		2106
		2107	frame->destroy = 0;
		2108
		2109	coro_push_av (aTHX_ coro->status, GIMME_V);
		2110
		2111	SvREFCNT_dec ((SV *)coro->hv);
		2112
		2113	return 0;
		2114	}
		2115
		2116	static void
		2117	slf_init_join (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2118	{
		2119	struct coro *coro = SvSTATE (items > 0 ? arg [0] : &PL_sv_undef);
		2120
		2121	if (items > 1)
		2122	croak ("join called with too many arguments");
		2123
		2124	if (coro->status)
		2125	frame->prepare = prepare_nop;
		2126	else
		2127	{
		2128	coro_push_on_destroy (aTHX_ coro, SvREFCNT_inc_NN (SvRV (coro_current)));
		2129	frame->prepare = prepare_schedule;
		2130	}
		2131
		2132	frame->check = slf_check_join;
		2133	frame->destroy = slf_destroy_join;
		2134	frame->data = (void *)coro;
		2135	SvREFCNT_inc (coro->hv);
		2136	}
		2137
		2138	static void
1882	coro_call_on_destroy (pTHX_ struct coro *coro)	2139	coro_call_on_destroy (pTHX_ struct coro *coro)
1883	{	2140	{
1884	SV **on_destroyp = hv_fetch (coro->hv, "_on_destroy", sizeof ("_on_destroy") - 1, 0);	2141	AV *od = coro->on_destroy;
1885	SV **statusp = hv_fetch (coro->hv, "_status", sizeof ("_status") - 1, 0);
1886		2142
1887	if (on_destroyp)	2143	if (!od)
1888	{	2144	return;
1889	AV *on_destroy = (AV *)SvRV (*on_destroyp);
1890		2145
		2146	coro->on_destroy = 0;
		2147	sv_2mortal ((SV *)od);
		2148
1891	while (AvFILLp (on_destroy) >= 0)	2149	while (AvFILLp (od) >= 0)
		2150	{
		2151	SV *cb = sv_2mortal (av_pop (od));
		2152
		2153	/* coro hv's (and only hv's at the moment) are supported as well */
		2154	if (SvSTATEhv_p (aTHX_ cb))
		2155	api_ready (aTHX_ cb);
		2156	else
1892	{	2157	{
1893	dSP; /* don't disturb outer sp */	2158	dSP; /* don't disturb outer sp */
1894	SV *cb = av_pop (on_destroy);
1895
1896	PUSHMARK (SP);	2159	PUSHMARK (SP);
1897		2160
1898	if (statusp)	2161	if (coro->status)
1899	{	2162	{
1900	int i;	2163	PUTBACK;
1901	AV *status = (AV *)SvRV (*statusp);	2164	coro_push_av (aTHX_ coro->status, G_ARRAY);
1902	EXTEND (SP, AvFILLp (status) + 1);	2165	SPAGAIN;
1903
1904	for (i = 0; i <= AvFILLp (status); ++i)
1905	PUSHs (AvARRAY (status)[i]);
1906	}	2166	}
1907		2167
1908	PUTBACK;	2168	PUTBACK;
1909	call_sv (sv_2mortal (cb), G_VOID | G_DISCARD);	2169	call_sv (cb, G_VOID | G_DISCARD);
1910	}	2170	}
1911	}	2171	}
1912	}	2172	}
1913		2173
1914	static void	2174	static void
1915	slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2175	coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
1916	{	2176	{
1917	int i;	2177	AV *av;
1918	HV *hv = (HV *)SvRV (coro_current);	2178
1919	AV *av = newAV ();	2179	if (coro->status)
		2180	{
		2181	av = coro->status;
		2182	av_clear (av);
		2183	}
		2184	else
		2185	av = coro->status = newAV ();
1920		2186
1921	/* items are actually not so common, so optimise for this case */	2187	/* items are actually not so common, so optimise for this case */
1922	if (items)	2188	if (items)
1923	{	2189	{
		2190	int i;
		2191
1924	av_extend (av, items - 1);	2192	av_extend (av, items - 1);
1925		2193
1926	for (i = 0; i < items; ++i)	2194	for (i = 0; i < items; ++i)
1927	av_push (av, SvREFCNT_inc_NN (arg [i]));	2195	av_push (av, SvREFCNT_inc_NN (arg [i]));
1928	}	2196	}
		2197	}
1929		2198
1930	hv_store (hv, "_status", sizeof ("_status") - 1, newRV_noinc ((SV *)av), 0);	2199	static void
1931		2200	slf_init_terminate_cancel_common (pTHX_ struct CoroSLF *frame, HV *coro_hv)
		2201	{
1932	av_push (av_destroy, (SV *)newRV_inc ((SV *)hv)); /* RVinc for perl */	2202	av_push (av_destroy, (SV *)newRV_inc ((SV *)coro_hv)); /* RVinc for perl */
1933	api_ready (aTHX_ sv_manager);	2203	api_ready (aTHX_ sv_manager);
1934		2204
1935	frame->prepare = prepare_schedule;	2205	frame->prepare = prepare_schedule;
1936	frame->check = slf_check_repeat;	2206	frame->check = slf_check_repeat;
1937		2207
1938	/* as a minor optimisation, we could unwind all stacks here */	2208	/* as a minor optimisation, we could unwind all stacks here */
1939	/* but that puts extra pressure on pp_slf, and is not worth much */	2209	/* but that puts extra pressure on pp_slf, and is not worth much */
1940	/*coro_unwind_stacks (aTHX);*/	2210	/*coro_unwind_stacks (aTHX);*/
		2211	}
		2212
		2213	static void
		2214	slf_init_terminate (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2215	{
		2216	HV *coro_hv = (HV *)SvRV (coro_current);
		2217
		2218	coro_set_status (aTHX_ SvSTATE ((SV *)coro_hv), arg, items);
		2219	slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
		2220	}
		2221
		2222	static void
		2223	slf_init_cancel (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
		2224	{
		2225	HV *coro_hv;
		2226	struct coro *coro;
		2227
		2228	if (items <= 0)
		2229	croak ("Coro::cancel called without coro object,");
		2230
		2231	coro = SvSTATE (arg [0]);
		2232	coro_hv = coro->hv;
		2233
		2234	coro_set_status (aTHX_ coro, arg + 1, items - 1);
		2235
		2236	if (ecb_expect_false (coro->flags & CF_NOCANCEL))
		2237	{
		2238	/* coro currently busy cancelling something, so just notify it */
		2239	coro->slf_frame.data = (void *)coro;
		2240
		2241	frame->prepare = prepare_nop;
		2242	frame->check = slf_check_nop;
		2243	}
		2244	else if (coro_hv == (HV *)SvRV (coro_current))
		2245	{
		2246	/* cancelling the current coro is allowed, and equals terminate */
		2247	slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
		2248	}
		2249	else
		2250	{
		2251	struct coro *self = SvSTATE_current;
		2252
		2253	/* otherwise we cancel directly, purely for speed reasons
		2254	* unfortunately, this requires some magic trickery, as
		2255	* somebody else could cancel us, so we have to fight the cancellation.
		2256	* this is ugly, and hopefully fully worth the extra speed.
		2257	* besides, I can't get the slow-but-safe version working...
		2258	*/
		2259	slf_frame.data = 0;
		2260	self->flags |= CF_NOCANCEL;
		2261	coro_state_destroy (aTHX_ coro);
		2262	self->flags &= ~CF_NOCANCEL;
		2263
		2264	if (slf_frame.data)
		2265	{
		2266	/* while we were busy we have been cancelled, so terminate */
		2267	slf_init_terminate_cancel_common (aTHX_ frame, self->hv);
		2268	}
		2269	else
		2270	{
		2271	frame->prepare = prepare_nop;
		2272	frame->check = slf_check_nop;
		2273	}
		2274	}
		2275	}
		2276
		2277	static int
		2278	slf_check_safe_cancel (pTHX_ struct CoroSLF *frame)
		2279	{
		2280	frame->prepare = 0;
		2281	coro_unwind_stacks (aTHX);
		2282
		2283	slf_init_terminate_cancel_common (aTHX_ frame, (HV *)SvRV (coro_current));
		2284
		2285	return 1;
		2286	}
		2287
		2288	static int
		2289	safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)
		2290	{
		2291	if (coro->cctx)
		2292	croak ("coro inside C callback, unable to cancel at this time, caught");
		2293
		2294	if (coro->flags & CF_NEW)
		2295	{
		2296	coro_set_status (aTHX_ coro, arg, items);
		2297	coro_state_destroy (aTHX_ coro);
		2298	}
		2299	else
		2300	{
		2301	if (!coro->slf_frame.prepare)
		2302	croak ("coro outside an SLF function, unable to cancel at this time, caught");
		2303
		2304	slf_destroy (aTHX_ coro);
		2305
		2306	coro_set_status (aTHX_ coro, arg, items);
		2307	coro->slf_frame.prepare = prepare_nop;
		2308	coro->slf_frame.check = slf_check_safe_cancel;
		2309
		2310	api_ready (aTHX_ (SV *)coro->hv);
		2311	}
		2312
		2313	return 1;
1941	}	2314	}
1942		2315
1943	/*****************************************************************************/	2316	/*****************************************************************************/
1944	/* async pool handler */	2317	/* async pool handler */
1945		2318
…		…
1976	slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2349	slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
1977	{	2350	{
1978	HV *hv = (HV *)SvRV (coro_current);	2351	HV *hv = (HV *)SvRV (coro_current);
1979	struct coro *coro = SvSTATE_hv ((SV *)hv);	2352	struct coro *coro = SvSTATE_hv ((SV *)hv);
1980		2353
1981	if (expect_true (coro->saved_deffh))	2354	if (ecb_expect_true (coro->saved_deffh))
1982	{	2355	{
1983	/* subsequent iteration */	2356	/* subsequent iteration */
1984	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;	2357	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
1985	coro->saved_deffh = 0;	2358	coro->saved_deffh = 0;
1986		2359
1987	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)	2360	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
1988	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))	2361	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
1989	{	2362	{
1990	coro->invoke_cb = SvREFCNT_inc_NN ((SV *)cv_coro_terminate);	2363	slf_init_terminate_cancel_common (aTHX_ frame, hv);
1991	coro->invoke_av = newAV ();	2364	return;
1992
1993	frame->prepare = prepare_nop;
1994	}	2365	}
1995	else	2366	else
1996	{	2367	{
1997	av_clear (GvAV (PL_defgv));	2368	av_clear (GvAV (PL_defgv));
1998	hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);	2369	hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
…		…
2048		2419
2049	static int	2420	static int
2050	slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)	2421	slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
2051	{	2422	{
2052	SV *data = (SV *)frame->data;	2423	SV *data = (SV *)frame->data;
2053		2424
2054	if (CORO_THROW)	2425	if (CORO_THROW)
2055	return 0;	2426	return 0;
2056		2427
2057	if (SvTYPE (SvRV (data)) != SVt_PVAV)	2428	if (SvTYPE (SvRV (data)) != SVt_PVAV)
2058	return 1;	2429	return 1;
…		…
2094	cb = sv_2mortal (coro->rouse_cb);	2465	cb = sv_2mortal (coro->rouse_cb);
2095	coro->rouse_cb = 0;	2466	coro->rouse_cb = 0;
2096	}	2467	}
2097		2468
2098	if (!SvROK (cb)	2469	if (!SvROK (cb)
2099	|| SvTYPE (SvRV (cb)) != SVt_PVCV	2470	|| SvTYPE (SvRV (cb)) != SVt_PVCV
2100	|| CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)	2471	|| CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
2101	croak ("Coro::rouse_wait called with illegal callback argument,");	2472	croak ("Coro::rouse_wait called with illegal callback argument,");
2102		2473
2103	{	2474	{
2104	CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */	2475	CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
…		…
2221	static void	2592	static void
2222	slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	2593	slf_init_cede_notself (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
2223	{	2594	{
2224	frame->prepare = prepare_cede_notself;	2595	frame->prepare = prepare_cede_notself;
2225	frame->check = slf_check_nop;	2596	frame->check = slf_check_nop;
		2597	}
		2598
		2599	/* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
		2600	static void
		2601	slf_destroy (pTHX_ struct coro *coro)
		2602	{
		2603	/* this callback is reserved for slf functions needing to do cleanup */
		2604	if (coro->slf_frame.destroy && coro->slf_frame.prepare && !PL_dirty)
		2605	coro->slf_frame.destroy (aTHX_ &coro->slf_frame);
		2606
		2607	/*
		2608	* The on_destroy above most likely is from an SLF call.
		2609	* Since by definition the SLF call will not finish when we destroy
		2610	* the coro, we will have to force-finish it here, otherwise
		2611	* cleanup functions cannot call SLF functions.
		2612	*/
		2613	coro->slf_frame.prepare = 0;
2226	}	2614	}
2227		2615
2228	/*	2616	/*
2229	* these not obviously related functions are all rolled into one	2617	* these not obviously related functions are all rolled into one
2230	* function to increase chances that they all will call transfer with the same	2618	* function to increase chances that they all will call transfer with the same
…		…
2237	I32 checkmark; /* mark SP to see how many elements check has pushed */	2625	I32 checkmark; /* mark SP to see how many elements check has pushed */
2238		2626
2239	/* set up the slf frame, unless it has already been set-up */	2627	/* set up the slf frame, unless it has already been set-up */
2240	/* the latter happens when a new coro has been started */	2628	/* the latter happens when a new coro has been started */
2241	/* or when a new cctx was attached to an existing coroutine */	2629	/* or when a new cctx was attached to an existing coroutine */
2242	if (expect_true (!slf_frame.prepare))	2630	if (ecb_expect_true (!slf_frame.prepare))
2243	{	2631	{
2244	/* first iteration */	2632	/* first iteration */
2245	dSP;	2633	dSP;
2246	SV **arg = PL_stack_base + TOPMARK + 1;	2634	SV **arg = PL_stack_base + TOPMARK + 1;
2247	int items = SP - arg; /* args without function object */	2635	int items = SP - arg; /* args without function object */
…		…
2288	while (slf_frame.check (aTHX_ &slf_frame));	2676	while (slf_frame.check (aTHX_ &slf_frame));
2289		2677
2290	slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */	2678	slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */
2291		2679
2292	/* exception handling */	2680	/* exception handling */
2293	if (expect_false (CORO_THROW))	2681	if (ecb_expect_false (CORO_THROW))
2294	{	2682	{
2295	SV *exception = sv_2mortal (CORO_THROW);	2683	SV *exception = sv_2mortal (CORO_THROW);
2296		2684
2297	CORO_THROW = 0;	2685	CORO_THROW = 0;
2298	sv_setsv (ERRSV, exception);	2686	sv_setsv (ERRSV, exception);
2299	croak (0);	2687	croak (0);
2300	}	2688	}
2301		2689
2302	/* return value handling - mostly like entersub */	2690	/* return value handling - mostly like entersub */
2303	/* make sure we put something on the stack in scalar context */	2691	/* make sure we put something on the stack in scalar context */
2304	if (GIMME_V == G_SCALAR)	2692	if (GIMME_V == G_SCALAR
		2693	&& ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1))
2305	{	2694	{
2306	dSP;	2695	dSP;
2307	SV **bot = PL_stack_base + checkmark;	2696	SV **bot = PL_stack_base + checkmark;
2308		2697
2309	if (sp == bot) /* too few, push undef */	2698	if (sp == bot) /* too few, push undef */
2310	bot [1] = &PL_sv_undef;	2699	bot [1] = &PL_sv_undef;
2311	else if (sp != bot + 1) /* too many, take last one */	2700	else /* too many, take last one */
2312	bot [1] = *sp;	2701	bot [1] = *sp;
2313		2702
2314	SP = bot + 1;	2703	SP = bot + 1;
2315		2704
2316	PUTBACK;	2705	PUTBACK;
…		…
2349	if (PL_op->op_flags & OPf_STACKED)	2738	if (PL_op->op_flags & OPf_STACKED)
2350	{	2739	{
2351	if (items > slf_arga)	2740	if (items > slf_arga)
2352	{	2741	{
2353	slf_arga = items;	2742	slf_arga = items;
2354	free (slf_argv);	2743	Safefree (slf_argv);
2355	slf_argv = malloc (slf_arga * sizeof (SV *));	2744	New (0, slf_argv, slf_arga, SV *);
2356	}	2745	}
2357		2746
2358	slf_argc = items;	2747	slf_argc = items;
2359		2748
2360	for (i = 0; i < items; ++i)	2749	for (i = 0; i < items; ++i)
…		…
2423	{	2812	{
2424	PerlIOBuf base;	2813	PerlIOBuf base;
2425	NV next, every;	2814	NV next, every;
2426	} PerlIOCede;	2815	} PerlIOCede;
2427		2816
2428	static IV	2817	static IV ecb_cold
2429	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)	2818	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2430	{	2819	{
2431	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);	2820	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2432		2821
2433	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;	2822	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
2434	self->next = nvtime () + self->every;	2823	self->next = nvtime () + self->every;
2435		2824
2436	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);	2825	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
2437	}	2826	}
2438		2827
2439	static SV *	2828	static SV * ecb_cold
2440	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)	2829	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
2441	{	2830	{
2442	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);	2831	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
2443		2832
2444	return newSVnv (self->every);	2833	return newSVnv (self->every);
…		…
2556	SvREFCNT_dec (cb);	2945	SvREFCNT_dec (cb);
2557	}	2946	}
2558	}	2947	}
2559		2948
2560	static void	2949	static void
2561	coro_semaphore_on_destroy (pTHX_ struct coro *coro)	2950	coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
2562	{	2951	{
2563	/* call $sem->adjust (0) to possibly wake up some other waiters */	2952	/* call $sem->adjust (0) to possibly wake up some other waiters */
2564	coro_semaphore_adjust (aTHX_ (AV *)coro->slf_frame.data, 0);	2953	coro_semaphore_adjust (aTHX_ (AV *)frame->data, 0);
2565	}	2954	}
2566		2955
2567	static int	2956	static int
2568	slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)	2957	slf_check_semaphore_down_or_wait (pTHX_ struct CoroSLF *frame, int acquire)
2569	{	2958	{
2570	AV *av = (AV *)frame->data;	2959	AV *av = (AV *)frame->data;
2571	SV *count_sv = AvARRAY (av)[0];	2960	SV *count_sv = AvARRAY (av)[0];
		2961	SV *coro_hv = SvRV (coro_current);
2572		2962
2573	/* if we are about to throw, don't actually acquire the lock, just throw */	2963	/* if we are about to throw, don't actually acquire the lock, just throw */
2574	if (CORO_THROW)	2964	if (CORO_THROW)
2575	return 0;	2965	return 0;
2576	else if (SvIVX (count_sv) > 0)	2966	else if (SvIVX (count_sv) > 0)
2577	{	2967	{
2578	SvSTATE_current->on_destroy = 0;	2968	frame->destroy = 0;
2579		2969
2580	if (acquire)	2970	if (acquire)
2581	SvIVX (count_sv) = SvIVX (count_sv) - 1;	2971	SvIVX (count_sv) = SvIVX (count_sv) - 1;
2582	else	2972	else
2583	coro_semaphore_adjust (aTHX_ av, 0);	2973	coro_semaphore_adjust (aTHX_ av, 0);
…		…
2588	{	2978	{
2589	int i;	2979	int i;
2590	/* if we were woken up but can't down, we look through the whole */	2980	/* if we were woken up but can't down, we look through the whole */
2591	/* waiters list and only add us if we aren't in there already */	2981	/* waiters list and only add us if we aren't in there already */
2592	/* this avoids some degenerate memory usage cases */	2982	/* this avoids some degenerate memory usage cases */
2593		2983	for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */
2594	for (i = 1; i <= AvFILLp (av); ++i)
2595	if (AvARRAY (av)[i] == SvRV (coro_current))	2984	if (AvARRAY (av)[i] == coro_hv)
2596	return 1;	2985	return 1;
2597		2986
2598	av_push (av, SvREFCNT_inc (SvRV (coro_current)));	2987	av_push (av, SvREFCNT_inc (coro_hv));
2599	return 1;	2988	return 1;
2600	}	2989	}
2601	}	2990	}
2602		2991
2603	static int	2992	static int
…		…
2626	{	3015	{
2627	av_push (av, SvREFCNT_inc (SvRV (coro_current)));	3016	av_push (av, SvREFCNT_inc (SvRV (coro_current)));
2628		3017
2629	frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));	3018	frame->data = (void *)sv_2mortal (SvREFCNT_inc ((SV *)av));
2630	frame->prepare = prepare_schedule;	3019	frame->prepare = prepare_schedule;
2631
2632	/* to avoid race conditions when a woken-up coro gets terminated */	3020	/* to avoid race conditions when a woken-up coro gets terminated */
2633	/* we arrange for a temporary on_destroy that calls adjust (0) */	3021	/* we arrange for a temporary on_destroy that calls adjust (0) */
2634	SvSTATE_current->on_destroy = coro_semaphore_on_destroy;	3022	frame->destroy = coro_semaphore_destroy;
2635	}	3023	}
2636	}	3024	}
2637		3025
2638	static void	3026	static void
2639	slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)	3027	slf_init_semaphore_down (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
…		…
2721	{	3109	{
2722	SV *cb_cv = s_get_cv_croak (arg [1]);	3110	SV *cb_cv = s_get_cv_croak (arg [1]);
2723	av_push (av, SvREFCNT_inc_NN (cb_cv));	3111	av_push (av, SvREFCNT_inc_NN (cb_cv));
2724		3112
2725	if (SvIVX (AvARRAY (av)[0]))	3113	if (SvIVX (AvARRAY (av)[0]))
2726	coro_signal_wake (aTHX_ av, 1); /* ust be the only waiter */	3114	coro_signal_wake (aTHX_ av, 1); /* must be the only waiter */
2727		3115
2728	frame->prepare = prepare_nop;	3116	frame->prepare = prepare_nop;
2729	frame->check = slf_check_nop;	3117	frame->check = slf_check_nop;
2730	}	3118	}
2731	else if (SvIVX (AvARRAY (av)[0]))	3119	else if (SvIVX (AvARRAY (av)[0]))
…		…
2808	/* it quickly returns */	3196	/* it quickly returns */
2809	if (CORO_THROW)	3197	if (CORO_THROW)
2810	return 0;	3198	return 0;
2811		3199
2812	/* one element that is an RV? repeat! */	3200	/* one element that is an RV? repeat! */
2813	if (AvFILLp (state) == 0 && SvROK (AvARRAY (state)[0]))	3201	if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
2814	return 1;	3202	return 1;
2815		3203
2816	/* restore status */	3204	/* restore status */
2817	{	3205	{
2818	SV *data_sv = av_pop (state);	3206	SV *data_sv = av_pop (state);
…		…
2857	dSP;	3245	dSP;
2858		3246
2859	static SV *prio_cv;	3247	static SV *prio_cv;
2860	static SV *prio_sv;	3248	static SV *prio_sv;
2861		3249
2862	if (expect_false (!prio_cv))	3250	if (ecb_expect_false (!prio_cv))
2863	{	3251	{
2864	prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);	3252	prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0);
2865	prio_sv = newSViv (0);	3253	prio_sv = newSViv (0);
2866	}	3254	}
2867		3255
…		…
2893	/* now call the AIO function - we assume our request is uncancelable */	3281	/* now call the AIO function - we assume our request is uncancelable */
2894	PUTBACK;	3282	PUTBACK;
2895	call_sv ((SV *)req, G_VOID | G_DISCARD);	3283	call_sv ((SV *)req, G_VOID | G_DISCARD);
2896	}	3284	}
2897		3285
2898	/* now that the requets is going, we loop toll we have a result */	3286	/* now that the request is going, we loop till we have a result */
2899	frame->data = (void *)state;	3287	frame->data = (void *)state;
2900	frame->prepare = prepare_schedule;	3288	frame->prepare = prepare_schedule;
2901	frame->check = slf_check_aio_req;	3289	frame->check = slf_check_aio_req;
2902	}	3290	}
2903		3291
…		…
2973	}	3361	}
2974		3362
2975	return coro_sv;	3363	return coro_sv;
2976	}	3364	}
2977		3365
		3366	#ifndef __cplusplus
		3367	ecb_cold XS(boot_Coro__State);
		3368	#endif
		3369
		3370	#if CORO_JIT
		3371
		3372	static void ecb_noinline ecb_cold
		3373	pushav_4uv (pTHX_ UV a, UV b, UV c, UV d)
		3374	{
		3375	dSP;
		3376	AV *av = newAV ();
		3377
		3378	av_store (av, 3, newSVuv (d));
		3379	av_store (av, 2, newSVuv (c));
		3380	av_store (av, 1, newSVuv (b));
		3381	av_store (av, 0, newSVuv (a));
		3382
		3383	XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		3384
		3385	PUTBACK;
		3386	}
		3387
		3388	static void ecb_noinline ecb_cold
		3389	jit_init (pTHX)
		3390	{
		3391	dSP;
		3392	SV *load, *save;
		3393	char *map_base;
		3394	char *load_ptr, *save_ptr;
		3395	STRLEN load_len, save_len, map_len;
		3396	int count;
		3397
		3398	eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1);
		3399
		3400	PUSHMARK (SP);
		3401	#define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
		3402	#include "state.h"
		3403	count = call_pv ("Coro::State::_jit", G_ARRAY);
		3404	SPAGAIN;
		3405
		3406	save = POPs; save_ptr = SvPVbyte (save, save_len);
		3407	load = POPs; load_ptr = SvPVbyte (load, load_len);
		3408
		3409	map_len = load_len + save_len + 16;
		3410
		3411	map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
		3412
		3413	assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED));
		3414
		3415	load_perl_slots = (load_save_perl_slots_type)map_base;
		3416	memcpy (map_base, load_ptr, load_len);
		3417
		3418	map_base += (load_len + 15) & ~15;
		3419
		3420	save_perl_slots = (load_save_perl_slots_type)map_base;
		3421	memcpy (map_base, save_ptr, save_len);
		3422
		3423	/* we are good citizens and try to make the page read-only, so the evil evil */
		3424	/* hackers might have it a bit more difficult */
		3425	mprotect (map_base, map_len, PROT_READ | PROT_EXEC);
		3426
		3427	PUTBACK;
		3428	eval_pv ("undef &Coro::State::_jit", 1);
		3429	}
		3430
		3431	#endif
		3432
2978	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_	3433	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
2979		3434
2980	PROTOTYPES: DISABLE	3435	PROTOTYPES: DISABLE
2981		3436
2982	BOOT:	3437	BOOT:
…		…
2984	#ifdef USE_ITHREADS	3439	#ifdef USE_ITHREADS
2985	# if CORO_PTHREAD	3440	# if CORO_PTHREAD
2986	coro_thx = PERL_GET_CONTEXT;	3441	coro_thx = PERL_GET_CONTEXT;
2987	# endif	3442	# endif
2988	#endif	3443	#endif
2989	BOOT_PAGESIZE;	3444	/* perl defines these to check for existance first, but why it doesn't */
		3445	/* just create them one at init time is not clear to me, except for */
		3446	/* programs trying to delete them, but... */
		3447	/* anyway, we declare this as invalid and make sure they are initialised here */
		3448	DEFSV;
		3449	ERRSV;
2990		3450
2991	cctx_current = cctx_new_empty ();	3451	cctx_current = cctx_new_empty ();
2992		3452
2993	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);	3453	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
2994	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);	3454	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
…		…
3034	coroapi.prepare_nop = prepare_nop;	3494	coroapi.prepare_nop = prepare_nop;
3035	coroapi.prepare_schedule = prepare_schedule;	3495	coroapi.prepare_schedule = prepare_schedule;
3036	coroapi.prepare_cede = prepare_cede;	3496	coroapi.prepare_cede = prepare_cede;
3037	coroapi.prepare_cede_notself = prepare_cede_notself;	3497	coroapi.prepare_cede_notself = prepare_cede_notself;
3038		3498
3039	{	3499	time_init (aTHX);
3040	SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
3041
3042	if (!svp) croak ("Time::HiRes is required");
3043	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
3044
3045	nvtime = INT2PTR (double (*)(), SvIV (*svp));
3046
3047	svp = hv_fetch (PL_modglobal, "Time::U2time", 12, 0);
3048	u2time = INT2PTR (void (*)(pTHX_ UV ret[2]), SvIV (*svp));
3049	}
3050		3500
3051	assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));	3501	assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));
		3502	#if CORO_JIT
		3503	PUTBACK;
		3504	jit_init (aTHX);
		3505	SPAGAIN;
		3506	#endif
3052	}	3507	}
3053		3508
3054	SV *	3509	SV *
3055	new (SV *klass, ...)	3510	new (SV *klass, ...)
3056	ALIAS:	3511	ALIAS:
…		…
3063	void	3518	void
3064	transfer (...)	3519	transfer (...)
3065	PROTOTYPE: $$	3520	PROTOTYPE: $$
3066	CODE:	3521	CODE:
3067	CORO_EXECUTE_SLF_XS (slf_init_transfer);	3522	CORO_EXECUTE_SLF_XS (slf_init_transfer);
3068
3069	bool
3070	_destroy (SV *coro_sv)
3071	CODE:
3072	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
3073	OUTPUT:
3074	RETVAL
3075
3076	void
3077	_exit (int code)
3078	PROTOTYPE: $
3079	CODE:
3080	_exit (code);
3081		3523
3082	SV *	3524	SV *
3083	clone (Coro::State coro)	3525	clone (Coro::State coro)
3084	CODE:	3526	CODE:
3085	{	3527	{
…		…
3140	void	3582	void
3141	list ()	3583	list ()
3142	PROTOTYPE:	3584	PROTOTYPE:
3143	PPCODE:	3585	PPCODE:
3144	{	3586	{
3145	struct coro *coro;	3587	struct coro *coro;
3146	for (coro = coro_first; coro; coro = coro->next)	3588	for (coro = coro_first; coro; coro = coro->next)
3147	if (coro->hv)	3589	if (coro->hv)
3148	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));	3590	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
3149	}	3591	}
3150		3592
…		…
3155	CODE:	3597	CODE:
3156	{	3598	{
3157	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))	3599	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
3158	{	3600	{
3159	struct coro *current = SvSTATE_current;	3601	struct coro *current = SvSTATE_current;
		3602	struct CoroSLF slf_save;
3160		3603
3161	if (current != coro)	3604	if (current != coro)
3162	{	3605	{
3163	PUTBACK;	3606	PUTBACK;
3164	save_perl (aTHX_ current);	3607	save_perl (aTHX_ current);
3165	load_perl (aTHX_ coro);	3608	load_perl (aTHX_ coro);
		3609	/* the coro is most likely in an active SLF call.
		3610	* while not strictly required (the code we execute is
		3611	* not allowed to call any SLF functions), it's cleaner
		3612	* to reinitialise the slf_frame and restore it later.
		3613	* This might one day allow us to actually do SLF calls
		3614	* from code executed here.
		3615	*/
		3616	slf_save = slf_frame;
		3617	slf_frame.prepare = 0;
3166	SPAGAIN;	3618	SPAGAIN;
3167	}	3619	}
3168		3620
3169	PUSHSTACK;	3621	PUSHSTACK;
3170		3622
…		…
3180	SPAGAIN;	3632	SPAGAIN;
3181		3633
3182	if (current != coro)	3634	if (current != coro)
3183	{	3635	{
3184	PUTBACK;	3636	PUTBACK;
		3637	slf_frame = slf_save;
3185	save_perl (aTHX_ coro);	3638	save_perl (aTHX_ coro);
3186	load_perl (aTHX_ current);	3639	load_perl (aTHX_ current);
3187	SPAGAIN;	3640	SPAGAIN;
3188	}	3641	}
3189	}	3642	}
…		…
3194	PROTOTYPE: $	3647	PROTOTYPE: $
3195	ALIAS:	3648	ALIAS:
3196	is_ready = CF_READY	3649	is_ready = CF_READY
3197	is_running = CF_RUNNING	3650	is_running = CF_RUNNING
3198	is_new = CF_NEW	3651	is_new = CF_NEW
3199	is_destroyed = CF_DESTROYED	3652	is_destroyed = CF_ZOMBIE
		3653	is_zombie = CF_ZOMBIE
3200	is_suspended = CF_SUSPENDED	3654	is_suspended = CF_SUSPENDED
3201	CODE:	3655	CODE:
3202	RETVAL = boolSV (coro->flags & ix);	3656	RETVAL = boolSV (coro->flags & ix);
3203	OUTPUT:	3657	OUTPUT:
3204	RETVAL	3658	RETVAL
3205		3659
3206	void	3660	void
3207	throw (Coro::State self, SV *throw = &PL_sv_undef)	3661	throw (SV *self, SV *exception = &PL_sv_undef)
3208	PROTOTYPE: $;$	3662	PROTOTYPE: $;$
3209	CODE:	3663	CODE:
3210	{	3664	{
		3665	struct coro *coro = SvSTATE (self);
3211	struct coro *current = SvSTATE_current;	3666	struct coro *current = SvSTATE_current;
3212	SV **throwp = self == current ? &CORO_THROW : &self->except;	3667	SV **exceptionp = coro == current ? &CORO_THROW : &coro->except;
3213	SvREFCNT_dec (*throwp);	3668	SvREFCNT_dec (*exceptionp);
3214	SvGETMAGIC (throw);	3669	SvGETMAGIC (exception);
3215	*throwp = SvOK (throw) ? newSVsv (throw) : 0;	3670	*exceptionp = SvOK (exception) ? newSVsv (exception) : 0;
		3671
		3672	api_ready (aTHX_ self);
3216	}	3673	}
3217		3674
3218	void	3675	void
3219	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)	3676	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
3220	PROTOTYPE: $;$	3677	PROTOTYPE: $;$
…		…
3275		3732
3276	void	3733	void
3277	cancel (Coro::State self)	3734	cancel (Coro::State self)
3278	CODE:	3735	CODE:
3279	coro_state_destroy (aTHX_ self);	3736	coro_state_destroy (aTHX_ self);
3280	coro_call_on_destroy (aTHX_ self); /* actually only for Coro objects */
3281
3282		3737
3283	SV *	3738	SV *
3284	enable_times (int enabled = enable_times)	3739	enable_times (int enabled = enable_times)
3285	CODE:	3740	CODE:
3286	{	3741	{
…		…
3299		3754
3300	void	3755	void
3301	times (Coro::State self)	3756	times (Coro::State self)
3302	PPCODE:	3757	PPCODE:
3303	{	3758	{
3304	struct coro *current = SvSTATE (coro_current);	3759	struct coro *current = SvSTATE (coro_current);
3305		3760
3306	if (expect_false (current == self))	3761	if (ecb_expect_false (current == self))
3307	{	3762	{
3308	coro_times_update ();	3763	coro_times_update ();
3309	coro_times_add (SvSTATE (coro_current));	3764	coro_times_add (SvSTATE (coro_current));
3310	}	3765	}
3311		3766
3312	EXTEND (SP, 2);	3767	EXTEND (SP, 2);
3313	PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));	3768	PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9)));
3314	PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));	3769	PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9)));
3315		3770
3316	if (expect_false (current == self))	3771	if (ecb_expect_false (current == self))
3317	coro_times_sub (SvSTATE (coro_current));	3772	coro_times_sub (SvSTATE (coro_current));
3318	}	3773	}
		3774
		3775	void
		3776	swap_sv (Coro::State coro, SV *sv, SV *swapsv)
		3777	CODE:
		3778	{
		3779	struct coro *current = SvSTATE_current;
		3780
		3781	if (current == coro)
		3782	SWAP_SVS (current);
		3783
		3784	if (!coro->swap_sv)
		3785	coro->swap_sv = newAV ();
		3786
		3787	av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (sv )));
		3788	av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (swapsv)));
		3789
		3790	if (current == coro)
		3791	SWAP_SVS (current);
		3792	}
		3793
3319		3794
3320	MODULE = Coro::State PACKAGE = Coro	3795	MODULE = Coro::State PACKAGE = Coro
3321		3796
3322	BOOT:	3797	BOOT:
3323	{	3798	{
3324	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);	3799	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
3325	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);	3800	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
3326	cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);	3801	cv_coro_run = get_cv ( "Coro::_coro_run" , GV_ADD);
3327	cv_coro_terminate = get_cv ( "Coro::terminate" , GV_ADD);
3328	coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);	3802	coro_current = coro_get_sv (aTHX_ "Coro::current" , FALSE); SvREADONLY_on (coro_current);
3329	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);	3803	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
3330	av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);	3804	av_destroy = coro_get_av (aTHX_ "Coro::destroy" , TRUE);
3331	sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);	3805	sv_manager = coro_get_sv (aTHX_ "Coro::manager" , TRUE);
3332	sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);	3806	sv_idle = coro_get_sv (aTHX_ "Coro::idle" , TRUE);
3333		3807
3334	sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);	3808	sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
3335	sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);	3809	sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro);
3336	cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);	3810	cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler);
3337	CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */	3811	CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */
3338		3812
3339	coro_stash = gv_stashpv ("Coro", TRUE);	3813	coro_stash = gv_stashpv ("Coro", TRUE);
3340		3814
3341	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));	3815	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX));
3342	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));	3816	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (CORO_PRIO_HIGH));
3343	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));	3817	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
…		…
3371	api_ready (aTHX_ RETVAL);	3845	api_ready (aTHX_ RETVAL);
3372	OUTPUT:	3846	OUTPUT:
3373	RETVAL	3847	RETVAL
3374		3848
3375	void	3849	void
		3850	_destroy (Coro::State coro)
		3851	CODE:
		3852	/* used by the manager thread */
		3853	coro_state_destroy (aTHX_ coro);
		3854
		3855	void
		3856	on_destroy (Coro::State coro, SV *cb)
		3857	CODE:
		3858	coro_push_on_destroy (aTHX_ coro, newSVsv (cb));
		3859
		3860	void
		3861	join (...)
		3862	CODE:
		3863	CORO_EXECUTE_SLF_XS (slf_init_join);
		3864
		3865	void
3376	terminate (...)	3866	terminate (...)
3377	CODE:	3867	CODE:
3378	CORO_EXECUTE_SLF_XS (slf_init_terminate);	3868	CORO_EXECUTE_SLF_XS (slf_init_terminate);
		3869
		3870	void
		3871	cancel (...)
		3872	CODE:
		3873	CORO_EXECUTE_SLF_XS (slf_init_cancel);
		3874
		3875	int
		3876	safe_cancel (Coro::State self, ...)
		3877	C_ARGS: aTHX_ self, &ST (1), items - 1
3379		3878
3380	void	3879	void
3381	schedule (...)	3880	schedule (...)
3382	CODE:	3881	CODE:
3383	CORO_EXECUTE_SLF_XS (slf_init_schedule);	3882	CORO_EXECUTE_SLF_XS (slf_init_schedule);
…		…
3540	on_leave = 1	4039	on_leave = 1
3541	PROTOTYPE: &	4040	PROTOTYPE: &
3542	CODE:	4041	CODE:
3543	{	4042	{
3544	struct coro *coro = SvSTATE_current;	4043	struct coro *coro = SvSTATE_current;
3545	AV **avp = ix ? &coro->on_leave : &coro->on_enter;	4044	AV **avp = ix ? &coro->on_leave : &coro->on_enter;
3546		4045
3547	block = s_get_cv_croak (block);	4046	block = s_get_cv_croak (block);
3548		4047
3549	if (!*avp)	4048	if (!*avp)
3550	*avp = newAV ();	4049	*avp = newAV ();
…		…
3570		4069
3571	SV *	4070	SV *
3572	new (SV *klass, SV *count = 0)	4071	new (SV *klass, SV *count = 0)
3573	CODE:	4072	CODE:
3574	{	4073	{
3575	int semcnt = 1;	4074	int semcnt = 1;
3576		4075
3577	if (count)	4076	if (count)
3578	{	4077	{
3579	SvGETMAGIC (count);	4078	SvGETMAGIC (count);
3580		4079
…		…
3640	XSRETURN_NO;	4139	XSRETURN_NO;
3641	}	4140	}
3642		4141
3643	void	4142	void
3644	waiters (SV *self)	4143	waiters (SV *self)
3645	PPCODE:	4144	PPCODE:
3646	{	4145	{
3647	AV *av = (AV *)SvRV (self);	4146	AV *av = (AV *)SvRV (self);
3648	int wcount = AvFILLp (av) + 1 - 1;	4147	int wcount = AvFILLp (av) + 1 - 1;
3649		4148
3650	if (GIMME_V == G_SCALAR)	4149	if (GIMME_V == G_SCALAR)
…		…
3659	}	4158	}
3660		4159
3661	MODULE = Coro::State PACKAGE = Coro::SemaphoreSet	4160	MODULE = Coro::State PACKAGE = Coro::SemaphoreSet
3662		4161
3663	void	4162	void
3664	_may_delete (SV *sem, int count, int extra_refs)	4163	_may_delete (SV *sem, int count, unsigned int extra_refs)
3665	PPCODE:	4164	PPCODE:
3666	{	4165	{
3667	AV *av = (AV *)SvRV (sem);	4166	AV *av = (AV *)SvRV (sem);
3668		4167
3669	if (SvREFCNT ((SV *)av) == 1 + extra_refs	4168	if (SvREFCNT ((SV *)av) == 1 + extra_refs
3670	&& AvFILLp (av) == 0 /* no waiters, just count */	4169	&& AvFILLp (av) == 0 /* no waiters, just count */
3671	&& SvIV (AvARRAY (av)[0]) == count)	4170	&& SvIV (AvARRAY (av)[0]) == count)
3672	XSRETURN_YES;	4171	XSRETURN_YES;
…		…
3693		4192
3694	void	4193	void
3695	broadcast (SV *self)	4194	broadcast (SV *self)
3696	CODE:	4195	CODE:
3697	{	4196	{
3698	AV *av = (AV *)SvRV (self);	4197	AV *av = (AV *)SvRV (self);
3699	coro_signal_wake (aTHX_ av, AvFILLp (av));	4198	coro_signal_wake (aTHX_ av, AvFILLp (av));
3700	}	4199	}
3701		4200
3702	void	4201	void
3703	send (SV *self)	4202	send (SV *self)
…		…
3711	SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */	4210	SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
3712	}	4211	}
3713		4212
3714	IV	4213	IV
3715	awaited (SV *self)	4214	awaited (SV *self)
3716	CODE:	4215	CODE:
3717	RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;	4216	RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
3718	OUTPUT:	4217	OUTPUT:
3719	RETVAL	4218	RETVAL
3720		4219
3721		4220
…		…
3726		4225
3727	void	4226	void
3728	_schedule (...)	4227	_schedule (...)
3729	CODE:	4228	CODE:
3730	{	4229	{
3731	static int incede;	4230	static int incede;
3732		4231
3733	api_cede_notself (aTHX);	4232	api_cede_notself (aTHX);
3734		4233
3735	++incede;	4234	++incede;
3736	while (coro_nready >= incede && api_cede (aTHX))	4235	while (coro_nready >= incede && api_cede (aTHX))
…		…
3780	{	4279	{
3781	PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;	4280	PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
3782	coro_old_pp_sselect = 0;	4281	coro_old_pp_sselect = 0;
3783	}	4282	}
3784		4283
		4284	MODULE = Coro::State PACKAGE = Coro::Util
3785		4285
		4286	void
		4287	_exit (int code)
		4288	CODE:
		4289	_exit (code);
		4290
		4291	NV
		4292	time ()
		4293	CODE:
		4294	RETVAL = nvtime (aTHX);
		4295	OUTPUT:
		4296	RETVAL
		4297
		4298	NV
		4299	gettimeofday ()
		4300	PPCODE:
		4301	{
		4302	UV tv [2];
		4303	u2time (aTHX_ tv);
		4304	EXTEND (SP, 2);
		4305	PUSHs (sv_2mortal (newSVuv (tv [0])));
		4306	PUSHs (sv_2mortal (newSVuv (tv [1])));
		4307	}
		4308

Diff Legend

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