ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.133 by root, Thu Jan 4 20:14:19 2007 UTC

		1	#include "libcoro/coro.c"
		2
1	#include "EXTERN.h"	3	#include "EXTERN.h"
2	#include "perl.h"	4	#include "perl.h"
3	#include "XSUB.h"	5	#include "XSUB.h"
4		6
5	#if 0	7	#include "patchlevel.h"
6	# define CHK(x) (void *)0	8
		9	#include <stdio.h>
		10	#include <errno.h>
		11	#include <assert.h>
		12
		13	#ifdef HAVE_MMAP
		14	# include <unistd.h>
		15	# include <sys/mman.h>
		16	# ifndef MAP_ANONYMOUS
		17	# ifdef MAP_ANON
		18	# define MAP_ANONYMOUS MAP_ANON
		19	# else
		20	# undef HAVE_MMAP
		21	# endif
		22	# endif
		23	# include <limits.h>
		24	# ifndef PAGESIZE
		25	# define PAGESIZE pagesize
		26	# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
		27	static long pagesize;
		28	# else
		29	# define BOOT_PAGESIZE (void)0
		30	# endif
7	#else	31	#else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	32	# define PAGESIZE 0
		33	# define BOOT_PAGESIZE (void)0
		34	#endif
		35
		36	#if USE_VALGRIND
		37	# include <valgrind/valgrind.h>
		38	#endif
		39
		40	/* the maximum number of idle cctx that will be pooled */
		41	#define MAX_IDLE_CCTX 8
		42
		43	#define PERL_VERSION_ATLEAST(a,b,c) \
		44	(PERL_REVISION > (a) \
		45	|| (PERL_REVISION == (a) \
		46	&& (PERL_VERSION > (b) \
		47	|| (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
		48
		49	#if !PERL_VERSION_ATLEAST (5,6,0)
		50	# ifndef PL_ppaddr
		51	# define PL_ppaddr ppaddr
9	#endif	52	# endif
		53	# ifndef call_sv
		54	# define call_sv perl_call_sv
		55	# endif
		56	# ifndef get_sv
		57	# define get_sv perl_get_sv
		58	# endif
		59	# ifndef get_cv
		60	# define get_cv perl_get_cv
		61	# endif
		62	# ifndef IS_PADGV
		63	# define IS_PADGV(v) 0
		64	# endif
		65	# ifndef IS_PADCONST
		66	# define IS_PADCONST(v) 0
		67	# endif
		68	#endif
10		69
		70	/* 5.8.7 */
		71	#ifndef SvRV_set
		72	# define SvRV_set(s,v) SvRV(s) = (v)
		73	#endif
		74
		75	#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
		76	# undef STACKGUARD
		77	#endif
		78
		79	#ifndef STACKGUARD
		80	# define STACKGUARD 0
		81	#endif
		82
		83	/* prefer perl internal functions over our own? */
		84	#ifndef PREFER_PERL_FUNCTIONS
		85	# define PREFER_PERL_FUNCTIONS 0
		86	#endif
		87
		88	/* The next macro should declare a variable stacklevel that contains and approximation
		89	* to the current C stack pointer. Its property is that it changes with each call
		90	* and should be unique. */
		91	#define dSTACKLEVEL int stacklevel
		92	#define STACKLEVEL ((void *)&stacklevel)
		93
		94	#define IN_DESTRUCT (PL_main_cv == Nullcv)
		95
		96	#if __GNUC__ >= 3
		97	# define attribute(x) __attribute__(x)
		98	# define BARRIER __asm__ __volatile__ ("" : : : "memory")
		99	#else
		100	# define attribute(x)
		101	# define BARRIER
		102	#endif
		103
		104	#define NOINLINE attribute ((noinline))
		105
		106	#include "CoroAPI.h"
		107
		108	#ifdef USE_ITHREADS
		109	static perl_mutex coro_mutex;
		110	# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
		111	# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
		112	#else
		113	# define LOCK (void)0
		114	# define UNLOCK (void)0
		115	#endif
		116
		117	struct io_state
		118	{
		119	int errorno;
		120	I32 laststype;
		121	int laststatval;
		122	Stat_t statcache;
		123	};
		124
		125	static struct CoroAPI coroapi;
		126	static AV *main_mainstack; /* used to differentiate between $main and others */
		127	static HV *coro_state_stash, *coro_stash;
		128	static SV *coro_mortal; /* will be freed after next transfer */
		129
		130	static struct coro_cctx *cctx_first;
		131	static int cctx_count, cctx_idle;
		132
		133	/* this is a structure representing a c-level coroutine */
		134	typedef struct coro_cctx {
		135	struct coro_cctx *next;
		136
		137	/* the stack */
		138	void *sptr;
		139	long ssize; /* positive == mmap, otherwise malloc */
		140
		141	/* cpu state */
		142	void *idle_sp; /* sp of top-level transfer/schedule/cede call */
		143	JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
		144	JMPENV *top_env;
		145	coro_context cctx;
		146
		147	int inuse;
		148
		149	#if USE_VALGRIND
		150	int valgrind_id;
		151	#endif
		152	} coro_cctx;
		153
		154	enum {
		155	CF_RUNNING = 0x0001, /* coroutine is running */
		156	CF_READY = 0x0002, /* coroutine is ready */
		157	CF_NEW = 0x0004, /* has never been switched to */
		158	CF_DESTROYED = 0x0008, /* coroutine data has been freed */
		159	};
		160
		161	/* this is a structure representing a perl-level coroutine */
11	struct coro {	162	struct coro {
12	U8 dowarn;	163	/* the c coroutine allocated to this perl coroutine, if any */
13	AV *defav;	164	coro_cctx *cctx;
		165
		166	/* data associated with this coroutine (initial args) */
		167	AV *args;
		168	int refcnt;
		169	int save; /* CORO_SAVE flags */
		170	int flags; /* CF_ flags */
		171
		172	/* optionally saved, might be zero */
		173	AV *defav; /* @_ */
		174	SV *defsv; /* $_ */
		175	SV *errsv; /* $@ */
		176	SV *irssv; /* $/ */
		177	SV *irssv_sv; /* real $/ cache */
14		178
15	PERL_SI *curstackinfo;	179	#define VAR(name,type) type name;
16	AV *curstack;	180	# include "state.h"
17	AV *mainstack;	181	#undef VAR
18	SV **stack_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		182
41	AV *args;	183	/* coro process data */
		184	int prio;
42	};	185	};
43		186
44	typedef struct coro *Coro__State;	187	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	188	typedef struct coro *Coro__State_or_hashref;
46		189
47	static HV *padlist_cache;	190	static AV *
48		191	coro_clone_padlist (CV *cv)
49	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *
51	clone_padlist (AV *protopadlist)
52	{	192	{
53	AV *av;	193	AV *padlist = CvPADLIST (cv);
54	I32 ix;
55	AV *protopad_name = (AV *) * av_fetch (protopadlist, 0, FALSE);
56	AV *protopad = (AV *) * av_fetch (protopadlist, 1, FALSE);
57	SV **pname = AvARRAY (protopad_name);
58	SV **ppad = AvARRAY (protopad);
59	I32 fname = AvFILLp (protopad_name);
60	I32 fpad = AvFILLp (protopad);
61	AV *newpadlist, *newpad_name, *newpad;	194	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		195
72	newpadlist = newAV ();	196	newpadlist = newAV ();
73	AvREAL_off (newpadlist);	197	AvREAL_off (newpadlist);
74	av_store (newpadlist, 0, (SV *) newpad_name);	198	#if PERL_VERSION_ATLEAST (5,9,0)
		199	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
		200	#else
		201	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
		202	#endif
		203	newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
		204	--AvFILLp (padlist);
		205
		206	av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75	av_store (newpadlist, 1, (SV *) newpad);	207	av_store (newpadlist, 1, (SV *)newpad);
76		208
77	av = newAV (); /* will be @_ */	209	return newpadlist;
78	av_extend (av, 0);	210	}
79	av_store (newpad, 0, (SV *) av);
80	AvFLAGS (av) = AVf_REIFY;
81		211
82	for (ix = fpad; ix > 0; ix--)	212	static void
		213	free_padlist (AV *padlist)
		214	{
		215	/* may be during global destruction */
		216	if (SvREFCNT (padlist))
83	{	217	{
84	SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;	218	I32 i = AvFILLp (padlist);
85	if (namesv && namesv != &PL_sv_undef)	219	while (i >= 0)
86	{	220	{
87	char *name = SvPVX (namesv); /* XXX */	221	SV **svp = av_fetch (padlist, i--, FALSE);
88	if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')	222	if (svp)
89	{ /* lexical from outside? */
90	npad[ix] = SvREFCNT_inc (ppad[ix]);
91	}	223	{
92	else
93	{ /* our own lexical */
94	SV *sv;	224	SV *sv;
95	if (*name == '&')	225	while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96	sv = SvREFCNT_inc (ppad[ix]);	226	SvREFCNT_dec (sv);
97	else if (*name == '@')	227
98	sv = (SV *) newAV ();	228	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	}	229	}
107	}	230	}
108	else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))	231
109	{	232	SvREFCNT_dec ((SV*)padlist);
110	npad[ix] = SvREFCNT_inc (ppad[ix]);	233	}
111	}	234	}
		235
		236	static int
		237	coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
		238	{
		239	AV *padlist;
		240	AV *av = (AV *)mg->mg_obj;
		241
		242	/* casting is fun. */
		243	while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
		244	free_padlist (padlist);
		245
		246	SvREFCNT_dec (av);
		247
		248	return 0;
		249	}
		250
		251	#define PERL_MAGIC_coro PERL_MAGIC_ext
		252
		253	static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
		254
		255	#define CORO_MAGIC(cv) \
		256	SvMAGIC (cv) \
		257	? SvMAGIC (cv)->mg_type == PERL_MAGIC_coro \
		258	? SvMAGIC (cv) \
		259	: mg_find ((SV *)cv, PERL_MAGIC_coro) \
		260	: 0
		261
		262	/* the next two functions merely cache the padlists */
		263	static void
		264	get_padlist (CV *cv)
		265	{
		266	MAGIC *mg = CORO_MAGIC (cv);
		267	AV *av;
		268
		269	if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
		270	CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
		271	else
		272	{
		273	#if PREFER_PERL_FUNCTIONS
		274	/* this is probably cleaner, but also slower? */
		275	CV *cp = Perl_cv_clone (cv);
		276	CvPADLIST (cv) = CvPADLIST (cp);
		277	CvPADLIST (cp) = 0;
		278	SvREFCNT_dec (cp);
		279	#else
		280	CvPADLIST (cv) = coro_clone_padlist (cv);
		281	#endif
		282	}
		283	}
		284
		285	static void
		286	put_padlist (CV *cv)
		287	{
		288	MAGIC *mg = CORO_MAGIC (cv);
		289	AV *av;
		290
		291	if (!mg)
		292	{
		293	sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
		294	mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
		295	mg->mg_virtual = &vtbl_coro;
		296	mg->mg_obj = (SV *)newAV ();
		297	}
		298
		299	av = (AV *)mg->mg_obj;
		300
		301	if (AvFILLp (av) >= AvMAX (av))
		302	av_extend (av, AvMAX (av) + 1);
		303
		304	AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
		305	}
		306
		307	#define SB do {
		308	#define SE } while (0)
		309
		310	#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
		311
		312	static void
		313	load_perl (Coro__State c)
		314	{
		315	#define VAR(name,type) PL_ ## name = c->name;
		316	# include "state.h"
		317	#undef VAR
		318
		319	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		320	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		321	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		322	if (c->irssv)
		323	{
		324	if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
		325	SvREFCNT_dec (c->irssv);
112	else	326	else
113	{	327	{
114	SV *sv = NEWSV (0, 0);	328	REPLACE_SV (PL_rs, c->irssv);
115	SvPADTMP_on (sv);	329	if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
116	npad[ix] = sv;	330	sv_setsv (c->irssv_sv, PL_rs);
117	}	331	}
118	}	332	}
119		333
120	#if 0 /* NONOTUNDERSTOOD */	334	{
121	/* Now that vars are all in place, clone nested closures. */	335	dSP;
		336	CV *cv;
122		337
123	for (ix = fpad; ix > 0; ix--) {	338	/* now do the ugly restore mess */
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	339	while ((cv = (CV *)POPs))
125	if (namesv
126	&& namesv != &PL_sv_undef
127	&& !(SvFLAGS(namesv) & SVf_FAKE)
128	&& *SvPVX(namesv) == '&'
129	&& CvCLONE(ppad[ix]))
130	{	340	{
131	CV *kid = cv_clone((CV*)ppad[ix]);	341	put_padlist (cv); /* mark this padlist as available */
132	SvREFCNT_dec(ppad[ix]);	342	CvDEPTH (cv) = PTR2IV (POPs);
133	CvCLONE_on(kid);	343	CvPADLIST (cv) = (AV *)POPs;
134	SvPADMY_on(kid);
135	npad[ix] = (SV*)kid;
136	}	344	}
137	}
138	#endif
139		345
140	return newpadlist;	346	PUTBACK;
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);
159	}	347	}
160	}	348	}
161		349
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	350	static void
189	SAVE(pTHX_ Coro__State c)	351	save_perl (Coro__State c)
190	{	352	{
191	{	353	{
192	dSP;	354	dSP;
193	I32 cxix = cxstack_ix;	355	I32 cxix = cxstack_ix;
		356	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	357	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		358
197	/*	359	/*
198	* the worst thing you can imagine happens first - we have to save	360	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	361	* (and reinitialize) all cv's in the whole callchain :(
200	*/	362	*/
201		363
		364	EXTEND (SP, 3 + 1);
202	PUSHs (Nullsv);	365	PUSHs (Nullsv);
203	/* this loop was inspired by pp_caller */	366	/* this loop was inspired by pp_caller */
204	for (;;)	367	for (;;)
205	{	368	{
206	while (cxix >= 0)	369	while (cxix >= 0)
207	{	370	{
208	PERL_CONTEXT *cx = &ccstk[cxix--];	371	PERL_CONTEXT *cx = &ccstk[cxix--];
209		372
210	if (CxTYPE(cx) == CXt_SUB)	373	if (CxTYPE (cx) == CXt_SUB)
211	{	374	{
212	CV *cv = cx->blk_sub.cv;	375	CV *cv = cx->blk_sub.cv;
		376
213	if (CvDEPTH(cv))	377	if (CvDEPTH (cv))
214	{	378	{
215	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));
217	#endif
218	EXTEND (SP, 3);	379	EXTEND (SP, 3);
219	PUSHs ((SV *)CvDEPTH(cv));
220	PUSHs ((SV *)CvPADLIST(cv));	380	PUSHs ((SV *)CvPADLIST (cv));
		381	PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
221	PUSHs ((SV *)cv);	382	PUSHs ((SV *)cv);
222		383
		384	CvDEPTH (cv) = 0;
223	get_padlist (cv);	385	get_padlist (cv);
224
225	CvDEPTH(cv) = 0;
226	#ifdef USE_THREADS
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	}	386	}
233	}
234	else if (CxTYPE(cx) == CXt_FORMAT)
235	{
236	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}	387	}
240	}	388	}
241		389
242	if (top_si->si_type == PERLSI_MAIN)	390	if (top_si->si_type == PERLSI_MAIN)
243	break;	391	break;
…		…
248	}	396	}
249		397
250	PUTBACK;	398	PUTBACK;
251	}	399	}
252		400
253	c->dowarn = PL_dowarn;	401	c->defav = c->save & CORO_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
254	c->defav = GvAV (PL_defgv);	402	c->defsv = c->save & CORO_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
255	c->curstackinfo = PL_curstackinfo;	403	c->errsv = c->save & CORO_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
256	c->curstack = PL_curstack;	404	c->irssv = c->save & CORO_SAVE_IRSSV ? SvREFCNT_inc (PL_rs) : 0;
257	c->mainstack = PL_mainstack;	405
258	c->stack_sp = PL_stack_sp;	406	#define VAR(name,type)c->name = PL_ ## name;
259	c->op = PL_op;	407	# include "state.h"
260	c->curpad = PL_curpad;	408	#undef VAR
		409	}
		410
		411	/*
		412	* allocate various perl stacks. This is an exact copy
		413	* of perl.c:init_stacks, except that it uses less memory
		414	* on the (sometimes correct) assumption that coroutines do
		415	* not usually need a lot of stackspace.
		416	*/
		417	#if PREFER_PERL_FUNCTIONS
		418	# define coro_init_stacks init_stacks
		419	#else
		420	static void
		421	coro_init_stacks ()
		422	{
		423	PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT));
		424	PL_curstackinfo->si_type = PERLSI_MAIN;
		425	PL_curstack = PL_curstackinfo->si_stack;
		426	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		427
		428	PL_stack_base = AvARRAY(PL_curstack);
