ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.264 by root, Fri Nov 14 02:29:09 2008 UTC

		1	#include "libcoro/coro.c"
		2
		3	#define PERL_NO_GET_CONTEXT
		4	#define PERL_EXT
		5
1	#include "EXTERN.h"	6	#include "EXTERN.h"
2	#include "perl.h"	7	#include "perl.h"
3	#include "XSUB.h"	8	#include "XSUB.h"
		9	#include "perliol.h"
4		10
5	#if 0	11	#include "patchlevel.h"
6	# define CHK(x) (void *)0	12
		13	#include <stdio.h>
		14	#include <errno.h>
		15	#include <assert.h>
		16
		17	#ifdef WIN32
		18	# undef setjmp
		19	# undef longjmp
		20	# undef _exit
		21	# define setjmp _setjmp // deep magic, don't ask
7	#else	22	#else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	23	# include <inttypes.h> /* most portable stdint.h */
		24	#endif
		25
		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
9	#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
10		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 */
		54	static int cctx_max_idle = 4;
		55
		56	#define PERL_VERSION_ATLEAST(a,b,c) \
		57	(PERL_REVISION > (a) \
		58	|| (PERL_REVISION == (a) \
		59	&& (PERL_VERSION > (b) \
		60	|| (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
		61
		62	#if !PERL_VERSION_ATLEAST (5,6,0)
		63	# ifndef PL_ppaddr
		64	# define PL_ppaddr ppaddr
		65	# endif
		66	# ifndef call_sv
		67	# define call_sv perl_call_sv
		68	# endif
		69	# ifndef get_sv
		70	# define get_sv perl_get_sv
		71	# endif
		72	# ifndef get_cv
		73	# define get_cv perl_get_cv
		74	# endif
		75	# ifndef IS_PADGV
		76	# define IS_PADGV(v) 0
		77	# endif
		78	# ifndef IS_PADCONST
		79	# define IS_PADCONST(v) 0
		80	# endif
		81	#endif
		82
		83	/* 5.11 */
		84	#ifndef CxHASARGS
		85	# define CxHASARGS(cx) (cx)->blk_sub.hasargs
		86	#endif
		87
		88	/* 5.10.0 */
		89	#ifndef SvREFCNT_inc_NN
		90	# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
		91	#endif
		92
		93	/* 5.8.8 */
		94	#ifndef GV_NOTQUAL
		95	# define GV_NOTQUAL 0
		96	#endif
		97	#ifndef newSV
		98	# define newSV(l) NEWSV(0,l)
		99	#endif
		100
		101	/* 5.8.7 */
		102	#ifndef SvRV_set
		103	# define SvRV_set(s,v) SvRV(s) = (v)
		104	#endif
		105
		106	#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
		107	# undef CORO_STACKGUARD
		108	#endif
		109
		110	#ifndef CORO_STACKGUARD
		111	# define CORO_STACKGUARD 0
		112	#endif
		113
		114	/* prefer perl internal functions over our own? */
		115	#ifndef CORO_PREFER_PERL_FUNCTIONS
		116	# define CORO_PREFER_PERL_FUNCTIONS 0
		117	#endif
		118
		119	/* The next macros try to return the current stack pointer, in an as
		120	* portable way as possible. */
		121	#define dSTACKLEVEL volatile char stacklevel
		122	#define STACKLEVEL ((void *)&stacklevel)
		123
		124	#define IN_DESTRUCT (PL_main_cv == Nullcv)
		125
		126	#if __GNUC__ >= 3
		127	# define attribute(x) __attribute__(x)
		128	# define expect(expr,value) __builtin_expect ((expr),(value))
		129	# define INLINE static inline
		130	#else
		131	# define attribute(x)
		132	# define expect(expr,value) (expr)
		133	# define INLINE static
		134	#endif
		135
		136	#define expect_false(expr) expect ((expr) != 0, 0)
		137	#define expect_true(expr) expect ((expr) != 0, 1)
		138
		139	#define NOINLINE attribute ((noinline))
		140
		141	#include "CoroAPI.h"
		142
		143	#ifdef USE_ITHREADS
		144
		145	static perl_mutex coro_lock;
		146	# define LOCK do { MUTEX_LOCK (&coro_lock); } while (0)
		147	# define UNLOCK do { MUTEX_UNLOCK (&coro_lock); } while (0)
		148	# if CORO_PTHREAD
		149	static void *coro_thx;
		150	# endif
		151
		152	#else
		153
		154	# define LOCK (void)0
		155	# define UNLOCK (void)0
		156
		157	#endif
		158
		159	# undef LOCK
		160	# define LOCK (void)0
		161	# undef UNLOCK
		162	# define UNLOCK (void)0
		163
		164	/* helper storage struct for Coro::AIO */
		165	struct io_state
		166	{
		167	AV *res;
		168	int errorno;
		169	I32 laststype; /* U16 in 5.10.0 */
		170	int laststatval;
		171	Stat_t statcache;
		172	};
		173
		174	static double (*nvtime)(); /* so why doesn't it take void? */
		175
		176	static U32 cctx_gen;
		177	static size_t cctx_stacksize = CORO_STACKSIZE;
		178	static struct CoroAPI coroapi;
		179	static AV *main_mainstack; /* used to differentiate between $main and others */
		180	static JMPENV *main_top_env;
		181	static HV *coro_state_stash, *coro_stash;
		182	static volatile SV *coro_mortal; /* will be freed/thrown after next transfer */
		183	static volatile struct coro *transfer_next;
		184
		185	struct transfer_args
		186	{
		187	struct coro *prev, *next;
		188	};
		189
		190	static GV *irsgv; /* $/ */
		191	static GV *stdoutgv; /* *STDOUT */
		192	static SV *rv_diehook;
		193	static SV *rv_warnhook;
		194	static HV *hv_sig; /* %SIG */
		195
		196	/* async_pool helper stuff */
		197	static SV *sv_pool_rss;
		198	static SV *sv_pool_size;
		199	static AV *av_async_pool;
		200
		201	/* Coro::AnyEvent */
		202	static SV *sv_activity;
		203
		204	static struct coro_cctx *cctx_first;
		205	static int cctx_count, cctx_idle;
		206
		207	enum {
		208	CC_MAPPED = 0x01,
		209	CC_NOREUSE = 0x02, /* throw this away after tracing */
		210	CC_TRACE = 0x04,
		211	CC_TRACE_SUB = 0x08, /* trace sub calls */
		212	CC_TRACE_LINE = 0x10, /* trace each statement */
		213	CC_TRACE_ALL = CC_TRACE_SUB | CC_TRACE_LINE,
		214	};
		215
		216	/* this is a structure representing a c-level coroutine */
		217	typedef struct coro_cctx {
		218	struct coro_cctx *next;
		219
		220	/* the stack */
		221	void *sptr;
		222	size_t ssize;
		223
		224	/* cpu state */
		225	void *idle_sp; /* sp of top-level transfer/schedule/cede call */
		226	JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
		227	JMPENV *top_env;
		228	coro_context cctx;
		229
		230	U32 gen;
		231	#if CORO_USE_VALGRIND
		232	int valgrind_id;
		233	#endif
		234	unsigned char flags;
		235	} coro_cctx;
		236
		237	enum {
		238	CF_RUNNING = 0x0001, /* coroutine is running */
		239	CF_READY = 0x0002, /* coroutine is ready */
		240	CF_NEW = 0x0004, /* has never been switched to */
		241	CF_DESTROYED = 0x0008, /* coroutine data has been freed */
		242	};
		243
		244	/* the structure where most of the perl state is stored, overlaid on the cxstack */
		245	typedef struct {
		246	SV *defsv;
		247	AV *defav;
		248	SV *errsv;
		249	SV *irsgv;
		250	#define VAR(name,type) type name;
		251	# include "state.h"
		252	#undef VAR
		253	} perl_slots;
		254
		255	#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
		256
		257	/* this is a structure representing a perl-level coroutine */
11	struct coro {	258	struct coro {
12	U8 dowarn;	259	/* the c coroutine allocated to this perl coroutine, if any */
13	AV *defav;	260	coro_cctx *cctx;
14		261
15	PERL_SI *curstackinfo;	262	/* process data */
16	AV *curstack;
17	AV *mainstack;	263	AV *mainstack;
18	SV **stack_sp;	264	perl_slots *slot; /* basically the saved sp */
19	OP *op;
20	SV **curpad;
21	SV **stack_base;
22	SV **stack_max;
23	SV **tmps_stack;
24	I32 tmps_floor;
25	I32 tmps_ix;
26	I32 tmps_max;
27	I32 *markstack;
28	I32 *markstack_ptr;
29	I32 *markstack_max;
30	I32 *scopestack;
31	I32 scopestack_ix;
32	I32 scopestack_max;
33	ANY *savestack;
34	I32 savestack_ix;
35	I32 savestack_max;
36	OP **retstack;
37	I32 retstack_ix;
38	I32 retstack_max;
39	COP *curcop;
40		265
41	AV *args;	266	AV *args; /* data associated with this coroutine (initial args) */
		267	int refcnt; /* coroutines are refcounted, yes */
		268	int flags; /* CF_ flags */
		269	HV *hv; /* the perl hash associated with this coro, if any */
		270
		271	/* statistics */
		272	int usecount; /* number of transfers to this coro */
		273
		274	/* coro process data */
		275	int prio;
		276	SV *throw; /* exception to be thrown */
		277
		278	/* async_pool */
		279	SV *saved_deffh;
		280
		281	/* linked list */
		282	struct coro *next, *prev;
42	};	283	};
43		284
44	typedef struct coro *Coro__State;	285	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	286	typedef struct coro *Coro__State_or_hashref;
46		287
47	static HV *padlist_cache;	288	/** Coro ********************************************************************/
48		289
49	/* mostly copied from op.c:cv_clone2 */	290	#define PRIO_MAX 3
50	STATIC AV *	291	#define PRIO_HIGH 1
51	clone_padlist (AV *protopadlist)	292	#define PRIO_NORMAL 0
		293	#define PRIO_LOW -1
		294	#define PRIO_IDLE -3
		295	#define PRIO_MIN -4
		296
		297	/* for Coro.pm */
		298	static SV *coro_current;
		299	static SV *coro_readyhook;
		300	static AV *coro_ready [PRIO_MAX - PRIO_MIN + 1];
		301	static int coro_nready;
		302	static struct coro *coro_first;
		303
		304	/** lowlevel stuff **********************************************************/
		305
		306	static SV *
		307	coro_get_sv (pTHX_ const char *name, int create)
52	{	308	{
53	AV *av;	309	#if PERL_VERSION_ATLEAST (5,10,0)
54	I32 ix;	310	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
55	AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);	311	get_sv (name, create);
56	AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);	312	#endif
57	SV **pname = AvARRAY (protopad_name);	313	return get_sv (name, create);
58	SV **ppad = AvARRAY (protopad);	314	}
59	I32 fname = AvFILLp (protopad_name);	315
60	I32 fpad = AvFILLp (protopad);	316	static AV *
		317	coro_get_av (pTHX_ const char *name, int create)
		318	{
		319	#if PERL_VERSION_ATLEAST (5,10,0)
		320	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
		321	get_av (name, create);
		322	#endif
		323	return get_av (name, create);
		324	}
		325
		326	static HV *
		327	coro_get_hv (pTHX_ const char *name, int create)
		328	{
		329	#if PERL_VERSION_ATLEAST (5,10,0)
		330	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
		331	get_hv (name, create);
		332	#endif
		333	return get_hv (name, create);
		334	}
		335
		336	static AV *
		337	coro_clone_padlist (pTHX_ CV *cv)
		338	{
		339	AV *padlist = CvPADLIST (cv);
61	AV *newpadlist, *newpad_name, *newpad;	340	AV *newpadlist, *newpad;
62	SV **npad;
63
64	newpad_name = newAV ();
65	for (ix = fname; ix >= 0; ix--)
66	av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
67
68	newpad = newAV ();
69	av_fill (newpad, AvFILLp (protopad));
70	npad = AvARRAY (newpad);
71		341
72	newpadlist = newAV ();	342	newpadlist = newAV ();
73	AvREAL_off (newpadlist);	343	AvREAL_off (newpadlist);
74	av_store (newpadlist, 0, (SV *) newpad_name);	344	#if PERL_VERSION_ATLEAST (5,10,0)
		345	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
		346	#else
		347	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
		348	#endif
		349	newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
		350	--AvFILLp (padlist);
		351
		352	av_store (newpadlist, 0, SvREFCNT_inc_NN (*av_fetch (padlist, 0, FALSE)));
75	av_store (newpadlist, 1, (SV *) newpad);	353	av_store (newpadlist, 1, (SV *)newpad);
76		354
77	av = newAV (); /* will be @_ */	355	return newpadlist;
78	av_extend (av, 0);	356	}
79	av_store (newpad, 0, (SV *) av);
80	AvFLAGS (av) = AVf_REIFY;
81		357
82	for (ix = fpad; ix > 0; ix--)	358	static void
		359	free_padlist (pTHX_ AV *padlist)
		360	{
		361	/* may be during global destruction */
		362	if (SvREFCNT (padlist))
83	{	363	{
84	SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;	364	I32 i = AvFILLp (padlist);
85	if (namesv && namesv != &PL_sv_undef)	365	while (i >= 0)
86	{	366	{
87	char *name = SvPVX (namesv); /* XXX */	367	SV **svp = av_fetch (padlist, i--, FALSE);
88	if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')	368	if (svp)
89	{ /* lexical from outside? */
90	npad[ix] = SvREFCNT_inc (ppad[ix]);
91	}	369	{
92	else
93	{ /* our own lexical */
94	SV *sv;	370	SV *sv;
95	if (*name == '&')	371	while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96	sv = SvREFCNT_inc (ppad[ix]);	372	SvREFCNT_dec (sv);
97	else if (*name == '@')	373
98	sv = (SV *) newAV ();	374	SvREFCNT_dec (*svp);
99	else if (*name == '%')
100	sv = (SV *) newHV ();
101	else
102	sv = NEWSV (0, 0);
103	if (!SvPADBUSY (sv))
104	SvPADMY_on (sv);
105	npad[ix] = sv;
106	}	375	}
107	}	376	}
108	else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))
109	{
110	npad[ix] = SvREFCNT_inc (ppad[ix]);
111	}
112	else
113	{
114	SV *sv = NEWSV (0, 0);
115	SvPADTMP_on (sv);
116	npad[ix] = sv;
117	}
118	}
119		377
120	#if 0 /* NONOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */
122
123	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv
126	&& namesv != &PL_sv_undef
127	&& !(SvFLAGS(namesv) & SVf_FAKE)
128	&& *SvPVX(namesv) == '&'
129	&& CvCLONE(ppad[ix]))
130	{
131	CV *kid = cv_clone((CV*)ppad[ix]);
132	SvREFCNT_dec(ppad[ix]);
133	CvCLONE_on(kid);
134	SvPADMY_on(kid);
135	npad[ix] = (SV*)kid;
136	}
137	}
138	#endif
139
140	return newpadlist;
141	}
142
143	STATIC AV *
144	free_padlist (AV *padlist)
145	{
146	/* may be during global destruction */
147	if (SvREFCNT(padlist))
148	{
149	I32 i = AvFILLp(padlist);
150	while (i >= 0)
151	{
152	SV **svp = av_fetch(padlist, i--, FALSE);
153	SV *sv = svp ? *svp : Nullsv;
154	if (sv)
155	SvREFCNT_dec(sv);
156	}
157
158	SvREFCNT_dec((SV*)padlist);	378	SvREFCNT_dec ((SV*)padlist);
		379	}
		380	}
		381
		382	static int
		383	coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
		384	{
		385	AV *padlist;
		386	AV *av = (AV *)mg->mg_obj;
		387
		388	/* casting is fun. */
		389	while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
		390	free_padlist (aTHX_ padlist);
		391
		392	SvREFCNT_dec (av); /* sv_magicext increased the refcount */
		393
		394	return 0;
		395	}
		396
		397	#define CORO_MAGIC_type_cv PERL_MAGIC_ext
		398	#define CORO_MAGIC_type_state PERL_MAGIC_ext
		399
		400	static MGVTBL coro_cv_vtbl = {
		401	0, 0, 0, 0,
		402	coro_cv_free
		403	};
		404
		405	#define CORO_MAGIC(sv, type) \
		406	SvMAGIC (sv) \
		407	? SvMAGIC (sv)->mg_type == type \
		408	? SvMAGIC (sv) \
		409	: mg_find (sv, type) \
		410	: 0
		411
		412	#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
		413	#define CORO_MAGIC_state(sv) CORO_MAGIC (((SV *)(sv)), CORO_MAGIC_type_state)
		414
		415	INLINE struct coro *
		416	SvSTATE_ (pTHX_ SV *coro)
		417	{
		418	HV *stash;
		419	MAGIC *mg;
		420
		421	if (SvROK (coro))
		422	coro = SvRV (coro);
		423
		424	if (expect_false (SvTYPE (coro) != SVt_PVHV))
		425	croak ("Coro::State object required");
		426
		427	stash = SvSTASH (coro);
		428	if (expect_false (stash != coro_stash && stash != coro_state_stash))
		429	{
		430	/* very slow, but rare, check */
		431	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		432	croak ("Coro::State object required");
		433	}
		434
		435	mg = CORO_MAGIC_state (coro);
		436	return (struct coro *)mg->mg_ptr;
		437	}
		438
		439	#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
		440
		441	/* the next two functions merely cache the padlists */
		442	static void
		443	get_padlist (pTHX_ CV *cv)
		444	{
		445	MAGIC *mg = CORO_MAGIC_cv (cv);
		446	AV *av;
		447
		448	if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))
		449	CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
		450	else
		451	{
		452	#if CORO_PREFER_PERL_FUNCTIONS
		453	/* this is probably cleaner? but also slower! */
		454	/* in practise, it seems to be less stable */
		455	CV *cp = Perl_cv_clone (cv);
		456	CvPADLIST (cv) = CvPADLIST (cp);
		457	CvPADLIST (cp) = 0;
		458	SvREFCNT_dec (cp);
		459	#else
		460	CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
		461	#endif
		462	}
		463	}
		464
		465	static void
		466	put_padlist (pTHX_ CV *cv)
		467	{
		468	MAGIC *mg = CORO_MAGIC_cv (cv);
		469	AV *av;
		470
		471	if (expect_false (!mg))
		472	mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
		473
		474	av = (AV *)mg->mg_obj;
		475
		476	if (expect_false (AvFILLp (av) >= AvMAX (av)))
		477	av_extend (av, AvMAX (av) + 1);
		478
		479	AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
		480	}
		481
		482	/** load & save, init *******************************************************/
		483
		484	static void
		485	load_perl (pTHX_ Coro__State c)
		486	{
		487	perl_slots *slot = c->slot;
		488	c->slot = 0;
		489
		490	PL_mainstack = c->mainstack;
		491
		492	GvSV (PL_defgv) = slot->defsv;
		493	GvAV (PL_defgv) = slot->defav;
		494	GvSV (PL_errgv) = slot->errsv;
		495	GvSV (irsgv) = slot->irsgv;
		496
		497	#define VAR(name,type) PL_ ## name = slot->name;
		498	# include "state.h"
		499	#undef VAR
		500
		501	{
		502	dSP;
		503
		504	CV *cv;
		505
		506	/* now do the ugly restore mess */
		507	while (expect_true (cv = (CV *)POPs))
		508	{
		509	put_padlist (aTHX_ cv); /* mark this padlist as available */
		510	CvDEPTH (cv) = PTR2IV (POPs);
		511	CvPADLIST (cv) = (AV *)POPs;
		512	}
		513
		514	PUTBACK;
159	}	515	}
160	}	516	}
161		517
162	/* the next tow functions merely cache the padlists */
163	STATIC void
164	get_padlist (CV *cv)
165	{
166	SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 0);
167
168	if (he && AvFILLp ((AV *)*he) >= 0)
169	CvPADLIST (cv) = (AV *)av_pop ((AV *)*he);
170	else
171	CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172	}
173
174	STATIC void
175	put_padlist (CV *cv)
176	{
177	SV **he = hv_fetch (padlist_cache, (void *)&cv, sizeof (CV *), 1);
178
179	if (SvTYPE (*he) != SVt_PVAV)
180	{
181	SvREFCNT_dec (*he);
182	*he = (SV *)newAV ();
183	}
184
185	av_push ((AV *)*he, (SV *)CvPADLIST (cv));
186	}
187
188	static void	518	static void
189	save_state(pTHX_ Coro__State c)	519	save_perl (pTHX_ Coro__State c)
190	{	520	{
191	{	521	{
192	dSP;	522	dSP;
193	I32 cxix = cxstack_ix;	523	I32 cxix = cxstack_ix;
		524	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	525	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		526
197	/*	527	/*
198	* the worst thing you can imagine happens first - we have to save	528	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	529	* (and reinitialize) all cv's in the whole callchain :(
200	*/	530	*/
201		531
202	PUSHs (Nullsv);	532	XPUSHs (Nullsv);
203	/* this loop was inspired by pp_caller */	533	/* this loop was inspired by pp_caller */
204	for (;;)	534	for (;;)
205	{	535	{
206	while (cxix >= 0)	536	while (expect_true (cxix >= 0))
207	{	537	{
208	PERL_CONTEXT *cx = &ccstk[cxix--];	538	PERL_CONTEXT *cx = &ccstk[cxix--];
209		539
210	if (CxTYPE(cx) == CXt_SUB)	540	if (expect_true (CxTYPE (cx) == CXt_SUB || CxTYPE (cx) == CXt_FORMAT))
211	{	541	{
212	CV *cv = cx->blk_sub.cv;	542	CV *cv = cx->blk_sub.cv;
		543
213	if (CvDEPTH(cv))	544	if (expect_true (CvDEPTH (cv)))
214	{	545	{
215	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));
217	#endif
218	EXTEND (SP, 3);	546	EXTEND (SP, 3);
219	PUSHs ((SV *)CvDEPTH(cv));
220	PUSHs ((SV *)CvPADLIST(cv));	547	PUSHs ((SV *)CvPADLIST (cv));
		548	PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
221	PUSHs ((SV *)cv);	549	PUSHs ((SV *)cv);
222		550
223	get_padlist (cv);
224
225	CvDEPTH(cv) = 0;	551	CvDEPTH (cv) = 0;
226	#ifdef USE_THREADS	552	get_padlist (aTHX_ cv);
227	CvOWNER(cv) = 0;
228	error must unlock this cv etc.. etc...
229	if you are here wondering about this error message then
230	the reason is that it will not work as advertised yet
231	#endif
232	}	553	}
233	}	554	}
234	else if (CxTYPE(cx) == CXt_FORMAT)	555	}
		556
		557	if (expect_true (top_si->si_type == PERLSI_MAIN))
		558	break;
		559
		560	top_si = top_si->si_prev;
		561	ccstk = top_si->si_cxstack;
		562	cxix = top_si->si_cxix;
		563	}
		564
		565	PUTBACK;
		566	}
		567
		568	/* allocate some space on the context stack for our purposes */
		569	/* we manually unroll here, as usually 2 slots is enough */
		570	if (SLOT_COUNT >= 1) CXINC;
		571	if (SLOT_COUNT >= 2) CXINC;
		572	if (SLOT_COUNT >= 3) CXINC;
		573	{
		574	int i;
		575	for (i = 3; i < SLOT_COUNT; ++i)
		576	CXINC;
		577	}
		578	cxstack_ix -= SLOT_COUNT; /* undo allocation */
		579
		580	c->mainstack = PL_mainstack;
		581
		582	{
		583	perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
		584
		585	slot->defav = GvAV (PL_defgv);
		586	slot->defsv = DEFSV;
		587	slot->errsv = ERRSV;
		588	slot->irsgv = GvSV (irsgv);
		589
		590	#define VAR(name,type) slot->name = PL_ ## name;
		591	# include "state.h"
		592	#undef VAR
		593	}
		594	}
		595
		596	/*
		597	* allocate various perl stacks. This is an exact copy
		598	* of perl.c:init_stacks, except that it uses less memory
		599	* on the (sometimes correct) assumption that coroutines do
		600	* not usually need a lot of stackspace.
		601	*/
		602	#if CORO_PREFER_PERL_FUNCTIONS
		603	# define coro_init_stacks init_stacks
		604	#else
		605	static void
		606	coro_init_stacks (pTHX)
		607	{
		608	PL_curstackinfo = new_stackinfo(32, 8);
		609	PL_curstackinfo->si_type = PERLSI_MAIN;
		610	PL_curstack = PL_curstackinfo->si_stack;
		611	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		612
		613	PL_stack_base = AvARRAY(PL_curstack);
		614	PL_stack_sp = PL_stack_base;
		615	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
		616
		617	New(50,PL_tmps_stack,32,SV*);
		618	PL_tmps_floor = -1;
		619	PL_tmps_ix = -1;
		620	PL_tmps_max = 32;
		621
		622	New(54,PL_markstack,16,I32);
		623	PL_markstack_ptr = PL_markstack;
		624	PL_markstack_max = PL_markstack + 16;
		625
		626	#ifdef SET_MARK_OFFSET
		627	SET_MARK_OFFSET;
		628	#endif
		629
		630	New(54,PL_scopestack,8,I32);
		631	PL_scopestack_ix = 0;
		632	PL_scopestack_max = 8;
		633
		634	New(54,PL_savestack,24,ANY);
		635	PL_savestack_ix = 0;
		636	PL_savestack_max = 24;
		637
		638	#if !PERL_VERSION_ATLEAST (5,10,0)
		639	New(54,PL_retstack,4,OP*);
		640	PL_retstack_ix = 0;
		641	PL_retstack_max = 4;
		642	#endif
		643	}
		644	#endif
		645
		646	/*
		647	* destroy the stacks, the callchain etc...
		648	*/
		649	static void
		650	coro_destruct_stacks (pTHX)
		651	{
		652	while (PL_curstackinfo->si_next)
		653	PL_curstackinfo = PL_curstackinfo->si_next;
		654
		655	while (PL_curstackinfo)
		656	{
		657	PERL_SI *p = PL_curstackinfo->si_prev;
		658
		659	if (!IN_DESTRUCT)
		660	SvREFCNT_dec (PL_curstackinfo->si_stack);
		661
		662	Safefree (PL_curstackinfo->si_cxstack);
		663	Safefree (PL_curstackinfo);
		664	PL_curstackinfo = p;
		665	}
		666
		667	Safefree (PL_tmps_stack);
		668	Safefree (PL_markstack);
		669	Safefree (PL_scopestack);
		670	Safefree (PL_savestack);
		671	#if !PERL_VERSION_ATLEAST (5,10,0)
		672	Safefree (PL_retstack);
		673	#endif
		674	}
		675
		676	static size_t
		677	coro_rss (pTHX_ struct coro *coro)
		678	{
		679	size_t rss = sizeof (*coro);
		680
		681	if (coro->mainstack)
		682	{
		683	perl_slots tmp_slot;
		684	perl_slots *slot;
		685
		686	if (coro->flags & CF_RUNNING)
		687	{
		688	slot = &tmp_slot;
		689
		690	#define VAR(name,type) slot->name = PL_ ## name;
		691	# include "state.h"
		692	#undef VAR
		693	}
		694	else
		695	slot = coro->slot;
		696
		697	if (slot)
		698	{
		699	rss += sizeof (slot->curstackinfo);
		700	rss += (slot->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
		701	rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (slot->curstack)) * sizeof (SV *);
		702	rss += slot->tmps_max * sizeof (SV *);
		703	rss += (slot->markstack_max - slot->markstack_ptr) * sizeof (I32);
		704	rss += slot->scopestack_max * sizeof (I32);
		705	rss += slot->savestack_max * sizeof (ANY);
		706
		707	#if !PERL_VERSION_ATLEAST (5,10,0)
		708	rss += slot->retstack_max * sizeof (OP *);
		709	#endif
		710	}
		711	}
		712
		713	return rss;
		714	}
		715
		716	/** coroutine stack handling ************************************************/
		717
		718	static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg);
		719	static int (*orig_sigelem_set) (pTHX_ SV *sv, MAGIC *mg);
		720	static int (*orig_sigelem_clr) (pTHX_ SV *sv, MAGIC *mg);
		721
		722	/* apparently < 5.8.8 */
		723	#ifndef MgPV_nolen_const
		724	#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
		725	SvPV_nolen((SV*)((mg)->mg_ptr)) : \
		726	(const char*)(mg)->mg_ptr)
		727	#endif
		728
		729	/* we sometimes need to create the effect of entersub calling us */
		730	#define SSL_HEAD (void)0
		731	/* we somtimes need to create the effect of leaving via entersub */
		732	#define SSL_TAIL (void)0
		733
		734	/*
		735	* This overrides the default magic get method of %SIG elements.
		736	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook
		737	* and instead of tryign to save and restore the hash elements, we just provide
		738	* readback here.
		739	* We only do this when the hook is != 0, as they are often set to 0 temporarily,
		740	* not expecting this to actually change the hook. This is a potential problem
		741	* when a schedule happens then, but we ignore this.
		742	*/
		743	static int
		744	coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
		745	{
		746	const char *s = MgPV_nolen_const (mg);
		747
		748	if (*s == '_')
		749	{
		750	SV **svp = 0;
		751
		752	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		753	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		754
		755	if (svp)
		756	{
		757	sv_setsv (sv, *svp ? *svp : &PL_sv_undef);
		758	return 0;
		759	}
		760	}
		761
		762	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
		763	}
		764
		765	static int
		766	coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
		767	{
		768	const char *s = MgPV_nolen_const (mg);
		769
		770	if (*s == '_')
		771	{
		772	SV **svp = 0;
		773
		774	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		775	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		776
		777	if (svp)
		778	{
		779	SV *old = *svp;
		780	*svp = 0;
		781	SvREFCNT_dec (old);
		782	return 0;
		783	}
		784	}
		785
		786	return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
		787	}
		788
		789	static int
		790	coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
		791	{
		792	const char *s = MgPV_nolen_const (mg);
		793
		794	if (*s == '_')
		795	{
		796	SV **svp = 0;
		797
		798	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		799	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		800
		801	if (svp)
		802	{
		803	SV *old = *svp;
		804	*svp = newSVsv (sv);
		805	SvREFCNT_dec (old);
		806	return 0;
		807	}
		808	}
		809
		810	return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
		811	}
		812
		813	static void
		814	coro_setup (pTHX_ struct coro *coro)
		815	{
		816	/*
		817	* emulate part of the perl startup here.
		818	*/
		819	coro_init_stacks (aTHX);
		820
		821	PL_runops = RUNOPS_DEFAULT;
		822	PL_curcop = &PL_compiling;
		823	PL_in_eval = EVAL_NULL;
		824	PL_comppad = 0;
		825	PL_curpm = 0;
		826	PL_curpad = 0;
		827	PL_localizing = 0;
		828	PL_dirty = 0;
		829	PL_restartop = 0;
		830	#if PERL_VERSION_ATLEAST (5,10,0)
		831	PL_parser = 0;
		832	#endif
		833
		834	/* recreate the die/warn hooks */
		835	PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
		836	PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
		837
		838	GvSV (PL_defgv) = newSV (0);
		839	GvAV (PL_defgv) = coro->args; coro->args = 0;
		840	GvSV (PL_errgv) = newSV (0);
		841	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
		842	PL_rs = newSVsv (GvSV (irsgv));
		843	PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
		844
		845	{
		846	dSP;
		847	UNOP myop;
		848
		849	Zero (&myop, 1, UNOP);
		850	myop.op_next = Nullop;
		851	myop.op_flags = OPf_WANT_VOID;
		852
		853	PUSHMARK (SP);
		854	XPUSHs (sv_2mortal (av_shift (GvAV (PL_defgv))));
		855	PUTBACK;
		856	PL_op = (OP *)&myop;
		857	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		858	SPAGAIN;
		859	}
		860
		861	/* this newly created coroutine might be run on an existing cctx which most
		862	* likely was suspended in set_stacklevel, called from entersub.
		863	* set_stacklevel doesn't do anything on return, but entersub does LEAVE,
		864	* so we ENTER here for symmetry.
		865	*/
		866	SSL_HEAD;
		867	}
		868
		869	static void
		870	coro_destruct (pTHX_ struct coro *coro)
		871	{
		872	if (!IN_DESTRUCT)
		873	{
		874	/* restore all saved variables and stuff */
		875	LEAVE_SCOPE (0);
		876	assert (PL_tmps_floor == -1);
		877
		878	/* free all temporaries */
		879	FREETMPS;
		880	assert (PL_tmps_ix == -1);
		881
		882	/* unwind all extra stacks */
		883	POPSTACK_TO (PL_mainstack);
		884
		885	/* unwind main stack */
		886	dounwind (-1);
		887	}
		888
		889	SvREFCNT_dec (GvSV (PL_defgv));
		890	SvREFCNT_dec (GvAV (PL_defgv));
		891	SvREFCNT_dec (GvSV (PL_errgv));
		892	SvREFCNT_dec (PL_defoutgv);
		893	SvREFCNT_dec (PL_rs);
		894	SvREFCNT_dec (GvSV (irsgv));
		895
		896	SvREFCNT_dec (PL_diehook);
		897	SvREFCNT_dec (PL_warnhook);
		898
		899	SvREFCNT_dec (coro->saved_deffh);
		900	SvREFCNT_dec (coro->throw);
		901
		902	coro_destruct_stacks (aTHX);
		903	}
		904
		905	INLINE void
		906	free_coro_mortal (pTHX)
		907	{
		908	if (expect_true (coro_mortal))
		909	{
		910	SvREFCNT_dec (coro_mortal);
		911	coro_mortal = 0;
		912	}
		913	}
		914
		915	static int
		916	runops_trace (pTHX)
		917	{
		918	COP *oldcop = 0;
		919	int oldcxix = -2;
		920	struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
		921	coro_cctx *cctx = coro->cctx;
		922
		923	while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
		924	{
		925	PERL_ASYNC_CHECK ();
		926
		927	if (cctx->flags & CC_TRACE_ALL)
		928	{
		929	if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
		930	{
		931	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		932	SV **bot, **top;
		933	AV *av = newAV (); /* return values */
		934	SV **cb;
		935	dSP;
		936
		937	GV *gv = CvGV (cx->blk_sub.cv);
		938	SV *fullname = sv_2mortal (newSV (0));
		939	if (isGV (gv))
		940	gv_efullname3 (fullname, gv, 0);
		941
		942	bot = PL_stack_base + cx->blk_oldsp + 1;
		943	top = cx->blk_gimme == G_ARRAY ? SP + 1
		944	: cx->blk_gimme == G_SCALAR ? bot + 1
		945	: bot;
		946
		947	av_extend (av, top - bot);
		948	while (bot < top)
		949	av_push (av, SvREFCNT_inc_NN (*bot++));
		950
		951	PL_runops = RUNOPS_DEFAULT;
		952	ENTER;
		953	SAVETMPS;
		954	EXTEND (SP, 3);
		955	PUSHMARK (SP);
		956	PUSHs (&PL_sv_no);
		957	PUSHs (fullname);
		958	PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		959	PUTBACK;
		960	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		961	if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		962	SPAGAIN;
		963	FREETMPS;
		964	LEAVE;
		965	PL_runops = runops_trace;
		966	}
		967
		968	if (oldcop != PL_curcop)
		969	{
		970	oldcop = PL_curcop;
		971
		972	if (PL_curcop != &PL_compiling)
		973	{
		974	SV **cb;
		975
		976	if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
		977	{
		978	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		979
		980	if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
		981	{
		982	runops_proc_t old_runops = PL_runops;
		983	dSP;
		984	GV *gv = CvGV (cx->blk_sub.cv);
		985	SV *fullname = sv_2mortal (newSV (0));
		986
		987	if (isGV (gv))
		988	gv_efullname3 (fullname, gv, 0);
		989
		990	PL_runops = RUNOPS_DEFAULT;
		991	ENTER;
		992	SAVETMPS;
		993	EXTEND (SP, 3);
		994	PUSHMARK (SP);
		995	PUSHs (&PL_sv_yes);
		996	PUSHs (fullname);
		997	PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
		998	PUTBACK;
		999	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		1000	if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		1001	SPAGAIN;
		1002	FREETMPS;
		1003	LEAVE;
		1004	PL_runops = runops_trace;
		1005	}
		1006
		1007	oldcxix = cxstack_ix;
		1008	}
		1009
		1010	if (cctx->flags & CC_TRACE_LINE)
		1011	{
		1012	dSP;
		1013
		1014	PL_runops = RUNOPS_DEFAULT;
		1015	ENTER;
		1016	SAVETMPS;
		1017	EXTEND (SP, 3);
		1018	PL_runops = RUNOPS_DEFAULT;
		1019	PUSHMARK (SP);
		1020	PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
		1021	PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
		1022	PUTBACK;
		1023	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
		1024	if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		1025	SPAGAIN;
		1026	FREETMPS;
		1027	LEAVE;
		1028	PL_runops = runops_trace;
		1029	}
		1030	}
		1031	}
		1032	}
		1033	}
		1034
		1035	TAINT_NOT;
		1036	return 0;
		1037	}
		1038
		1039	static void
		1040	prepare_set_stacklevel (struct transfer_args *ta, struct coro_cctx *cctx)
		1041	{
		1042	ta->prev = (struct coro *)cctx;
		1043	ta->next = 0;
		1044	}
		1045
		1046	/* inject a fake call to Coro::State::_cctx_init into the execution */
		1047	/* _cctx_init should be careful, as it could be called at almost any time */
		1048	/* during execution of a perl program */
		1049	/* also initialises PL_top_env */
		1050	static void NOINLINE
		1051	cctx_prepare (pTHX_ coro_cctx *cctx)
		1052	{
		1053	dSP;
		1054	UNOP myop;
		1055
		1056	PL_top_env = &PL_start_env;
		1057
		1058	if (cctx->flags & CC_TRACE)
		1059	PL_runops = runops_trace;
		1060
		1061	Zero (&myop, 1, UNOP);
		1062	myop.op_next = PL_op;
		1063	myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
		1064
		1065	PUSHMARK (SP);
		1066	EXTEND (SP, 2);
		1067	PUSHs (sv_2mortal (newSViv ((IV)cctx)));
		1068	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
		1069	PUTBACK;
		1070	PL_op = (OP *)&myop;
		1071	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		1072	SPAGAIN;
		1073	}
		1074
		1075	/* the tail of transfer: execute stuff we can only do after a transfer */
		1076	INLINE void
		1077	transfer_tail (pTHX)
		1078	{
		1079	struct coro *next = (struct coro *)transfer_next;
		1080	assert (!(transfer_next = 0)); /* just used for the side effect when asserts are enabled */
		1081	assert (("FATAL: next coroutine was zero in transfer_tail (please report)", next));
		1082
		1083	free_coro_mortal (aTHX);
		1084	UNLOCK;
		1085
		1086	if (expect_false (next->throw))
		1087	{
		1088	SV *exception = sv_2mortal (next->throw);
		1089
		1090	next->throw = 0;
		1091	sv_setsv (ERRSV, exception);
		1092	croak (0);
		1093	}
		1094	}
		1095
		1096	/*
		1097	* this is a _very_ stripped down perl interpreter ;)
		1098	*/
		1099	static void
		1100	cctx_run (void *arg)
		1101	{
		1102	#ifdef USE_ITHREADS
		1103	# if CORO_PTHREAD
		1104	PERL_SET_CONTEXT (coro_thx);
		1105	# endif
		1106	#endif
		1107	{
		1108	dTHX;
		1109
		1110	/* entersub called ENTER, but we never 'returned', undo that here */
		1111	SSL_TAIL;
		1112
		1113	/* we now skip the op that did lead to transfer() */
		1114	PL_op = PL_op->op_next;
		1115
		1116	/* inject a fake subroutine call to cctx_init */
		1117	cctx_prepare (aTHX_ (coro_cctx *)arg);
		1118
		1119	/* cctx_run is the alternative tail of transfer() */
		1120	transfer_tail (aTHX);
		1121
		1122	/* somebody or something will hit me for both perl_run and PL_restartop */
		1123	PL_restartop = PL_op;
		1124	perl_run (PL_curinterp);
		1125
		1126	/*
		1127	* If perl-run returns we assume exit() was being called or the coro
		1128	* fell off the end, which seems to be the only valid (non-bug)
		1129	* reason for perl_run to return. We try to exit by jumping to the
		1130	* bootstrap-time "top" top_env, as we cannot restore the "main"
		1131	* coroutine as Coro has no such concept
		1132	*/
		1133	PL_top_env = main_top_env;
		1134	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
		1135	}
		1136	}
		1137
		1138	static coro_cctx *
		1139	cctx_new ()
		1140	{
		1141	coro_cctx *cctx;
		1142
		1143	++cctx_count;
		1144	New (0, cctx, 1, coro_cctx);
		1145
		1146	cctx->gen = cctx_gen;
		1147	cctx->flags = 0;
		1148	cctx->idle_sp = 0; /* can be accessed by transfer between cctx_run and set_stacklevel, on throw */
		1149
		1150	return cctx;
		1151	}
		1152
		1153	/* create a new cctx only suitable as source */
		1154	static coro_cctx *
		1155	cctx_new_empty ()
		1156	{
		1157	coro_cctx *cctx = cctx_new ();
		1158
		1159	cctx->sptr = 0;
		1160	coro_create (&cctx->cctx, 0, 0, 0, 0);
		1161
		1162	return cctx;
		1163	}
		1164
		1165	/* create a new cctx suitable as destination/running a perl interpreter */
		1166	static coro_cctx *
		1167	cctx_new_run ()
		1168	{
		1169	coro_cctx *cctx = cctx_new ();
		1170	void *stack_start;
		1171	size_t stack_size;
		1172
		1173	#if HAVE_MMAP
		1174	cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
		1175	/* mmap supposedly does allocate-on-write for us */
		1176	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
		1177
		1178	if (cctx->sptr != (void *)-1)
		1179	{
		1180	#if CORO_STACKGUARD
		1181	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
		1182	#endif
		1183	stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE;
		1184	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
		1185	cctx->flags |= CC_MAPPED;
		1186	}
		1187	else
		1188	#endif
		1189	{
		1190	cctx->ssize = cctx_stacksize * (long)sizeof (long);
		1191	New (0, cctx->sptr, cctx_stacksize, long);
		1192
		1193	if (!cctx->sptr)
		1194	{
		1195	perror ("FATAL: unable to allocate stack for coroutine, exiting.");
		1196	_exit (EXIT_FAILURE);
		1197	}
		1198
		1199	stack_start = cctx->sptr;
		1200	stack_size = cctx->ssize;
		1201	}
		1202
		1203	#if CORO_USE_VALGRIND
		1204	cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size);
		1205	#endif
		1206
		1207	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
		1208
		1209	return cctx;
		1210	}
		1211
		1212	static void
		1213	cctx_destroy (coro_cctx *cctx)
		1214	{
		1215	if (!cctx)
		1216	return;
		1217
		1218	--cctx_count;
		1219	coro_destroy (&cctx->cctx);
		1220
		1221	/* coro_transfer creates new, empty cctx's */
		1222	if (cctx->sptr)
		1223	{
		1224	#if CORO_USE_VALGRIND
		1225	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		1226	#endif
		1227
		1228	#if HAVE_MMAP
		1229	if (cctx->flags & CC_MAPPED)
		1230	munmap (cctx->sptr, cctx->ssize);
		1231	else
		1232	#endif
		1233	Safefree (cctx->sptr);
		1234	}
		1235
		1236	Safefree (cctx);
		1237	}
		1238
		1239	/* wether this cctx should be destructed */
		1240	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
		1241
		1242	static coro_cctx *
		1243	cctx_get (pTHX)
		1244	{
		1245	while (expect_true (cctx_first))
		1246	{
		1247	coro_cctx *cctx = cctx_first;
		1248	cctx_first = cctx->next;
		1249	--cctx_idle;
		1250
		1251	if (expect_true (!CCTX_EXPIRED (cctx)))
		1252	return cctx;
		1253
		1254	cctx_destroy (cctx);
		1255	}
		1256
		1257	return cctx_new_run ();
		1258	}
		1259
		1260	static void
		1261	cctx_put (coro_cctx *cctx)
		1262	{
		1263	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr));
		1264
		1265	/* free another cctx if overlimit */
		1266	if (expect_false (cctx_idle >= cctx_max_idle))
		1267	{
		1268	coro_cctx *first = cctx_first;
		1269	cctx_first = first->next;
		1270	--cctx_idle;
		1271
		1272	cctx_destroy (first);
		1273	}
		1274
		1275	++cctx_idle;
		1276	cctx->next = cctx_first;
		1277	cctx_first = cctx;
		1278	}
		1279
		1280	/** coroutine switching *****************************************************/
		1281
		1282	static void
		1283	transfer_check (pTHX_ struct coro *prev, struct coro *next)
		1284	{
		1285	if (expect_true (prev != next))
		1286	{
		1287	if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
		1288	croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
		1289
		1290	if (expect_false (next->flags & CF_RUNNING))
		1291	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		1292
		1293	if (expect_false (next->flags & CF_DESTROYED))
		1294	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		1295
		1296	#if !PERL_VERSION_ATLEAST (5,10,0)
		1297	if (expect_false (PL_lex_state != LEX_NOTPARSING))
		1298	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version");
		1299	#endif
		1300	}
		1301	}
		1302
		1303	/* always use the TRANSFER macro */
		1304	static void NOINLINE
		1305	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
		1306	{
		1307	dSTACKLEVEL;
		1308
		1309	/* sometimes transfer is only called to set idle_sp */
		1310	if (expect_false (!next))
		1311	{
		1312	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		1313	assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
		1314	}
		1315	else if (expect_true (prev != next))
		1316	{
		1317	coro_cctx *prev__cctx;
		1318
		1319	if (expect_false (prev->flags & CF_NEW))
		1320	{
		1321	/* create a new empty/source context */
		1322	prev->cctx = cctx_new_empty ();
		1323	prev->flags &= ~CF_NEW;
		1324	prev->flags |= CF_RUNNING;
		1325	}
		1326
		1327	prev->flags &= ~CF_RUNNING;
		1328	next->flags |= CF_RUNNING;
		1329
		1330	LOCK;
		1331
		1332	/* first get rid of the old state */
		1333	save_perl (aTHX_ prev);
		1334
		1335	if (expect_false (next->flags & CF_NEW))
		1336	{
		1337	/* need to start coroutine */
		1338	next->flags &= ~CF_NEW;
		1339	/* setup coroutine call */
		1340	coro_setup (aTHX_ next);
		1341	}
		1342	else
		1343	load_perl (aTHX_ next);
		1344
		1345	prev__cctx = prev->cctx;
		1346
		1347	/* possibly untie and reuse the cctx */
		1348	if (expect_true (
		1349	prev__cctx->idle_sp == STACKLEVEL
		1350	&& !(prev__cctx->flags & CC_TRACE)
		1351	&& !force_cctx
		1352	))
		1353	{
		1354	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		1355	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == prev__cctx->idle_te));
		1356
		1357	prev->cctx = 0;
		1358
		1359	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
		1360	/* without this the next cctx_get might destroy the prev__cctx while still in use */
		1361	if (expect_false (CCTX_EXPIRED (prev__cctx)))
		1362	if (!next->cctx)
		1363	next->cctx = cctx_get (aTHX);
		1364
		1365	cctx_put (prev__cctx);
		1366	}
		1367
		1368	++next->usecount;
		1369
		1370	if (expect_true (!next->cctx))
		1371	next->cctx = cctx_get (aTHX);
		1372
		1373	assert (("FATAL: transfer_next already nonzero in Coro (please report)", !transfer_next));
		1374	transfer_next = next;
		1375
		1376	if (expect_false (prev__cctx != next->cctx))
		1377	{
		1378	prev__cctx->top_env = PL_top_env;
		1379	PL_top_env = next->cctx->top_env;
		1380	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		1381	}
		1382
		1383	transfer_tail (aTHX);
		1384	}
		1385	}
		1386
		1387	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
		1388	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
		1389
		1390	/** high level stuff ********************************************************/
		1391
		1392	static int
		1393	coro_state_destroy (pTHX_ struct coro *coro)
		1394	{
		1395	if (coro->flags & CF_DESTROYED)
		1396	return 0;
		1397
		1398	coro->flags |= CF_DESTROYED;
		1399
		1400	if (coro->flags & CF_READY)
		1401	{
		1402	/* reduce nready, as destroying a ready coro effectively unreadies it */
		1403	/* alternative: look through all ready queues and remove the coro */
		1404	LOCK;
		1405	--coro_nready;
		1406	UNLOCK;
		1407	}
		1408	else
		1409	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
		1410
		1411	if (coro->mainstack && coro->mainstack != main_mainstack)
		1412	{
		1413	struct coro temp;
		1414
		1415	if (coro->flags & CF_RUNNING)
		1416	croak ("FATAL: tried to destroy currently running coroutine");
		1417
		1418	save_perl (aTHX_ &temp);
		1419	load_perl (aTHX_ coro);
		1420
		1421	coro_destruct (aTHX_ coro);
		1422
		1423	load_perl (aTHX_ &temp);
		1424
		1425	coro->slot = 0;
		1426	}
		1427
		1428	cctx_destroy (coro->cctx);
		1429	SvREFCNT_dec (coro->args);
		1430
		1431	if (coro->next) coro->next->prev = coro->prev;
		1432	if (coro->prev) coro->prev->next = coro->next;
		1433	if (coro == coro_first) coro_first = coro->next;
		1434
		1435	return 1;
		1436	}
		1437
		1438	static int
		1439	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
		1440	{
		1441	struct coro *coro = (struct coro *)mg->mg_ptr;
		1442	mg->mg_ptr = 0;
		1443
		1444	coro->hv = 0;
		1445
		1446	if (--coro->refcnt < 0)
		1447	{
		1448	coro_state_destroy (aTHX_ coro);
		1449	Safefree (coro);
		1450	}
		1451
		1452	return 0;
		1453	}
		1454
		1455	static int
		1456	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		1457	{
		1458	struct coro *coro = (struct coro *)mg->mg_ptr;
		1459
		1460	++coro->refcnt;
		1461
		1462	return 0;
		1463	}
		1464
		1465	static MGVTBL coro_state_vtbl = {
		1466	0, 0, 0, 0,
		1467	coro_state_free,
		1468	0,
		1469	#ifdef MGf_DUP
		1470	coro_state_dup,
		1471	#else
		1472	# define MGf_DUP 0
		1473	#endif
		1474	};
		1475
		1476	static void
		1477	prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
		1478	{
		1479	ta->prev = SvSTATE (prev_sv);
		1480	ta->next = SvSTATE (next_sv);
		1481	TRANSFER_CHECK (*ta);
		1482	}
		1483
		1484	static void
		1485	api_transfer (SV *prev_sv, SV *next_sv)
		1486	{
		1487	dTHX;
		1488	struct transfer_args ta;
		1489
		1490	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
		1491	TRANSFER (ta, 1);
		1492	}
		1493
		1494	/** Coro ********************************************************************/
		1495
		1496	static void
		1497	coro_enq (pTHX_ SV *coro_sv)
		1498	{
		1499	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		1500	}
		1501
		1502	static SV *
		1503	coro_deq (pTHX)
		1504	{
		1505	int prio;
		1506
		1507	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
		1508	if (AvFILLp (coro_ready [prio]) >= 0)
		1509	return av_shift (coro_ready [prio]);
		1510
		1511	return 0;
		1512	}
		1513
		1514	static int
		1515	api_ready (SV *coro_sv)
		1516	{
		1517	dTHX;
		1518	struct coro *coro;
		1519	SV *sv_hook;
		1520	void (*xs_hook)(void);
		1521
		1522	if (SvROK (coro_sv))
		1523	coro_sv = SvRV (coro_sv);
		1524
		1525	coro = SvSTATE (coro_sv);
		1526
		1527	if (coro->flags & CF_READY)
		1528	return 0;
		1529
		1530	coro->flags |= CF_READY;
		1531
		1532	LOCK;
		1533
		1534	sv_hook = coro_nready ? 0 : coro_readyhook;
		1535	xs_hook = coro_nready ? 0 : coroapi.readyhook;
		1536
		1537	coro_enq (aTHX_ SvREFCNT_inc_NN (coro_sv));
		1538	++coro_nready;
		1539
		1540	UNLOCK;
		1541
		1542	if (sv_hook)
		1543	{
		1544	dSP;
		1545
		1546	ENTER;
		1547	SAVETMPS;
		1548
		1549	PUSHMARK (SP);
		1550	PUTBACK;
		1551	call_sv (sv_hook, G_DISCARD);
		1552	SPAGAIN;
		1553
		1554	FREETMPS;
		1555	LEAVE;
		1556	}
		1557
		1558	if (xs_hook)
		1559	xs_hook ();
		1560
		1561	return 1;
		1562	}
		1563
		1564	static int
		1565	api_is_ready (SV *coro_sv)
		1566	{
		1567	dTHX;
		1568
		1569	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		1570	}
		1571
		1572	INLINE void
		1573	prepare_schedule (pTHX_ struct transfer_args *ta)
		1574	{
		1575	SV *prev_sv, *next_sv;
		1576
		1577	for (;;)
		1578	{
		1579	LOCK;
		1580	next_sv = coro_deq (aTHX);
		1581
		1582	/* nothing to schedule: call the idle handler */
		1583	if (expect_false (!next_sv))
		1584	{
		1585	dSP;
		1586	UNLOCK;
		1587
		1588	ENTER;
		1589	SAVETMPS;
		1590
		1591	PUSHMARK (SP);
		1592	PUTBACK;
		1593	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1594	SPAGAIN;
		1595
		1596	FREETMPS;
		1597	LEAVE;
		1598	continue;
		1599	}
		1600
		1601	ta->next = SvSTATE (next_sv);
		1602
		1603	/* cannot transfer to destroyed coros, skip and look for next */
		1604	if (expect_false (ta->next->flags & CF_DESTROYED))
		1605	{
		1606	UNLOCK;
		1607	SvREFCNT_dec (next_sv);
		1608	/* coro_nready has already been taken care of by destroy */
		1609	continue;
		1610	}
		1611
		1612	--coro_nready;
		1613	UNLOCK;
		1614	break;
		1615	}
		1616
		1617	/* free this only after the transfer */
		1618	prev_sv = SvRV (coro_current);
		1619	ta->prev = SvSTATE (prev_sv);
		1620	TRANSFER_CHECK (*ta);
		1621	assert (("FATAL: next coroutine isn't marked as ready in Coro (please report)", ta->next->flags & CF_READY));
		1622	ta->next->flags &= ~CF_READY;
		1623	SvRV_set (coro_current, next_sv);
		1624
		1625	LOCK;
		1626	free_coro_mortal (aTHX);
		1627	coro_mortal = prev_sv;
		1628	UNLOCK;
		1629	}
		1630
		1631	INLINE void
		1632	prepare_cede (pTHX_ struct transfer_args *ta)
		1633	{
		1634	api_ready (coro_current);
		1635	prepare_schedule (aTHX_ ta);
		1636	}
		1637
		1638	static int
		1639	prepare_cede_notself (pTHX_ struct transfer_args *ta)
		1640	{
		1641	if (coro_nready)
		1642	{
		1643	SV *prev = SvRV (coro_current);
		1644	prepare_schedule (aTHX_ ta);
		1645	api_ready (prev);
		1646	return 1;
		1647	}
		1648	else
		1649	return 0;
		1650	}
		1651
		1652	static void
		1653	api_schedule (void)
		1654	{
		1655	dTHX;
		1656	struct transfer_args ta;
		1657
		1658	prepare_schedule (aTHX_ &ta);
		1659	TRANSFER (ta, 1);
		1660	}
		1661
		1662	static int
		1663	api_cede (void)
		1664	{
		1665	dTHX;
		1666	struct transfer_args ta;
		1667
		1668	prepare_cede (aTHX_ &ta);
		1669
		1670	if (expect_true (ta.prev != ta.next))
		1671	{
		1672	TRANSFER (ta, 1);
		1673	return 1;
		1674	}
		1675	else
		1676	return 0;
		1677	}
		1678
		1679	static int
		1680	api_cede_notself (void)
		1681	{
		1682	dTHX;
		1683	struct transfer_args ta;
		1684
		1685	if (prepare_cede_notself (aTHX_ &ta))
		1686	{
		1687	TRANSFER (ta, 1);
		1688	return 1;
		1689	}
		1690	else
		1691	return 0;
		1692	}
		1693
		1694	static void
		1695	api_trace (SV *coro_sv, int flags)
		1696	{
		1697	dTHX;
		1698	struct coro *coro = SvSTATE (coro_sv);
		1699
		1700	if (flags & CC_TRACE)
		1701	{
		1702	if (!coro->cctx)
		1703	coro->cctx = cctx_new_run ();
		1704	else if (!(coro->cctx->flags & CC_TRACE))
		1705	croak ("cannot enable tracing on coroutine with custom stack");
		1706
		1707	coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
		1708	}
		1709	else if (coro->cctx && coro->cctx->flags & CC_TRACE)
		1710	{
		1711	coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
		1712
		1713	if (coro->flags & CF_RUNNING)
		1714	PL_runops = RUNOPS_DEFAULT;
		1715	else
		1716	coro->slot->runops = RUNOPS_DEFAULT;
		1717	}
		1718	}
		1719
		1720	#if 0
		1721	static int
		1722	coro_gensub_free (pTHX_ SV *sv, MAGIC *mg)
		1723	{
		1724	AV *padlist;
		1725	AV *av = (AV *)mg->mg_obj;
		1726
		1727	abort ();
		1728
		1729	return 0;
		1730	}
		1731
		1732	static MGVTBL coro_gensub_vtbl = {
		1733	0, 0, 0, 0,
		1734	coro_gensub_free
		1735	};
		1736	#endif
		1737
		1738	/*****************************************************************************/
		1739	/* PerlIO::cede */
		1740
		1741	typedef struct
		1742	{
		1743	PerlIOBuf base;
		1744	NV next, every;
		1745	} PerlIOCede;
		1746
		1747	static IV
		1748	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
		1749	{
		1750	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1751
		1752	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
		1753	self->next = nvtime () + self->every;
		1754
		1755	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
		1756	}
		1757
		1758	static SV *
		1759	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
		1760	{
		1761	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1762
		1763	return newSVnv (self->every);
		1764	}
		1765
		1766	static IV
		1767	PerlIOCede_flush (pTHX_ PerlIO *f)
		1768	{
		1769	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1770	double now = nvtime ();
		1771
		1772	if (now >= self->next)
		1773	{
		1774	api_cede ();
		1775	self->next = now + self->every;
		1776	}
		1777
		1778	return PerlIOBuf_flush (aTHX_ f);
		1779	}
		1780
		1781	static PerlIO_funcs PerlIO_cede =
		1782	{
		1783	sizeof(PerlIO_funcs),
		1784	"cede",
		1785	sizeof(PerlIOCede),
		1786	PERLIO_K_DESTRUCT | PERLIO_K_RAW,
		1787	PerlIOCede_pushed,
		1788	PerlIOBuf_popped,
		1789	PerlIOBuf_open,
		1790	PerlIOBase_binmode,
		1791	PerlIOCede_getarg,
		1792	PerlIOBase_fileno,
		1793	PerlIOBuf_dup,
		1794	PerlIOBuf_read,
		1795	PerlIOBuf_unread,
		1796	PerlIOBuf_write,
		1797	PerlIOBuf_seek,
		1798	PerlIOBuf_tell,
		1799	PerlIOBuf_close,
		1800	PerlIOCede_flush,
		1801	PerlIOBuf_fill,
		1802	PerlIOBase_eof,
		1803	PerlIOBase_error,
		1804	PerlIOBase_clearerr,
		1805	PerlIOBase_setlinebuf,
		1806	PerlIOBuf_get_base,
		1807	PerlIOBuf_bufsiz,
		1808	PerlIOBuf_get_ptr,
		1809	PerlIOBuf_get_cnt,
		1810	PerlIOBuf_set_ptrcnt,
		1811	};
		1812
		1813	/*****************************************************************************/
		1814
		1815	static const CV *ssl_cv; /* for quick consistency check */
		1816
		1817	static UNOP ssl_restore; /* restore stack as entersub did, for first-re-run */
		1818	static SV *ssl_arg0;
		1819	static SV *ssl_arg1;
		1820
		1821	/* this restores the stack in the case we patched the entersub, to */
		1822	/* recreate the stack frame as perl will on following calls */
		1823	/* since entersub cleared the stack */
		1824	static OP *
		1825	pp_restore (pTHX)
		1826	{
		1827	dSP;
		1828
		1829	PUSHMARK (SP);
		1830
		1831	EXTEND (SP, 3);
		1832	if (ssl_arg0) PUSHs (sv_2mortal (ssl_arg0)), ssl_arg0 = 0;
		1833	if (ssl_arg1) PUSHs (sv_2mortal (ssl_arg1)), ssl_arg1 = 0;
		1834	PUSHs ((SV *)CvGV (ssl_cv));
		1835
		1836	RETURNOP (ssl_restore.op_first);
		1837	}
		1838
		1839	/* declare prototype */
		1840	XS(XS_Coro__State__set_stacklevel);
		1841
		1842	static OP *
		1843	pp_set_stacklevel (pTHX)
		1844	{
		1845	dSP;
		1846	struct transfer_args ta;
		1847	SV **arg = PL_stack_base + TOPMARK + 1;
		1848	int items = SP - arg; /* args without function object */
		1849
		1850	/* do a quick consistency check on the "function" object, and if it isn't */
		1851	/* for us, divert to the real entersub */
		1852	if (SvTYPE (*sp) != SVt_PVGV || CvXSUB (GvCV (*sp)) != XS_Coro__State__set_stacklevel)
		1853	return PL_ppaddr[OP_ENTERSUB](aTHX);
		1854
		1855	/* pop args */
		1856	SP = PL_stack_base + POPMARK;
		1857
		1858	if (!(PL_op->op_flags & OPf_STACKED))
		1859	{
		1860	/* ampersand-form of call, use @_ instead of stack */
		1861	AV *av = GvAV (PL_defgv);
		1862	arg = AvARRAY (av);
		1863	items = AvFILLp (av) + 1;
		1864	}
		1865
		1866	PUTBACK;
		1867	switch (PL_op->op_private & 7)
		1868	{
		1869	case 0:
		1870	prepare_set_stacklevel (&ta, (struct coro_cctx *)SvIV (arg [0]));
		1871	break;
		1872
		1873	case 1:
		1874	if (items != 2)
		1875	croak ("Coro::State::transfer (prev, next) expects two arguments, not %d.", items);
		1876
		1877	prepare_transfer (aTHX_ &ta, arg [0], arg [1]);
		1878	break;
		1879
		1880	case 2:
		1881	prepare_schedule (aTHX_ &ta);
		1882	break;
		1883
		1884	case 3:
		1885	prepare_cede (aTHX_ &ta);
		1886	break;
		1887
		1888	case 4:
		1889	if (!prepare_cede_notself (aTHX_ &ta))
		1890	RETURN;
		1891
		1892	break;
		1893	}
		1894
		1895	TRANSFER (ta, 0);
		1896	SPAGAIN;
		1897
		1898	skip:
		1899
		1900	RETURN;
		1901	}
		1902
		1903	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
		1904
		1905	PROTOTYPES: DISABLE
		1906
		1907	# these not obviously related functions are all rolled into the same xs
		1908	# function to increase chances that they all will call transfer with the same
		1909	# stack offset
		1910	void
		1911	_set_stacklevel (...)
		1912	ALIAS:
		1913	Coro::State::transfer = 1
		1914	Coro::schedule = 2
		1915	Coro::cede = 3
		1916	Coro::cede_notself = 4
		1917	CODE:
		1918	{
		1919	assert (("FATAL: ssl call recursion in Coro module (please report)", PL_op->op_ppaddr != pp_set_stacklevel));
		1920
		1921	/* we patch the op, and then re-run the whole call */
		1922	/* we have to put some dummy argument on the stack for this to work */
		1923	/* TODO: walk back the opcode chain (but how?), nuke the pp_gv etc. */
		1924	ssl_restore.op_next = (OP *)&ssl_restore;
		1925	ssl_restore.op_type = OP_NULL;
		1926	ssl_restore.op_ppaddr = pp_restore;
		1927	ssl_restore.op_first = PL_op;
		1928
		1929	ssl_arg0 = items > 0 ? SvREFCNT_inc (ST (0)) : 0;
		1930	ssl_arg1 = items > 1 ? SvREFCNT_inc (ST (1)) : 0;
		1931
		1932	PL_op->op_ppaddr = pp_set_stacklevel;
		1933	PL_op->op_private = PL_op->op_private & ~7 | ix; /* we potentially share our private flags with entersub */
		1934
		1935	PL_op = (OP *)&ssl_restore;
		1936	}
		1937
		1938	BOOT:
		1939	{
		1940	#ifdef USE_ITHREADS
		1941	MUTEX_INIT (&coro_lock);
		1942	# if CORO_PTHREAD
		1943	coro_thx = PERL_GET_CONTEXT;
		1944	# endif
		1945	#endif
		1946	BOOT_PAGESIZE;
		1947
		1948	ssl_cv = get_cv ("Coro::State::_set_stacklevel", 0);
		1949
		1950	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
		1951	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
		1952
		1953	orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
		1954	orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
		1955	orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
		1956
		1957	hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
		1958	rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
		1959	rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
		1960
		1961	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		1962
		1963	newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
		1964	newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
		1965	newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
		1966	newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
		1967
		1968	main_mainstack = PL_mainstack;
		1969	main_top_env = PL_top_env;
		1970
		1971	while (main_top_env->je_prev)
		1972	main_top_env = main_top_env->je_prev;
		1973
		1974	coroapi.ver = CORO_API_VERSION;
		1975	coroapi.rev = CORO_API_REVISION;
		1976	coroapi.transfer = api_transfer;
		1977
		1978	{
		1979	SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
		1980
		1981	if (!svp) croak ("Time::HiRes is required");
		1982	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
		1983
		1984	nvtime = INT2PTR (double (*)(), SvIV (*svp));
		1985	}
		1986
		1987	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1988	}
		1989
		1990	SV *
		1991	new (char *klass, ...)
		1992	CODE:
		1993	{
		1994	struct coro *coro;
		1995	MAGIC *mg;
		1996	HV *hv;
		1997	int i;
		1998
		1999	Newz (0, coro, 1, struct coro);
		2000	coro->args = newAV ();
		2001	coro->flags = CF_NEW;
		2002
		2003	if (coro_first) coro_first->prev = coro;
		2004	coro->next = coro_first;
		2005	coro_first = coro;
		2006
		2007	coro->hv = hv = newHV ();
		2008	mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
		2009	mg->mg_flags |= MGf_DUP;
		2010	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		2011
		2012	av_extend (coro->args, items - 1);
		2013	for (i = 1; i < items; i++)
		2014	av_push (coro->args, newSVsv (ST (i)));
		2015	}
		2016	OUTPUT:
		2017	RETVAL
		2018
		2019	bool
		2020	_destroy (SV *coro_sv)
		2021	CODE:
		2022	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		2023	OUTPUT:
		2024	RETVAL
		2025
		2026	void
		2027	_exit (int code)
		2028	PROTOTYPE: $
		2029	CODE:
		2030	_exit (code);
		2031
		2032	int
		2033	cctx_stacksize (int new_stacksize = 0)
		2034	CODE:
		2035	RETVAL = cctx_stacksize;
		2036	if (new_stacksize)
		2037	{
		2038	cctx_stacksize = new_stacksize;
		2039	++cctx_gen;
		2040	}
		2041	OUTPUT:
		2042	RETVAL
		2043
		2044	int
		2045	cctx_max_idle (int max_idle = 0)
		2046	CODE:
		2047	RETVAL = cctx_max_idle;
		2048	if (max_idle > 1)
		2049	cctx_max_idle = max_idle;
		2050	OUTPUT:
		2051	RETVAL
		2052
		2053	int
		2054	cctx_count ()
		2055	CODE:
		2056	RETVAL = cctx_count;
		2057	OUTPUT:
		2058	RETVAL
		2059
		2060	int
		2061	cctx_idle ()
		2062	CODE:
		2063	RETVAL = cctx_idle;
		2064	OUTPUT:
		2065	RETVAL
		2066
		2067	void
		2068	list ()
		2069	PPCODE:
		2070	{
		2071	struct coro *coro;
		2072	for (coro = coro_first; coro; coro = coro->next)
		2073	if (coro->hv)
		2074	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
		2075	}
		2076
		2077	void
		2078	call (Coro::State coro, SV *coderef)
		2079	ALIAS:
		2080	eval = 1
		2081	CODE:
		2082	{
		2083	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
		2084	{
		2085	struct coro temp;
		2086
		2087	if (!(coro->flags & CF_RUNNING))
235	{	2088	{
236	/* I never used formats, so how should I know how these are implemented? */	2089	PUTBACK;
237	/* my bold guess is as a simple, plain sub... */	2090	save_perl (aTHX_ &temp);
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	2091	load_perl (aTHX_ coro);
		2092	}
		2093
		2094	{
		2095	dSP;
		2096	ENTER;
		2097	SAVETMPS;
		2098	PUTBACK;
		2099	PUSHSTACK;
		2100	PUSHMARK (SP);
		2101
		2102	if (ix)
		2103	eval_sv (coderef, 0);
		2104	else
		2105	call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		2106
		2107	POPSTACK;
		2108	SPAGAIN;
		2109	FREETMPS;
		2110	LEAVE;
		2111	PUTBACK;
		2112	}
		2113
		2114	if (!(coro->flags & CF_RUNNING))
		2115	{
		2116	save_perl (aTHX_ coro);
		2117	load_perl (aTHX_ &temp);
		2118	SPAGAIN;
239	}	2119	}
240	}	2120	}
241
242	if (top_si->si_type == PERLSI_MAIN)
243	break;
244
245	top_si = top_si->si_prev;
246	ccstk = top_si->si_cxstack;
247	cxix = top_si->si_cxix;
248	}
249
250	PUTBACK;
251	}
252
253	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);
255	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;
260	c->curpad = PL_curpad;
261	c->stack_base = PL_stack_base;
262	c->stack_max = PL_stack_max;
263	c->tmps_stack = PL_tmps_stack;
264	c->tmps_floor = PL_tmps_floor;
265	c->tmps_ix = PL_tmps_ix;
266	c->tmps_max = PL_tmps_max;
267	c->markstack = PL_markstack;
268	c->markstack_ptr = PL_markstack_ptr;
269	c->markstack_max = PL_markstack_max;
270	c->scopestack = PL_scopestack;
271	c->scopestack_ix = PL_scopestack_ix;
272	c->scopestack_max = PL_scopestack_max;
273	c->savestack = PL_savestack;
274	c->savestack_ix = PL_savestack_ix;
275	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;
280	}	2121	}
281		2122
282	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	2123	SV *
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	2124	is_ready (Coro::State coro)
		2125	PROTOTYPE: $
		2126	ALIAS:
		2127	is_ready = CF_READY
		2128	is_running = CF_RUNNING
		2129	is_new = CF_NEW
		2130	is_destroyed = CF_DESTROYED
		2131	CODE:
		2132	RETVAL = boolSV (coro->flags & ix);
		2133	OUTPUT:
		2134	RETVAL
