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.148 by root, Fri Apr 13 12:56:55 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 ((SV *)get_cv ("Coro::State::_coro_init", FALSE));
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
		596	prepare_cctx (pTHX_ coro_cctx *cctx)
		597	{
		598	dSP;
		599	LOGOP myop;
		600
		601	Zero (&myop, 1, LOGOP);
		602	myop.op_next = PL_op;
		603	myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
		604
		605	PUSHMARK (SP);
		606	EXTEND (SP, 2);
		607	PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
		608	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
		609	PUTBACK;
		610	PL_op = (OP *)&myop;
		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
		635	/* If perl-run returns we assume exit() was being called, which */
		636	/* seems to be the only valid (non-bug) reason for perl_run to return. */
		637	/* We try to exit by jumping to the bootstrap-time "top" top_env, as */
		638	/* we cannot restore the "main" coroutine as Coro has no such concept */
		639	PL_top_env = main_top_env;
		640	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
		641	}
		642
		643	static coro_cctx *
		644	cctx_new ()
		645	{
		646	coro_cctx *cctx;
		647	void *stack_start;
		648	size_t stack_size;
		649
		650	++cctx_count;
		651
		652	Newz (0, cctx, 1, coro_cctx);
		653
		654	#if HAVE_MMAP
		655
		656	cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
		657	/* mmap supposedly does allocate-on-write for us */
		658	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
		659
		660	if (cctx->sptr != (void *)-1)
		661	{
		662	# if CORO_STACKGUARD
		663	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
		664	# endif
		665	stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
		666	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
		667	cctx->mapped = 1;
		668	}
		669	else
		670	#endif
		671	{
		672	cctx->ssize = coro_stacksize * (long)sizeof (long);
		673	New (0, cctx->sptr, coro_stacksize, long);
		674
		675	if (!cctx->sptr)
		676	{
		677	perror ("FATAL: unable to allocate stack for coroutine");
		678	_exit (EXIT_FAILURE);
		679	}
		680
		681	stack_start = cctx->sptr;
		682	stack_size = cctx->ssize;
		683	}
		684
		685	REGISTER_STACK (cctx, (char *)stack_start, (char *)stack_start + stack_size);
		686	coro_create (&cctx->cctx, coro_run, (void *)cctx, stack_start, stack_size);
		687
		688	return cctx;
		689	}
		690
		691	static void
		692	cctx_destroy (coro_cctx *cctx)
		693	{
		694	if (!cctx)
		695	return;
		696
		697	--cctx_count;
		698
		699	#if CORO_USE_VALGRIND
		700	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		701	#endif
		702
		703	#if HAVE_MMAP
		704	if (cctx->mapped)
		705	munmap (cctx->sptr, cctx->ssize);
		706	else
		707	#endif
		708	Safefree (cctx->sptr);
		709
		710	Safefree (cctx);
		711	}
		712
		713	static coro_cctx *
		714	cctx_get (pTHX)
		715	{
		716	while (cctx_first)
		717	{
		718	coro_cctx *cctx = cctx_first;
		719	cctx_first = cctx->next;
		720	--cctx_idle;
		721
		722	if (cctx->ssize >= coro_stacksize)
		723	return cctx;
		724
		725	cctx_destroy (cctx);
		726	}
		727
		728	PL_op = PL_op->op_next;
		729	return cctx_new ();
		730	}
		731
		732	static void
		733	cctx_put (coro_cctx *cctx)
		734	{
		735	/* free another cctx if overlimit */
		736	if (cctx_idle >= MAX_IDLE_CCTX)
		737	{
		738	coro_cctx *first = cctx_first;
		739	cctx_first = first->next;
		740	--cctx_idle;
		741
		742	assert (!first->inuse);
		743	cctx_destroy (first);
		744	}
		745
		746	++cctx_idle;
		747	cctx->next = cctx_first;
		748	cctx_first = cctx;
		749	}
		750
		751	/** coroutine switching *****************************************************/
		752
		753	/* never call directly, always through the coro_state_transfer global variable */
		754	static void NOINLINE
		755	transfer (pTHX_ struct coro *prev, struct coro *next)
		756	{
		757	dSTACKLEVEL;
		758
		759	/* sometimes transfer is only called to set idle_sp */
		760	if (!next)
		761	{
		762	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		763	assert (((coro_cctx *)prev)->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */
		764	}
		765	else if (prev != next)
		766	{
		767	coro_cctx *prev__cctx;
		768
		769	if (prev->flags & CF_NEW)
		770	{
		771	/* create a new empty context */
		772	Newz (0, prev->cctx, 1, coro_cctx);
		773	prev->cctx->inuse = 1;
		774	prev->flags &= ~CF_NEW;
		775	prev->flags |= CF_RUNNING;
		776	}
		777
		778	/*TODO: must not croak here */
		779	if (!prev->flags & CF_RUNNING)
		780	croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
		781
		782	if (next->flags & CF_RUNNING)
		783	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		784
		785	if (next->flags & CF_DESTROYED)
		786	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		787
		788	prev->flags &= ~CF_RUNNING;
		789	next->flags |= CF_RUNNING;
		790
		791	LOCK;
		792
		793	if (next->flags & CF_NEW)
		794	{
		795	/* need to start coroutine */
		796	next->flags &= ~CF_NEW;
		797	/* first get rid of the old state */
		798	save_perl (aTHX_ prev);
		799	/* setup coroutine call */
		800	setup_coro (aTHX_ next);
		801	/* need a new stack */
		802	assert (!next->cctx);
		803	}
		804	else
		805	{
		806	/* coroutine already started */
		807	save_perl (aTHX_ prev);
		808	load_perl (aTHX_ next);
		809	}
		810
		811	prev__cctx = prev->cctx;
		812
		813	/* possibly "free" the cctx */
		814	if (prev__cctx->idle_sp == STACKLEVEL)
		815	{
		816	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		817	assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
		818
		819	prev->cctx = 0;
		820
		821	cctx_put (prev__cctx);
		822	prev__cctx->inuse = 0;
		823	}
		824
		825	if (!next->cctx)
		826	{
		827	next->cctx = cctx_get (aTHX);
		828	assert (!next->cctx->inuse);
		829	next->cctx->inuse = 1;
		830	}
		831
		832	if (prev__cctx != next->cctx)
		833	{
		834	prev__cctx->top_env = PL_top_env;
		835	PL_top_env = next->cctx->top_env;
		836	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		837	}
		838
		839	free_coro_mortal (aTHX);
		840	UNLOCK;
		841	}
		842	}
		843
		844	struct transfer_args
		845	{
		846	struct coro *prev, *next;
		847	};
		848
		849	#define TRANSFER(ta) transfer (aTHX_ (ta).prev, (ta).next)
		850
		851	/** high level stuff ********************************************************/
		852
		853	static int
		854	coro_state_destroy (pTHX_ struct coro *coro)
		855	{
		856	if (coro->flags & CF_DESTROYED)
		857	return 0;
		858
		859	coro->flags |= CF_DESTROYED;
362	}	860
		861	if (coro->flags & CF_READY)
		862	{
		863	/* reduce nready, as destroying a ready coro effectively unreadies it */
		864	/* alternative: look through all ready queues and remove the coro */
		865	LOCK;
		866	--coro_nready;
		867	UNLOCK;
		868	}
		869	else
		870	coro->flags |= CF_READY; /* make sure it is NOT put into the readyqueue */
363		871
364	if (PL_scopestack_ix != 0)	872	if (coro->mainstack && coro->mainstack != main_mainstack)
365	Perl_warner(aTHX_ WARN_INTERNAL,	873	{
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	874	struct coro temp;
367	(long)PL_scopestack_ix);
368	if (PL_savestack_ix != 0)
369	Perl_warner(aTHX_ WARN_INTERNAL,
370	"Unbalanced saves: %ld more saves than restores\n",
371	(long)PL_savestack_ix);
372	if (PL_tmps_floor != -1)
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374	(long)PL_tmps_floor + 1);
375	/*
376	*/
377	Safefree(PL_tmps_stack);
378	Safefree(PL_markstack);
379	Safefree(PL_scopestack);
380	Safefree(PL_savestack);
381	Safefree(PL_retstack);
382	}
383		875
384	#define SUB_INIT "Coro::State::_newcoro"	876	assert (!(coro->flags & CF_RUNNING));
		877
		878	Zero (&temp, 1, struct coro);
		879	temp.save = CORO_SAVE_DEF;
		880
		881	if (coro->flags & CF_RUNNING)
		882	croak ("FATAL: tried to destroy currently running coroutine");
		883
		884	save_perl (aTHX_ &temp);
		885	load_perl (aTHX_ coro);
		886
		887	coro_destroy_stacks (aTHX);
		888
		889	load_perl (aTHX_ &temp); /* this will get rid of defsv etc.. */
		890
		891	coro->mainstack = 0;
		892	}
		893
		894	cctx_destroy (coro->cctx);
		895	SvREFCNT_dec (coro->args);
		896
		897	return 1;
		898	}
		899
		900	static int
		901	coro_state_free (pTHX_ SV *sv, MAGIC *mg)
		902	{
		903	struct coro *coro = (struct coro *)mg->mg_ptr;
		904	mg->mg_ptr = 0;
		905
		906	if (--coro->refcnt < 0)
		907	{
		908	coro_state_destroy (aTHX_ coro);
		909	Safefree (coro);
		910	}
		911
		912	return 0;
		913	}
		914
		915	static int
		916	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		917	{
		918	struct coro *coro = (struct coro *)mg->mg_ptr;
		919
		920	++coro->refcnt;
		921
		922	return 0;
		923	}
		924
		925	static MGVTBL coro_state_vtbl = {
		926	0, 0, 0, 0,
		927	coro_state_free,
		928	0,
		929	#ifdef MGf_DUP
		930	coro_state_dup,
		931	#else
		932	# define MGf_DUP 0
		933	#endif
		934	};
		935
		936	static struct coro *
		937	SvSTATE_ (pTHX_ SV *coro)
		938	{
		939	HV *stash;
		940	MAGIC *mg;
		941
		942	if (SvROK (coro))
		943	coro = SvRV (coro);
		944
		945	stash = SvSTASH (coro);
		946	if (stash != coro_stash && stash != coro_state_stash)
		947	{
		948	/* very slow, but rare, check */
		949	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		950	croak ("Coro::State object required");
		951	}
		952
		953	mg = CORO_MAGIC (coro);
		954	return (struct coro *)mg->mg_ptr;
		955	}
		956
		957	#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
		958
		959	static void
		960	prepare_transfer (pTHX_ struct transfer_args *ta, SV *prev_sv, SV *next_sv)
		961	{
		962	ta->prev = SvSTATE (prev_sv);
		963	ta->next = SvSTATE (next_sv);
		964	}
		965
		966	static void
		967	api_transfer (SV *prev_sv, SV *next_sv)
		968	{
		969	dTHX;
		970	struct transfer_args ta;
		971
		972	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
		973	TRANSFER (ta);
		974	}
		975
		976	static int
		977	api_save (SV *coro_sv, int new_save)
		978	{
		979	dTHX;
		980	struct coro *coro = SvSTATE (coro_sv);
		981	int old_save = coro->save;
		982
		983	if (new_save >= 0)
		984	coro->save = new_save;
		985
		986	return old_save;
		987	}
		988
		989	/** Coro ********************************************************************/
		990
		991	static void
		992	coro_enq (pTHX_ SV *coro_sv)
		993	{
		994	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		995	}
		996
		997	static SV *
		998	coro_deq (pTHX_ int min_prio)
		999	{
		1000	int prio = PRIO_MAX - PRIO_MIN;
		1001
		1002	min_prio -= PRIO_MIN;
		1003	if (min_prio < 0)
		1004	min_prio = 0;
		1005
		1006	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		1007	if (AvFILLp (coro_ready [prio]) >= 0)
		1008	return av_shift (coro_ready [prio]);
		1009
		1010	return 0;
		1011	}
		1012
		1013	static int
		1014	api_ready (SV *coro_sv)
		1015	{
		1016	dTHX;
		1017	struct coro *coro;
		1018
		1019	if (SvROK (coro_sv))
		1020	coro_sv = SvRV (coro_sv);
		1021
		1022	coro = SvSTATE (coro_sv);
		1023
		1024	if (coro->flags & CF_READY)
		1025	return 0;
		1026
		1027	coro->flags |= CF_READY;
		1028
		1029	LOCK;
		1030	coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
		1031	++coro_nready;
		1032	UNLOCK;
		1033
		1034	return 1;
		1035	}
		1036
		1037	static int
		1038	api_is_ready (SV *coro_sv)
		1039	{
		1040	dTHX;
		1041	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		1042	}
		1043
		1044	static void
		1045	prepare_schedule (pTHX_ struct transfer_args *ta)
		1046	{
		1047	SV *prev_sv, *next_sv;
		1048
		1049	for (;;)
		1050	{
		1051	LOCK;
		1052	next_sv = coro_deq (aTHX_ PRIO_MIN);
		1053
		1054	/* nothing to schedule: call the idle handler */
		1055	if (!next_sv)
		1056	{
		1057	dSP;
		1058	UNLOCK;
		1059
		1060	ENTER;
		1061	SAVETMPS;
		1062
		1063	PUSHMARK (SP);
		1064	PUTBACK;
		1065	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1066
		1067	FREETMPS;
		1068	LEAVE;
		1069	continue;
		1070	}
		1071
		1072	ta->next = SvSTATE (next_sv);
		1073
		1074	/* cannot transfer to destroyed coros, skip and look for next */
		1075	if (ta->next->flags & CF_DESTROYED)
		1076	{
		1077	UNLOCK;
		1078	SvREFCNT_dec (next_sv);
		1079	/* coro_nready is already taken care of by destroy */
		1080	continue;
		1081	}
		1082
		1083	--coro_nready;
		1084	UNLOCK;
		1085	break;
		1086	}
		1087
		1088	/* free this only after the transfer */
		1089	prev_sv = SvRV (coro_current);
		1090	SvRV_set (coro_current, next_sv);
		1091	ta->prev = SvSTATE (prev_sv);
		1092
		1093	assert (ta->next->flags & CF_READY);
		1094	ta->next->flags &= ~CF_READY;
		1095
		1096	LOCK;
		1097	free_coro_mortal (aTHX);
		1098	coro_mortal = prev_sv;
		1099	UNLOCK;
		1100	}
		1101
		1102	static void
		1103	prepare_cede (pTHX_ struct transfer_args *ta)
		1104	{
		1105	api_ready (coro_current);
		1106	prepare_schedule (aTHX_ ta);
		1107	}
		1108
		1109	static int
		1110	prepare_cede_notself (pTHX_ struct transfer_args *ta)
		1111	{
		1112	if (coro_nready)
		1113	{
		1114	SV *prev = SvRV (coro_current);
		1115	prepare_schedule (aTHX_ ta);
		1116	api_ready (prev);
		1117	return 1;
		1118	}
		1119	else
		1120	return 0;
		1121	}
		1122
		1123	static void
		1124	api_schedule (void)
		1125	{
		1126	dTHX;
		1127	struct transfer_args ta;
		1128
		1129	prepare_schedule (aTHX_ &ta);
		1130	TRANSFER (ta);
		1131	}
		1132
		1133	static int
		1134	api_cede (void)
		1135	{
		1136	dTHX;
		1137	struct transfer_args ta;
		1138
		1139	prepare_cede (aTHX_ &ta);
		1140
		1141	if (ta.prev != ta.next)
		1142	{
		1143	TRANSFER (ta);
		1144	return 1;
		1145	}
		1146	else
		1147	return 0;
		1148	}
		1149
		1150	static int
		1151	api_cede_notself (void)
		1152	{
		1153	dTHX;
		1154	struct transfer_args ta;
		1155
		1156	if (prepare_cede_notself (aTHX_ &ta))
		1157	{
		1158	TRANSFER (ta);
		1159	return 1;
		1160	}
		1161	else
		1162	return 0;
		1163	}
