ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.135 by root, Fri Jan 5 18:25:51 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	/* unwind all extra stacks */
		478	POPSTACK_TO (PL_mainstack);
		479
		480	/* unwind main stack */
		481	dounwind (-1);
		482	}
		483
		484	while (PL_curstackinfo->si_next)
		485	PL_curstackinfo = PL_curstackinfo->si_next;
		486
		487	while (PL_curstackinfo)
		488	{
		489	PERL_SI *p = PL_curstackinfo->si_prev;
		490
		491	if (!IN_DESTRUCT)
		492	SvREFCNT_dec (PL_curstackinfo->si_stack);
		493
		494	Safefree (PL_curstackinfo->si_cxstack);
		495	Safefree (PL_curstackinfo);
		496	PL_curstackinfo = p;
		497	}
		498
		499	Safefree (PL_tmps_stack);
		500	Safefree (PL_markstack);
		501	Safefree (PL_scopestack);
		502	Safefree (PL_savestack);
		503	#if !PERL_VERSION_ATLEAST (5,9,0)
		504	Safefree (PL_retstack);
		505	#endif
		506	}
		507
		508	static void
		509	setup_coro (struct coro *coro)
		510	{
		511	/*
		512	* emulate part of the perl startup here.
		513	*/
		514
		515	coro_init_stacks ();
		516
		517	PL_curcop = &PL_compiling;
		518	PL_in_eval = EVAL_NULL;
		519	PL_curpm = 0;
		520	PL_localizing = 0;
		521	PL_dirty = 0;
		522	PL_restartop = 0;
312		523
313	{	524	{
314	dSP;	525	dSP;
315	CV *cv;	526	LOGOP myop;
316		527
317	/* now do the ugly restore mess */	528	SvREFCNT_dec (GvAV (PL_defgv));
318	while ((cv = (CV *)POPs))	529	GvAV (PL_defgv) = coro->args; coro->args = 0;
		530
		531	Zero (&myop, 1, LOGOP);
		532	myop.op_next = Nullop;
		533	myop.op_flags = OPf_WANT_VOID;
		534
		535	PUSHMARK (SP);
		536	XPUSHs ((SV *)get_cv ("Coro::State::_coro_init", FALSE));
		537	PUTBACK;
		538	PL_op = (OP *)&myop;
		539	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		540	SPAGAIN;
		541	}
		542
		543	ENTER; /* necessary e.g. for dounwind */
		544	}
		545
		546	static void
		547	free_coro_mortal ()
		548	{
		549	if (coro_mortal)
		550	{
		551	SvREFCNT_dec (coro_mortal);
		552	coro_mortal = 0;
		553	}
		554	}
		555
		556	/* inject a fake call to Coro::State::_cctx_init into the execution */
		557	static void NOINLINE
		558	prepare_cctx (coro_cctx *cctx)
		559	{
		560	dSP;
		561	LOGOP myop;
		562
		563	Zero (&myop, 1, LOGOP);
		564	myop.op_next = PL_op;
		565	myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
		566
		567	PUSHMARK (SP);
		568	EXTEND (SP, 2);
		569	PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
		570	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
		571	PUTBACK;
		572	PL_op = (OP *)&myop;
		573	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		574	SPAGAIN;
		575	}
		576
		577	static void
		578	coro_run (void *arg)
		579	{
		580	/* coro_run is the alternative tail of transfer(), so unlock here. */
		581	UNLOCK;
		582
		583	/*
		584	* this is a _very_ stripped down perl interpreter ;)
		585	*/
		586	PL_top_env = &PL_start_env;
		587
		588	/* inject call to cctx_init */
		589	prepare_cctx ((coro_cctx *)arg);
		590
		591	/* somebody will hit me for both perl_run and PL_restartop */
		592	PL_restartop = PL_op;
		593	perl_run (PL_curinterp);
		594
		595	fputs ("FATAL: C coroutine fell over the edge of the world, aborting. Did you call exit in a coroutine?\n", stderr);
		596	abort ();
		597	}
		598
		599	static coro_cctx *
		600	cctx_new ()
		601	{
		602	coro_cctx *cctx;
		603
		604	++cctx_count;
		605
		606	Newz (0, cctx, 1, coro_cctx);
		607
		608	#if HAVE_MMAP
		609
		610	cctx->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
		611	/* mmap supposedly does allocate-on-write for us */
		612	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
		613
		614	if (cctx->sptr == (void *)-1)
		615	{
		616	perror ("FATAL: unable to mmap stack for coroutine");
		617	_exit (EXIT_FAILURE);
		618	}
		619
		620	# if STACKGUARD
		621	mprotect (cctx->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
		622	# endif
		623
		624	#else
		625
		626	cctx->ssize = STACKSIZE * (long)sizeof (long);
		627	New (0, cctx->sptr, STACKSIZE, long);
		628
		629	if (!cctx->sptr)
		630	{
		631	perror ("FATAL: unable to malloc stack for coroutine");
		632	_exit (EXIT_FAILURE);
		633	}
		634
		635	#endif
		636
		637	#if USE_VALGRIND
		638	cctx->valgrind_id = VALGRIND_STACK_REGISTER (
		639	STACKGUARD * PAGESIZE + (char *)cctx->sptr,
		640	cctx->ssize + (char *)cctx->sptr
		641	);
		642	#endif
		643
		644	coro_create (&cctx->cctx, coro_run, (void *)cctx, cctx->sptr, cctx->ssize);
		645
		646	return cctx;
		647	}
		648
		649	static void
		650	cctx_destroy (coro_cctx *cctx)
		651	{
		652	if (!cctx)
		653	return;
		654
		655	--cctx_count;
		656
		657	#if USE_VALGRIND
		658	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		659	#endif
		660
		661	#if HAVE_MMAP
		662	munmap (cctx->sptr, cctx->ssize);
		663	#else
		664	Safefree (cctx->sptr);
		665	#endif
		666
		667	Safefree (cctx);
		668	}
		669
		670	static coro_cctx *
		671	cctx_get ()
		672	{
		673	coro_cctx *cctx;
		674
		675	if (cctx_first)
		676	{
		677	cctx = cctx_first;
		678	cctx_first = cctx->next;
		679	--cctx_idle;
		680	}
		681	else
		682	{
		683	cctx = cctx_new ();
		684	PL_op = PL_op->op_next;
		685	}
		686
		687	return cctx;
		688	}
		689
		690	static void
		691	cctx_put (coro_cctx *cctx)
		692	{
		693	/* free another cctx if overlimit */
		694	if (cctx_idle >= MAX_IDLE_CCTX)
		695	{
		696	coro_cctx *first = cctx_first;
		697	cctx_first = first->next;
		698	--cctx_idle;
		699
		700	assert (!first->inuse);
		701	cctx_destroy (first);
		702	}
		703
		704	++cctx_idle;
		705	cctx->next = cctx_first;
		706	cctx_first = cctx;
		707	}
		708
		709	/* never call directly, always through the coro_state_transfer global variable */
		710	static void NOINLINE
		711	transfer (struct coro *prev, struct coro *next)
		712	{
		713	dSTACKLEVEL;
		714
		715	/* sometimes transfer is only called to set idle_sp */
		716	if (!next)
		717	{
		718	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		719	assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
		720	}
		721	else if (prev != next)
		722	{
		723	coro_cctx *prev__cctx;
		724
		725	if (prev->flags & CF_NEW)
		726	{
		727	/* create a new empty context */
		728	Newz (0, prev->cctx, 1, coro_cctx);
		729	prev->cctx->inuse = 1;
		730	prev->flags &= ~CF_NEW;
		731	prev->flags |= CF_RUNNING;
		732	}
		733
		734	/*TODO: must not croak here */
		735	if (!prev->flags & CF_RUNNING)
		736	croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
		737
		738	if (next->flags & CF_RUNNING)
		739	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		740
		741	if (next->flags & CF_DESTROYED)
		742	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		743
		744	prev->flags &= ~CF_RUNNING;
		745	next->flags |= CF_RUNNING;
		746
		747	LOCK;
		748
		749	if (next->flags & CF_NEW)
		750	{
		751	/* need to start coroutine */
		752	next->flags &= ~CF_NEW;
		753	/* first get rid of the old state */
		754	save_perl (prev);
		755	/* setup coroutine call */
		756	setup_coro (next);
		757	/* need a new stack */
		758	assert (!next->cctx);
		759	}
		760	else
		761	{
		762	/* coroutine already started */
		763	save_perl (prev);
		764	load_perl (next);
		765	}
		766
		767	prev__cctx = prev->cctx;
		768
		769	/* possibly "free" the cctx */
		770	if (prev__cctx->idle_sp == STACKLEVEL)
		771	{
		772	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		773	assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
		774
		775	prev->cctx = 0;
		776
		777	cctx_put (prev__cctx);
		778	prev__cctx->inuse = 0;
		779	}
		780
		781	if (!next->cctx)
		782	{
		783	next->cctx = cctx_get ();
		784	assert (!next->cctx->inuse);
		785	next->cctx->inuse = 1;
		786	}
		787
		788	if (prev__cctx != next->cctx)
		789	{
		790	prev__cctx->top_env = PL_top_env;
		791	PL_top_env = next->cctx->top_env;
		792	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		793	}
		794
		795	free_coro_mortal ();
		796	UNLOCK;
		797	}
		798	}
		799
		800	struct transfer_args
		801	{
		802	struct coro *prev, *next;
		803	};
		804
		805	#define TRANSFER(ta) transfer ((ta).prev, (ta).next)
		806
		807	static int
		808	coro_state_destroy (struct coro *coro)
		809	{
		810	if (coro->flags & CF_DESTROYED)
		811	return 0;
		812
		813	coro->flags |= CF_DESTROYED;
		814
		815	if (coro->mainstack && coro->mainstack != main_mainstack)
		816	{
		817	assert (!(coro->flags & CF_RUNNING));
		818
		819	struct coro temp;
		820	Zero (&temp, 1, struct coro);
		821	temp.save = CORO_SAVE_ALL;
		822
		823	if (coro->flags & CF_RUNNING)
		824	croak ("FATAL: tried to destroy currently running coroutine");
		825
		826	save_perl (&temp);
		827	load_perl (coro);
		828
		829	coro_destroy_stacks ();
		830
		831	load_perl (&temp); /* this will get rid of defsv etc.. */
		832
		833	coro->mainstack = 0;
		834	}
		835
		836	cctx_destroy (coro->cctx);
		837	SvREFCNT_dec (coro->args);
		838
		839	return 1;
		840	}
		841
		842	static int
		843	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
		844	{
		845	struct coro *coro = (struct coro *)mg->mg_ptr;
		846	mg->mg_ptr = 0;
		847
		848	if (--coro->refcnt < 0)
		849	{
		850	coro_state_destroy (coro);
		851	Safefree (coro);
		852	}
		853
		854	return 0;
		855	}
		856
		857	static int
		858	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		859	{
		860	struct coro *coro = (struct coro *)mg->mg_ptr;
		861
		862	++coro->refcnt;
		863
		864	return 0;
		865	}
		866
		867	static MGVTBL coro_state_vtbl = {
		868	0, 0, 0, 0,
		869	coro_state_free,
		870	0,
		871	#ifdef MGf_DUP
		872	coro_state_dup,
		873	#else
		874	# define MGf_DUP 0
		875	#endif
		876	};
		877
		878	static struct coro *
		879	SvSTATE (SV *coro)
		880	{
		881	HV *stash;
		882	MAGIC *mg;
		883
		884	if (SvROK (coro))
		885	coro = SvRV (coro);
		886
		887	stash = SvSTASH (coro);
		888	if (stash != coro_stash && stash != coro_state_stash)
		889	{
		890	/* very slow, but rare, check */
		891	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		892	croak ("Coro::State object required");
		893	}
		894
		895	mg = SvMAGIC (coro);
		896	assert (mg->mg_type == PERL_MAGIC_ext);
		897	return (struct coro *)mg->mg_ptr;
		898	}
		899
		900	static void
		901	prepare_transfer (struct transfer_args *ta, SV *prev_sv, SV *next_sv)
		902	{
		903	ta->prev = SvSTATE (prev_sv);
		904	ta->next = SvSTATE (next_sv);
		905	}
		906
		907	static void
		908	api_transfer (SV *prev_sv, SV *next_sv)
		909	{
		910	struct transfer_args ta;
		911
		912	prepare_transfer (&ta, prev_sv, next_sv);
		913	TRANSFER (ta);
		914	}
		915
		916	static int
		917	api_save (SV *coro_sv, int new_save)
		918	{
		919	struct coro *coro = SvSTATE (coro_sv);
		920	int old_save = coro->save;
		921
		922	if (new_save >= 0)
		923	coro->save = new_save;
		924
		925	return old_save;
		926	}
		927
		928	/** Coro ********************************************************************/
		929
		930	#define PRIO_MAX 3
		931	#define PRIO_HIGH 1
		932	#define PRIO_NORMAL 0
		933	#define PRIO_LOW -1
		934	#define PRIO_IDLE -3
		935	#define PRIO_MIN -4
		936
		937	/* for Coro.pm */
		938	static SV *coro_current;
		939	static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
		940	static int coro_nready;
		941
		942	static void
		943	coro_enq (SV *coro_sv)
		944	{
		945	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		946	coro_nready++;
		947	}
		948
		949	static SV *
		950	coro_deq (int min_prio)
		951	{
		952	int prio = PRIO_MAX - PRIO_MIN;
		953
		954	min_prio -= PRIO_MIN;
		955	if (min_prio < 0)
		956	min_prio = 0;
		957
		958	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		959	if (AvFILLp (coro_ready [prio]) >= 0)
319	{	960	{
320	AV *padlist = (AV *)POPs;	961	coro_nready--;
321		962	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	}	963	}
331		964
		965	return 0;
		966	}
		967
		968	static int
		969	api_ready (SV *coro_sv)
		970	{
		971	struct coro *coro;
		972
		973	if (SvROK (coro_sv))
		974	coro_sv = SvRV (coro_sv);
		975
		976	coro = SvSTATE (coro_sv);
		977
		978	if (coro->flags & CF_READY)
		979	return 0;
		980
		981	coro->flags |= CF_READY;
		982
		983	LOCK;
		984	coro_enq (SvREFCNT_inc (coro_sv));
		985	UNLOCK;
		986
		987	return 1;
		988	}
		989
		990	static int
		991	api_is_ready (SV *coro_sv)
		992	{
		993	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		994	}
		995
		996	static void
		997	prepare_schedule (struct transfer_args *ta)
		998	{
		999	SV *prev_sv, *next_sv;
		1000
		1001	for (;;)
		1002	{
		1003	LOCK;
		1004	next_sv = coro_deq (PRIO_MIN);
		1005	UNLOCK;
		1006
		1007	/* nothing to schedule: call the idle handler */
		1008	if (!next_sv)
		1009	{
		1010	dSP;
		1011
		1012	ENTER;
		1013	SAVETMPS;
		1014
		1015	PUSHMARK (SP);
332	PUTBACK;	1016	PUTBACK;
333	}	1017	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
334	}
335		1018
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	1019	FREETMPS;
337	STATIC void
338	destroy_stacks(pTHX)
339	{
340	dSP;
341
342	/* die does this while calling POPSTACK, but I just don't see why. */
343	dounwind(-1);
344
345	/* is this ugly, I ask? */
346	while (PL_scopestack_ix)
347	LEAVE;	1020	LEAVE;
		1021	continue;
		1022	}
348		1023
349	while (PL_curstackinfo->si_next)	1024	ta->next = SvSTATE (next_sv);
350	PL_curstackinfo = PL_curstackinfo->si_next;
351		1025
352	while (PL_curstackinfo)	1026	/* cannot transfer to destroyed coros, skip and look for next */
		1027	if (ta->next->flags & CF_DESTROYED)
		1028	{
		1029	SvREFCNT_dec (next_sv);
		1030	continue;
		1031	}
		1032
		1033	break;
353	{	1034	}
354	PERL_SI *p = PL_curstackinfo->si_prev;
355		1035
356	SvREFCNT_dec(PL_curstackinfo->si_stack);	1036	/* free this only after the transfer */
357	Safefree(PL_curstackinfo->si_cxstack);	1037	prev_sv = SvRV (coro_current);
358	Safefree(PL_curstackinfo);	1038	SvRV_set (coro_current, next_sv);
359	PL_curstackinfo = p;	1039	ta->prev = SvSTATE (prev_sv);
		1040
		1041	assert (ta->next->flags & CF_READY);
		1042	ta->next->flags &= ~CF_READY;
		1043
		1044	LOCK;
		1045	free_coro_mortal ();
		1046	coro_mortal = prev_sv;
		1047	UNLOCK;
		1048	}
		1049
		1050	static void
		1051	prepare_cede (struct transfer_args *ta)
		1052	{
		1053	api_ready (coro_current);
		1054	prepare_schedule (ta);
		1055	}
		1056
		1057	static int
		1058	prepare_cede_notself (struct transfer_args *ta)
		1059	{
		1060	if (coro_nready)
		1061	{
		1062	SV *prev = SvRV (coro_current);
		1063	prepare_schedule (ta);
		1064	api_ready (prev);
		1065	return 1;
360	}	1066	}
361		1067	else
362	if (PL_scopestack_ix != 0)	1068	return 0;
363	Perl_warner(aTHX_ WARN_INTERNAL,
364	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365	(long)PL_scopestack_ix);
366	if (PL_savestack_ix != 0)
367	Perl_warner(aTHX_ WARN_INTERNAL,
368	"Unbalanced saves: %ld more saves than restores\n",
369	(long)PL_savestack_ix);
370	if (PL_tmps_floor != -1)
371	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372	(long)PL_tmps_floor + 1);
373	/*
374	*/
375	Safefree(PL_tmps_stack);
376	Safefree(PL_markstack);
377	Safefree(PL_scopestack);
378	Safefree(PL_savestack);
379	Safefree(PL_retstack);
380	}	1069	}
381		1070
382	#define SUB_INIT "Coro::State::_newcoro"	1071	static void
		1072	api_schedule (void)
		1073	{
		1074	struct transfer_args ta;
		1075
		1076	prepare_schedule (&ta);
		1077	TRANSFER (ta);
		1078	}
		1079
		1080	static int
		1081	api_cede (void)
		1082	{
		1083	struct transfer_args ta;
		1084
		1085	prepare_cede (&ta);
		1086
		1087	if (ta.prev != ta.next)
		1088	{
		1089	TRANSFER (ta);
		1090	return 1;
		1091	}
		1092	else
		1093	return 0;
		1094	}
		1095
		1096	static int
		1097	api_cede_notself (void)
		1098	{
		1099	struct transfer_args ta;
		1100
		1101	if (prepare_cede_notself (&ta))
		1102	{
		1103	TRANSFER (ta);
		1104	return 1;
		1105	}
		1106	else
		1107	return 0;
		1108	}