284		2135
285	static void	2136	void
286	load_state(pTHX_ Coro__State c)	2137	throw (Coro::State self, SV *throw = &PL_sv_undef)
287	{	2138	PROTOTYPE: $;$
288	PL_dowarn = c->dowarn;	2139	CODE:
289	GvAV (PL_defgv) = c->defav;	2140	SvREFCNT_dec (self->throw);
290	PL_curstackinfo = c->curstackinfo;	2141	self->throw = SvOK (throw) ? newSVsv (throw) : 0;
291	PL_curstack = c->curstack;
292	PL_mainstack = c->mainstack;
293	PL_stack_sp = c->stack_sp;
294	PL_op = c->op;
295	PL_curpad = c->curpad;
296	PL_stack_base = c->stack_base;
297	PL_stack_max = c->stack_max;
298	PL_tmps_stack = c->tmps_stack;
299	PL_tmps_floor = c->tmps_floor;
300	PL_tmps_ix = c->tmps_ix;
301	PL_tmps_max = c->tmps_max;
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;
304	PL_markstack_max = c->markstack_max;
305	PL_scopestack = c->scopestack;
306	PL_scopestack_ix = c->scopestack_ix;
307	PL_scopestack_max = c->scopestack_max;
308	PL_savestack = c->savestack;
309	PL_savestack_ix = c->savestack_ix;
310	PL_savestack_max = c->savestack_max;
311	PL_retstack = c->retstack;
312	PL_retstack_ix = c->retstack_ix;
313	PL_retstack_max = c->retstack_max;
314	PL_curcop = c->curcop;
315		2142
		2143	void
		2144	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
		2145
		2146	SV *
		2147	has_cctx (Coro::State coro)
		2148	PROTOTYPE: $
		2149	CODE:
		2150	RETVAL = boolSV (!!coro->cctx);
		2151	OUTPUT:
		2152	RETVAL
		2153
		2154	int
		2155	is_traced (Coro::State coro)
		2156	PROTOTYPE: $
		2157	CODE:
		2158	RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
		2159	OUTPUT:
		2160	RETVAL
		2161
		2162	UV
		2163	rss (Coro::State coro)
		2164	PROTOTYPE: $
		2165	ALIAS:
		2166	usecount = 1
		2167	CODE:
		2168	switch (ix)
316	{	2169	{
317	dSP;	2170	case 0: RETVAL = coro_rss (aTHX_ coro); break;
318	CV *cv;	2171	case 1: RETVAL = coro->usecount; break;
319
320	/* now do the ugly restore mess */
321	while ((cv = (CV *)POPs))
322	{
323	AV *padlist = (AV *)POPs;
324
325	put_padlist (cv);
326	CvPADLIST(cv) = padlist;
327	CvDEPTH(cv) = (I32)POPs;
328
329	#ifdef USE_THREADS
330	CvOWNER(cv) = (struct perl_thread *)POPs;
331	error does not work either
332	#endif
333	}	2172	}
		2173	OUTPUT:
		2174	RETVAL
334		2175
335	PUTBACK;	2176	void
336	}	2177	force_cctx ()
337	}	2178	CODE:
		2179	struct coro *coro = SvSTATE (coro_current);
		2180	coro->cctx->idle_sp = 0;
