ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.266 by root, Fri Nov 14 03:26:22 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(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	/** set stacklevel support **************************************************/
		717
		718	/* we sometimes need to create the effect of pp_set_stacklevel calling us */
		719	#define SSL_HEAD (void)0
		720	/* we somtimes need to create the effect of leaving via pp_set_stacklevel */
		721	#define SSL_TAIL set_stacklevel_tail (aTHX)
		722
		723	INLINE void
		724	set_stacklevel_tail (pTHX)
		725	{
		726	dSP;
		727	SV **bot = SP;
		728
		729	int gimme = GIMME_V;
		730
		731	/* make sure we put something on the stack in scalar context */
		732	if (gimme == G_SCALAR)
		733	{
		734	if (sp == bot)
		735	XPUSHs (&PL_sv_undef);
		736
		737	SP = bot + 1;
		738	}
		739
		740	PUTBACK;
		741	}
		742
		743	/** coroutine stack handling ************************************************/
		744
		745	static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg);
		746	static int (*orig_sigelem_set) (pTHX_ SV *sv, MAGIC *mg);
		747	static int (*orig_sigelem_clr) (pTHX_ SV *sv, MAGIC *mg);
		748
		749	/* apparently < 5.8.8 */
		750	#ifndef MgPV_nolen_const
		751	#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
		752	SvPV_nolen((SV*)((mg)->mg_ptr)) : \
		753	(const char*)(mg)->mg_ptr)
		754	#endif
		755
		756	/*
		757	* This overrides the default magic get method of %SIG elements.
		758	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook
		759	* and instead of tryign to save and restore the hash elements, we just provide
		760	* readback here.
		761	* We only do this when the hook is != 0, as they are often set to 0 temporarily,
		762	* not expecting this to actually change the hook. This is a potential problem
		763	* when a schedule happens then, but we ignore this.
		764	*/
		765	static int
		766	coro_sigelem_get (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_setsv (sv, *svp ? *svp : &PL_sv_undef);
		780	return 0;
		781	}
		782	}
		783
		784	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
		785	}
		786
		787	static int
		788	coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
		789	{
		790	const char *s = MgPV_nolen_const (mg);
		791
		792	if (*s == '_')
		793	{
		794	SV **svp = 0;
		795
		796	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		797	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		798
		799	if (svp)
		800	{
		801	SV *old = *svp;
		802	*svp = 0;
		803	SvREFCNT_dec (old);
		804	return 0;
		805	}
		806	}
		807
		808	return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
		809	}
		810
		811	static int
		812	coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
		813	{
		814	const char *s = MgPV_nolen_const (mg);
		815
		816	if (*s == '_')
		817	{
		818	SV **svp = 0;
		819
		820	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		821	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		822
		823	if (svp)
		824	{
		825	SV *old = *svp;
		826	*svp = newSVsv (sv);
		827	SvREFCNT_dec (old);
		828	return 0;
		829	}
		830	}
		831
		832	return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
		833	}
		834
		835	static void
		836	coro_setup (pTHX_ struct coro *coro)
		837	{
		838	/*
		839	* emulate part of the perl startup here.
		840	*/
		841	coro_init_stacks (aTHX);
		842
		843	PL_runops = RUNOPS_DEFAULT;
		844	PL_curcop = &PL_compiling;
		845	PL_in_eval = EVAL_NULL;
		846	PL_comppad = 0;
		847	PL_curpm = 0;
		848	PL_curpad = 0;
		849	PL_localizing = 0;
		850	PL_dirty = 0;
		851	PL_restartop = 0;
		852	#if PERL_VERSION_ATLEAST (5,10,0)
		853	PL_parser = 0;
		854	#endif
		855
		856	/* recreate the die/warn hooks */
		857	PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
		858	PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
		859
		860	GvSV (PL_defgv) = newSV (0);
		861	GvAV (PL_defgv) = coro->args; coro->args = 0;
		862	GvSV (PL_errgv) = newSV (0);
		863	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
		864	PL_rs = newSVsv (GvSV (irsgv));
		865	PL_defoutgv = (GV *)SvREFCNT_inc_NN (stdoutgv);
		866
		867	{
		868	dSP;
		869	UNOP myop;
		870
		871	Zero (&myop, 1, UNOP);
		872	myop.op_next = Nullop;
		873	myop.op_flags = OPf_WANT_VOID;
		874
		875	PUSHMARK (SP);
		876	XPUSHs (sv_2mortal (av_shift (GvAV (PL_defgv))));
		877	PUTBACK;
		878	PL_op = (OP *)&myop;
		879	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		880	SPAGAIN;
		881	}
		882
		883	/* this newly created coroutine might be run on an existing cctx which most
		884	* likely was suspended in set_stacklevel, called from pp_set_stacklevel,
		885	* so we have to emulate entering pp_set_stacklevel here.
		886	*/
		887	SSL_HEAD;
		888	}
		889
		890	static void
		891	coro_destruct (pTHX_ struct coro *coro)
		892	{
		893	if (!IN_DESTRUCT)
		894	{
		895	/* restore all saved variables and stuff */
		896	LEAVE_SCOPE (0);
		897	assert (PL_tmps_floor == -1);
		898
		899	/* free all temporaries */
		900	FREETMPS;
		901	assert (PL_tmps_ix == -1);
		902
		903	/* unwind all extra stacks */
		904	POPSTACK_TO (PL_mainstack);
		905
		906	/* unwind main stack */
		907	dounwind (-1);
		908	}
		909
		910	SvREFCNT_dec (GvSV (PL_defgv));
		911	SvREFCNT_dec (GvAV (PL_defgv));
		912	SvREFCNT_dec (GvSV (PL_errgv));
		913	SvREFCNT_dec (PL_defoutgv);
		914	SvREFCNT_dec (PL_rs);
		915	SvREFCNT_dec (GvSV (irsgv));
		916
		917	SvREFCNT_dec (PL_diehook);
		918	SvREFCNT_dec (PL_warnhook);
		919
		920	SvREFCNT_dec (coro->saved_deffh);
		921	SvREFCNT_dec (coro->throw);
		922
		923	coro_destruct_stacks (aTHX);
		924	}
		925
		926	INLINE void
		927	free_coro_mortal (pTHX)
		928	{
		929	if (expect_true (coro_mortal))
		930	{
		931	SvREFCNT_dec (coro_mortal);
		932	coro_mortal = 0;
		933	}
		934	}
		935
		936	static int
		937	runops_trace (pTHX)
		938	{
		939	COP *oldcop = 0;
		940	int oldcxix = -2;
		941	struct coro *coro = SvSTATE (coro_current); /* trace cctx is tied to specific coro */
		942	coro_cctx *cctx = coro->cctx;
		943
		944	while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
		945	{
		946	PERL_ASYNC_CHECK ();
		947
		948	if (cctx->flags & CC_TRACE_ALL)
		949	{
		950	if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
		951	{
		952	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		953	SV **bot, **top;
		954	AV *av = newAV (); /* return values */
		955	SV **cb;
		956	dSP;
		957
		958	GV *gv = CvGV (cx->blk_sub.cv);
		959	SV *fullname = sv_2mortal (newSV (0));
		960	if (isGV (gv))
		961	gv_efullname3 (fullname, gv, 0);
		962
		963	bot = PL_stack_base + cx->blk_oldsp + 1;
		964	top = cx->blk_gimme == G_ARRAY ? SP + 1
		965	: cx->blk_gimme == G_SCALAR ? bot + 1
		966	: bot;
		967
		968	av_extend (av, top - bot);
		969	while (bot < top)
		970	av_push (av, SvREFCNT_inc_NN (*bot++));
		971
		972	PL_runops = RUNOPS_DEFAULT;
		973	ENTER;
		974	SAVETMPS;
		975	EXTEND (SP, 3);
		976	PUSHMARK (SP);
		977	PUSHs (&PL_sv_no);
		978	PUSHs (fullname);
		979	PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		980	PUTBACK;
		981	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		982	if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		983	SPAGAIN;
		984	FREETMPS;
		985	LEAVE;
		986	PL_runops = runops_trace;
		987	}
		988
		989	if (oldcop != PL_curcop)
		990	{
		991	oldcop = PL_curcop;
		992
		993	if (PL_curcop != &PL_compiling)
		994	{
		995	SV **cb;
		996
		997	if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
		998	{
		999	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		1000
		1001	if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
		1002	{
		1003	runops_proc_t old_runops = PL_runops;
		1004	dSP;
		1005	GV *gv = CvGV (cx->blk_sub.cv);
		1006	SV *fullname = sv_2mortal (newSV (0));
		1007
		1008	if (isGV (gv))
		1009	gv_efullname3 (fullname, gv, 0);
		1010
		1011	PL_runops = RUNOPS_DEFAULT;
		1012	ENTER;
		1013	SAVETMPS;
		1014	EXTEND (SP, 3);
		1015	PUSHMARK (SP);
		1016	PUSHs (&PL_sv_yes);
		1017	PUSHs (fullname);
		1018	PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
		1019	PUTBACK;
		1020	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		1021	if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		1022	SPAGAIN;
		1023	FREETMPS;
		1024	LEAVE;
		1025	PL_runops = runops_trace;
		1026	}
		1027
		1028	oldcxix = cxstack_ix;
		1029	}
		1030
		1031	if (cctx->flags & CC_TRACE_LINE)
		1032	{
		1033	dSP;
		1034
		1035	PL_runops = RUNOPS_DEFAULT;
		1036	ENTER;
		1037	SAVETMPS;
		1038	EXTEND (SP, 3);
		1039	PL_runops = RUNOPS_DEFAULT;
		1040	PUSHMARK (SP);
		1041	PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
		1042	PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
		1043	PUTBACK;
		1044	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
		1045	if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		1046	SPAGAIN;
		1047	FREETMPS;
		1048	LEAVE;
		1049	PL_runops = runops_trace;
		1050	}
		1051	}
		1052	}
		1053	}
		1054	}
		1055
		1056	TAINT_NOT;
		1057	return 0;
		1058	}
		1059
		1060	static void
		1061	prepare_set_stacklevel (struct transfer_args *ta, struct coro_cctx *cctx)
		1062	{
		1063	ta->prev = (struct coro *)cctx;
		1064	ta->next = 0;
		1065	}
		1066
		1067	/* inject a fake call to Coro::State::_cctx_init into the execution */
		1068	/* _cctx_init should be careful, as it could be called at almost any time */
		1069	/* during execution of a perl program */
		1070	/* also initialises PL_top_env */
		1071	static void NOINLINE
		1072	cctx_prepare (pTHX_ coro_cctx *cctx)
		1073	{
		1074	dSP;
		1075	UNOP myop;
		1076
		1077	PL_top_env = &PL_start_env;
		1078
		1079	if (cctx->flags & CC_TRACE)
		1080	PL_runops = runops_trace;
		1081
		1082	Zero (&myop, 1, UNOP);
		1083	myop.op_next = PL_op;
		1084	myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
		1085
		1086	PUSHMARK (SP);
		1087	EXTEND (SP, 2);
		1088	PUSHs (sv_2mortal (newSViv ((IV)cctx)));
		1089	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
		1090	PUTBACK;
		1091	PL_op = (OP *)&myop;
		1092	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		1093	SPAGAIN;
		1094	}
		1095
		1096	/* the tail of transfer: execute stuff we can only do after a transfer */
		1097	INLINE void
		1098	transfer_tail (pTHX)
		1099	{
		1100	struct coro *next = (struct coro *)transfer_next;
		1101	assert (!(transfer_next = 0)); /* just used for the side effect when asserts are enabled */
		1102	assert (("FATAL: next coroutine was zero in transfer_tail (please report)", next));
		1103
		1104	free_coro_mortal (aTHX);
		1105	UNLOCK;
		1106
		1107	if (expect_false (next->throw))
		1108	{
		1109	SV *exception = sv_2mortal (next->throw);
		1110
		1111	next->throw = 0;
		1112	sv_setsv (ERRSV, exception);
		1113	croak (0);
		1114	}
		1115	}
		1116
		1117	/*
		1118	* this is a _very_ stripped down perl interpreter ;)
		1119	*/
		1120	static void
		1121	cctx_run (void *arg)
		1122	{
		1123	#ifdef USE_ITHREADS
		1124	# if CORO_PTHREAD
		1125	PERL_SET_CONTEXT (coro_thx);
		1126	# endif
		1127	#endif
		1128	{
		1129	dTHX;
		1130
		1131	/* we are the alternative tail to pp_set_stacklevel */
		1132	/* so do the same things here */
		1133	SSL_TAIL;
		1134
		1135	/* we now skip the op that did lead to transfer() */
		1136	PL_op = PL_op->op_next;
		1137
		1138	/* inject a fake subroutine call to cctx_init */
		1139	cctx_prepare (aTHX_ (coro_cctx *)arg);
		1140
		1141	/* cctx_run is the alternative tail of transfer() */
		1142	transfer_tail (aTHX);
		1143
		1144	/* somebody or something will hit me for both perl_run and PL_restartop */
		1145	PL_restartop = PL_op;
		1146	perl_run (PL_curinterp);
		1147
		1148	/*
		1149	* If perl-run returns we assume exit() was being called or the coro
		1150	* fell off the end, which seems to be the only valid (non-bug)
		1151	* reason for perl_run to return. We try to exit by jumping to the
		1152	* bootstrap-time "top" top_env, as we cannot restore the "main"
		1153	* coroutine as Coro has no such concept
		1154	*/
		1155	PL_top_env = main_top_env;
		1156	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
		1157	}
		1158	}
		1159
		1160	static coro_cctx *
		1161	cctx_new ()
		1162	{
		1163	coro_cctx *cctx;
		1164
		1165	++cctx_count;
		1166	New (0, cctx, 1, coro_cctx);
		1167
		1168	cctx->gen = cctx_gen;
		1169	cctx->flags = 0;
		1170	cctx->idle_sp = 0; /* can be accessed by transfer between cctx_run and set_stacklevel, on throw */
		1171
		1172	return cctx;
		1173	}
		1174
		1175	/* create a new cctx only suitable as source */
		1176	static coro_cctx *
		1177	cctx_new_empty ()
		1178	{
		1179	coro_cctx *cctx = cctx_new ();
		1180
		1181	cctx->sptr = 0;
		1182	coro_create (&cctx->cctx, 0, 0, 0, 0);
		1183
		1184	return cctx;
		1185	}
		1186
		1187	/* create a new cctx suitable as destination/running a perl interpreter */
		1188	static coro_cctx *
		1189	cctx_new_run ()
		1190	{
		1191	coro_cctx *cctx = cctx_new ();
		1192	void *stack_start;
		1193	size_t stack_size;
		1194
		1195	#if HAVE_MMAP
		1196	cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
		1197	/* mmap supposedly does allocate-on-write for us */
		1198	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
		1199
		1200	if (cctx->sptr != (void *)-1)
		1201	{
		1202	#if CORO_STACKGUARD
		1203	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
		1204	#endif
		1205	stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE;
		1206	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
		1207	cctx->flags |= CC_MAPPED;
		1208	}
		1209	else
		1210	#endif
		1211	{
		1212	cctx->ssize = cctx_stacksize * (long)sizeof (long);
		1213	New (0, cctx->sptr, cctx_stacksize, long);
		1214
		1215	if (!cctx->sptr)
		1216	{
		1217	perror ("FATAL: unable to allocate stack for coroutine, exiting.");
		1218	_exit (EXIT_FAILURE);
		1219	}
		1220
		1221	stack_start = cctx->sptr;
		1222	stack_size = cctx->ssize;
		1223	}
		1224
		1225	#if CORO_USE_VALGRIND
		1226	cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size);
		1227	#endif
		1228
		1229	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
		1230
		1231	return cctx;
		1232	}
		1233
		1234	static void
		1235	cctx_destroy (coro_cctx *cctx)
		1236	{
		1237	if (!cctx)
		1238	return;
		1239
		1240	--cctx_count;
		1241	coro_destroy (&cctx->cctx);
		1242
		1243	/* coro_transfer creates new, empty cctx's */
		1244	if (cctx->sptr)
		1245	{
		1246	#if CORO_USE_VALGRIND
		1247	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		1248	#endif
		1249
		1250	#if HAVE_MMAP
		1251	if (cctx->flags & CC_MAPPED)
		1252	munmap (cctx->sptr, cctx->ssize);
		1253	else
		1254	#endif
		1255	Safefree (cctx->sptr);
		1256	}
		1257
		1258	Safefree (cctx);
		1259	}
		1260
		1261	/* wether this cctx should be destructed */
		1262	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
		1263
		1264	static coro_cctx *
		1265	cctx_get (pTHX)
		1266	{
		1267	while (expect_true (cctx_first))
		1268	{
		1269	coro_cctx *cctx = cctx_first;
		1270	cctx_first = cctx->next;
		1271	--cctx_idle;
		1272
		1273	if (expect_true (!CCTX_EXPIRED (cctx)))
		1274	return cctx;
		1275
		1276	cctx_destroy (cctx);
		1277	}
		1278
		1279	return cctx_new_run ();
		1280	}
		1281
		1282	static void
		1283	cctx_put (coro_cctx *cctx)
		1284	{
		1285	assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr));
		1286
		1287	/* free another cctx if overlimit */
		1288	if (expect_false (cctx_idle >= cctx_max_idle))
		1289	{
		1290	coro_cctx *first = cctx_first;
		1291	cctx_first = first->next;
		1292	--cctx_idle;
		1293
		1294	cctx_destroy (first);
		1295	}
		1296
		1297	++cctx_idle;
		1298	cctx->next = cctx_first;
		1299	cctx_first = cctx;
		1300	}
		1301
		1302	/** coroutine switching *****************************************************/
		1303
		1304	static void
		1305	transfer_check (pTHX_ struct coro *prev, struct coro *next)
		1306	{
		1307	if (expect_true (prev != next))
		1308	{
		1309	if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW))))
		1310	croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
		1311
		1312	if (expect_false (next->flags & CF_RUNNING))
		1313	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		1314
		1315	if (expect_false (next->flags & CF_DESTROYED))
		1316	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		1317
		1318	#if !PERL_VERSION_ATLEAST (5,10,0)
		1319	if (expect_false (PL_lex_state != LEX_NOTPARSING))
		1320	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version");
		1321	#endif
		1322	}
		1323	}
		1324
		1325	/* always use the TRANSFER macro */
		1326	static void NOINLINE
		1327	transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx)
		1328	{
		1329	dSTACKLEVEL;
		1330
		1331	/* sometimes transfer is only called to set idle_sp */
		1332	if (expect_false (!next))
		1333	{
		1334	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		1335	assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
		1336	}
		1337	else if (expect_true (prev != next))
		1338	{
		1339	coro_cctx *prev__cctx;
		1340
		1341	if (expect_false (prev->flags & CF_NEW))
		1342	{
		1343	/* create a new empty/source context */
		1344	prev->cctx = cctx_new_empty ();
		1345	prev->flags &= ~CF_NEW;
		1346	prev->flags |= CF_RUNNING;
		1347	}
		1348
		1349	prev->flags &= ~CF_RUNNING;
		1350	next->flags |= CF_RUNNING;
		1351
		1352	LOCK;
		1353
		1354	/* first get rid of the old state */
		1355	save_perl (aTHX_ prev);
		1356
		1357	if (expect_false (next->flags & CF_NEW))
		1358	{
		1359	/* need to start coroutine */
		1360	next->flags &= ~CF_NEW;
		1361	/* setup coroutine call */
		1362	coro_setup (aTHX_ next);
		1363	}
		1364	else
		1365	load_perl (aTHX_ next);
		1366
		1367	prev__cctx = prev->cctx;
		1368
		1369	/* possibly untie and reuse the cctx */
		1370	if (expect_true (
		1371	prev__cctx->idle_sp == STACKLEVEL
		1372	&& !(prev__cctx->flags & CC_TRACE)
		1373	&& !force_cctx
		1374	))
		1375	{
		1376	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		1377	assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == prev__cctx->idle_te));
		1378
		1379	prev->cctx = 0;
		1380
		1381	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
		1382	/* without this the next cctx_get might destroy the prev__cctx while still in use */
		1383	if (expect_false (CCTX_EXPIRED (prev__cctx)))
		1384	if (!next->cctx)
		1385	next->cctx = cctx_get (aTHX);
		1386
		1387	cctx_put (prev__cctx);
		1388	}
		1389
		1390	++next->usecount;
		1391
		1392	if (expect_true (!next->cctx))
		1393	next->cctx = cctx_get (aTHX);
		1394
		1395	assert (("FATAL: transfer_next already nonzero in Coro (please report)", !transfer_next));
		1396	transfer_next = next;
		1397
		1398	if (expect_false (prev__cctx != next->cctx))
		1399	{
		1400	prev__cctx->top_env = PL_top_env;
		1401	PL_top_env = next->cctx->top_env;
		1402	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		1403	}
		1404
		1405	transfer_tail (aTHX);
		1406	}
		1407	}
		1408
		1409	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
		1410	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
		1411
		1412	/** high level stuff ********************************************************/
		1413
		1414	static int
		1415	coro_state_destroy (pTHX_ struct coro *coro)
		1416	{
		1417	if (coro->flags & CF_DESTROYED)
		1418	return 0;
		1419
		1420	coro->flags |= CF_DESTROYED;
		1421
		1422	if (coro->flags & CF_READY)
		1423	{
		1424	/* reduce nready, as destroying a ready coro effectively unreadies it */
		1425	/* alternative: look through all ready queues and remove the coro */
		1426	LOCK;
		1427	--coro_nready;
		1428	UNLOCK;
		1429	}
		1430	else
		1431	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
		1432
		1433	if (coro->mainstack && coro->mainstack != main_mainstack)
		1434	{
		1435	struct coro temp;
		1436
		1437	if (coro->flags & CF_RUNNING)
		1438	croak ("FATAL: tried to destroy currently running coroutine");
		1439
		1440	save_perl (aTHX_ &temp);
		1441	load_perl (aTHX_ coro);
		1442
		1443	coro_destruct (aTHX_ coro);
		1444
		1445	load_perl (aTHX_ &temp);
		1446
		1447	coro->slot = 0;
		1448	}
		1449
		1450	cctx_destroy (coro->cctx);
		1451	SvREFCNT_dec (coro->args);
		1452
		1453	if (coro->next) coro->next->prev = coro->prev;
		1454	if (coro->prev) coro->prev->next = coro->next;
		1455	if (coro == coro_first) coro_first = coro->next;
		1456
		1457	return 1;
		1458	}
		1459
		1460	static int
		1461	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
		1462	{
		1463	struct coro *coro = (struct coro *)mg->mg_ptr;
		1464	mg->mg_ptr = 0;
		1465
		1466	coro->hv = 0;
		1467
		1468	if (--coro->refcnt < 0)
		1469	{
		1470	coro_state_destroy (aTHX_ coro);
		1471	Safefree (coro);
		1472	}
		1473
		1474	return 0;
		1475	}
		1476
		1477	static int
		1478	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		1479	{
		1480	struct coro *coro = (struct coro *)mg->mg_ptr;
		1481
		1482	++coro->refcnt;
		1483
		1484	return 0;
		1485	}
		1486
		1487	static MGVTBL coro_state_vtbl = {
		1488	0, 0, 0, 0,
		1489	coro_state_free,
		1490	0,
		1491	#ifdef MGf_DUP
		1492	coro_state_dup,
		1493	#else
		1494	# define MGf_DUP 0
		1495	#endif
		1496	};
		1497
		1498	static void
		1499	prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
		1500	{
		1501	ta->prev = SvSTATE (prev_sv);
		1502	ta->next = SvSTATE (next_sv);
		1503	TRANSFER_CHECK (*ta);
		1504	}
		1505
		1506	static void
		1507	api_transfer (SV *prev_sv, SV *next_sv)
		1508	{
		1509	dTHX;
		1510	struct transfer_args ta;
		1511
		1512	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
		1513	TRANSFER (ta, 1);
		1514	}
		1515
		1516	/** Coro ********************************************************************/
		1517
		1518	static void
		1519	coro_enq (pTHX_ SV *coro_sv)
		1520	{
		1521	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		1522	}
		1523
		1524	static SV *
		1525	coro_deq (pTHX)
		1526	{
		1527	int prio;
		1528
		1529	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
		1530	if (AvFILLp (coro_ready [prio]) >= 0)
		1531	return av_shift (coro_ready [prio]);
		1532
		1533	return 0;
		1534	}
		1535
		1536	static int
		1537	api_ready (SV *coro_sv)
		1538	{
		1539	dTHX;
		1540	struct coro *coro;
		1541	SV *sv_hook;
		1542	void (*xs_hook)(void);
		1543
		1544	if (SvROK (coro_sv))
		1545	coro_sv = SvRV (coro_sv);
		1546
		1547	coro = SvSTATE (coro_sv);
		1548
		1549	if (coro->flags & CF_READY)
		1550	return 0;
		1551
		1552	coro->flags |= CF_READY;
		1553
		1554	LOCK;
		1555
		1556	sv_hook = coro_nready ? 0 : coro_readyhook;
		1557	xs_hook = coro_nready ? 0 : coroapi.readyhook;
		1558
		1559	coro_enq (aTHX_ SvREFCNT_inc_NN (coro_sv));
		1560	++coro_nready;
		1561
		1562	UNLOCK;
		1563
		1564	if (sv_hook)
		1565	{
		1566	dSP;
		1567
		1568	ENTER;
		1569	SAVETMPS;
		1570
		1571	PUSHMARK (SP);
		1572	PUTBACK;
		1573	call_sv (sv_hook, G_DISCARD);
		1574	SPAGAIN;
		1575
		1576	FREETMPS;
		1577	LEAVE;
		1578	}
		1579
		1580	if (xs_hook)
		1581	xs_hook ();
		1582
		1583	return 1;
		1584	}
		1585
		1586	static int
		1587	api_is_ready (SV *coro_sv)
		1588	{
		1589	dTHX;
		1590
		1591	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		1592	}
		1593
		1594	INLINE void
		1595	prepare_schedule (pTHX_ struct transfer_args *ta)
		1596	{
		1597	SV *prev_sv, *next_sv;
		1598
		1599	for (;;)
		1600	{
		1601	LOCK;
		1602	next_sv = coro_deq (aTHX);
		1603
		1604	/* nothing to schedule: call the idle handler */
		1605	if (expect_false (!next_sv))
		1606	{
		1607	dSP;
		1608	UNLOCK;
		1609
		1610	ENTER;
		1611	SAVETMPS;
		1612
		1613	PUSHMARK (SP);
		1614	PUTBACK;
		1615	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1616	SPAGAIN;
		1617
		1618	FREETMPS;
		1619	LEAVE;
		1620	continue;
		1621	}
		1622
		1623	ta->next = SvSTATE (next_sv);
		1624
		1625	/* cannot transfer to destroyed coros, skip and look for next */
		1626	if (expect_false (ta->next->flags & CF_DESTROYED))
		1627	{
		1628	UNLOCK;
		1629	SvREFCNT_dec (next_sv);
		1630	/* coro_nready has already been taken care of by destroy */
		1631	continue;
		1632	}
		1633
		1634	--coro_nready;
		1635	UNLOCK;
		1636	break;
		1637	}
		1638
		1639	/* free this only after the transfer */
		1640	prev_sv = SvRV (coro_current);
		1641	ta->prev = SvSTATE (prev_sv);
		1642	TRANSFER_CHECK (*ta);
		1643	assert (("FATAL: next coroutine isn't marked as ready in Coro (please report)", ta->next->flags & CF_READY));
		1644	ta->next->flags &= ~CF_READY;
		1645	SvRV_set (coro_current, next_sv);
		1646
		1647	LOCK;
		1648	free_coro_mortal (aTHX);
		1649	coro_mortal = prev_sv;
		1650	UNLOCK;
		1651	}
		1652
		1653	INLINE void
		1654	prepare_cede (pTHX_ struct transfer_args *ta)
		1655	{
		1656	api_ready (coro_current);
		1657	prepare_schedule (aTHX_ ta);
		1658	}
		1659
		1660	static int
		1661	prepare_cede_notself (pTHX_ struct transfer_args *ta)
		1662	{
		1663	if (coro_nready)
		1664	{
		1665	SV *prev = SvRV (coro_current);
		1666	prepare_schedule (aTHX_ ta);
		1667	api_ready (prev);
		1668	return 1;
		1669	}
		1670	else
		1671	return 0;
		1672	}
		1673
		1674	static void
		1675	api_schedule (void)
		1676	{
		1677	dTHX;
		1678	struct transfer_args ta;
		1679
		1680	prepare_schedule (aTHX_ &ta);
		1681	TRANSFER (ta, 1);
		1682	}
		1683
		1684	static int
		1685	api_cede (void)
		1686	{
		1687	dTHX;
		1688	struct transfer_args ta;
		1689
		1690	prepare_cede (aTHX_ &ta);
		1691
		1692	if (expect_true (ta.prev != ta.next))
		1693	{
		1694	TRANSFER (ta, 1);
		1695	return 1;
		1696	}
		1697	else
		1698	return 0;
		1699	}
		1700
		1701	static int
		1702	api_cede_notself (void)
		1703	{
		1704	dTHX;
		1705	struct transfer_args ta;
		1706
		1707	if (prepare_cede_notself (aTHX_ &ta))
		1708	{
		1709	TRANSFER (ta, 1);
		1710	return 1;
		1711	}
		1712	else
		1713	return 0;
		1714	}
		1715
		1716	static void
		1717	api_trace (SV *coro_sv, int flags)
		1718	{
		1719	dTHX;
		1720	struct coro *coro = SvSTATE (coro_sv);
		1721
		1722	if (flags & CC_TRACE)
		1723	{
		1724	if (!coro->cctx)
		1725	coro->cctx = cctx_new_run ();
		1726	else if (!(coro->cctx->flags & CC_TRACE))
		1727	croak ("cannot enable tracing on coroutine with custom stack");
		1728
		1729	coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
		1730	}
		1731	else if (coro->cctx && coro->cctx->flags & CC_TRACE)
		1732	{
		1733	coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
		1734
		1735	if (coro->flags & CF_RUNNING)
		1736	PL_runops = RUNOPS_DEFAULT;
		1737	else
		1738	coro->slot->runops = RUNOPS_DEFAULT;
		1739	}
		1740	}
		1741
		1742	#if 0
		1743	static int
		1744	coro_gensub_free (pTHX_ SV *sv, MAGIC *mg)
		1745	{
		1746	AV *padlist;
		1747	AV *av = (AV *)mg->mg_obj;
		1748
		1749	abort ();
		1750
		1751	return 0;
		1752	}
		1753
		1754	static MGVTBL coro_gensub_vtbl = {
		1755	0, 0, 0, 0,
		1756	coro_gensub_free
		1757	};
		1758	#endif
		1759
		1760	/*****************************************************************************/
		1761	/* PerlIO::cede */
		1762
		1763	typedef struct
		1764	{
		1765	PerlIOBuf base;
		1766	NV next, every;
		1767	} PerlIOCede;
		1768
		1769	static IV
		1770	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
		1771	{
		1772	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1773
		1774	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
		1775	self->next = nvtime () + self->every;
		1776
		1777	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
		1778	}
		1779
		1780	static SV *
		1781	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
		1782	{
		1783	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1784
		1785	return newSVnv (self->every);
		1786	}
		1787
		1788	static IV
		1789	PerlIOCede_flush (pTHX_ PerlIO *f)
		1790	{
		1791	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1792	double now = nvtime ();
		1793
		1794	if (now >= self->next)
		1795	{
		1796	api_cede ();
		1797	self->next = now + self->every;
		1798	}
		1799
		1800	return PerlIOBuf_flush (aTHX_ f);
		1801	}
		1802
		1803	static PerlIO_funcs PerlIO_cede =
		1804	{
		1805	sizeof(PerlIO_funcs),
		1806	"cede",
		1807	sizeof(PerlIOCede),
		1808	PERLIO_K_DESTRUCT | PERLIO_K_RAW,
		1809	PerlIOCede_pushed,
		1810	PerlIOBuf_popped,
		1811	PerlIOBuf_open,
		1812	PerlIOBase_binmode,
		1813	PerlIOCede_getarg,
		1814	PerlIOBase_fileno,
		1815	PerlIOBuf_dup,
		1816	PerlIOBuf_read,
		1817	PerlIOBuf_unread,
		1818	PerlIOBuf_write,
		1819	PerlIOBuf_seek,
		1820	PerlIOBuf_tell,
		1821	PerlIOBuf_close,
		1822	PerlIOCede_flush,
		1823	PerlIOBuf_fill,
		1824	PerlIOBase_eof,
		1825	PerlIOBase_error,
		1826	PerlIOBase_clearerr,
		1827	PerlIOBase_setlinebuf,
		1828	PerlIOBuf_get_base,
		1829	PerlIOBuf_bufsiz,
		1830	PerlIOBuf_get_ptr,
		1831	PerlIOBuf_get_cnt,
		1832	PerlIOBuf_set_ptrcnt,
		1833	};
		1834
		1835	/*****************************************************************************/
		1836
		1837	static const CV *ssl_cv; /* for quick consistency check */
		1838
		1839	static UNOP ssl_restore; /* restore stack as entersub did, for first-re-run */
		1840	static SV *ssl_arg0;
		1841	static SV *ssl_arg1;
		1842
		1843	/* this restores the stack in the case we patched the entersub, to */
		1844	/* recreate the stack frame as perl will on following calls */
		1845	/* since entersub cleared the stack */
		1846	static OP *
		1847	pp_restore (pTHX)
		1848	{
		1849	dSP;
		1850
		1851	PUSHMARK (SP);
		1852
		1853	EXTEND (SP, 3);
		1854	if (ssl_arg0) PUSHs (sv_2mortal (ssl_arg0)), ssl_arg0 = 0;
		1855	if (ssl_arg1) PUSHs (sv_2mortal (ssl_arg1)), ssl_arg1 = 0;
		1856	PUSHs ((SV *)CvGV (ssl_cv));
		1857
		1858	RETURNOP (ssl_restore.op_first);
		1859	}
		1860
		1861	/* declare prototype */
		1862	XS(XS_Coro__State__set_stacklevel);
		1863
		1864	#define OPpENTERSUB_SSL 15
		1865
		1866	static OP *
		1867	pp_set_stacklevel (pTHX)
		1868	{
		1869	dSP;
		1870	struct transfer_args ta;
		1871	SV **arg = PL_stack_base + TOPMARK + 1;
		1872	int items = SP - arg; /* args without function object */
		1873
		1874	/* do a quick consistency check on the "function" object, and if it isn't */
		1875	/* for us, divert to the real entersub */
		1876	if (SvTYPE (*sp) != SVt_PVGV || CvXSUB (GvCV (*sp)) != XS_Coro__State__set_stacklevel)
		1877	return PL_ppaddr[OP_ENTERSUB](aTHX);
		1878
		1879	/* pop args */
		1880	SP = PL_stack_base + POPMARK;
		1881
		1882	if (!(PL_op->op_flags & OPf_STACKED))
		1883	{
		1884	/* ampersand-form of call, use @_ instead of stack */
		1885	AV *av = GvAV (PL_defgv);
		1886	arg = AvARRAY (av);
		1887	items = AvFILLp (av) + 1;
		1888	}
		1889
		1890	PUTBACK;
		1891	switch (PL_op->op_private & OPpENTERSUB_SSL)
		1892	{
		1893	case 0:
		1894	prepare_set_stacklevel (&ta, (struct coro_cctx *)SvIV (arg [0]));
		1895	break;
		1896
		1897	case 1:
		1898	if (items != 2)
		1899	croak ("Coro::State::transfer (prev, next) expects two arguments, not %d.", items);
		1900
		1901	prepare_transfer (aTHX_ &ta, arg [0], arg [1]);
		1902	break;
		1903
		1904	case 2:
		1905	prepare_schedule (aTHX_ &ta);
		1906	break;
		1907
		1908	case 3:
		1909	prepare_cede (aTHX_ &ta);
		1910	break;
		1911
		1912	case 4:
		1913	if (!prepare_cede_notself (aTHX_ &ta))
		1914	goto skip;
		1915
		1916	break;
		1917	}
		1918
		1919	TRANSFER (ta, 0);
		1920	SPAGAIN;
		1921
		1922	skip:
		1923	PUTBACK;
		1924	SSL_TAIL;
		1925	SPAGAIN;
		1926	RETURN;
		1927	}
		1928
		1929	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
		1930
		1931	PROTOTYPES: DISABLE
		1932
		1933	# these not obviously related functions are all rolled into the same xs
		1934	# function to increase chances that they all will call transfer with the same
		1935	# stack offset
		1936	void
		1937	_set_stacklevel (...)
		1938	ALIAS:
		1939	Coro::State::transfer = 1
		1940	Coro::schedule = 2
		1941	Coro::cede = 3
		1942	Coro::cede_notself = 4
		1943	CODE:
		1944	{
		1945	assert (("FATAL: ssl call recursion in Coro module (please report)", PL_op->op_ppaddr != pp_set_stacklevel));
		1946
		1947	assert (("FATAL: ssl call with illegal CV value", CvGV (cv)));
		1948	ssl_cv = cv;
		1949
		1950	/* we patch the op, and then re-run the whole call */
		1951	/* we have to put some dummy argument on the stack for this to work */
		1952	ssl_restore.op_next = (OP *)&ssl_restore;
		1953	ssl_restore.op_type = OP_NULL;
		1954	ssl_restore.op_ppaddr = pp_restore;
		1955	ssl_restore.op_first = PL_op;
		1956
		1957	ssl_arg0 = items > 0 ? SvREFCNT_inc (ST (0)) : 0;
		1958	ssl_arg1 = items > 1 ? SvREFCNT_inc (ST (1)) : 0;
		1959
		1960	PL_op->op_ppaddr = pp_set_stacklevel;
		1961	PL_op->op_private = PL_op->op_private & ~OPpENTERSUB_SSL | ix; /* we potentially share our private flags with entersub */
		1962
		1963	PL_op = (OP *)&ssl_restore;
		1964	}
		1965
		1966	BOOT:
		1967	{
		1968	#ifdef USE_ITHREADS
		1969	MUTEX_INIT (&coro_lock);
		1970	# if CORO_PTHREAD
		1971	coro_thx = PERL_GET_CONTEXT;
		1972	# endif
		1973	#endif
		1974	BOOT_PAGESIZE;
		1975
		1976	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
		1977	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
		1978
		1979	orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
		1980	orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
		1981	orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
		1982
		1983	hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
		1984	rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
		1985	rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
		1986
		1987	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		1988
		1989	newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
		1990	newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
		1991	newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
		1992	newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
		1993
		1994	main_mainstack = PL_mainstack;
		1995	main_top_env = PL_top_env;
		1996
		1997	while (main_top_env->je_prev)
		1998	main_top_env = main_top_env->je_prev;
		1999
		2000	coroapi.ver = CORO_API_VERSION;
		2001	coroapi.rev = CORO_API_REVISION;
		2002	coroapi.transfer = api_transfer;
		2003
		2004	{
		2005	SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
		2006
		2007	if (!svp) croak ("Time::HiRes is required");
		2008	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
		2009
		2010	nvtime = INT2PTR (double (*)(), SvIV (*svp));
		2011	}
		2012
		2013	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		2014	}
		2015
		2016	SV *
		2017	new (char *klass, ...)
		2018	CODE:
		2019	{
		2020	struct coro *coro;
		2021	MAGIC *mg;
		2022	HV *hv;
		2023	int i;
		2024
		2025	Newz (0, coro, 1, struct coro);
		2026	coro->args = newAV ();
		2027	coro->flags = CF_NEW;
		2028
		2029	if (coro_first) coro_first->prev = coro;
		2030	coro->next = coro_first;
		2031	coro_first = coro;
		2032
		2033	coro->hv = hv = newHV ();
		2034	mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
		2035	mg->mg_flags |= MGf_DUP;
		2036	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		2037
		2038	av_extend (coro->args, items - 1);
		2039	for (i = 1; i < items; i++)
		2040	av_push (coro->args, newSVsv (ST (i)));
		2041	}
		2042	OUTPUT:
		2043	RETVAL
		2044
		2045	bool
		2046	_destroy (SV *coro_sv)
		2047	CODE:
		2048	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		2049	OUTPUT:
		2050	RETVAL
		2051
		2052	void
		2053	_exit (int code)
		2054	PROTOTYPE: $
		2055	CODE:
		2056	_exit (code);
		2057
		2058	int
		2059	cctx_stacksize (int new_stacksize = 0)
		2060	CODE:
		2061	RETVAL = cctx_stacksize;
		2062	if (new_stacksize)
		2063	{
		2064	cctx_stacksize = new_stacksize;
		2065	++cctx_gen;
		2066	}
		2067	OUTPUT:
		2068	RETVAL
		2069
		2070	int
		2071	cctx_max_idle (int max_idle = 0)
		2072	CODE:
		2073	RETVAL = cctx_max_idle;
		2074	if (max_idle > 1)
		2075	cctx_max_idle = max_idle;
		2076	OUTPUT:
		2077	RETVAL
		2078
		2079	int
		2080	cctx_count ()
		2081	CODE:
		2082	RETVAL = cctx_count;
		2083	OUTPUT:
		2084	RETVAL
		2085
		2086	int
		2087	cctx_idle ()
		2088	CODE:
		2089	RETVAL = cctx_idle;
		2090	OUTPUT:
		2091	RETVAL
		2092
		2093	void
		2094	list ()
		2095	PPCODE:
		2096	{
		2097	struct coro *coro;
		2098	for (coro = coro_first; coro; coro = coro->next)
		2099	if (coro->hv)
		2100	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
		2101	}
		2102
		2103	void
		2104	call (Coro::State coro, SV *coderef)
		2105	ALIAS:
		2106	eval = 1
		2107	CODE:
		2108	{
		2109	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
		2110	{
		2111	struct coro temp;
		2112
		2113	if (!(coro->flags & CF_RUNNING))
235	{	2114	{
236	/* I never used formats, so how should I know how these are implemented? */	2115	PUTBACK;
237	/* my bold guess is as a simple, plain sub... */	2116	save_perl (aTHX_ &temp);
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	2117	load_perl (aTHX_ coro);
		2118	}
		2119
		2120	{
		2121	dSP;
		2122	ENTER;
		2123	SAVETMPS;
		2124	PUTBACK;
		2125	PUSHSTACK;
		2126	PUSHMARK (SP);
		2127
		2128	if (ix)
		2129	eval_sv (coderef, 0);
		2130	else
		2131	call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		2132
		2133	POPSTACK;
		2134	SPAGAIN;
		2135	FREETMPS;
		2136	LEAVE;
		2137	PUTBACK;
		2138	}
		2139
		2140	if (!(coro->flags & CF_RUNNING))
		2141	{
		2142	save_perl (aTHX_ coro);
		2143	load_perl (aTHX_ &temp);
		2144	SPAGAIN;
239	}	2145	}
240	}	2146	}
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	}	2147	}
281		2148
282	static void	2149	SV *
283	LOAD(pTHX_ Coro__State c)	2150	is_ready (Coro::State coro)
284	{	2151	PROTOTYPE: $
285	PL_dowarn = c->dowarn;	2152	ALIAS:
286	GvAV (PL_defgv) = c->defav;	2153	is_ready = CF_READY
287	PL_curstackinfo = c->curstackinfo;	2154	is_running = CF_RUNNING
288	PL_curstack = c->curstack;	2155	is_new = CF_NEW
289	PL_mainstack = c->mainstack;	2156	is_destroyed = CF_DESTROYED
290	PL_stack_sp = c->stack_sp;	2157	CODE:
291	PL_op = c->op;	2158	RETVAL = boolSV (coro->flags & ix);
292	PL_curpad = c->curpad;	2159	OUTPUT:
293	PL_stack_base = c->stack_base;	2160	RETVAL
294	PL_stack_max = c->stack_max;
295	PL_tmps_stack = c->tmps_stack;
296	PL_tmps_floor = c->tmps_floor;
297	PL_tmps_ix = c->tmps_ix;
298	PL_tmps_max = c->tmps_max;
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;
301	PL_markstack_max = c->markstack_max;
302	PL_scopestack = c->scopestack;
303	PL_scopestack_ix = c->scopestack_ix;
304	PL_scopestack_max = c->scopestack_max;
305	PL_savestack = c->savestack;
306	PL_savestack_ix = c->savestack_ix;
307	PL_savestack_max = c->savestack_max;
308	PL_retstack = c->retstack;
309	PL_retstack_ix = c->retstack_ix;
310	PL_retstack_max = c->retstack_max;
311	PL_curcop = c->curcop;
312		2161
		2162	void
		2163	throw (Coro::State self, SV *throw = &PL_sv_undef)
		2164	PROTOTYPE: $;$
		2165	CODE:
		2166	SvREFCNT_dec (self->throw);
		2167	self->throw = SvOK (throw) ? newSVsv (throw) : 0;
		2168
		2169	void
		2170	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
		2171
		2172	SV *
		2173	has_cctx (Coro::State coro)
		2174	PROTOTYPE: $
		2175	CODE:
		2176	RETVAL = boolSV (!!coro->cctx);
		2177	OUTPUT:
		2178	RETVAL
		2179
		2180	int
		2181	is_traced (Coro::State coro)
		2182	PROTOTYPE: $
		2183	CODE:
		2184	RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
		2185	OUTPUT:
		2186	RETVAL
		2187
		2188	UV
		2189	rss (Coro::State coro)
		2190	PROTOTYPE: $
		2191	ALIAS:
		2192	usecount = 1
		2193	CODE:
		2194	switch (ix)
313	{	2195	{
314	dSP;	2196	case 0: RETVAL = coro_rss (aTHX_ coro); break;
315	CV *cv;	2197	case 1: RETVAL = coro->usecount; break;
316
317	/* now do the ugly restore mess */
318	while ((cv = (CV *)POPs))
319	{
320	AV *padlist = (AV *)POPs;
321
322	put_padlist (cv);
323	CvPADLIST(cv) = padlist;
324	CvDEPTH(cv) = (I32)POPs;
325
326	#ifdef USE_THREADS
327	CvOWNER(cv) = (struct perl_thread *)POPs;
328	error does not work either
329	#endif
330	}	2198	}
		2199	OUTPUT:
		2200	RETVAL
331		2201
332	PUTBACK;	2202	void
333	}	2203	force_cctx ()
334	}	2204	CODE:
		2205	struct coro *coro = SvSTATE (coro_current);
		2206	coro->cctx->idle_sp = 0;
