[ViewVC] Diff of: cvs/Coro/Coro/State.xs

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs. Revision 1.270 by root, Fri Nov 14 07:22:11 2008 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.270 by root, Fri Nov 14 07:22:11 2008 UTC