385		1164
386	MODULE = Coro::State PACKAGE = Coro::State	1165	MODULE = Coro::State PACKAGE = Coro::State
387		1166
388	PROTOTYPES: ENABLE	1167	PROTOTYPES: DISABLE
389		1168
390	BOOT:	1169	BOOT:
391	if (!padlist_cache)	1170	{
392	padlist_cache = newHV ();	1171	#ifdef USE_ITHREADS
		1172	MUTEX_INIT (&coro_mutex);
		1173	#endif
		1174	BOOT_PAGESIZE;
393		1175
394	Coro::State	1176	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
395	_newprocess(args)	1177
396	SV * args	1178	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
397	PROTOTYPE: $	1179	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
		1180	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
		1181	newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
		1182	newCONSTSUB (coro_state_stash, "SAVE_DEFFH", newSViv (CORO_SAVE_DEFFH));
		1183	newCONSTSUB (coro_state_stash, "SAVE_DEF", newSViv (CORO_SAVE_DEF));
		1184	newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
		1185
		1186	main_mainstack = PL_mainstack;
		1187	main_top_env = PL_top_env;
		1188
		1189	while (main_top_env->je_prev)
		1190	main_top_env = main_top_env->je_prev;
		1191
		1192	coroapi.ver = CORO_API_VERSION;
		1193	coroapi.transfer = api_transfer;
		1194
		1195	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1196	}
		1197
		1198	SV *
		1199	new (char *klass, ...)
