ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.134 by root, Thu Jan 4 23:49:27 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_state(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	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	432	New(50,PL_tmps_stack,128,SV*);
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	433	PL_tmps_floor = -1;
		434	PL_tmps_ix = -1;
		435	PL_tmps_max = 128;
284		436
285	static void	437	New(54,PL_markstack,32,I32);
286	load_state(pTHX_ Coro__State c)
287	{
288	PL_dowarn = c->dowarn;
289	GvAV (PL_defgv) = c->defav;
290	PL_curstackinfo = c->curstackinfo;
291	PL_curstack = c->curstack;
292	PL_mainstack = c->mainstack;
293	PL_stack_sp = c->stack_sp;
294	PL_op = c->op;
295	PL_curpad = c->curpad;
296	PL_stack_base = c->stack_base;
297	PL_stack_max = c->stack_max;
298	PL_tmps_stack = c->tmps_stack;
299	PL_tmps_floor = c->tmps_floor;
300	PL_tmps_ix = c->tmps_ix;
301	PL_tmps_max = c->tmps_max;
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;	438	PL_markstack_ptr = PL_markstack;
304	PL_markstack_max = c->markstack_max;	439	PL_markstack_max = PL_markstack + 32;
305	PL_scopestack = c->scopestack;	440
306	PL_scopestack_ix = c->scopestack_ix;	441	#ifdef SET_MARK_OFFSET
307	PL_scopestack_max = c->scopestack_max;	442	SET_MARK_OFFSET;
308	PL_savestack = c->savestack;	443	#endif
309	PL_savestack_ix = c->savestack_ix;	444
310	PL_savestack_max = c->savestack_max;	445	New(54,PL_scopestack,32,I32);
311	PL_retstack = c->retstack;	446	PL_scopestack_ix = 0;
312	PL_retstack_ix = c->retstack_ix;	447	PL_scopestack_max = 32;
313	PL_retstack_max = c->retstack_max;	448
314	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;
315		523
316	{	524	{
317	dSP;	525	dSP;
318	CV *cv;	526	LOGOP myop;
319		527
320	/* now do the ugly restore mess */	528	SvREFCNT_dec (GvAV (PL_defgv));
321	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)
322	{	960	{
323	AV *padlist = (AV *)POPs;	961	coro_nready--;
324		962	return av_shift (coro_ready [prio]);
325	put_padlist (cv);
326	CvPADLIST(cv) = padlist;
327	CvDEPTH(cv) = (I32)POPs;
328
329	#ifdef USE_THREADS
330	CvOWNER(cv) = (struct perl_thread *)POPs;
331	error does not work either
332	#endif
333	}	963	}
334		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);
335	PUTBACK;	1016	PUTBACK;
336	}	1017	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
337	}
338		1018
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	1019	FREETMPS;
340	STATIC void
341	destroy_stacks(pTHX)
342	{
343	/* die does this while calling POPSTACK, but I just don't see why. */
344	/* OTOH, die does not have a memleak, but we do... */
345	dounwind(-1);
346
347	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)
349	LEAVE;	1020	LEAVE;
		1021	continue;
		1022	}