335		2207
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	2208	void
337	STATIC void	2209	swap_defsv (Coro::State self)
338	destroy_stacks(pTHX)	2210	PROTOTYPE: $
339	{	2211	ALIAS:
340	/* die does this while calling POPSTACK, but I just don't see why. */	2212	swap_defav = 1
341	dounwind(-1);	2213	CODE:
		2214	if (!self->slot)
		2215	croak ("cannot swap state with coroutine that has no saved state");
		2216	else
		2217	{
		2218	SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
		2219	SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
342		2220
343	/* is this ugly, I ask? */	2221	SV *tmp = *src; *src = *dst; *dst = tmp;
344	while (PL_scopestack_ix)	2222	}
345	LEAVE;
346		2223
347	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;
349
350	while (PL_curstackinfo)
351	{
352	PERL_SI *p = PL_curstackinfo->si_prev;
353
354	SvREFCNT_dec(PL_curstackinfo->si_stack);
355	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;
358	}
359
360	if (PL_scopestack_ix != 0)
361	Perl_warner(aTHX_ WARN_INTERNAL,
362	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
363	(long)PL_scopestack_ix);
364	if (PL_savestack_ix != 0)
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced saves: %ld more saves than restores\n",
367	(long)PL_savestack_ix);
368	if (PL_tmps_floor != -1)
369	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
370	(long)PL_tmps_floor + 1);
371	/*
372	*/
373	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);
375	Safefree(PL_scopestack);
376	Safefree(PL_savestack);
377	Safefree(PL_retstack);
378	}
379
380	#define SUB_INIT "Coro::State::_newcoro"
381
382	MODULE = Coro::State PACKAGE = Coro::State	2224	MODULE = Coro::State PACKAGE = Coro
383
384	PROTOTYPES: ENABLE
385		2225
386	BOOT:	2226	BOOT:
387	if (!padlist_cache)	2227	{
388	padlist_cache = newHV ();	2228	int i;
389		2229
390	Coro::State	2230	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
391	_newprocess(args)	2231	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
392	SV * args	2232	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
		2233
		2234	coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
		2235	SvREADONLY_on (coro_current);
		2236
		2237	coro_stash = gv_stashpv ("Coro", TRUE);
		2238
		2239	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		2240	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		2241	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		2242	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		2243	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		2244	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		2245
		2246	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		2247	coro_ready[i] = newAV ();
		2248
		2249	{
		2250	SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
		2251
		2252	coroapi.schedule = api_schedule;
		2253	coroapi.cede = api_cede;
		2254	coroapi.cede_notself = api_cede_notself;
		2255	coroapi.ready = api_ready;
		2256	coroapi.is_ready = api_is_ready;
		2257	coroapi.nready = &coro_nready;
		2258	coroapi.current = coro_current;
		2259
		2260	GCoroAPI = &coroapi;
		2261	sv_setiv (sv, (IV)&coroapi);
		2262	SvREADONLY_on (sv);
		2263	}
		2264	}
		2265
		2266	void
		2267	_set_current (SV *current)