383		1109
384	MODULE = Coro::State PACKAGE = Coro::State	1110	MODULE = Coro::State PACKAGE = Coro::State
385		1111
386	PROTOTYPES: ENABLE	1112	PROTOTYPES: DISABLE
387		1113
388	BOOT:	1114	BOOT:
389	if (!padlist_cache)	1115	{
390	padlist_cache = newHV ();	1116	#ifdef USE_ITHREADS
		1117	MUTEX_INIT (&coro_mutex);
		1118	#endif
		1119	BOOT_PAGESIZE;
391		1120
392	Coro::State	1121	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
393	_newprocess(args)	1122
394	SV * args	1123	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
395	PROTOTYPE: $	1124	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
		1125	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
		1126	newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
		1127	newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
		1128
		1129	main_mainstack = PL_mainstack;
		1130
		1131	coroapi.ver = CORO_API_VERSION;
		1132	coroapi.transfer = api_transfer;
		1133
		1134	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1135	}
		1136
		1137	SV *
		1138	new (char *klass, ...)
396	CODE:	1139	CODE:
397	Coro__State coro;	1140	{
		1141	struct coro *coro;
		1142	HV *hv;
		1143	int i;
398		1144
399	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
400	croak ("Coro::State::newprocess expects an arrayref");
401
402	New (0, coro, 1, struct coro);	1145	Newz (0, coro, 1, struct coro);
		1146	coro->args = newAV ();
		1147	coro->save = CORO_SAVE_ALL;
		1148	coro->flags = CF_NEW;
403		1149
404	coro->mainstack = 0; /* actual work is done inside transfer */	1150	hv = newHV ();
405	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1151	sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
		1152	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
406		1153
407	RETVAL = coro;	1154	for (i = 1; i < items; i++)
		1155	av_push (coro->args, newSVsv (ST (i)));
		1156	}
