ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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