ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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