408	OUTPUT:	1157	OUTPUT:
409	RETVAL	1158	RETVAL
410		1159
		1160	int
		1161	save (SV *coro, int new_save = -1)
		1162	CODE:
		1163	RETVAL = api_save (coro, new_save);
		1164	OUTPUT:
		1165	RETVAL
		1166
411	void	1167	void
412	transfer(prev,next)	1168	_set_stacklevel (...)
413	Coro::State_or_hashref prev	1169	ALIAS:
414	Coro::State_or_hashref next	1170	Coro::State::transfer = 1
		1171	Coro::schedule = 2
		1172	Coro::cede = 3
		1173	Coro::cede_notself = 4
415	CODE:	1174	CODE:
		1175	{
		1176	struct transfer_args ta;
416		1177
417	if (prev != next)	1178	switch (ix)
418	{	1179	{
419	PUTBACK;
420	SAVE (aTHX_ prev);
421
422	/*
423	* this could be done in newprocess which would lead to
424	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425	* code here, but lazy allocation of stacks has also
426	* some virtues and the overhead of the if() is nil.
427	*/
428	if (next->mainstack)
429	{
430	LOAD (aTHX_ next);
431	next->mainstack = 0; /* unnecessary but much cleaner */
432	SPAGAIN;
433	}
434	else	1180	case 0:
		1181	ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
		1182	ta.next = 0;
435	{	1183	break;
436	/*
437	* emulate part of the perl startup here.
438	*/
439	UNOP myop;
440		1184
441	init_stacks (); /* from perl.c */	1185	case 1:
442	PL_op = (OP *)&myop;	1186	if (items != 2)
443	/*PL_curcop = 0;*/	1187	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
444	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445		1188
446	SPAGAIN;	1189	prepare_transfer (&ta, ST (0), ST (1));
447	Zero(&myop, 1, UNOP);
448	myop.op_next = Nullop;
449	myop.op_flags = OPf_WANT_VOID;
450
451	PUSHMARK(SP);
452	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453	PUTBACK;
454	/*
455	* the next line is slightly wrong, as PL_op->op_next
456	* is actually being executed so we skip the first op.
457	* that doesn't matter, though, since it is only
458	* pp_nextstate and we never return...
459	*/
460	PL_op = Perl_pp_entersub(aTHX);
461	SPAGAIN;
462
463	ENTER;
464	}	1190	break;
		1191
		1192	case 2:
		1193	prepare_schedule (&ta);
		1194	break;
		1195
		1196	case 3:
		1197	prepare_cede (&ta);
		1198	break;
		1199
		1200	case 4:
		1201	if (!prepare_cede_notself (&ta))
		1202	XSRETURN_EMPTY;
		1203
		1204	break;
465	}	1205	}
466		1206
		1207	BARRIER;
		1208	TRANSFER (ta);
		1209
		1210	if (GIMME_V != G_VOID && ta.next != ta.prev)
		1211	XSRETURN_YES;
		1212	}
		1213
		1214	bool
		1215	_destroy (SV *coro_sv)
		1216	CODE:
		1217	RETVAL = coro_state_destroy (SvSTATE (coro_sv));
		1218	OUTPUT:
		1219	RETVAL
		1220
