ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.116 by root, Fri Dec 1 14:01:43 2006 UTC

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

Diff Legend

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