338		2181
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	2182	void
340	STATIC void	2183	swap_defsv (Coro::State self)
341	destroy_stacks(pTHX)	2184	PROTOTYPE: $
342	{	2185	ALIAS:
343	/* die does this while calling POPSTACK, but I just don't see why. */	2186	swap_defav = 1
344	/* OTOH, die does not have a memleak, but we do... */	2187	CODE:
345	dounwind(-1);	2188	if (!self->slot)
		2189	croak ("cannot swap state with coroutine that has no saved state");
		2190	else
		2191	{
		2192	SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
		2193	SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
346		2194
347	/* is this ugly, I ask? */	2195	SV *tmp = *src; *src = *dst; *dst = tmp;
348	while (PL_scopestack_ix)	2196	}
349	LEAVE;
350		2197
351	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;
353
354	while (PL_curstackinfo)
355	{
356	PERL_SI *p = PL_curstackinfo->si_prev;
357
358	SvREFCNT_dec(PL_curstackinfo->si_stack);
359	Safefree(PL_curstackinfo->si_cxstack);
360	Safefree(PL_curstackinfo);
361	PL_curstackinfo = p;
362	}
363
364	if (PL_scopestack_ix != 0)
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367	(long)PL_scopestack_ix);
368	if (PL_savestack_ix != 0)
369	Perl_warner(aTHX_ WARN_INTERNAL,
370	"Unbalanced saves: %ld more saves than restores\n",
371	(long)PL_savestack_ix);
372	if (PL_tmps_floor != -1)
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374	(long)PL_tmps_floor + 1);
375	/*
376	*/
377	Safefree(PL_tmps_stack);
378	Safefree(PL_markstack);
379	Safefree(PL_scopestack);
380	Safefree(PL_savestack);
381	Safefree(PL_retstack);
382	}
383
384	#define SUB_INIT "Coro::State::_newcoro"
385
386	MODULE = Coro::State PACKAGE = Coro::State	2198	MODULE = Coro::State PACKAGE = Coro
387
388	PROTOTYPES: ENABLE
389		2199
390	BOOT:	2200	BOOT:
391	if (!padlist_cache)	2201	{
392	padlist_cache = newHV ();	2202	int i;
393		2203
394	Coro::State	2204	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
395	_newprocess(args)	2205	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
396	SV * args	2206	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
		2207
		2208	coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
		2209	SvREADONLY_on (coro_current);
		2210
		2211	coro_stash = gv_stashpv ("Coro", TRUE);
		2212
		2213	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		2214	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		2215	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		2216	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		2217	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		2218	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		2219
		2220	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		2221	coro_ready[i] = newAV ();
		2222
		2223	{
		2224	SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
		2225
		2226	coroapi.schedule = api_schedule;
		2227	coroapi.cede = api_cede;
		2228	coroapi.cede_notself = api_cede_notself;
		2229	coroapi.ready = api_ready;
		2230	coroapi.is_ready = api_is_ready;
		2231	coroapi.nready = &coro_nready;
		2232	coroapi.current = coro_current;
		2233
		2234	GCoroAPI = &coroapi;
		2235	sv_setiv (sv, (IV)&coroapi);
		2236	SvREADONLY_on (sv);
		2237	}
		2238	}
		2239
		2240	void
		2241	_set_current (SV *current)