393	PROTOTYPE: $	2268	PROTOTYPE: $
		2269	CODE:
		2270	SvREFCNT_dec (SvRV (coro_current));
		2271	SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
		2272
		2273	void
		2274	_set_readyhook (SV *hook)
		2275	PROTOTYPE: $
394	CODE:	2276	CODE:
395	Coro__State coro;
396
397	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");
399		2277	LOCK;
400	New (0, coro, 1, struct coro);	2278	SvREFCNT_dec (coro_readyhook);
		2279	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
		2280	UNLOCK;
401		2281
402	coro->mainstack = 0; /* actual work is done inside transfer */	2282	int
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	2283	prio (Coro::State coro, int newprio = 0)
404		2284	ALIAS:
		2285	nice = 1
		2286	CODE:
		2287	{
405	RETVAL = coro;	2288	RETVAL = coro->prio;
406	OUTPUT:	2289
		2290	if (items > 1)
		2291	{
		2292	if (ix)
		2293	newprio = coro->prio - newprio;
		2294
		2295	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
		2296	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
		2297
		2298	coro->prio = newprio;
		2299	}
		2300	}
		2301	OUTPUT:
407	RETVAL	2302	RETVAL
408		2303
		2304	SV *
		2305	ready (SV *self)
		2306	PROTOTYPE: $
		2307	CODE:
		2308	RETVAL = boolSV (api_ready (self));
		2309	OUTPUT:
		2310	RETVAL
		2311
		2312	int
		2313	nready (...)
		2314	PROTOTYPE:
		2315	CODE:
		2316	RETVAL = coro_nready;
		2317	OUTPUT:
		2318	RETVAL
		2319
		2320	# for async_pool speedup