261	c->stack_base = PL_stack_base;	429	PL_stack_sp = PL_stack_base;
262	c->stack_max = PL_stack_max;	430	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
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	}
281		431
282	static void	432	New(50,PL_tmps_stack,128,SV*);
283	LOAD(pTHX_ Coro__State c)	433	PL_tmps_floor = -1;
284	{	434	PL_tmps_ix = -1;
285	PL_dowarn = c->dowarn;	435	PL_tmps_max = 128;
286	GvAV (PL_defgv) = c->defav;	436
287	PL_curstackinfo = c->curstackinfo;	437	New(54,PL_markstack,32,I32);
288	PL_curstack = c->curstack;
289	PL_mainstack = c->mainstack;
290	PL_stack_sp = c->stack_sp;
291	PL_op = c->op;
292	PL_curpad = c->curpad;
293	PL_stack_base = c->stack_base;
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;	438	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	439	PL_markstack_max = PL_markstack + 32;
302	PL_scopestack = c->scopestack;	440
303	PL_scopestack_ix = c->scopestack_ix;	441	#ifdef SET_MARK_OFFSET
304	PL_scopestack_max = c->scopestack_max;	442	SET_MARK_OFFSET;
305	PL_savestack = c->savestack;	443	#endif
306	PL_savestack_ix = c->savestack_ix;	444
307	PL_savestack_max = c->savestack_max;	445	New(54,PL_scopestack,32,I32);
308	PL_retstack = c->retstack;	446	PL_scopestack_ix = 0;
309	PL_retstack_ix = c->retstack_ix;	447	PL_scopestack_max = 32;
310	PL_retstack_max = c->retstack_max;	448
311	PL_curcop = c->curcop;	449	New(54,PL_savestack,64,ANY);
		450	PL_savestack_ix = 0;
		451	PL_savestack_max = 64;
		452
		453	#if !PERL_VERSION_ATLEAST (5,9,0)
		454	New(54,PL_retstack,16,OP*);
		455	PL_retstack_ix = 0;
		456	PL_retstack_max = 16;
		457	#endif
		458	}
		459	#endif
		460
		461	/*
		462	* destroy the stacks, the callchain etc...
		463	*/
		464	static void
		465	coro_destroy_stacks ()
		466	{
		467	if (!IN_DESTRUCT)
		468	{
		469	/* restore all saved variables and stuff */
		470	LEAVE_SCOPE (0);
		471	assert (PL_tmps_floor == -1);
		472
		473	/* free all temporaries */
		474	FREETMPS;
		475	assert (PL_tmps_ix == -1);
		476
		477	POPSTACK_TO (PL_mainstack);
		478	}
		479
		480	while (PL_curstackinfo->si_next)
		481	PL_curstackinfo = PL_curstackinfo->si_next;
		482
		483	while (PL_curstackinfo)
		484	{
		485	PERL_SI *p = PL_curstackinfo->si_prev;
		486
		487	if (!IN_DESTRUCT)
		488	SvREFCNT_dec (PL_curstackinfo->si_stack);
		489
		490	Safefree (PL_curstackinfo->si_cxstack);
		491	Safefree (PL_curstackinfo);
		492	PL_curstackinfo = p;
		493	}
		494
		495	Safefree (PL_tmps_stack);
		496	Safefree (PL_markstack);
		497	Safefree (PL_scopestack);
		498	Safefree (PL_savestack);
		499	#if !PERL_VERSION_ATLEAST (5,9,0)
		500	Safefree (PL_retstack);
		501	#endif
		502	}
		503
		504	static void
		505	setup_coro (struct coro *coro)
		506	{
		507	/*
		508	* emulate part of the perl startup here.
		509	*/
		510
		511	coro_init_stacks ();
		512
		513	PL_curcop = &PL_compiling;
		514	PL_in_eval = EVAL_NULL;
		515	PL_curpm = 0;
		516	PL_localizing = 0;
		517	PL_dirty = 0;
		518	PL_restartop = 0;
312		519
313	{	520	{
314	dSP;	521	dSP;
315	CV *cv;	522	LOGOP myop;
316		523
317	/* now do the ugly restore mess */	524	SvREFCNT_dec (GvAV (PL_defgv));
318	while ((cv = (CV *)POPs))	525	GvAV (PL_defgv) = coro->args; coro->args = 0;
		526
		527	Zero (&myop, 1, LOGOP);
		528	myop.op_next = Nullop;
		529	myop.op_flags = OPf_WANT_VOID;
		530
		531	PUSHMARK (SP);
		532	XPUSHs ((SV *)get_cv ("Coro::State::_coro_init", FALSE));
		533	PUTBACK;
		534	PL_op = (OP *)&myop;
		535	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		536	SPAGAIN;
		537	}
		538
		539	ENTER; /* necessary e.g. for dounwind */
		540	}
		541
		542	static void
		543	free_coro_mortal ()
		544	{
		545	if (coro_mortal)
		546	{
		547	SvREFCNT_dec (coro_mortal);
		548	coro_mortal = 0;
		549	}
		550	}
		551
		552	/* inject a fake call to Coro::State::_cctx_init into the execution */
		553	static void NOINLINE
		554	prepare_cctx (coro_cctx *cctx)
		555	{
		556	dSP;
		557	LOGOP myop;
		558
		559	Zero (&myop, 1, LOGOP);
		560	myop.op_next = PL_op;
		561	myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
		562
		563	PUSHMARK (SP);
		564	EXTEND (SP, 2);
		565	PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
		566	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
		567	PUTBACK;
		568	PL_op = (OP *)&myop;
		569	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		570	SPAGAIN;
		571	}
		572
		573	static void
		574	coro_run (void *arg)
		575	{
		576	/* coro_run is the alternative tail of transfer(), so unlock here. */
		577	UNLOCK;
		578
		579	/*
		580	* this is a _very_ stripped down perl interpreter ;)
		581	*/
		582	PL_top_env = &PL_start_env;
		583
		584	/* inject call to cctx_init */
		585	prepare_cctx ((coro_cctx *)arg);
		586
		587	/* somebody will hit me for both perl_run and PL_restartop */
		588	PL_restartop = PL_op;
		589	perl_run (PL_curinterp);
		590
		591	fputs ("FATAL: C coroutine fell over the edge of the world, aborting. Did you call exit in a coroutine?\n", stderr);
		592	abort ();
		593	}
		594
		595	static coro_cctx *
		596	cctx_new ()
		597	{
		598	coro_cctx *cctx;
		599
		600	++cctx_count;
		601
		602	Newz (0, cctx, 1, coro_cctx);
		603
		604	#if HAVE_MMAP
		605
		606	cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
		607	/* mmap supposedly does allocate-on-write for us */
		608	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
		609
		610	if (cctx->sptr == (void *)-1)
		611	{
		612	perror ("FATAL: unable to mmap stack for coroutine");
		613	_exit (EXIT_FAILURE);
		614	}
		615
		616	# if STACKGUARD
		617	mprotect (cctx->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
		618	# endif
		619
		620	#else
		621
		622	cctx->ssize = STACKSIZE * (long)sizeof (long);
		623	New (0, cctx->sptr, STACKSIZE, long);
		624
		625	if (!cctx->sptr)
		626	{
		627	perror ("FATAL: unable to malloc stack for coroutine");
		628	_exit (EXIT_FAILURE);
		629	}
		630
		631	#endif
		632
		633	#if USE_VALGRIND
		634	cctx->valgrind_id = VALGRIND_STACK_REGISTER (
		635	STACKGUARD * PAGESIZE + (char *)cctx->sptr,
		636	cctx->ssize + (char *)cctx->sptr
		637	);
		638	#endif
		639
		640	coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, cctx->ssize);
		641
		642	return cctx;
		643	}
		644
		645	static void
		646	cctx_destroy (coro_cctx *cctx)
		647	{
		648	if (!cctx)
		649	return;
		650
		651	--cctx_count;
		652
		653	#if USE_VALGRIND
		654	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		655	#endif
		656
		657	#if HAVE_MMAP
		658	munmap (cctx->sptr, cctx->ssize);
		659	#else
		660	Safefree (cctx->sptr);
		661	#endif
		662
		663	Safefree (cctx);
		664	}
		665
		666	static coro_cctx *
		667	cctx_get ()
		668	{
		669	coro_cctx *cctx;
		670
		671	if (cctx_first)
		672	{
		673	cctx = cctx_first;
		674	cctx_first = cctx->next;
		675	--cctx_idle;
		676	}
		677	else
		678	{
		679	cctx = cctx_new ();
		680	PL_op = PL_op->op_next;
		681	}
		682
		683	return cctx;
		684	}
		685
		686	static void
		687	cctx_put (coro_cctx *cctx)
		688	{
		689	/* free another cctx if overlimit */
		690	if (cctx_idle >= MAX_IDLE_CCTX)
		691	{
		692	coro_cctx *first = cctx_first;
		693	cctx_first = first->next;
		694	--cctx_idle;
		695
		696	assert (!first->inuse);
		697	cctx_destroy (first);
		698	}
		699
		700	++cctx_idle;
		701	cctx->next = cctx_first;
		702	cctx_first = cctx;
		703	}
		704
		705	/* never call directly, always through the coro_state_transfer global variable */
		706	static void NOINLINE
		707	transfer (struct coro *prev, struct coro *next)
		708	{
		709	dSTACKLEVEL;
		710
		711	/* sometimes transfer is only called to set idle_sp */
		712	if (!next)
		713	{
		714	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		715	assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
		716	}
		717	else if (prev != next)
		718	{
		719	coro_cctx *prev__cctx;
		720
		721	if (prev->flags & CF_NEW)
		722	{
		723	/* create a new empty context */
		724	Newz (0, prev->cctx, 1, coro_cctx);
		725	prev->cctx->inuse = 1;
		726	prev->flags &= ~CF_NEW;
		727	prev->flags |= CF_RUNNING;
		728	}
		729
		730	/*TODO: must not croak here */
		731	if (!prev->flags & CF_RUNNING)
		732	croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
		733
		734	if (next->flags & CF_RUNNING)
		735	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		736
		737	if (next->flags & CF_DESTROYED)
		738	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		739
		740	prev->flags &= ~CF_RUNNING;
		741	next->flags |= CF_RUNNING;
		742
		743	LOCK;
		744
		745	if (next->flags & CF_NEW)
		746	{
		747	/* need to start coroutine */
		748	next->flags &= ~CF_NEW;
		749	/* first get rid of the old state */
		750	save_perl (prev);
		751	/* setup coroutine call */
		752	setup_coro (next);
		753	/* need a new stack */
		754	assert (!next->cctx);
		755	}
		756	else
		757	{
		758	/* coroutine already started */
		759	save_perl (prev);
		760	load_perl (next);
		761	}
		762
		763	prev__cctx = prev->cctx;
		764
		765	/* possibly "free" the cctx */
		766	if (prev__cctx->idle_sp == STACKLEVEL)
		767	{
		768	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		769	assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
		770
		771	prev->cctx = 0;
		772
		773	cctx_put (prev__cctx);
		774	prev__cctx->inuse = 0;
		775	}
		776
		777	if (!next->cctx)
		778	{
		779	next->cctx = cctx_get ();
		780	assert (!next->cctx->inuse);
		781	next->cctx->inuse = 1;
		782	}
		783
		784	if (prev__cctx != next->cctx)
		785	{
		786	prev__cctx->top_env = PL_top_env;
		787	PL_top_env = next->cctx->top_env;
		788	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		789	}
		790
		791	free_coro_mortal ();
		792	UNLOCK;
		793	}
		794	}
		795
		796	struct transfer_args
		797	{
		798	struct coro *prev, *next;
		799	};
		800
		801	#define TRANSFER(ta) transfer ((ta).prev, (ta).next)
		802
		803	static int
		804	coro_state_destroy (struct coro *coro)
		805	{
		806	if (coro->refcnt--)
		807	return 0;
		808
		809	if (coro->flags & CF_DESTROYED)
		810	return 0;
		811
		812	coro->flags |= CF_DESTROYED;
		813
		814	if (coro->mainstack && coro->mainstack != main_mainstack)
		815	{
		816	assert (!(coro->flags & CF_RUNNING));
		817
		818	struct coro temp;
		819	Zero (&temp, 1, struct coro);
		820	temp.save = CORO_SAVE_ALL;
		821
		822	if (coro->flags & CF_RUNNING)
		823	croak ("FATAL: tried to destroy currently running coroutine");
		824
		825	save_perl (&temp);
		826	load_perl (coro);
		827
		828	coro_destroy_stacks ();
		829
		830	load_perl (&temp); /* this will get rid of defsv etc.. */
		831
		832	coro->mainstack = 0;
		833	}
		834
		835	cctx_destroy (coro->cctx);
		836	SvREFCNT_dec (coro->args);
		837
		838	return 1;
		839	}
		840
		841	static int
		842	coro_state_clear (pTHX_ SV *sv, MAGIC *mg)
		843	{
		844	struct coro *coro = (struct coro *)mg->mg_ptr;
		845	mg->mg_ptr = 0;
		846
		847	coro_state_destroy (coro);
		848
		849	if (!coro->refcnt)
		850	Safefree (coro);
		851
		852	return 0;
		853	}
		854
		855	static int
		856	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		857	{
		858	struct coro *coro = (struct coro *)mg->mg_ptr;
		859
		860	++coro->refcnt;
		861
		862	return 0;
		863	}
		864
		865	static MGVTBL coro_state_vtbl = {
		866	0, 0, 0, 0,
		867	coro_state_clear,
		868	0,
		869	#ifdef MGf_DUP
		870	coro_state_dup,
		871	#else
		872	# define MGf_DUP 0
		873	#endif
		874	};
		875
		876	static struct coro *
		877	SvSTATE (SV *coro)
		878	{
		879	HV *stash;
		880	MAGIC *mg;
		881
		882	if (SvROK (coro))
		883	coro = SvRV (coro);
		884
		885	stash = SvSTASH (coro);
		886	if (stash != coro_stash && stash != coro_state_stash)
		887	{
		888	/* very slow, but rare, check */
		889	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		890	croak ("Coro::State object required");
		891	}
		892
		893	mg = SvMAGIC (coro);
		894	assert (mg->mg_type == PERL_MAGIC_ext);
		895	return (struct coro *)mg->mg_ptr;
		896	}
		897
		898	static void
		899	prepare_transfer (struct transfer_args *ta, SV *prev_sv, SV *next_sv)
		900	{
		901	ta->prev = SvSTATE (prev_sv);
		902	ta->next = SvSTATE (next_sv);
		903	}
		904
		905	static void
		906	api_transfer (SV *prev_sv, SV *next_sv)
		907	{
		908	struct transfer_args ta;
		909
		910	prepare_transfer (&ta, prev_sv, next_sv);
		911	TRANSFER (ta);
		912	}
		913
		914	static int
		915	api_save (SV *coro_sv, int new_save)
		916	{
		917	struct coro *coro = SvSTATE (coro_sv);
		918	int old_save = coro->save;
		919
		920	if (new_save >= 0)
		921	coro->save = new_save;
		922
		923	return old_save;
		924	}
		925
		926	/** Coro ********************************************************************/
		927
		928	#define PRIO_MAX 3
		929	#define PRIO_HIGH 1
		930	#define PRIO_NORMAL 0
		931	#define PRIO_LOW -1
		932	#define PRIO_IDLE -3
		933	#define PRIO_MIN -4
		934
		935	/* for Coro.pm */
		936	static SV *coro_current;
		937	static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
		938	static int coro_nready;
		939
		940	static void
		941	coro_enq (SV *coro_sv)
		942	{
		943	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		944	coro_nready++;
		945	}
		946
		947	static SV *
		948	coro_deq (int min_prio)
		949	{
		950	int prio = PRIO_MAX - PRIO_MIN;
		951
		952	min_prio -= PRIO_MIN;
		953	if (min_prio < 0)
		954	min_prio = 0;
		955
		956	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		957	if (AvFILLp (coro_ready [prio]) >= 0)
319	{	958	{
320	AV *padlist = (AV *)POPs;	959	coro_nready--;
321		960	return av_shift (coro_ready [prio]);
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	}	961	}
331		962
		963	return 0;
		964	}
		965
		966	static int
		967	api_ready (SV *coro_sv)
		968	{
		969	struct coro *coro;
		970
		971	if (SvROK (coro_sv))
		972	coro_sv = SvRV (coro_sv);
		973
		974	coro = SvSTATE (coro_sv);
		975
		976	if (coro->flags & CF_READY)
		977	return 0;
		978
		979	coro->flags |= CF_READY;
		980
		981	LOCK;
		982	coro_enq (SvREFCNT_inc (coro_sv));
		983	UNLOCK;
		984
		985	return 1;
		986	}
		987
		988	static int
		989	api_is_ready (SV *coro_sv)
		990	{
		991	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		992	}
		993
		994	static void
		995	prepare_schedule (struct transfer_args *ta)
		996	{
		997	SV *prev_sv, *next_sv;
		998
		999	for (;;)
		1000	{
		1001	LOCK;
		1002	next_sv = coro_deq (PRIO_MIN);
		1003	UNLOCK;
		1004
		1005	/* nothing to schedule: call the idle handler */
		1006	if (!next_sv)
		1007	{
		1008	dSP;
		1009
		1010	ENTER;
		1011	SAVETMPS;
		1012
		1013	PUSHMARK (SP);
332	PUTBACK;	1014	PUTBACK;
333	}	1015	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
334	}
335		1016
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	1017	FREETMPS;
337	STATIC void
338	destroy_stacks(pTHX)
339	{
340	/* die does this while calling POPSTACK, but I just don't see why. */
341	dounwind(-1);
342
343	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)
345	LEAVE;	1018	LEAVE;
		1019	continue;
		1020	}
346		1021
347	while (PL_curstackinfo->si_next)	1022	ta->next = SvSTATE (next_sv);
348	PL_curstackinfo = PL_curstackinfo->si_next;
349		1023
350	while (PL_curstackinfo)	1024	/* cannot transfer to destroyed coros, skip and look for next */
		1025	if (ta->next->flags & CF_DESTROYED)
		1026	{
		1027	SvREFCNT_dec (next_sv);
		1028	continue;
		1029	}
		1030
		1031	break;
351	{	1032	}
352	PERL_SI *p = PL_curstackinfo->si_prev;
353		1033
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	1034	/* free this only after the transfer */
355	Safefree(PL_curstackinfo->si_cxstack);	1035	prev_sv = SvRV (coro_current);
356	Safefree(PL_curstackinfo);	1036	SvRV_set (coro_current, next_sv);
357	PL_curstackinfo = p;	1037	ta->prev = SvSTATE (prev_sv);
		1038
		1039	assert (ta->next->flags & CF_READY);
		1040	ta->next->flags &= ~CF_READY;
		1041
		1042	LOCK;
		1043	free_coro_mortal ();
		1044	coro_mortal = prev_sv;
		1045	UNLOCK;
		1046	}
		1047
		1048	static void
		1049	prepare_cede (struct transfer_args *ta)
		1050	{
		1051	api_ready (coro_current);
		1052	prepare_schedule (ta);
		1053	}
		1054
		1055	static int
		1056	prepare_cede_notself (struct transfer_args *ta)
		1057	{
		1058	if (coro_nready)
		1059	{
		1060	SV *prev = SvRV (coro_current);
		1061	prepare_schedule (ta);
		1062	api_ready (prev);
		1063	return 1;
358	}	1064	}
359		1065	else
360	if (PL_scopestack_ix != 0)	1066	return 0;
361	Perl_warner(aTHX_ WARN_INTERNAL,
362	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
363	(long)PL_scopestack_ix);
364	if (PL_savestack_ix != 0)
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced saves: %ld more saves than restores\n",
367	(long)PL_savestack_ix);
368	if (PL_tmps_floor != -1)
369	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
370	(long)PL_tmps_floor + 1);
371	/*
372	*/
373	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);
375	Safefree(PL_scopestack);
376	Safefree(PL_savestack);
377	Safefree(PL_retstack);
378	}	1067	}
379		1068
380	#define SUB_INIT "Coro::State::_newcoro"	1069	static void
		1070	api_schedule (void)
		1071	{
		1072	struct transfer_args ta;
		1073
		1074	prepare_schedule (&ta);
		1075	TRANSFER (ta);
		1076	}
		1077
		1078	static int
		1079	api_cede (void)
		1080	{
		1081	struct transfer_args ta;
		1082
		1083	prepare_cede (&ta);
		1084
		1085	if (ta.prev != ta.next)
		1086	{
		1087	TRANSFER (ta);
		1088	return 1;
		1089	}
		1090	else
		1091	return 0;
		1092	}
		1093
		1094	static int
		1095	api_cede_notself (void)
		1096	{
		1097	struct transfer_args ta;
		1098
		1099	if (prepare_cede_notself (&ta))
		1100	{
		1101	TRANSFER (ta);
		1102	return 1;
		1103	}
		1104	else
		1105	return 0;
		1106	}