397	PROTOTYPE: $	2242	PROTOTYPE: $
		2243	CODE:
		2244	SvREFCNT_dec (SvRV (coro_current));
		2245	SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
		2246
		2247	void
		2248	_set_readyhook (SV *hook)
		2249	PROTOTYPE: $
398	CODE:	2250	CODE:
399	Coro__State coro;
400
401	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");
403		2251	LOCK;
404	New (0, coro, 1, struct coro);	2252	SvREFCNT_dec (coro_readyhook);
		2253	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
		2254	UNLOCK;
405		2255
406	coro->mainstack = 0; /* actual work is done inside transfer */	2256	int
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	2257	prio (Coro::State coro, int newprio = 0)
408		2258	ALIAS:
		2259	nice = 1
		2260	CODE:
		2261	{
409	RETVAL = coro;	2262	RETVAL = coro->prio;
410	OUTPUT:	2263
		2264	if (items > 1)
		2265	{
		2266	if (ix)
		2267	newprio = coro->prio - newprio;
		2268
		2269	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
		2270	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
		2271
		2272	coro->prio = newprio;
		2273	}
		2274	}
		2275	OUTPUT:
411	RETVAL	2276	RETVAL
412		2277
		2278	SV *
		2279	ready (SV *self)
		2280	PROTOTYPE: $
		2281	CODE:
		2282	RETVAL = boolSV (api_ready (self));
		2283	OUTPUT:
		2284	RETVAL
		2285
		2286	int
		2287	nready (...)
		2288	PROTOTYPE:
		2289	CODE:
		2290	RETVAL = coro_nready;
		2291	OUTPUT:
		2292	RETVAL
		2293
		2294	# for async_pool speedup
