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

Diff Legend

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