381		1107
382	MODULE = Coro::State PACKAGE = Coro::State	1108	MODULE = Coro::State PACKAGE = Coro::State
383		1109
384	PROTOTYPES: ENABLE	1110	PROTOTYPES: DISABLE
385		1111
386	BOOT:	1112	BOOT:
387	if (!padlist_cache)	1113	{
388	padlist_cache = newHV ();	1114	#ifdef USE_ITHREADS
		1115	MUTEX_INIT (&coro_mutex);
		1116	#endif
		1117	BOOT_PAGESIZE;
389		1118
390	Coro::State	1119	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
391	_newprocess(args)	1120
392	SV * args	1121	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
393	PROTOTYPE: $	1122	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
		1123	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
		1124	newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
		1125	newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
		1126
		1127	main_mainstack = PL_mainstack;
		1128
		1129	coroapi.ver = CORO_API_VERSION;
		1130	coroapi.transfer = api_transfer;
		1131
		1132	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1133	}
		1134
		1135	SV *
		1136	new (char *klass, ...)
394	CODE:	1137	CODE:
395	Coro__State coro;	1138	{
		1139	struct coro *coro;
		1140	HV *hv;
		1141	int i;
396		1142
397	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");
399
400	New (0, coro, 1, struct coro);	1143	Newz (0, coro, 1, struct coro);
		1144	coro->args = newAV ();
		1145	coro->save = CORO_SAVE_ALL;
		1146	coro->flags = CF_NEW;
401		1147
402	coro->mainstack = 0; /* actual work is done inside transfer */	1148	hv = newHV ();
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1149	sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
		1150	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
404		1151
405	RETVAL = coro;	1152	for (i = 1; i < items; i++)
		1153	av_push (coro->args, newSVsv (ST (i)));
		1154	}
