ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.140 by root, Sat Jan 20 19:52:15 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)
339	{
340	/* die does this while calling POPSTACK, but I just don't see why. */
341	dounwind(-1);
342		566
343	/* is this ugly, I ask? */	567	static void
344	while (PL_scopestack_ix)	568	free_coro_mortal ()
345	LEAVE;	569	{
346		570	if (coro_mortal)
347	while (PL_curstackinfo->si_next)	571	{
348	PL_curstackinfo = PL_curstackinfo->si_next;	572	SvREFCNT_dec (coro_mortal);
349		573	coro_mortal = 0;
350	while (PL_curstackinfo)
351	{	574	}
352	PERL_SI *p = PL_curstackinfo->si_prev;	575	}
353		576
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	577	/* inject a fake call to Coro::State::_cctx_init into the execution */
355	Safefree(PL_curstackinfo->si_cxstack);	578	static void NOINLINE
356	Safefree(PL_curstackinfo);	579	prepare_cctx (coro_cctx *cctx)
357	PL_curstackinfo = p;	580	{
358	}	581	dSP;
		582	LOGOP myop;
359		583
360	if (PL_scopestack_ix != 0)	584	Zero (&myop, 1, LOGOP);
361	Perl_warner(aTHX_ WARN_INTERNAL,	585	myop.op_next = PL_op;
362	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	586	myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
363	(long)PL_scopestack_ix);	587
364	if (PL_savestack_ix != 0)	588	PUSHMARK (SP);
365	Perl_warner(aTHX_ WARN_INTERNAL,	589	EXTEND (SP, 2);
366	"Unbalanced saves: %ld more saves than restores\n",	590	PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
367	(long)PL_savestack_ix);	591	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
368	if (PL_tmps_floor != -1)	592	PUTBACK;
369	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	593	PL_op = (OP *)&myop;
370	(long)PL_tmps_floor + 1);	594	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		595	SPAGAIN;
		596	}
		597
		598	static void
		599	coro_run (void *arg)
		600	{
		601	/* coro_run is the alternative tail of transfer(), so unlock here. */
		602	UNLOCK;
		603
371	/*	604	/*
372	*/	605	* this is a _very_ stripped down perl interpreter ;)
373	Safefree(PL_tmps_stack);	606	*/
374	Safefree(PL_markstack);	607	PL_top_env = &PL_start_env;
375	Safefree(PL_scopestack);
376	Safefree(PL_savestack);
377	Safefree(PL_retstack);
378	}
379		608
380	#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 the coro */
		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	struct coro temp;
		854
		855	assert (!(coro->flags & CF_RUNNING));
		856
		857	Zero (&temp, 1, struct coro);
		858	temp.save = CORO_SAVE_ALL;
		859
		860	if (coro->flags & CF_RUNNING)
		861	croak ("FATAL: tried to destroy currently running coroutine");
		862
		863	save_perl (&temp);
		864	load_perl (coro);
		865
		866	coro_destroy_stacks ();
		867
		868	load_perl (&temp); /* this will get rid of defsv etc.. */
		869
		870	coro->mainstack = 0;
		871	}
		872
		873	cctx_destroy (coro->cctx);
		874	SvREFCNT_dec (coro->args);
		875
		876	return 1;
		877	}
		878
		879	static int
		880	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
		881	{
		882	struct coro *coro = (struct coro *)mg->mg_ptr;
		883	mg->mg_ptr = 0;
		884
		885	if (--coro->refcnt < 0)
		886	{
		887	coro_state_destroy (coro);
		888	Safefree (coro);
		889	}
		890
		891	return 0;
		892	}
		893
		894	static int
		895	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		896	{
		897	struct coro *coro = (struct coro *)mg->mg_ptr;
		898
		899	++coro->refcnt;
		900
		901	return 0;
		902	}
		903
		904	static MGVTBL coro_state_vtbl = {
		905	0, 0, 0, 0,
		906	coro_state_free,
		907	0,
		908	#ifdef MGf_DUP
		909	coro_state_dup,
		910	#else
		911	# define MGf_DUP 0
		912	#endif
		913	};
		914
		915	static struct coro *
		916	SvSTATE (SV *coro)
		917	{
		918	HV *stash;
		919	MAGIC *mg;
		920
		921	if (SvROK (coro))
		922	coro = SvRV (coro);
		923
		924	stash = SvSTASH (coro);
		925	if (stash != coro_stash && stash != coro_state_stash)
		926	{
		927	/* very slow, but rare, check */
		928	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		929	croak ("Coro::State object required");
		930	}
		931
		932	mg = SvMAGIC (coro);
		933	assert (mg->mg_type == PERL_MAGIC_ext);
		934	return (struct coro *)mg->mg_ptr;
		935	}
		936
		937	static void
		938	prepare_transfer (struct transfer_args *ta, SV *prev_sv, SV *next_sv)
		939	{
		940	ta->prev = SvSTATE (prev_sv);
		941	ta->next = SvSTATE (next_sv);
		942	}
		943
		944	static void
		945	api_transfer (SV *prev_sv, SV *next_sv)
		946	{
		947	struct transfer_args ta;
		948
		949	prepare_transfer (&ta, prev_sv, next_sv);
		950	TRANSFER (ta);
		951	}
		952
		953	static int
		954	api_save (SV *coro_sv, int new_save)
		955	{
		956	struct coro *coro = SvSTATE (coro_sv);
		957	int old_save = coro->save;
		958
		959	if (new_save >= 0)
		960	coro->save = new_save;
		961
		962	return old_save;
		963	}
		964
		965	/** Coro ********************************************************************/
		966
		967	static void
		968	coro_enq (SV *coro_sv)
		969	{
		970	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		971	}
		972
		973	static SV *
		974	coro_deq (int min_prio)
		975	{
		976	int prio = PRIO_MAX - PRIO_MIN;
		977
		978	min_prio -= PRIO_MIN;
		979	if (min_prio < 0)
		980	min_prio = 0;
		981
		982	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		983	if (AvFILLp (coro_ready [prio]) >= 0)
		984	return av_shift (coro_ready [prio]);
		985
		986	return 0;
		987	}
		988
		989	static int
		990	api_ready (SV *coro_sv)
		991	{
		992	struct coro *coro;
		993
		994	if (SvROK (coro_sv))
		995	coro_sv = SvRV (coro_sv);
		996
		997	coro = SvSTATE (coro_sv);
		998
		999	if (coro->flags & CF_READY)
		1000	return 0;
		1001
		1002	coro->flags |= CF_READY;
		1003
		1004	LOCK;
		1005	coro_enq (SvREFCNT_inc (coro_sv));
		1006	++coro_nready;
		1007	UNLOCK;
		1008
		1009	return 1;
		1010	}
		1011
		1012	static int
		1013	api_is_ready (SV *coro_sv)
		1014	{
		1015	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		1016	}
		1017
		1018	static void
		1019	prepare_schedule (struct transfer_args *ta)
		1020	{
		1021	SV *prev_sv, *next_sv;
		1022
		1023	for (;;)
		1024	{
		1025	LOCK;
		1026	next_sv = coro_deq (PRIO_MIN);
		1027
		1028	/* nothing to schedule: call the idle handler */
		1029	if (!next_sv)
		1030	{
		1031	dSP;
		1032	UNLOCK;
		1033
		1034	ENTER;
		1035	SAVETMPS;
		1036
		1037	PUSHMARK (SP);
		1038	PUTBACK;
		1039	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1040
		1041	FREETMPS;
		1042	LEAVE;
		1043	continue;
		1044	}
		1045
		1046	ta->next = SvSTATE (next_sv);
		1047
		1048	/* cannot transfer to destroyed coros, skip and look for next */
		1049	if (ta->next->flags & CF_DESTROYED)
		1050	{
		1051	UNLOCK;
		1052	SvREFCNT_dec (next_sv);
		1053	/* coro_nready is already taken care of by destroy */
		1054	continue;
		1055	}
		1056
		1057	--coro_nready;
		1058	UNLOCK;
		1059	break;
		1060	}
		1061
		1062	/* free this only after the transfer */
		1063	prev_sv = SvRV (coro_current);
		1064	SvRV_set (coro_current, next_sv);
		1065	ta->prev = SvSTATE (prev_sv);
		1066
		1067	assert (ta->next->flags & CF_READY);
		1068	ta->next->flags &= ~CF_READY;
		1069
		1070	LOCK;
		1071	free_coro_mortal ();
		1072	coro_mortal = prev_sv;
		1073	UNLOCK;
		1074	}
		1075
		1076	static void
		1077	prepare_cede (struct transfer_args *ta)
		1078	{
		1079	api_ready (coro_current);
		1080	prepare_schedule (ta);
		1081	}
		1082
		1083	static int
		1084	prepare_cede_notself (struct transfer_args *ta)
		1085	{
		1086	if (coro_nready)
		1087	{
		1088	SV *prev = SvRV (coro_current);
		1089	prepare_schedule (ta);
		1090	api_ready (prev);
		1091	return 1;
		1092	}
		1093	else
		1094	return 0;
		1095	}
		1096
		1097	static void
		1098	api_schedule (void)
		1099	{
		1100	struct transfer_args ta;
		1101
		1102	prepare_schedule (&ta);
		1103	TRANSFER (ta);
		1104	}
		1105
		1106	static int
		1107	api_cede (void)
		1108	{
		1109	struct transfer_args ta;
		1110
		1111	prepare_cede (&ta);
		1112
		1113	if (ta.prev != ta.next)
		1114	{
		1115	TRANSFER (ta);
		1116	return 1;
		1117	}
		1118	else
		1119	return 0;
		1120	}
		1121
		1122	static int
		1123	api_cede_notself (void)
		1124	{
		1125	struct transfer_args ta;
		1126
		1127	if (prepare_cede_notself (&ta))
		1128	{
		1129	TRANSFER (ta);
		1130	return 1;
		1131	}
		1132	else
		1133	return 0;
		1134	}