350		1023
351	while (PL_curstackinfo->si_next)	1024	ta->next = SvSTATE (next_sv);
352	PL_curstackinfo = PL_curstackinfo->si_next;
353		1025
354	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;
355	{	1034	}
356	PERL_SI *p = PL_curstackinfo->si_prev;
357		1035
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	1036	/* free this only after the transfer */
359	Safefree(PL_curstackinfo->si_cxstack);	1037	prev_sv = SvRV (coro_current);
360	Safefree(PL_curstackinfo);	1038	SvRV_set (coro_current, next_sv);
361	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;
362	}	1066	}
363		1067	else
364	if (PL_scopestack_ix != 0)	1068	return 0;
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367	(long)PL_scopestack_ix);
368	if (PL_savestack_ix != 0)
369	Perl_warner(aTHX_ WARN_INTERNAL,
370	"Unbalanced saves: %ld more saves than restores\n",
371	(long)PL_savestack_ix);
372	if (PL_tmps_floor != -1)
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374	(long)PL_tmps_floor + 1);
375	/*
376	*/
377	Safefree(PL_tmps_stack);
378	Safefree(PL_markstack);
379	Safefree(PL_scopestack);
380	Safefree(PL_savestack);
381	Safefree(PL_retstack);
382	}	1069	}
383		1070
384	#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	}
385		1109
386	MODULE = Coro::State PACKAGE = Coro::State	1110	MODULE = Coro::State PACKAGE = Coro::State
387		1111
388	PROTOTYPES: ENABLE	1112	PROTOTYPES: DISABLE
389		1113
390	BOOT:	1114	BOOT:
391	if (!padlist_cache)	1115	{
392	padlist_cache = newHV ();	1116	#ifdef USE_ITHREADS
		1117	MUTEX_INIT (&coro_mutex);
		1118	#endif
		1119	BOOT_PAGESIZE;
393		1120
394	Coro::State	1121	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
395	_newprocess(args)	1122
396	SV * args	1123	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
397	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, ...)
398	CODE:	1139	CODE:
399	Coro__State coro;	1140	{
		1141	struct coro *coro;
		1142	HV *hv;
		1143	int i;
400		1144
401	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");
403
404	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;
405		1149
406	coro->mainstack = 0; /* actual work is done inside transfer */	1150	hv = newHV ();
407	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));
408		1153
409	RETVAL = coro;	1154	for (i = 1; i < items; i++)
		1155	av_push (coro->args, newSVsv (ST (i)));
		1156	}
410	OUTPUT:	1157	OUTPUT:
411	RETVAL	1158	RETVAL
412		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
413	void	1167	void
414	transfer(prev,next)	1168	_set_stacklevel (...)
415	Coro::State_or_hashref prev	1169	ALIAS:
416	Coro::State_or_hashref next	1170	Coro::State::transfer = 1
		1171	Coro::schedule = 2
		1172	Coro::cede = 3
		1173	Coro::cede_notself = 4
417	CODE:	1174	CODE:
		1175	{
		1176	struct transfer_args ta;
418		1177
419	if (prev != next)	1178	switch (ix)
420	{	1179	{
421	/*
422	* this could be done in newprocess which would lead to
423	* extremely elegant and fast (just SAVE/LOAD)
424	* code here, but lazy allocation of stacks has also
425	* some virtues and the overhead of the if() is nil.
426	*/
427	if (next->mainstack)
428	{
429	SAVE (prev);
430	LOAD (next);
431	/* mark this state as in-use */
432	next->mainstack = 0;
433	next->tmps_ix = -2;
434	}
435	else if (next->tmps_ix == -2)
436	{
437	croak ("tried to transfer to running coroutine");
438	}
439	else	1180	case 0:
		1181	ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
		1182	ta.next = 0;
440	{	1183	break;
441	SAVE (prev);
442		1184
443	/*	1185	case 1:
444	* emulate part of the perl startup here.	1186	if (items != 2)
445	*/	1187	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446	UNOP myop;
447		1188
448	init_stacks (); /* from perl.c */	1189	prepare_transfer (&ta, ST (0), ST (1));
449	PL_op = (OP *)&myop;
450	/*PL_curcop = 0;*/
451	GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452
453	SPAGAIN;
454	Zero(&myop, 1, UNOP);
455	myop.op_next = Nullop;
456	myop.op_flags = OPf_WANT_VOID;
457
458	PUSHMARK(SP);
459	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	PUTBACK;
461	/*
462	* the next line is slightly wrong, as PL_op->op_next
463	* is actually being executed so we skip the first op.
464	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...
466	*/
467	PL_op = Perl_pp_entersub(aTHX);
468	SPAGAIN;
469
470	ENTER;
471	}	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;
472	}	1205	}
473		1206
		1207	BARRIER;
		1208	TRANSFER (ta);
		1209	}
		1210
		1211	bool
		1212	_destroy (SV *coro_sv)
		1213	CODE:
		1214	RETVAL = coro_state_destroy (SvSTATE (coro_sv));
		1215	OUTPUT:
		1216	RETVAL
		1217