406	OUTPUT:	1155	OUTPUT:
407	RETVAL	1156	RETVAL
408		1157
		1158	int
		1159	save (SV *coro, int new_save = -1)
		1160	CODE:
		1161	RETVAL = api_save (coro, new_save);
		1162	OUTPUT:
		1163	RETVAL
		1164
409	void	1165	void
410	transfer(prev,next)	1166	_set_stacklevel (...)
411	Coro::State_or_hashref prev	1167	ALIAS:
412	Coro::State_or_hashref next	1168	Coro::State::transfer = 1
		1169	Coro::schedule = 2
		1170	Coro::cede = 3
		1171	Coro::cede_notself = 4
413	CODE:	1172	CODE:
		1173	{
		1174	struct transfer_args ta;
414		1175
415	if (prev != next)	1176	switch (ix)
416	{	1177	{
417	PUTBACK;
418	SAVE (aTHX_ prev);
419
420	/*
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;
431	}
432	else	1178	case 0:
		1179	ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
		1180	ta.next = 0;
433	{	1181	break;
434	/*
435	* emulate part of the perl startup here.
436	*/
437	UNOP myop;
438		1182
439	init_stacks (); /* from perl.c */	1183	case 1:
440	PL_op = (OP *)&myop;	1184	if (items != 2)
441	/*PL_curcop = 0;*/	1185	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
442	GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
443		1186
444	SPAGAIN;	1187	prepare_transfer (&ta, ST (0), ST (1));
445	Zero(&myop, 1, UNOP);
446	myop.op_next = Nullop;
447	myop.op_flags = OPf_WANT_VOID;
448
449	PUSHMARK(SP);
450	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451	PUTBACK;
452	/*
453	* the next line is slightly wrong, as PL_op->op_next
454	* is actually being executed so we skip the first op.
455	* that doesn't matter, though, since it is only
456	* pp_nextstate and we never return...
457	*/
458	PL_op = Perl_pp_entersub(aTHX);
459	SPAGAIN;
460
461	ENTER;
462	}	1188	break;
		1189
		1190	case 2:
		1191	prepare_schedule (&ta);
		1192	break;
		1193
		1194	case 3:
		1195	prepare_cede (&ta);
		1196	break;
		1197
		1198	case 4:
		1199	if (!prepare_cede_notself (&ta))
		1200	XSRETURN_EMPTY;
		1201
		1202	break;
463	}	1203	}
464		1204
		1205	BARRIER;
		1206	TRANSFER (ta);
		1207	}
		1208
		1209	bool
		1210	_destroy (SV *coro_sv)
		1211	CODE:
		1212	RETVAL = coro_state_destroy (SvSTATE (coro_sv));
		1213	OUTPUT:
		1214	RETVAL
		1215