381		1135
382	MODULE = Coro::State PACKAGE = Coro::State	1136	MODULE = Coro::State PACKAGE = Coro::State
383		1137
384	PROTOTYPES: ENABLE	1138	PROTOTYPES: DISABLE
385		1139
386	BOOT:	1140	BOOT:
387	if (!padlist_cache)	1141	{
388	padlist_cache = newHV ();	1142	#ifdef USE_ITHREADS
		1143	MUTEX_INIT (&coro_mutex);
		1144	#endif
		1145	BOOT_PAGESIZE;
389		1146
390	Coro::State	1147	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
391	_newprocess(args)	1148
392	SV * args	1149	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
393	PROTOTYPE: $	1150	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
		1151	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
		1152	newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
		1153	newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
		1154
		1155	main_mainstack = PL_mainstack;
		1156
		1157	coroapi.ver = CORO_API_VERSION;
		1158	coroapi.transfer = api_transfer;
		1159
		1160	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1161	}
		1162
		1163	SV *
		1164	new (char *klass, ...)
394	CODE:	1165	CODE:
395	Coro__State coro;	1166	{
		1167	struct coro *coro;
		1168	HV *hv;
		1169	int i;
396		1170
397	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");
399
400	New (0, coro, 1, struct coro);	1171	Newz (0, coro, 1, struct coro);
		1172	coro->args = newAV ();
		1173	coro->save = CORO_SAVE_ALL;
		1174	coro->flags = CF_NEW;
401		1175
402	coro->mainstack = 0; /* actual work is done inside transfer */	1176	hv = newHV ();
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1177	sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
		1178	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
404		1179
405	RETVAL = coro;	1180	for (i = 1; i < items; i++)
		1181	av_push (coro->args, newSVsv (ST (i)));
		1182	}
