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

Diff Legend

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