465	void	1216	void
466	DESTROY(coro)	1217	_exit (code)
467	Coro::State coro	1218	int code
		1219	PROTOTYPE: $
		1220	CODE:
		1221	_exit (code);
		1222
		1223	int
		1224	cctx_count ()
		1225	CODE:
		1226	RETVAL = cctx_count;
		1227	OUTPUT:
		1228	RETVAL
		1229
		1230	int
		1231	cctx_idle ()
		1232	CODE:
		1233	RETVAL = cctx_idle;
		1234	OUTPUT:
		1235	RETVAL
		1236
		1237	MODULE = Coro::State PACKAGE = Coro
		1238
		1239	BOOT:
		1240	{
		1241	int i;
		1242
		1243	coro_stash = gv_stashpv ("Coro", TRUE);
		1244
		1245	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1246	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1247	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1248	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1249	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1250	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1251
		1252	coro_current = get_sv ("Coro::current", FALSE);
		1253	SvREADONLY_on (coro_current);
		1254
		1255	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1256	coro_ready[i] = newAV ();
		1257
		1258	{
		1259	SV *sv = perl_get_sv("Coro::API", 1);
		1260
		1261	coroapi.schedule = api_schedule;
		1262	coroapi.save = api_save;
		1263	coroapi.cede = api_cede;
		1264	coroapi.cede_notself = api_cede_notself;
		1265	coroapi.ready = api_ready;
		1266	coroapi.is_ready = api_is_ready;
		1267	coroapi.nready = &coro_nready;
		1268	coroapi.current = coro_current;
		1269
		1270	GCoroAPI = &coroapi;
		1271	sv_setiv (sv, (IV)&coroapi);
		1272	SvREADONLY_on (sv);
		1273	}
		1274	}
		1275
		1276	void
		1277	_set_current (SV *current)
		1278	PROTOTYPE: $
		1279	CODE:
		1280	SvREFCNT_dec (SvRV (coro_current));
		1281	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1282
		1283	int
		1284	prio (Coro::State coro, int newprio = 0)
		1285	ALIAS:
		1286	nice = 1