406	OUTPUT:	1183	OUTPUT:
407	RETVAL	1184	RETVAL
408		1185
		1186	int
		1187	save (SV *coro, int new_save = -1)
		1188	CODE:
		1189	RETVAL = api_save (coro, new_save);
		1190	OUTPUT:
		1191	RETVAL
		1192
409	void	1193	void
410	transfer(prev,next)	1194	_set_stacklevel (...)
411	Coro::State_or_hashref prev	1195	ALIAS:
412	Coro::State_or_hashref next	1196	Coro::State::transfer = 1
		1197	Coro::schedule = 2
		1198	Coro::cede = 3
		1199	Coro::cede_notself = 4
413	CODE:	1200	CODE:
		1201	{
		1202	struct transfer_args ta;
414		1203
415	if (prev != next)	1204	switch (ix)
416	{	1205	{
417	PUTBACK;
418	SAVE (aTHX_ prev);
419
420	/*
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;
431	}
432	else	1206	case 0:
		1207	ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
		1208	ta.next = 0;
433	{	1209	break;
434	/*
435	* emulate part of the perl startup here.
436	*/
437	UNOP myop;
438		1210
439	init_stacks (); /* from perl.c */	1211	case 1:
440	PL_op = (OP *)&myop;	1212	if (items != 2)
441	/*PL_curcop = 0;*/	1213	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
442	GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
443		1214
444	SPAGAIN;	1215	prepare_transfer (&ta, ST (0), ST (1));
445	Zero(&myop, 1, UNOP);
446	myop.op_next = Nullop;
447	myop.op_flags = OPf_WANT_VOID;
448
449	PUSHMARK(SP);
450	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451	PUTBACK;
452	/*
453	* the next line is slightly wrong, as PL_op->op_next
454	* is actually being executed so we skip the first op.
455	* that doesn't matter, though, since it is only
456	* pp_nextstate and we never return...
457	*/
458	PL_op = Perl_pp_entersub(aTHX);
459	SPAGAIN;
460
461	ENTER;
462	}	1216	break;
		1217
		1218	case 2:
		1219	prepare_schedule (&ta);
		1220	break;
		1221
		1222	case 3:
		1223	prepare_cede (&ta);
		1224	break;
		1225
		1226	case 4:
		1227	if (!prepare_cede_notself (&ta))
		1228	XSRETURN_EMPTY;
		1229
		1230	break;
463	}	1231	}
464		1232
		1233	BARRIER;
		1234	TRANSFER (ta);
		1235
		1236	if (GIMME_V != G_VOID && ta.next != ta.prev)
		1237	XSRETURN_YES;
		1238	}
		1239
		1240	bool
		1241	_destroy (SV *coro_sv)
		1242	CODE:
		1243	RETVAL = coro_state_destroy (SvSTATE (coro_sv));
		1244	OUTPUT:
		1245	RETVAL
		1246