413	void	2295	void
414	transfer(prev,next)	2296	_pool_1 (SV *cb)
415	Coro::State_or_hashref prev	2297	CODE:
416	Coro::State_or_hashref next	2298	{
		2299	struct coro *coro = SvSTATE (coro_current);
		2300	HV *hv = (HV *)SvRV (coro_current);
		2301	AV *defav = GvAV (PL_defgv);
		2302	SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
		2303	AV *invoke_av;
		2304	int i, len;
		2305
		2306	if (!invoke)
		2307	{
		2308	SV *old = PL_diehook;
		2309	PL_diehook = 0;
		2310	SvREFCNT_dec (old);
		2311	croak ("\3async_pool terminate\2\n");
		2312	}
		2313
		2314	SvREFCNT_dec (coro->saved_deffh);
		2315	coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
		2316
		2317	hv_store (hv, "desc", sizeof ("desc") - 1,
		2318	newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
		2319
		2320	invoke_av = (AV *)SvRV (invoke);
		2321	len = av_len (invoke_av);
		2322
		2323	sv_setsv (cb, AvARRAY (invoke_av)[0]);
		2324
		2325	if (len > 0)
		2326	{
		2327	av_fill (defav, len - 1);
		2328	for (i = 0; i < len; ++i)
		2329	av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
		2330	}
		2331
		2332	SvREFCNT_dec (invoke);
		2333	}
		2334
		2335	void
		2336	_pool_2 (SV *cb)
		2337	CODE:
		2338	{
		2339	struct coro *coro = SvSTATE (coro_current);
		2340
		2341	sv_setsv (cb, &PL_sv_undef);
		2342
		2343	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
		2344	coro->saved_deffh = 0;
		2345
		2346	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
		2347	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
		2348	{
		2349	SV *old = PL_diehook;
		2350	PL_diehook = 0;
		2351	SvREFCNT_dec (old);
		2352	croak ("\3async_pool terminate\2\n");
		2353	}
		2354
		2355	av_clear (GvAV (PL_defgv));
		2356	hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
		2357	newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
		2358
		2359	coro->prio = 0;
		2360
		2361	if (coro->cctx && (coro->cctx->flags & CC_TRACE))
		2362	api_trace (coro_current, 0);
		2363
		2364	av_push (av_async_pool, newSVsv (coro_current));
		2365	}
		2366
		2367	#if 0
		2368
		2369	void
		2370	_generator_call (...)
		2371	PROTOTYPE: @
		2372	PPCODE:
		2373	fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
		2374	xxxx
		2375	abort ();
		2376
		2377	SV *
		2378	gensub (SV *sub, ...)
		2379	PROTOTYPE: &;@
417	CODE:	2380	CODE:
		2381	{
		2382	struct coro *coro;
		2383	MAGIC *mg;
		2384	CV *xcv;
		2385	CV *ncv = (CV *)newSV_type (SVt_PVCV);
		2386	int i;
418		2387
419	if (prev != next)	2388	CvGV (ncv) = CvGV (cv);
		2389	CvFILE (ncv) = CvFILE (cv);
		2390
		2391	Newz (0, coro, 1, struct coro);
		2392	coro->args = newAV ();
		2393	coro->flags = CF_NEW;
		2394
		2395	av_extend (coro->args, items - 1);
		2396	for (i = 1; i < items; i++)
		2397	av_push (coro->args, newSVsv (ST (i)));
		2398
		2399	CvISXSUB_on (ncv);
		2400	CvXSUBANY (ncv).any_ptr = (void *)coro;
		2401
		2402	xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
		2403
		2404	CvXSUB (ncv) = CvXSUB (xcv);
		2405	CvANON_on (ncv);
		2406
		2407	mg = sv_magicext ((SV *)ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char *)coro, 0);
		2408	RETVAL = newRV_noinc ((SV *)ncv);
		2409	}
		2410	OUTPUT:
		2411	RETVAL
		2412
		2413	#endif
		2414
		2415
		2416	MODULE = Coro::State PACKAGE = Coro::AIO
		2417
		2418	void
		2419	_get_state (SV *self)
		2420	PPCODE:
		2421	{
		2422	AV *defav = GvAV (PL_defgv);
		2423	AV *av = newAV ();
		2424	int i;
		2425	SV *data_sv = newSV (sizeof (struct io_state));
		2426	struct io_state *data = (struct io_state *)SvPVX (data_sv);
		2427	SvCUR_set (data_sv, sizeof (struct io_state));
		2428	SvPOK_only (data_sv);
		2429
		2430	data->errorno = errno;
		2431	data->laststype = PL_laststype;
		2432	data->laststatval = PL_laststatval;
		2433	data->statcache = PL_statcache;
		2434
		2435	av_extend (av, AvFILLp (defav) + 1 + 1);
		2436
		2437	for (i = 0; i <= AvFILLp (defav); ++i)
		2438	av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
		2439
		2440	av_push (av, data_sv);
		2441
		2442	XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		2443
		2444	api_ready (self);
		2445	}
		2446
		2447	void
		2448	_set_state (SV *state)
		2449	PROTOTYPE: $
		2450	PPCODE:
		2451	{
		2452	AV *av = (AV *)SvRV (state);
		2453	struct io_state *data = (struct io_state *)SvPVX (AvARRAY (av)[AvFILLp (av)]);
		2454	int i;
		2455
		2456	errno = data->errorno;
		2457	PL_laststype = data->laststype;
		2458	PL_laststatval = data->laststatval;
		2459	PL_statcache = data->statcache;
		2460
		2461	EXTEND (SP, AvFILLp (av));
		2462	for (i = 0; i < AvFILLp (av); ++i)
		2463	PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
		2464	}
		2465
		2466
		2467	MODULE = Coro::State PACKAGE = Coro::AnyEvent
		2468
		2469	BOOT:
		2470	sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
		2471
		2472	SV *
		2473	_schedule (...)
		2474	PROTOTYPE: @
		2475	CODE:
		2476	{
		2477	static int incede;
		2478
		2479	api_cede_notself ();
		2480
		2481	++incede;
		2482	while (coro_nready >= incede && api_cede ())
		2483	;
		2484
		2485	sv_setsv (sv_activity, &PL_sv_undef);
		2486	if (coro_nready >= incede)
420	{	2487	{
421	/*
422	* this could be done in newprocess which would lead to
423	* extremely elegant and fast (just SAVE/LOAD)
424	* code here, but lazy allocation of stacks has also
425	* some virtues and the overhead of the if() is nil.
426	*/
427	if (next->mainstack)
428	{
429	SAVE (prev);
430	LOAD (next);
431	/* mark this state as in-use */
432	next->mainstack = 0;
433	next->tmps_ix = -2;
434	}
435	else if (next->tmps_ix == -2)
436	{
437	croak ("tried to transfer to running coroutine");
438	}
439	else
440	{
441	SAVE (prev);
442
443	/*
444	* emulate part of the perl startup here.
445	*/
446	UNOP myop;
447
448	init_stacks (); /* from perl.c */
449	PL_op = (OP *)&myop;
450	/*PL_curcop = 0;*/
451	GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452
453	SPAGAIN;
454	Zero(&myop, 1, UNOP);
455	myop.op_next = Nullop;
456	myop.op_flags = OPf_WANT_VOID;
457
458	PUSHMARK(SP);	2488	PUSHMARK (SP);
459	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	PUTBACK;	2489	PUTBACK;
461	/*	2490	call_pv ("Coro::AnyEvent::_activity", G_DISCARD | G_EVAL);
462	* the next line is slightly wrong, as PL_op->op_next
463	* is actually being executed so we skip the first op.
464	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...
466	*/
467	PL_op = Perl_pp_entersub(aTHX);
468	SPAGAIN;	2491	SPAGAIN;
469
470	ENTER;
471	}
472	}	2492	}
473		2493
474	void	2494	--incede;
475	DESTROY(coro)	2495	}
476	Coro::State coro
477	CODE:
478		2496
479	if (coro->mainstack)
480	{
481	struct coro temp;
482		2497
483	SAVE(aTHX_ (&temp));	2498	MODULE = Coro::State PACKAGE = PerlIO::cede
484	LOAD(aTHX_ coro);
485		2499
486	destroy_stacks ();	2500	BOOT:
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));	2501	PerlIO_define_layer (aTHX_ &PerlIO_cede);
488		2502
489	LOAD((&temp));
490	}
491
492	SvREFCNT_dec (coro->args);
493	Safefree (coro);
494
495

Diff Legend

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