468	CODE:	1287	CODE:
		1288	{
		1289	RETVAL = coro->prio;
469		1290
470	if (coro->mainstack)	1291	if (items > 1)
471	{	1292	{
472	struct coro temp;	1293	if (ix)
		1294	newprio = coro->prio - newprio;
473		1295
474	PUTBACK;	1296	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
475	SAVE(aTHX_ (&temp));	1297	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
476	LOAD(aTHX_ coro);
477		1298
478	destroy_stacks ();	1299	coro->prio = newprio;
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;
483	}	1300	}
		1301	}
		1302	OUTPUT:
		1303	RETVAL
484		1304
485	SvREFCNT_dec (coro->args);	1305	SV *
486	Safefree (coro);	1306	ready (SV *self)
		1307	PROTOTYPE: $
		1308	CODE:
		1309	RETVAL = boolSV (api_ready (self));
		1310	OUTPUT:
		1311	RETVAL
487		1312
		1313	SV *
		1314	is_ready (SV *self)
		1315	PROTOTYPE: $
		1316	CODE:
		1317	RETVAL = boolSV (api_is_ready (self));
		1318	OUTPUT:
		1319	RETVAL
488		1320
		1321	int
		1322	nready (...)
		1323	PROTOTYPE:
		1324	CODE:
		1325	RETVAL = coro_nready;
		1326	OUTPUT:
		1327	RETVAL
		1328
		1329	MODULE = Coro::State PACKAGE = Coro::AIO
		1330
		1331	SV *
		1332	_get_state ()
		1333	CODE:
		1334	{
		1335	struct io_state *data;
		1336
		1337	RETVAL = newSV (sizeof (struct io_state));
		1338	data = (struct io_state *)SvPVX (RETVAL);
		1339	SvCUR_set (RETVAL, sizeof (struct io_state));
		1340	SvPOK_only (RETVAL);
		1341
		1342	data->errorno = errno;
		1343	data->laststype = PL_laststype;
		1344	data->laststatval = PL_laststatval;
		1345	data->statcache = PL_statcache;
		1346	}
		1347	OUTPUT:
		1348	RETVAL
		1349
		1350	void
		1351	_set_state (char *data_)
		1352	PROTOTYPE: $
		1353	CODE:
		1354	{
		1355	struct io_state *data = (void *)data_;
		1356
		1357	errno = data->errorno;
		1358	PL_laststype = data->laststype;
		1359	PL_laststatval = data->laststatval;
		1360	PL_statcache = data->statcache;
		1361	}
		1362

Diff Legend

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