465	void	1247	void
466	DESTROY(coro)	1248	_exit (code)
467	Coro::State coro	1249	int code
		1250	PROTOTYPE: $
		1251	CODE:
		1252	_exit (code);
		1253
		1254	int
		1255	cctx_count ()
		1256	CODE:
		1257	RETVAL = cctx_count;
		1258	OUTPUT:
		1259	RETVAL
		1260
		1261	int
		1262	cctx_idle ()
		1263	CODE:
		1264	RETVAL = cctx_idle;
		1265	OUTPUT:
		1266	RETVAL
		1267
		1268	MODULE = Coro::State PACKAGE = Coro
		1269
		1270	BOOT:
		1271	{
		1272	int i;
		1273
		1274	coro_stash = gv_stashpv ("Coro", TRUE);
		1275
		1276	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1277	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1278	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1279	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1280	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1281	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1282
		1283	coro_current = get_sv ("Coro::current", FALSE);
		1284	SvREADONLY_on (coro_current);
		1285
		1286	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1287	coro_ready[i] = newAV ();
		1288
		1289	{
		1290	SV *sv = perl_get_sv("Coro::API", 1);
		1291
		1292	coroapi.schedule = api_schedule;
		1293	coroapi.save = api_save;
		1294	coroapi.cede = api_cede;
		1295	coroapi.cede_notself = api_cede_notself;
		1296	coroapi.ready = api_ready;
		1297	coroapi.is_ready = api_is_ready;
		1298	coroapi.nready = &coro_nready;
		1299	coroapi.current = coro_current;
		1300
		1301	GCoroAPI = &coroapi;
		1302	sv_setiv (sv, (IV)&coroapi);
		1303	SvREADONLY_on (sv);
		1304	}
		1305	}
		1306
		1307	void
		1308	_set_current (SV *current)
		1309	PROTOTYPE: $
		1310	CODE:
		1311	SvREFCNT_dec (SvRV (coro_current));
		1312	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1313
		1314	int
		1315	prio (Coro::State coro, int newprio = 0)
		1316	ALIAS:
		1317	nice = 1