409	void	2321	void
410	transfer(prev,next)	2322	_pool_1 (SV *cb)
411	Coro::State_or_hashref prev	2323	CODE:
412	Coro::State_or_hashref next	2324	{
		2325	struct coro *coro = SvSTATE (coro_current);
		2326	HV *hv = (HV *)SvRV (coro_current);
		2327	AV *defav = GvAV (PL_defgv);
		2328	SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
		2329	AV *invoke_av;
		2330	int i, len;
		2331
		2332	if (!invoke)
		2333	{
		2334	SV *old = PL_diehook;
		2335	PL_diehook = 0;
		2336	SvREFCNT_dec (old);
		2337	croak ("\3async_pool terminate\2\n");
		2338	}
		2339
		2340	SvREFCNT_dec (coro->saved_deffh);
		2341	coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
		2342
		2343	hv_store (hv, "desc", sizeof ("desc") - 1,
		2344	newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
		2345
		2346	invoke_av = (AV *)SvRV (invoke);
		2347	len = av_len (invoke_av);
		2348
		2349	sv_setsv (cb, AvARRAY (invoke_av)[0]);
		2350
		2351	if (len > 0)
		2352	{
		2353	av_fill (defav, len - 1);
		2354	for (i = 0; i < len; ++i)
		2355	av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
		2356	}
		2357
		2358	SvREFCNT_dec (invoke);
		2359	}
		2360
		2361	void
		2362	_pool_2 (SV *cb)
		2363	CODE:
		2364	{
		2365	struct coro *coro = SvSTATE (coro_current);
		2366
		2367	sv_setsv (cb, &PL_sv_undef);
		2368
		2369	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
		2370	coro->saved_deffh = 0;
		2371
		2372	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
		2373	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
		2374	{
		2375	SV *old = PL_diehook;
		2376	PL_diehook = 0;
		2377	SvREFCNT_dec (old);
		2378	croak ("\3async_pool terminate\2\n");
		2379	}
		2380
		2381	av_clear (GvAV (PL_defgv));
		2382	hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
		2383	newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
		2384
		2385	coro->prio = 0;
		2386
		2387	if (coro->cctx && (coro->cctx->flags & CC_TRACE))
		2388	api_trace (coro_current, 0);
		2389
		2390	av_push (av_async_pool, newSVsv (coro_current));
		2391	}
		2392
		2393	#if 0
		2394
		2395	void
		2396	_generator_call (...)
		2397	PROTOTYPE: @
		2398	PPCODE:
		2399	fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
		2400	xxxx
		2401	abort ();
		2402
		2403	SV *
		2404	gensub (SV *sub, ...)
		2405	PROTOTYPE: &;@
413	CODE:	2406	CODE:
		2407	{
		2408	struct coro *coro;
		2409	MAGIC *mg;
		2410	CV *xcv;
		2411	CV *ncv = (CV *)newSV_type (SVt_PVCV);
		2412	int i;
414		2413
415	if (prev != next)	2414	CvGV (ncv) = CvGV (cv);
		2415	CvFILE (ncv) = CvFILE (cv);
		2416
		2417	Newz (0, coro, 1, struct coro);
		2418	coro->args = newAV ();
		2419	coro->flags = CF_NEW;
		2420
		2421	av_extend (coro->args, items - 1);
		2422	for (i = 1; i < items; i++)
		2423	av_push (coro->args, newSVsv (ST (i)));
		2424
		2425	CvISXSUB_on (ncv);
		2426	CvXSUBANY (ncv).any_ptr = (void *)coro;
		2427
		2428	xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
		2429
		2430	CvXSUB (ncv) = CvXSUB (xcv);
		2431	CvANON_on (ncv);
		2432
		2433	mg = sv_magicext ((SV *)ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char *)coro, 0);
		2434	RETVAL = newRV_noinc ((SV *)ncv);
		2435	}
		2436	OUTPUT:
		2437	RETVAL
		2438
		2439	#endif
		2440
		2441
		2442	MODULE = Coro::State PACKAGE = Coro::AIO
		2443
		2444	void
		2445	_get_state (SV *self)
		2446	PPCODE:
		2447	{
		2448	AV *defav = GvAV (PL_defgv);
		2449	AV *av = newAV ();
		2450	int i;
		2451	SV *data_sv = newSV (sizeof (struct io_state));
		2452	struct io_state *data = (struct io_state *)SvPVX (data_sv);
		2453	SvCUR_set (data_sv, sizeof (struct io_state));
		2454	SvPOK_only (data_sv);
		2455
		2456	data->errorno = errno;
		2457	data->laststype = PL_laststype;
		2458	data->laststatval = PL_laststatval;
		2459	data->statcache = PL_statcache;
		2460
		2461	av_extend (av, AvFILLp (defav) + 1 + 1);
		2462
		2463	for (i = 0; i <= AvFILLp (defav); ++i)
		2464	av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
		2465
		2466	av_push (av, data_sv);
		2467
		2468	XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		2469
		2470	api_ready (self);
		2471	}
		2472
		2473	void
		2474	_set_state (SV *state)
		2475	PROTOTYPE: $
		2476	PPCODE:
		2477	{
		2478	AV *av = (AV *)SvRV (state);
		2479	struct io_state *data = (struct io_state *)SvPVX (AvARRAY (av)[AvFILLp (av)]);
		2480	int i;
		2481
		2482	errno = data->errorno;
		2483	PL_laststype = data->laststype;
		2484	PL_laststatval = data->laststatval;
		2485	PL_statcache = data->statcache;
		2486
		2487	EXTEND (SP, AvFILLp (av));
		2488	for (i = 0; i < AvFILLp (av); ++i)
		2489	PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
		2490	}
		2491
		2492
		2493	MODULE = Coro::State PACKAGE = Coro::AnyEvent
		2494
		2495	BOOT:
		2496	sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
		2497
		2498	SV *
		2499	_schedule (...)
		2500	PROTOTYPE: @
		2501	CODE:
		2502	{
		2503	static int incede;
		2504
		2505	api_cede_notself ();
		2506
		2507	++incede;
		2508	while (coro_nready >= incede && api_cede ())
		2509	;
		2510
		2511	sv_setsv (sv_activity, &PL_sv_undef);
		2512	if (coro_nready >= incede)
416	{	2513	{
		2514	PUSHMARK (SP);
417	PUTBACK;	2515	PUTBACK;
418	SAVE (aTHX_ prev);	2516	call_pv ("Coro::AnyEvent::_activity", G_DISCARD | G_EVAL);
419
420	/*
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;
431	}
432	else
433	{
434	/*
435	* emulate part of the perl startup here.
436	*/
437	UNOP myop;
438
439	init_stacks (); /* from perl.c */
440	PL_op = (OP *)&myop;
441	/*PL_curcop = 0;*/
442	GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
443
444	SPAGAIN;
445	Zero(&myop, 1, UNOP);
446	myop.op_next = Nullop;
447	myop.op_flags = OPf_WANT_VOID;
448
449	PUSHMARK(SP);
450	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451	PUTBACK;
452	/*
453	* the next line is slightly wrong, as PL_op->op_next
454	* is actually being executed so we skip the first op.
455	* that doesn't matter, though, since it is only
456	* pp_nextstate and we never return...
457	*/
458	PL_op = Perl_pp_entersub(aTHX);
459	SPAGAIN;
460
461	ENTER;
462	}
463	}
464
465	void
466	DESTROY(coro)
467	Coro::State coro
468	CODE:
469
470	if (coro->mainstack)
471	{
472	struct coro temp;
473
474	PUTBACK;
475	SAVE(aTHX_ (&temp));
476	LOAD(aTHX_ coro);
477
478	destroy_stacks ();
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;	2517	SPAGAIN;
483	}	2518	}
484		2519
485	SvREFCNT_dec (coro->args);	2520	--incede;
486	Safefree (coro);	2521	}
487		2522
488		2523
		2524	MODULE = Coro::State PACKAGE = PerlIO::cede
		2525
		2526	BOOT:
		2527	PerlIO_define_layer (aTHX_ &PerlIO_cede);
		2528

Diff Legend

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