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.149 by root, Sat Apr 14 15:06:05 2007 UTC

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

Diff Legend

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