398	CODE:	1200	CODE:
399	Coro__State coro;	1201	{
		1202	struct coro *coro;
		1203	HV *hv;
		1204	int i;
400		1205
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);	1206	Newz (0, coro, 1, struct coro);
		1207	coro->args = newAV ();
		1208	coro->save = CORO_SAVE_DEF;
		1209	coro->flags = CF_NEW;
405		1210
406	coro->mainstack = 0; /* actual work is done inside transfer */	1211	hv = newHV ();
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1212	sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
		1213	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
408		1214
409	RETVAL = coro;	1215	for (i = 1; i < items; i++)
		1216	av_push (coro->args, newSVsv (ST (i)));
		1217	}
410	OUTPUT:	1218	OUTPUT:
411	RETVAL	1219	RETVAL
412		1220
		1221	int
		1222	save (SV *coro, int new_save = -1)
		1223	CODE:
		1224	RETVAL = api_save (coro, new_save);
		1225	OUTPUT:
		1226	RETVAL
		1227
		1228	int
		1229	save_also (SV *coro_sv, int save_also)
		1230	CODE:
		1231	{
		1232	struct coro *coro = SvSTATE (coro_sv);
		1233	RETVAL = coro->save;
		1234	coro->save |= save_also;
		1235	}
		1236	OUTPUT:
		1237	RETVAL
		1238