467	void	1221	void
468	DESTROY(coro)	1222	_exit (code)
469	Coro::State coro	1223	int code
		1224	PROTOTYPE: $
		1225	CODE:
		1226	_exit (code);
		1227
		1228	int
		1229	cctx_count ()
		1230	CODE:
		1231	RETVAL = cctx_count;
		1232	OUTPUT:
		1233	RETVAL
		1234
		1235	int
		1236	cctx_idle ()
		1237	CODE:
		1238	RETVAL = cctx_idle;
		1239	OUTPUT:
		1240	RETVAL
		1241
		1242	MODULE = Coro::State PACKAGE = Coro
		1243
		1244	BOOT:
		1245	{
		1246	int i;
		1247
		1248	coro_stash = gv_stashpv ("Coro", TRUE);
		1249
		1250	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1251	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1252	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1253	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1254	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1255	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1256
		1257	coro_current = get_sv ("Coro::current", FALSE);
		1258	SvREADONLY_on (coro_current);
		1259
		1260	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1261	coro_ready[i] = newAV ();
		1262
		1263	{
		1264	SV *sv = perl_get_sv("Coro::API", 1);
		1265
		1266	coroapi.schedule = api_schedule;
		1267	coroapi.save = api_save;
		1268	coroapi.cede = api_cede;
		1269	coroapi.cede_notself = api_cede_notself;
		1270	coroapi.ready = api_ready;
		1271	coroapi.is_ready = api_is_ready;
		1272	coroapi.nready = &coro_nready;
		1273	coroapi.current = coro_current;
		1274
		1275	GCoroAPI = &coroapi;
		1276	sv_setiv (sv, (IV)&coroapi);
		1277	SvREADONLY_on (sv);
		1278	}
		1279	}
		1280
		1281	void
		1282	_set_current (SV *current)
		1283	PROTOTYPE: $
		1284	CODE:
		1285	SvREFCNT_dec (SvRV (coro_current));
		1286	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1287
		1288	int
		1289	prio (Coro::State coro, int newprio = 0)
		1290	ALIAS:
		1291	nice = 1
