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

Diff Legend

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