413	void	1239	void
414	transfer(prev,next)	1240	_set_stacklevel (...)
415	Coro::State_or_hashref prev	1241	ALIAS:
416	Coro::State_or_hashref next	1242	Coro::State::transfer = 1
		1243	Coro::schedule = 2
		1244	Coro::cede = 3
		1245	Coro::cede_notself = 4
417	CODE:	1246	CODE:
		1247	{
		1248	struct transfer_args ta;
418		1249
419	if (prev != next)	1250	switch (ix)
420	{	1251	{
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	1252	case 0:
		1253	ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
		1254	ta.next = 0;
440	{	1255	break;
441	SAVE (prev);
442		1256
443	/*	1257	case 1:
444	* emulate part of the perl startup here.	1258	if (items != 2)
445	*/	1259	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446	UNOP myop;
447		1260
448	init_stacks (); /* from perl.c */	1261	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	}	1262	break;
		1263
		1264	case 2:
		1265	prepare_schedule (aTHX_ &ta);
		1266	break;
		1267
		1268	case 3:
		1269	prepare_cede (aTHX_ &ta);
		1270	break;
		1271
		1272	case 4:
		1273	if (!prepare_cede_notself (aTHX_ &ta))
		1274	XSRETURN_EMPTY;
		1275
		1276	break;
472	}	1277	}
473		1278
		1279	BARRIER;
		1280	TRANSFER (ta);
		1281
		1282	if (GIMME_V != G_VOID && ta.next != ta.prev)
		1283	XSRETURN_YES;
		1284	}
		1285
		1286	bool
		1287	_destroy (SV *coro_sv)
		1288	CODE:
		1289	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		1290	OUTPUT:
		1291	RETVAL
		1292