468	CODE:	1318	CODE:
		1319	{
		1320	RETVAL = coro->prio;
469		1321
470	if (coro->mainstack)	1322	if (items > 1)
471	{	1323	{
472	struct coro temp;	1324	if (ix)
		1325	newprio = coro->prio - newprio;
473		1326
474	PUTBACK;	1327	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
475	SAVE(aTHX_ (&temp));	1328	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
476	LOAD(aTHX_ coro);
477		1329
478	destroy_stacks ();	1330	coro->prio = newprio;
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;
483	}	1331	}
		1332	}
		1333	OUTPUT:
		1334	RETVAL
484		1335
485	SvREFCNT_dec (coro->args);	1336	SV *
486	Safefree (coro);	1337	ready (SV *self)
		1338	PROTOTYPE: $
		1339	CODE:
		1340	RETVAL = boolSV (api_ready (self));
		1341	OUTPUT:
		1342	RETVAL
487		1343
		1344	SV *
		1345	is_ready (SV *self)
		1346	PROTOTYPE: $
		1347	CODE:
		1348	RETVAL = boolSV (api_is_ready (self));
		1349	OUTPUT:
		1350	RETVAL
488		1351
		1352	int
		1353	nready (...)
		1354	PROTOTYPE:
		1355	CODE:
		1356	RETVAL = coro_nready;
		1357	OUTPUT:
		1358	RETVAL
		1359
		1360	MODULE = Coro::State PACKAGE = Coro::AIO
		1361
		1362	SV *
		1363	_get_state ()
		1364	CODE:
		1365	{
		1366	struct io_state *data;
		1367
		1368	RETVAL = newSV (sizeof (struct io_state));
		1369	data = (struct io_state *)SvPVX (RETVAL);
		1370	SvCUR_set (RETVAL, sizeof (struct io_state));
		1371	SvPOK_only (RETVAL);
		1372
		1373	data->errorno = errno;
		1374	data->laststype = PL_laststype;
		1375	data->laststatval = PL_laststatval;
		1376	data->statcache = PL_statcache;
		1377	}
		1378	OUTPUT:
		1379	RETVAL
		1380
		1381	void
		1382	_set_state (char *data_)
		1383	PROTOTYPE: $
		1384	CODE:
		1385	{
		1386	struct io_state *data = (void *)data_;
		1387
		1388	errno = data->errorno;
		1389	PL_laststype = data->laststype;
		1390	PL_laststatval = data->laststatval;
		1391	PL_statcache = data->statcache;
		1392	}
		1393

Diff Legend

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