474	void	1218	void
475	DESTROY(coro)	1219	_exit (code)
476	Coro::State coro	1220	int code
		1221	PROTOTYPE: $
		1222	CODE:
		1223	_exit (code);
		1224
		1225	int
		1226	cctx_count ()
		1227	CODE:
		1228	RETVAL = cctx_count;
		1229	OUTPUT:
		1230	RETVAL
		1231
		1232	int
		1233	cctx_idle ()
		1234	CODE:
		1235	RETVAL = cctx_idle;
		1236	OUTPUT:
		1237	RETVAL
		1238
		1239	MODULE = Coro::State PACKAGE = Coro
		1240
		1241	BOOT:
		1242	{
		1243	int i;
		1244
		1245	coro_stash = gv_stashpv ("Coro", TRUE);
		1246
		1247	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1248	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1249	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1250	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1251	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1252	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1253
		1254	coro_current = get_sv ("Coro::current", FALSE);
		1255	SvREADONLY_on (coro_current);
		1256
		1257	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1258	coro_ready[i] = newAV ();
		1259
		1260	{
		1261	SV *sv = perl_get_sv("Coro::API", 1);
		1262
		1263	coroapi.schedule = api_schedule;
		1264	coroapi.save = api_save;
		1265	coroapi.cede = api_cede;
		1266	coroapi.cede_notself = api_cede_notself;
		1267	coroapi.ready = api_ready;
		1268	coroapi.is_ready = api_is_ready;
		1269	coroapi.nready = &coro_nready;
		1270	coroapi.current = coro_current;
		1271
		1272	GCoroAPI = &coroapi;
		1273	sv_setiv (sv, (IV)&coroapi);
		1274	SvREADONLY_on (sv);
		1275	}
		1276	}
		1277
		1278	void
		1279	_set_current (SV *current)
		1280	PROTOTYPE: $
		1281	CODE:
		1282	SvREFCNT_dec (SvRV (coro_current));
		1283	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1284
		1285	int
		1286	prio (Coro::State coro, int newprio = 0)
		1287	ALIAS:
		1288	nice = 1
477	CODE:	1289	CODE:
		1290	{
		1291	RETVAL = coro->prio;
478		1292
479	if (coro->mainstack)	1293	if (items > 1)
480	{	1294	{
481	struct coro temp;	1295	if (ix)
		1296	newprio = coro->prio - newprio;
482		1297
483	SAVE(aTHX_ (&temp));	1298	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
484	LOAD(aTHX_ coro);	1299	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
485		1300
486	destroy_stacks ();	1301	coro->prio = newprio;
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488
489	LOAD((&temp));
490	}	1302	}
		1303	}
		1304	OUTPUT:
		1305	RETVAL
491		1306
492	SvREFCNT_dec (coro->args);	1307	SV *
493	Safefree (coro);	1308	ready (SV *self)
		1309	PROTOTYPE: $
		1310	CODE:
		1311	RETVAL = boolSV (api_ready (self));
		1312	OUTPUT:
		1313	RETVAL
494		1314
		1315	SV *
		1316	is_ready (SV *self)
		1317	PROTOTYPE: $
		1318	CODE:
		1319	RETVAL = boolSV (api_is_ready (self));
		1320	OUTPUT:
		1321	RETVAL
495		1322
		1323	int
		1324	nready (...)
		1325	PROTOTYPE:
		1326	CODE:
		1327	RETVAL = coro_nready;
		1328	OUTPUT:
		1329	RETVAL
		1330
		1331	MODULE = Coro::State PACKAGE = Coro::AIO
		1332
		1333	SV *
		1334	_get_state ()
		1335	CODE:
		1336	{
		1337	struct io_state *data;
		1338
		1339	RETVAL = newSV (sizeof (struct io_state));
		1340	data = (struct io_state *)SvPVX (RETVAL);
		1341	SvCUR_set (RETVAL, sizeof (struct io_state));
		1342	SvPOK_only (RETVAL);
		1343
		1344	data->errorno = errno;
		1345	data->laststype = PL_laststype;
		1346	data->laststatval = PL_laststatval;
		1347	data->statcache = PL_statcache;
		1348	}
		1349	OUTPUT:
		1350	RETVAL
		1351
		1352	void
		1353	_set_state (char *data_)
		1354	PROTOTYPE: $
		1355	CODE:
		1356	{
		1357	struct io_state *data = (void *)data_;
		1358
		1359	errno = data->errorno;
		1360	PL_laststype = data->laststype;
		1361	PL_laststatval = data->laststatval;
		1362	PL_statcache = data->statcache;
		1363	}
		1364

Diff Legend

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