474	void	1293	void
475	DESTROY(coro)	1294	_exit (code)
476	Coro::State coro	1295	int code
		1296	PROTOTYPE: $
		1297	CODE:
		1298	_exit (code);
		1299
		1300	int
		1301	cctx_stacksize (int new_stacksize = 0)
		1302	CODE:
		1303	RETVAL = coro_stacksize;
		1304	if (new_stacksize)
		1305	coro_stacksize = new_stacksize;
		1306	OUTPUT:
		1307	RETVAL
		1308
		1309	int
		1310	cctx_count ()
		1311	CODE:
		1312	RETVAL = cctx_count;
		1313	OUTPUT:
		1314	RETVAL
		1315
		1316	int
		1317	cctx_idle ()
		1318	CODE:
		1319	RETVAL = cctx_idle;
		1320	OUTPUT:
		1321	RETVAL
		1322
		1323	MODULE = Coro::State PACKAGE = Coro
		1324
		1325	BOOT:
		1326	{
		1327	int i;
		1328
		1329	coro_stash = gv_stashpv ("Coro", TRUE);
		1330
		1331	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1332	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1333	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1334	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1335	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1336	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1337
		1338	coro_current = get_sv ("Coro::current", FALSE);
		1339	SvREADONLY_on (coro_current);
		1340
		1341	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1342	coro_ready[i] = newAV ();
		1343
		1344	{
		1345	SV *sv = perl_get_sv("Coro::API", 1);
		1346
		1347	coroapi.schedule = api_schedule;
		1348	coroapi.save = api_save;
		1349	coroapi.cede = api_cede;
		1350	coroapi.cede_notself = api_cede_notself;
		1351	coroapi.ready = api_ready;
		1352	coroapi.is_ready = api_is_ready;
		1353	coroapi.nready = &coro_nready;
		1354	coroapi.current = coro_current;
		1355
		1356	GCoroAPI = &coroapi;
		1357	sv_setiv (sv, (IV)&coroapi);
		1358	SvREADONLY_on (sv);
		1359	}
		1360	}
		1361
		1362	void
		1363	_set_current (SV *current)
		1364	PROTOTYPE: $
		1365	CODE:
		1366	SvREFCNT_dec (SvRV (coro_current));
		1367	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1368
		1369	int
		1370	prio (Coro::State coro, int newprio = 0)
		1371	ALIAS:
		1372	nice = 1
