ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.267 by root, Fri Nov 14 06:29:52 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 sometimes 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 void
		1661	prepare_cede_notself (pTHX_ struct transfer_args *ta)
		1662	{
		1663	SV *prev = SvRV (coro_current);
		1664
		1665	if (coro_nready)
		1666	{
		1667	prepare_schedule (aTHX_ ta);
		1668	api_ready (prev);
		1669	}
		1670	else
		1671	ta->prev = ta->next = SvSTATE (prev);
		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	if (coro_nready)
		1705	{
		1706	dTHX;
		1707	struct transfer_args ta;
		1708
		1709	prepare_cede_notself (aTHX_ &ta);
		1710	TRANSFER (ta, 1);
		1711	return 1;
		1712	}
		1713	else
		1714	return 0;
		1715	}
		1716
		1717	static void
		1718	api_trace (SV *coro_sv, int flags)
		1719	{
		1720	dTHX;
		1721	struct coro *coro = SvSTATE (coro_sv);
		1722
		1723	if (flags & CC_TRACE)
		1724	{
		1725	if (!coro->cctx)
		1726	coro->cctx = cctx_new_run ();
		1727	else if (!(coro->cctx->flags & CC_TRACE))
		1728	croak ("cannot enable tracing on coroutine with custom stack");
		1729
		1730	coro->cctx->flags |= CC_NOREUSE | (flags & (CC_TRACE | CC_TRACE_ALL));
		1731	}
		1732	else if (coro->cctx && coro->cctx->flags & CC_TRACE)
		1733	{
		1734	coro->cctx->flags &= ~(CC_TRACE | CC_TRACE_ALL);
		1735
		1736	if (coro->flags & CF_RUNNING)
		1737	PL_runops = RUNOPS_DEFAULT;
		1738	else
		1739	coro->slot->runops = RUNOPS_DEFAULT;
		1740	}
		1741	}
		1742
		1743	#if 0
		1744	static int
		1745	coro_gensub_free (pTHX_ SV *sv, MAGIC *mg)
		1746	{
		1747	AV *padlist;
		1748	AV *av = (AV *)mg->mg_obj;
		1749
		1750	abort ();
		1751
		1752	return 0;
		1753	}
		1754
		1755	static MGVTBL coro_gensub_vtbl = {
		1756	0, 0, 0, 0,
		1757	coro_gensub_free
		1758	};
		1759	#endif
		1760
		1761	/*****************************************************************************/
		1762	/* PerlIO::cede */
		1763
		1764	typedef struct
		1765	{
		1766	PerlIOBuf base;
		1767	NV next, every;
		1768	} PerlIOCede;
		1769
		1770	static IV
		1771	PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
		1772	{
		1773	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1774
		1775	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
		1776	self->next = nvtime () + self->every;
		1777
		1778	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
		1779	}
		1780
		1781	static SV *
		1782	PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
		1783	{
		1784	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1785
		1786	return newSVnv (self->every);
		1787	}
		1788
		1789	static IV
		1790	PerlIOCede_flush (pTHX_ PerlIO *f)
		1791	{
		1792	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1793	double now = nvtime ();
		1794
		1795	if (now >= self->next)
		1796	{
		1797	api_cede ();
		1798	self->next = now + self->every;
		1799	}
		1800
		1801	return PerlIOBuf_flush (aTHX_ f);
		1802	}
		1803
		1804	static PerlIO_funcs PerlIO_cede =
		1805	{
		1806	sizeof(PerlIO_funcs),
		1807	"cede",
		1808	sizeof(PerlIOCede),
		1809	PERLIO_K_DESTRUCT | PERLIO_K_RAW,
		1810	PerlIOCede_pushed,
		1811	PerlIOBuf_popped,
		1812	PerlIOBuf_open,
		1813	PerlIOBase_binmode,
		1814	PerlIOCede_getarg,
		1815	PerlIOBase_fileno,
		1816	PerlIOBuf_dup,
		1817	PerlIOBuf_read,
		1818	PerlIOBuf_unread,
		1819	PerlIOBuf_write,
		1820	PerlIOBuf_seek,
		1821	PerlIOBuf_tell,
		1822	PerlIOBuf_close,
		1823	PerlIOCede_flush,
		1824	PerlIOBuf_fill,
		1825	PerlIOBase_eof,
		1826	PerlIOBase_error,
		1827	PerlIOBase_clearerr,
		1828	PerlIOBase_setlinebuf,
		1829	PerlIOBuf_get_base,
		1830	PerlIOBuf_bufsiz,
		1831	PerlIOBuf_get_ptr,
		1832	PerlIOBuf_get_cnt,
		1833	PerlIOBuf_set_ptrcnt,
		1834	};
		1835
		1836	/*****************************************************************************/
		1837
		1838	static const CV *ssl_cv; /* for quick consistency check */
		1839
		1840	static UNOP ssl_restore; /* restore stack as entersub did, for first-re-run */
		1841	static SV *ssl_arg0;
		1842	static SV *ssl_arg1;
		1843
		1844	/* this restores the stack in the case we patched the entersub, to */
		1845	/* recreate the stack frame as perl will on following calls */
		1846	/* since entersub cleared the stack */
		1847	static OP *
		1848	pp_restore (pTHX)
		1849	{
		1850	dSP;
		1851
		1852	PUSHMARK (SP);
		1853
		1854	EXTEND (SP, 3);
		1855	if (ssl_arg0) PUSHs (sv_2mortal (ssl_arg0)), ssl_arg0 = 0;
		1856	if (ssl_arg1) PUSHs (sv_2mortal (ssl_arg1)), ssl_arg1 = 0;
		1857	PUSHs ((SV *)CvGV (ssl_cv));
		1858
		1859	RETURNOP (ssl_restore.op_first);
		1860	}
		1861
		1862	#define OPpENTERSUB_SSL 15 /* the part of op_private entersub hopefully doesn't use */
		1863
		1864	/* declare prototype */
		1865	XS(XS_Coro__State__set_stacklevel);
		1866
		1867	/*
		1868	* these not obviously related functions are all rolled into one
		1869	* function to increase chances that they all will call transfer with the same
		1870	* stack offset
		1871	*/
		1872	static OP *
		1873	pp_set_stacklevel (pTHX)
		1874	{
		1875	dSP;
		1876	struct transfer_args ta;
		1877	SV **arg = PL_stack_base + TOPMARK + 1;
		1878	int items = SP - arg; /* args without function object */
		1879
		1880	/* do a quick consistency check on the "function" object, and if it isn't */
		1881	/* for us, divert to the real entersub */
		1882	if (SvTYPE (*sp) != SVt_PVGV || CvXSUB (GvCV (*sp)) != XS_Coro__State__set_stacklevel)
		1883	return PL_ppaddr[OP_ENTERSUB](aTHX);
		1884
		1885	/* pop args */
		1886	SP = PL_stack_base + POPMARK;
		1887
		1888	if (!(PL_op->op_flags & OPf_STACKED))
		1889	{
		1890	/* ampersand-form of call, use @_ instead of stack */
		1891	AV *av = GvAV (PL_defgv);
		1892	arg = AvARRAY (av);
		1893	items = AvFILLp (av) + 1;
		1894	}
		1895
		1896	PUTBACK;
		1897	switch (PL_op->op_private & OPpENTERSUB_SSL)
		1898	{
		1899	case 0:
		1900	prepare_set_stacklevel (&ta, (struct coro_cctx *)SvIV (arg [0]));
		1901	break;
		1902
		1903	case 1:
		1904	if (items != 2)
		1905	croak ("Coro::State::transfer (prev, next) expects two arguments, not %d.", items);
		1906
		1907	prepare_transfer (aTHX_ &ta, arg [0], arg [1]);
		1908	break;
		1909
		1910	case 2:
		1911	prepare_schedule (aTHX_ &ta);
		1912	break;
		1913
		1914	case 3:
		1915	prepare_cede (aTHX_ &ta);
		1916	break;
		1917
		1918	case 4:
		1919	prepare_cede_notself (aTHX_ &ta);
		1920	break;
		1921	}
		1922
		1923	TRANSFER (ta, 0);
		1924	SPAGAIN;
		1925
		1926	skip:
		1927	PUTBACK;
		1928	SSL_TAIL;
		1929	SPAGAIN;
		1930	RETURN;
		1931	}
		1932
		1933	static void
		1934	coro_ssl_patch (pTHX_ CV *cv, int ix, SV **args, int items)
		1935	{
		1936	assert (("FATAL: ssl call recursion in Coro module (please report)", PL_op->op_ppaddr != pp_set_stacklevel));
		1937
		1938	assert (("FATAL: ssl call with illegal CV value", CvGV (cv)));
		1939	ssl_cv = cv;
		1940
		1941	/* we patch the op, and then re-run the whole call */
		1942	/* we have to put some dummy argument on the stack for this to work */
		1943	ssl_restore.op_next = (OP *)&ssl_restore;
		1944	ssl_restore.op_type = OP_NULL;
		1945	ssl_restore.op_ppaddr = pp_restore;
		1946	ssl_restore.op_first = PL_op;
		1947
		1948	ssl_arg0 = items > 0 ? SvREFCNT_inc (args [0]) : 0;
		1949	ssl_arg1 = items > 1 ? SvREFCNT_inc (args [1]) : 0;
		1950
		1951	PL_op->op_ppaddr = pp_set_stacklevel;
		1952	PL_op->op_private = PL_op->op_private & ~OPpENTERSUB_SSL | ix; /* we potentially share our private flags with entersub */
		1953
		1954	PL_op = (OP *)&ssl_restore;
		1955	}
		1956
		1957	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
		1958
		1959	PROTOTYPES: DISABLE
		1960
		1961	BOOT:
		1962	{
		1963	#ifdef USE_ITHREADS
		1964	MUTEX_INIT (&coro_lock);
		1965	# if CORO_PTHREAD
		1966	coro_thx = PERL_GET_CONTEXT;
		1967	# endif
		1968	#endif
		1969	BOOT_PAGESIZE;
		1970
		1971	irsgv = gv_fetchpv ("/" , GV_ADD|GV_NOTQUAL, SVt_PV);
		1972	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
		1973
		1974	orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
		1975	orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
		1976	orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
		1977
		1978	hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
		1979	rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
		1980	rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
		1981
		1982	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		1983
		1984	newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
		1985	newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
		1986	newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
		1987	newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
		1988
		1989	main_mainstack = PL_mainstack;
		1990	main_top_env = PL_top_env;
		1991
		1992	while (main_top_env->je_prev)
		1993	main_top_env = main_top_env->je_prev;
		1994
		1995	coroapi.ver = CORO_API_VERSION;
		1996	coroapi.rev = CORO_API_REVISION;
		1997	coroapi.transfer = api_transfer;
		1998
		1999	{
		2000	SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
		2001
		2002	if (!svp) croak ("Time::HiRes is required");
		2003	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
		2004
		2005	nvtime = INT2PTR (double (*)(), SvIV (*svp));
		2006	}
		2007
		2008	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		2009	}
		2010
		2011	SV *
		2012	new (char *klass, ...)
		2013	CODE:
		2014	{
		2015	struct coro *coro;
		2016	MAGIC *mg;
		2017	HV *hv;
		2018	int i;
		2019
		2020	Newz (0, coro, 1, struct coro);
		2021	coro->args = newAV ();
		2022	coro->flags = CF_NEW;
		2023
		2024	if (coro_first) coro_first->prev = coro;
		2025	coro->next = coro_first;
		2026	coro_first = coro;
		2027
		2028	coro->hv = hv = newHV ();
		2029	mg = sv_magicext ((SV *)hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char *)coro, 0);
		2030	mg->mg_flags |= MGf_DUP;
		2031	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		2032
		2033	av_extend (coro->args, items - 1);
		2034	for (i = 1; i < items; i++)
		2035	av_push (coro->args, newSVsv (ST (i)));
		2036	}
		2037	OUTPUT:
		2038	RETVAL
		2039
		2040	void
		2041	_set_stacklevel (...)
		2042	ALIAS:
		2043	Coro::State::transfer = 1
		2044	Coro::schedule = 2
		2045	Coro::cede = 3
		2046	Coro::cede_notself = 4
		2047	CODE:
		2048	coro_ssl_patch (aTHX_ cv, ix, &ST (0), items);
		2049
		2050	bool
		2051	_destroy (SV *coro_sv)
		2052	CODE:
		2053	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		2054	OUTPUT:
		2055	RETVAL
		2056
		2057	void
		2058	_exit (int code)
		2059	PROTOTYPE: $
		2060	CODE:
		2061	_exit (code);
		2062
		2063	int
		2064	cctx_stacksize (int new_stacksize = 0)
		2065	CODE:
		2066	RETVAL = cctx_stacksize;
		2067	if (new_stacksize)
		2068	{
		2069	cctx_stacksize = new_stacksize;
		2070	++cctx_gen;
		2071	}
		2072	OUTPUT:
		2073	RETVAL
		2074
		2075	int
		2076	cctx_max_idle (int max_idle = 0)
		2077	CODE:
		2078	RETVAL = cctx_max_idle;
		2079	if (max_idle > 1)
		2080	cctx_max_idle = max_idle;
		2081	OUTPUT:
		2082	RETVAL
		2083
		2084	int
		2085	cctx_count ()
		2086	CODE:
		2087	RETVAL = cctx_count;
		2088	OUTPUT:
		2089	RETVAL
		2090
		2091	int
		2092	cctx_idle ()
		2093	CODE:
		2094	RETVAL = cctx_idle;
		2095	OUTPUT:
		2096	RETVAL
		2097
		2098	void
		2099	list ()
		2100	PPCODE:
		2101	{
		2102	struct coro *coro;
		2103	for (coro = coro_first; coro; coro = coro->next)
		2104	if (coro->hv)
		2105	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
		2106	}
		2107
		2108	void
		2109	call (Coro::State coro, SV *coderef)
		2110	ALIAS:
		2111	eval = 1
		2112	CODE:
		2113	{
		2114	if (coro->mainstack && ((coro->flags & CF_RUNNING) || coro->slot))
		2115	{
		2116	struct coro temp;
		2117
		2118	if (!(coro->flags & CF_RUNNING))
235	{	2119	{
236	/* I never used formats, so how should I know how these are implemented? */	2120	PUTBACK;
237	/* my bold guess is as a simple, plain sub... */	2121	save_perl (aTHX_ &temp);
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	2122	load_perl (aTHX_ coro);
		2123	}
		2124
		2125	{
		2126	dSP;
		2127	ENTER;
		2128	SAVETMPS;
		2129	PUTBACK;
		2130	PUSHSTACK;
		2131	PUSHMARK (SP);
		2132
		2133	if (ix)
		2134	eval_sv (coderef, 0);
		2135	else
		2136	call_sv (coderef, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
		2137
		2138	POPSTACK;
		2139	SPAGAIN;
		2140	FREETMPS;
		2141	LEAVE;
		2142	PUTBACK;
		2143	}
		2144
		2145	if (!(coro->flags & CF_RUNNING))
		2146	{
		2147	save_perl (aTHX_ coro);
		2148	load_perl (aTHX_ &temp);
		2149	SPAGAIN;
239	}	2150	}
240	}	2151	}
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	}	2152	}
281		2153
282	static void	2154	SV *
283	LOAD(pTHX_ Coro__State c)	2155	is_ready (Coro::State coro)
284	{	2156	PROTOTYPE: $
285	PL_dowarn = c->dowarn;	2157	ALIAS:
286	GvAV (PL_defgv) = c->defav;	2158	is_ready = CF_READY
287	PL_curstackinfo = c->curstackinfo;	2159	is_running = CF_RUNNING
288	PL_curstack = c->curstack;	2160	is_new = CF_NEW
289	PL_mainstack = c->mainstack;	2161	is_destroyed = CF_DESTROYED
290	PL_stack_sp = c->stack_sp;	2162	CODE:
291	PL_op = c->op;	2163	RETVAL = boolSV (coro->flags & ix);
292	PL_curpad = c->curpad;	2164	OUTPUT:
293	PL_stack_base = c->stack_base;	2165	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		2166
		2167	void
		2168	throw (Coro::State self, SV *throw = &PL_sv_undef)
		2169	PROTOTYPE: $;$
		2170	CODE:
		2171	SvREFCNT_dec (self->throw);
		2172	self->throw = SvOK (throw) ? newSVsv (throw) : 0;
		2173
		2174	void
		2175	api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
		2176
		2177	SV *
		2178	has_cctx (Coro::State coro)
		2179	PROTOTYPE: $
		2180	CODE:
		2181	RETVAL = boolSV (!!coro->cctx);
		2182	OUTPUT:
		2183	RETVAL
		2184
		2185	int
		2186	is_traced (Coro::State coro)
		2187	PROTOTYPE: $
		2188	CODE:
		2189	RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
		2190	OUTPUT:
		2191	RETVAL
		2192
		2193	UV
		2194	rss (Coro::State coro)
		2195	PROTOTYPE: $
		2196	ALIAS:
		2197	usecount = 1
		2198	CODE:
		2199	switch (ix)
313	{	2200	{
314	dSP;	2201	case 0: RETVAL = coro_rss (aTHX_ coro); break;
315	CV *cv;	2202	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	}	2203	}
		2204	OUTPUT:
		2205	RETVAL
331		2206
332	PUTBACK;	2207	void
333	}	2208	force_cctx ()
334	}	2209	CODE:
		2210	struct coro *coro = SvSTATE (coro_current);
		2211	coro->cctx->idle_sp = 0;