470	CODE:	1292	CODE:
		1293	{
		1294	RETVAL = coro->prio;
471		1295
472	if (coro->mainstack)	1296	if (items > 1)
473	{	1297	{
474	struct coro temp;	1298	if (ix)
		1299	newprio = coro->prio - newprio;
475		1300
476	PUTBACK;	1301	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
477	SAVE(aTHX_ (&temp));	1302	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
478	LOAD(aTHX_ coro);
479		1303
480	destroy_stacks ();	1304	coro->prio = newprio;
481	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483	LOAD((&temp));
484	SPAGAIN;
485	}	1305	}
		1306	}
		1307	OUTPUT:
		1308	RETVAL
486		1309
487	SvREFCNT_dec (coro->args);	1310	SV *
488	Safefree (coro);	1311	ready (SV *self)
		1312	PROTOTYPE: $
		1313	CODE:
		1314	RETVAL = boolSV (api_ready (self));
		1315	OUTPUT:
		1316	RETVAL
489		1317
		1318	SV *
		1319	is_ready (SV *self)
		1320	PROTOTYPE: $
		1321	CODE:
		1322	RETVAL = boolSV (api_is_ready (self));
		1323	OUTPUT:
		1324	RETVAL
490		1325
		1326	int
		1327	nready (...)
		1328	PROTOTYPE:
		1329	CODE:
		1330	RETVAL = coro_nready;
		1331	OUTPUT:
		1332	RETVAL
		1333
		1334	MODULE = Coro::State PACKAGE = Coro::AIO
		1335
		1336	SV *
		1337	_get_state ()
		1338	CODE:
		1339	{
		1340	struct io_state *data;
		1341
		1342	RETVAL = newSV (sizeof (struct io_state));
		1343	data = (struct io_state *)SvPVX (RETVAL);
		1344	SvCUR_set (RETVAL, sizeof (struct io_state));
		1345	SvPOK_only (RETVAL);
		1346
		1347	data->errorno = errno;
		1348	data->laststype = PL_laststype;
		1349	data->laststatval = PL_laststatval;
		1350	data->statcache = PL_statcache;
		1351	}
		1352	OUTPUT:
		1353	RETVAL
		1354
		1355	void
		1356	_set_state (char *data_)
		1357	PROTOTYPE: $
		1358	CODE:
		1359	{
		1360	struct io_state *data = (void *)data_;
		1361
		1362	errno = data->errorno;
		1363	PL_laststype = data->laststype;
		1364	PL_laststatval = data->laststatval;
		1365	PL_statcache = data->statcache;
		1366	}
		1367

Diff Legend

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