477	CODE:	1373	CODE:
		1374	{
		1375	RETVAL = coro->prio;
478		1376
479	if (coro->mainstack)	1377	if (items > 1)
480	{	1378	{
481	struct coro temp;	1379	if (ix)
		1380	newprio = coro->prio - newprio;
482		1381
483	SAVE(aTHX_ (&temp));	1382	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
484	LOAD(aTHX_ coro);	1383	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
485		1384
486	destroy_stacks ();	1385	coro->prio = newprio;
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488
489	LOAD((&temp));
490	}	1386	}
		1387	}
		1388	OUTPUT:
		1389	RETVAL
491		1390
492	SvREFCNT_dec (coro->args);	1391	SV *
493	Safefree (coro);	1392	ready (SV *self)
		1393	PROTOTYPE: $
		1394	CODE:
		1395	RETVAL = boolSV (api_ready (self));
		1396	OUTPUT:
		1397	RETVAL
494		1398
		1399	SV *
		1400	is_ready (SV *self)
		1401	PROTOTYPE: $
		1402	CODE:
		1403	RETVAL = boolSV (api_is_ready (self));
		1404	OUTPUT:
		1405	RETVAL
495		1406
		1407	int
		1408	nready (...)
		1409	PROTOTYPE:
		1410	CODE:
		1411	RETVAL = coro_nready;
		1412	OUTPUT:
		1413	RETVAL
		1414
		1415	MODULE = Coro::State PACKAGE = Coro::AIO
		1416
		1417	SV *
		1418	_get_state ()
		1419	CODE:
		1420	{
		1421	struct io_state *data;
		1422
		1423	RETVAL = newSV (sizeof (struct io_state));
		1424	data = (struct io_state *)SvPVX (RETVAL);
		1425	SvCUR_set (RETVAL, sizeof (struct io_state));
		1426	SvPOK_only (RETVAL);
		1427
		1428	data->errorno = errno;
		1429	data->laststype = PL_laststype;
		1430	data->laststatval = PL_laststatval;
		1431	data->statcache = PL_statcache;
		1432	}
		1433	OUTPUT:
		1434	RETVAL
		1435
		1436	void
		1437	_set_state (char *data_)
		1438	PROTOTYPE: $
		1439	CODE:
		1440	{
		1441	struct io_state *data = (void *)data_;
		1442
		1443	errno = data->errorno;
		1444	PL_laststype = data->laststype;
		1445	PL_laststatval = data->laststatval;
		1446	PL_statcache = data->statcache;
		1447	}
		1448

Diff Legend

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