335		2212
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	2213	void
337	STATIC void	2214	swap_defsv (Coro::State self)
338	destroy_stacks(pTHX)	2215	PROTOTYPE: $
339	{	2216	ALIAS:
340	dSP;	2217	swap_defav = 1
		2218	CODE:
		2219	if (!self->slot)
		2220	croak ("cannot swap state with coroutine that has no saved state");
		2221	else
		2222	{
		2223	SV **src = ix ? (SV **)&GvAV (PL_defgv) : &GvSV (PL_defgv);
		2224	SV **dst = ix ? (SV **)&self->slot->defav : (SV **)&self->slot->defsv;
341		2225
342	/* die does this while calling POPSTACK, but I just don't see why. */	2226	SV *tmp = *src; *src = *dst; *dst = tmp;
343	dounwind(-1);	2227	}
344		2228
345	/* is this ugly, I ask? */
346	while (PL_scopestack_ix)
347	LEAVE;
348
349	while (PL_curstackinfo->si_next)
350	PL_curstackinfo = PL_curstackinfo->si_next;
351
352	while (PL_curstackinfo)
353	{
354	PERL_SI *p = PL_curstackinfo->si_prev;
355
356	SvREFCNT_dec(PL_curstackinfo->si_stack);
357	Safefree(PL_curstackinfo->si_cxstack);
358	Safefree(PL_curstackinfo);
359	PL_curstackinfo = p;
360	}
361
362	if (PL_scopestack_ix != 0)
363	Perl_warner(aTHX_ WARN_INTERNAL,
364	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365	(long)PL_scopestack_ix);
366	if (PL_savestack_ix != 0)
367	Perl_warner(aTHX_ WARN_INTERNAL,
368	"Unbalanced saves: %ld more saves than restores\n",
369	(long)PL_savestack_ix);
370	if (PL_tmps_floor != -1)
371	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372	(long)PL_tmps_floor + 1);
373	/*
374	*/
375	Safefree(PL_tmps_stack);
376	Safefree(PL_markstack);
377	Safefree(PL_scopestack);
378	Safefree(PL_savestack);
379	Safefree(PL_retstack);
380	}
381
382	#define SUB_INIT "Coro::State::_newcoro"
383
384	MODULE = Coro::State PACKAGE = Coro::State	2229	MODULE = Coro::State PACKAGE = Coro
385
386	PROTOTYPES: ENABLE
387		2230
388	BOOT:	2231	BOOT:
389	if (!padlist_cache)	2232	{
390	padlist_cache = newHV ();	2233	int i;
391		2234
392	Coro::State	2235	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
393	_newprocess(args)	2236	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
394	SV * args	2237	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
		2238
		2239	coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
		2240	SvREADONLY_on (coro_current);
		2241
		2242	coro_stash = gv_stashpv ("Coro", TRUE);
		2243
		2244	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		2245	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		2246	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		2247	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		2248	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		2249	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		2250
		2251	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		2252	coro_ready[i] = newAV ();
		2253
		2254	{
		2255	SV *sv = coro_get_sv (aTHX_ "Coro::API", TRUE);
		2256
		2257	coroapi.schedule = api_schedule;
		2258	coroapi.cede = api_cede;
		2259	coroapi.cede_notself = api_cede_notself;
		2260	coroapi.ready = api_ready;
		2261	coroapi.is_ready = api_is_ready;
		2262	coroapi.nready = &coro_nready;
		2263	coroapi.current = coro_current;
		2264
		2265	GCoroAPI = &coroapi;
		2266	sv_setiv (sv, (IV)&coroapi);
		2267	SvREADONLY_on (sv);
		2268	}
		2269	}
		2270
		2271	void
		2272	_set_current (SV *current)
395	PROTOTYPE: $	2273	PROTOTYPE: $
		2274	CODE:
		2275	SvREFCNT_dec (SvRV (coro_current));
		2276	SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
		2277
		2278	void
		2279	_set_readyhook (SV *hook)
		2280	PROTOTYPE: $
396	CODE:	2281	CODE:
397	Coro__State coro;
398
399	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
400	croak ("Coro::State::newprocess expects an arrayref");
401		2282	LOCK;
402	New (0, coro, 1, struct coro);	2283	SvREFCNT_dec (coro_readyhook);
		2284	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
		2285	UNLOCK;
403		2286
404	coro->mainstack = 0; /* actual work is done inside transfer */	2287	int
405	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	2288	prio (Coro::State coro, int newprio = 0)
406		2289	ALIAS:
		2290	nice = 1
		2291	CODE:
		2292	{
407	RETVAL = coro;	2293	RETVAL = coro->prio;
408	OUTPUT:	2294
		2295	if (items > 1)
		2296	{
		2297	if (ix)
		2298	newprio = coro->prio - newprio;
		2299
		2300	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
		2301	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
		2302
		2303	coro->prio = newprio;
		2304	}
		2305	}
		2306	OUTPUT:
409	RETVAL	2307	RETVAL
410		2308
		2309	SV *
		2310	ready (SV *self)
		2311	PROTOTYPE: $
		2312	CODE:
		2313	RETVAL = boolSV (api_ready (self));
		2314	OUTPUT:
		2315	RETVAL
		2316
		2317	int
		2318	nready (...)
		2319	PROTOTYPE:
		2320	CODE:
		2321	RETVAL = coro_nready;
		2322	OUTPUT:
		2323	RETVAL
		2324
		2325	# for async_pool speedup
411	void	2326	void
412	transfer(prev,next)	2327	_pool_1 (SV *cb)
413	Coro::State_or_hashref prev	2328	CODE:
414	Coro::State_or_hashref next	2329	{
		2330	struct coro *coro = SvSTATE (coro_current);
		2331	HV *hv = (HV *)SvRV (coro_current);
		2332	AV *defav = GvAV (PL_defgv);
		2333	SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
		2334	AV *invoke_av;
		2335	int i, len;
		2336
		2337	if (!invoke)
		2338	{
		2339	SV *old = PL_diehook;
		2340	PL_diehook = 0;
		2341	SvREFCNT_dec (old);
		2342	croak ("\3async_pool terminate\2\n");
		2343	}
		2344
		2345	SvREFCNT_dec (coro->saved_deffh);
		2346	coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
		2347
		2348	hv_store (hv, "desc", sizeof ("desc") - 1,
		2349	newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
		2350
		2351	invoke_av = (AV *)SvRV (invoke);
		2352	len = av_len (invoke_av);
		2353
		2354	sv_setsv (cb, AvARRAY (invoke_av)[0]);
		2355
		2356	if (len > 0)
		2357	{
		2358	av_fill (defav, len - 1);
		2359	for (i = 0; i < len; ++i)
		2360	av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
		2361	}
		2362
		2363	SvREFCNT_dec (invoke);
		2364	}
		2365
		2366	void
		2367	_pool_2 (SV *cb)
		2368	CODE:
		2369	{
		2370	struct coro *coro = SvSTATE (coro_current);
		2371
		2372	sv_setsv (cb, &PL_sv_undef);
		2373
		2374	SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh;
		2375	coro->saved_deffh = 0;
		2376
		2377	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
		2378	|| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
		2379	{
		2380	SV *old = PL_diehook;
		2381	PL_diehook = 0;
		2382	SvREFCNT_dec (old);
		2383	croak ("\3async_pool terminate\2\n");
		2384	}
		2385
		2386	av_clear (GvAV (PL_defgv));
		2387	hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
		2388	newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
		2389
		2390	coro->prio = 0;
		2391
		2392	if (coro->cctx && (coro->cctx->flags & CC_TRACE))
		2393	api_trace (coro_current, 0);
		2394
		2395	av_push (av_async_pool, newSVsv (coro_current));
		2396	}
		2397
		2398	#if 0
		2399
		2400	void
		2401	_generator_call (...)
		2402	PROTOTYPE: @
		2403	PPCODE:
		2404	fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
		2405	xxxx
		2406	abort ();
		2407
		2408	SV *
		2409	gensub (SV *sub, ...)
		2410	PROTOTYPE: &;@
415	CODE:	2411	CODE:
		2412	{
		2413	struct coro *coro;
		2414	MAGIC *mg;
		2415	CV *xcv;
		2416	CV *ncv = (CV *)newSV_type (SVt_PVCV);
		2417	int i;
416		2418
417	if (prev != next)	2419	CvGV (ncv) = CvGV (cv);
		2420	CvFILE (ncv) = CvFILE (cv);
		2421
		2422	Newz (0, coro, 1, struct coro);
		2423	coro->args = newAV ();
		2424	coro->flags = CF_NEW;
		2425
		2426	av_extend (coro->args, items - 1);
		2427	for (i = 1; i < items; i++)
		2428	av_push (coro->args, newSVsv (ST (i)));
		2429
		2430	CvISXSUB_on (ncv);
		2431	CvXSUBANY (ncv).any_ptr = (void *)coro;
		2432
		2433	xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
		2434
		2435	CvXSUB (ncv) = CvXSUB (xcv);
		2436	CvANON_on (ncv);
		2437
		2438	mg = sv_magicext ((SV *)ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char *)coro, 0);
		2439	RETVAL = newRV_noinc ((SV *)ncv);
		2440	}
		2441	OUTPUT:
		2442	RETVAL
		2443
		2444	#endif
		2445
		2446
		2447	MODULE = Coro::State PACKAGE = Coro::AIO
		2448
		2449	void
		2450	_get_state (SV *self)
		2451	PPCODE:
		2452	{
		2453	AV *defav = GvAV (PL_defgv);
		2454	AV *av = newAV ();
		2455	int i;
		2456	SV *data_sv = newSV (sizeof (struct io_state));
		2457	struct io_state *data = (struct io_state *)SvPVX (data_sv);
		2458	SvCUR_set (data_sv, sizeof (struct io_state));
		2459	SvPOK_only (data_sv);
		2460
		2461	data->errorno = errno;
		2462	data->laststype = PL_laststype;
		2463	data->laststatval = PL_laststatval;
		2464	data->statcache = PL_statcache;
		2465
		2466	av_extend (av, AvFILLp (defav) + 1 + 1);
		2467
		2468	for (i = 0; i <= AvFILLp (defav); ++i)
		2469	av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
		2470
		2471	av_push (av, data_sv);
		2472
		2473	XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		2474
		2475	api_ready (self);
		2476	}
		2477
		2478	void
		2479	_set_state (SV *state)
		2480	PROTOTYPE: $
		2481	PPCODE:
		2482	{
		2483	AV *av = (AV *)SvRV (state);
		2484	struct io_state *data = (struct io_state *)SvPVX (AvARRAY (av)[AvFILLp (av)]);
		2485	int i;
		2486
		2487	errno = data->errorno;
		2488	PL_laststype = data->laststype;
		2489	PL_laststatval = data->laststatval;
		2490	PL_statcache = data->statcache;
		2491
		2492	EXTEND (SP, AvFILLp (av));
		2493	for (i = 0; i < AvFILLp (av); ++i)
		2494	PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
		2495	}
		2496
		2497
		2498	MODULE = Coro::State PACKAGE = Coro::AnyEvent
		2499
		2500	BOOT:
		2501	sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
		2502
		2503	SV *
		2504	_schedule (...)
		2505	PROTOTYPE: @
		2506	CODE:
		2507	{
		2508	static int incede;
		2509
		2510	api_cede_notself ();
		2511
		2512	++incede;
		2513	while (coro_nready >= incede && api_cede ())
		2514	;
		2515
		2516	sv_setsv (sv_activity, &PL_sv_undef);
		2517	if (coro_nready >= incede)
418	{	2518	{
		2519	PUSHMARK (SP);
419	PUTBACK;	2520	PUTBACK;
420	SAVE (aTHX_ prev);	2521	call_pv ("Coro::AnyEvent::_activity", G_DISCARD | G_EVAL);
421
422	/*
423	* this could be done in newprocess which would lead to
424	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425	* code here, but lazy allocation of stacks has also
426	* some virtues and the overhead of the if() is nil.
427	*/
428	if (next->mainstack)
429	{
430	LOAD (aTHX_ next);
431	next->mainstack = 0; /* unnecessary but much cleaner */
432	SPAGAIN;
433	}
434	else
435	{
436	/*
437	* emulate part of the perl startup here.
438	*/
439	UNOP myop;
440
441	init_stacks (); /* from perl.c */
442	PL_op = (OP *)&myop;
443	/*PL_curcop = 0;*/
444	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445
446	SPAGAIN;
447	Zero(&myop, 1, UNOP);
448	myop.op_next = Nullop;
449	myop.op_flags = OPf_WANT_VOID;
450
451	PUSHMARK(SP);
452	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453	PUTBACK;
454	/*
455	* the next line is slightly wrong, as PL_op->op_next
456	* is actually being executed so we skip the first op.
457	* that doesn't matter, though, since it is only
458	* pp_nextstate and we never return...
459	*/
460	PL_op = Perl_pp_entersub(aTHX);
461	SPAGAIN;
462
463	ENTER;
464	}
465	}
466
467	void
468	DESTROY(coro)
469	Coro::State coro
470	CODE:
471
472	if (coro->mainstack)
473	{
474	struct coro temp;
475
476	PUTBACK;
477	SAVE(aTHX_ (&temp));
478	LOAD(aTHX_ coro);
479
480	destroy_stacks ();
481	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483	LOAD((&temp));
484	SPAGAIN;	2522	SPAGAIN;
485	}	2523	}
486		2524
487	SvREFCNT_dec (coro->args);	2525	--incede;
488	Safefree (coro);	2526	}
489		2527
490		2528
		2529	MODULE = Coro::State PACKAGE = PerlIO::cede
		2530
		2531	BOOT:
		2532	PerlIO_define_layer (aTHX_ &PerlIO_cede);
		2533

Diff Legend

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