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.100 by root, Mon Nov 27 00:07:49 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;
316
317	/* now do the ugly restore mess */
318	while ((cv = (CV *)POPs))
319	{
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	475	#endif
330	}
331		476
332	PUTBACK;	477	New(54,PL_scopestack,16,I32);
333	}	478	PL_scopestack_ix = 0;
334	}	479	PL_scopestack_max = 16;
335		480
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	481	New(54,PL_savestack,96,ANY);
337	STATIC void	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
338	destroy_stacks(pTHX)	496	destroy_stacks()
339	{	497	{
340	dSP;	498	if (!IN_DESTRUCT)
341		499	{
342	/* die does this while calling POPSTACK, but I just don't see why. */
343	dounwind(-1);
344
345	/* is this ugly, I ask? */	500	/* is this ugly, I ask? */
346	while (PL_scopestack_ix)	501	LEAVE_SCOPE (0);
347	LEAVE;	502
		503	/* sure it is, but more important: is it correct?? :/ */
		504	FREETMPS;
		505
		506	/*POPSTACK_TO (PL_mainstack);*//*D*//*use*/
		507	}
348		508
349	while (PL_curstackinfo->si_next)	509	while (PL_curstackinfo->si_next)
350	PL_curstackinfo = PL_curstackinfo->si_next;	510	PL_curstackinfo = PL_curstackinfo->si_next;
351		511
352	while (PL_curstackinfo)	512	while (PL_curstackinfo)
353	{	513	{
354	PERL_SI *p = PL_curstackinfo->si_prev;	514	PERL_SI *p = PL_curstackinfo->si_prev;
355		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*/
356	SvREFCNT_dec(PL_curstackinfo->si_stack);	525	SvREFCNT_dec (PL_curstackinfo->si_stack);
		526	}
		527
357	Safefree(PL_curstackinfo->si_cxstack);	528	Safefree (PL_curstackinfo->si_cxstack);
358	Safefree(PL_curstackinfo);	529	Safefree (PL_curstackinfo);
359	PL_curstackinfo = p;	530	PL_curstackinfo = p;
360	}	531	}
361		532
362	if (PL_scopestack_ix != 0)	533	Safefree (PL_tmps_stack);
363	Perl_warner(aTHX_ WARN_INTERNAL,	534	Safefree (PL_markstack);
364	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	535	Safefree (PL_scopestack);
365	(long)PL_scopestack_ix);	536	Safefree (PL_savestack);
366	if (PL_savestack_ix != 0)	537	#if !PERL_VERSION_ATLEAST (5,9,0)
367	Perl_warner(aTHX_ WARN_INTERNAL,	538	Safefree (PL_retstack);
368	"Unbalanced saves: %ld more saves than restores\n",	539	#endif
369	(long)PL_savestack_ix);	540	}
370	if (PL_tmps_floor != -1)	541
371	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	542	static void
372	(long)PL_tmps_floor + 1);	543	setup_coro (struct coro *coro)
		544	{
373	/*	545	/*
374	*/	546	* emulate part of the perl startup here.
375	Safefree(PL_tmps_stack);	547	*/
376	Safefree(PL_markstack);	548	dTHX;
377	Safefree(PL_scopestack);	549	dSP;
378	Safefree(PL_savestack);	550	UNOP myop;
		551	SV *sub_init = (SV *)get_cv ("Coro::State::coro_init", FALSE);
		552
		553	coro_init_stacks ();
		554	/*PL_curcop = 0;*/
		555	/*PL_in_eval = PL_in_eval;*/ /* inherit */
		556	SvREFCNT_dec (GvAV (PL_defgv));
		557	GvAV (PL_defgv) = coro->args; coro->args = 0;
		558
		559	SPAGAIN;
		560
		561	Zero (&myop, 1, UNOP);
		562	myop.op_next = Nullop;
		563	myop.op_flags = OPf_WANT_VOID;
		564
		565	PL_op = (OP *)&myop;
		566
		567	PUSHMARK(SP);
		568	XPUSHs (sub_init);
		569	PUTBACK;
		570	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		571	SPAGAIN;
		572
		573	ENTER; /* necessary e.g. for dounwind */
		574	}
		575
		576	static void
		577	free_coro_mortal ()
		578	{
		579	if (coro_mortal)
		580	{
		581	SvREFCNT_dec (coro_mortal);
		582	coro_mortal = 0;
		583	}
		584	}
		585
		586	static void NOINLINE
		587	prepare_cctx (coro_stack *cctx)
		588	{
		589	dSP;
		590	UNOP myop;
		591
		592	Zero (&myop, 1, UNOP);
		593	myop.op_next = PL_op;
		594	myop.op_flags = OPf_WANT_VOID | OPf_STACKED;
		595
		596	PUSHMARK(SP);
		597	EXTEND (SP, 2);
		598	PUSHs (newSViv (PTR2IV (cctx)));
		599	PUSHs ((SV *)get_cv ("Coro::State::cctx_init", FALSE));
		600	PUTBACK;
		601	PL_restartop = PL_ppaddr[OP_ENTERSUB](aTHX);
		602	SPAGAIN;
		603	}
		604
		605	static void
		606	coro_run (void *arg)
		607	{
		608	/*
		609	* this is a _very_ stripped down perl interpreter ;)
		610	*/
		611	UNLOCK;
		612
		613	PL_top_env = &PL_start_env;
		614	prepare_cctx ((coro_stack *)arg);
		615
		616	/* somebody will hit me for both perl_run and PL_restartop */
		617	perl_run (PERL_GET_CONTEXT);
		618
		619	fputs ("FATAL: C coroutine fell over the edge of the world, aborting.\n", stderr);
		620	abort ();
		621	}
		622
		623	static coro_stack *
		624	stack_new ()
		625	{
		626	coro_stack *stack;
		627
		628	New (0, stack, 1, coro_stack);
		629
		630	#if HAVE_MMAP
		631
		632	stack->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE;
		633	/* mmap suppsedly does allocate-on-write for us */
		634	stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
		635
		636	if (stack->sptr == (void *)-1)
		637	{
		638	perror ("FATAL: unable to mmap stack for coroutine");
		639	_exit (EXIT_FAILURE);
		640	}
		641
		642	# if STACKGUARD
		643	mprotect (stack->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
		644	# endif
		645
		646	#else
		647
		648	stack->ssize = STACKSIZE * (long)sizeof (long);
		649	New (0, stack->sptr, STACKSIZE, long);
		650
		651	if (!stack->sptr)
		652	{
		653	perror (stderr, "FATAL: unable to malloc stack for coroutine");
		654	_exit (EXIT_FAILURE);
		655	}
		656
		657	#endif
		658
		659	coro_create (&stack->cctx, coro_run, (void *)stack, stack->sptr, stack->ssize);
		660
		661	return stack;
		662	}
		663
		664	static void
		665	stack_free (coro_stack *stack)
		666	{
		667	if (!stack)
		668	return;
		669
		670	#if HAVE_MMAP
		671	munmap (stack->sptr, stack->ssize);
		672	#else
		673	Safefree (stack->sptr);
		674	#endif
		675
379	Safefree(PL_retstack);	676	Safefree (stack);
380	}	677	}
381		678
382	#define SUB_INIT "Coro::State::_newcoro"	679	static coro_stack *stack_first;
		680
		681	static coro_stack *
		682	stack_get ()
		683	{
		684	coro_stack *stack;
		685
		686	if (stack_first)
		687	{
		688	stack = stack_first;
		689	stack_first = stack->next;
		690	}
		691	else
		692	{
		693	stack = stack_new ();
		694	PL_op = PL_op->op_next;
		695	}
		696
		697	return stack;
		698	}
		699
		700	static void
		701	stack_put (coro_stack *stack)
		702	{
		703	stack->next = stack_first;
		704	stack_first = stack;
		705	}
		706
		707	/* never call directly, always through the coro_state_transfer global variable */
		708	static void NOINLINE
		709	transfer (struct coro *prev, struct coro *next, int flags)
		710	{
		711	dSTACKLEVEL;
		712
		713	/* sometimes transfer is only called to set idle_sp */
		714	if (flags == TRANSFER_SET_STACKLEVEL)
		715	((coro_stack *)prev)->idle_sp = STACKLEVEL;
		716	else if (prev != next)
		717	{
		718	coro_stack *prev__stack;
		719
		720	LOCK;
		721
		722	if (next->mainstack)
		723	{
		724	/* coroutine already started */
		725	SAVE (prev, flags);
		726	LOAD (next);
		727	}
		728	else
		729	{
		730	/* need to start coroutine */
		731	/* first get rid of the old state */
		732	SAVE (prev, -1);
		733	/* setup coroutine call */
		734	setup_coro (next);
		735	/* need a stack */
		736	next->stack = 0;
		737	}
		738
		739	if (!prev->stack)
		740	/* create a new empty context */
		741	Newz (0, prev->stack, 1, coro_stack);
		742
		743	prev__stack = prev->stack;
		744
		745	/* possibly "free" the stack */
		746	if (prev__stack->idle_sp == STACKLEVEL)
		747	{
		748	stack_put (prev__stack);
		749	prev->stack = 0;
		750	}
		751
		752	if (!next->stack)
		753	next->stack = stack_get ();
		754
		755	if (prev__stack != next->stack)
		756	{
		757	prev__stack->top_env = PL_top_env;
		758	PL_top_env = next->stack->top_env;
		759	coro_transfer (&prev__stack->cctx, &next->stack->cctx);
		760	}
		761
		762	free_coro_mortal ();
		763
		764	UNLOCK;
		765	}
		766	}
		767
		768	struct transfer_args
		769	{
		770	struct coro *prev, *next;
		771	int flags;
		772	};
		773
		774	#define TRANSFER(ta) transfer ((ta).prev, (ta).next, (ta).flags)
		775
		776	static void
		777	coro_state_destroy (struct coro *coro)
		778	{
		779	if (coro->refcnt--)
		780	return;
		781
		782	if (coro->mainstack && coro->mainstack != main_mainstack)
		783	{
		784	struct coro temp;
		785
		786	SAVE ((&temp), TRANSFER_SAVE_ALL);
		787	LOAD (coro);
		788
		789	destroy_stacks ();
		790
		791	LOAD ((&temp)); /* this will get rid of defsv etc.. */
		792
		793	coro->mainstack = 0;
		794	}
		795
		796	stack_free (coro->stack);
		797	SvREFCNT_dec (coro->args);
		798	Safefree (coro);
		799	}
		800
		801	static int
		802	coro_state_clear (pTHX_ SV *sv, MAGIC *mg)
		803	{
		804	struct coro *coro = (struct coro *)mg->mg_ptr;
		805	mg->mg_ptr = 0;
		806
		807	coro_state_destroy (coro);
		808
		809	return 0;
		810	}
		811
		812	static int
		813	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		814	{
		815	struct coro *coro = (struct coro *)mg->mg_ptr;
		816
		817	++coro->refcnt;
		818
		819	return 0;
		820	}
		821
		822	static MGVTBL coro_state_vtbl = {
		823	0, 0, 0, 0,
		824	coro_state_clear,
		825	0,
		826	#ifdef MGf_DUP
		827	coro_state_dup,
		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 *sv)
		887	{
		888	int prio;
		889
		890	if (SvTYPE (sv) != SVt_PVHV)
		891	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		892
		893	prio = SvSTATE (sv)->prio;
		894
		895	av_push (coro_ready [prio - PRIO_MIN], 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 void
		919	api_ready (SV *coro)
		920	{
		921	dTHX;
		922
		923	if (SvROK (coro))
		924	coro = SvRV (coro);
		925
		926	LOCK;
		927	coro_enq (SvREFCNT_inc (coro));
		928	UNLOCK;
		929	}
		930
		931	static void
		932	prepare_schedule (struct transfer_args *ta)
		933	{
		934	SV *current, *prev, *next;
		935
		936	current = GvSV (coro_current);
		937
		938	for (;;)
		939	{
		940	LOCK;
		941	next = coro_deq (PRIO_MIN);
		942	UNLOCK;
		943
		944	if (next)
		945	break;
		946
		947	{
		948	dSP;
		949
		950	ENTER;
		951	SAVETMPS;
		952
		953	PUSHMARK (SP);
		954	PUTBACK;
		955	call_sv (GvSV (coro_idle), G_DISCARD);
		956
		957	FREETMPS;
		958	LEAVE;
		959	}
		960	}
		961
		962	prev = SvRV (current);
		963	SvRV (current) = next;
		964
		965	/* free this only after the transfer */
		966	LOCK;
		967	free_coro_mortal ();
		968	UNLOCK;
		969	coro_mortal = prev;
		970
		971	ta->prev = SvSTATE (prev);
		972	ta->next = SvSTATE (next);
		973	ta->flags = TRANSFER_SAVE_ALL;
		974	}
		975
		976	static void
		977	prepare_cede (struct transfer_args *ta)
		978	{
		979	LOCK;
		980	coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
		981	UNLOCK;
		982
		983	prepare_schedule (ta);
		984	}
		985
		986	static void
		987	api_schedule (void)
		988	{
		989	dTHX;
		990	struct transfer_args ta;
		991
		992	prepare_schedule (&ta);
		993	TRANSFER (ta);
		994	}
		995
		996	static void
		997	api_cede (void)
		998	{
		999	dTHX;
		1000	struct transfer_args ta;
		1001
		1002	prepare_cede (&ta);
		1003	TRANSFER (ta);
		1004	}
383		1005
384	MODULE = Coro::State PACKAGE = Coro::State	1006	MODULE = Coro::State PACKAGE = Coro::State
385		1007
386	PROTOTYPES: ENABLE	1008	PROTOTYPES: DISABLE
387		1009
388	BOOT:	1010	BOOT:
389	if (!padlist_cache)	1011	{
390	padlist_cache = newHV ();	1012	#ifdef USE_ITHREADS
		1013	MUTEX_INIT (&coro_mutex);
		1014	#endif
		1015	BOOT_PAGESIZE;
391		1016
392	Coro::State	1017	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
393	_newprocess(args)	1018
394	SV * args	1019	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
395	PROTOTYPE: $	1020	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		1021	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		1022
		1023	main_mainstack = PL_mainstack;
		1024
		1025	coroapi.ver = CORO_API_VERSION;
		1026	coroapi.transfer = api_transfer;
		1027
		1028	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1029	}
		1030
		1031	SV *
		1032	new (char *klass, ...)
396	CODE:	1033	CODE:
397	Coro__State coro;	1034	{
		1035	struct coro *coro;
		1036	HV *hv;
		1037	int i;
398		1038
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);	1039	Newz (0, coro, 1, struct coro);
		1040	coro->args = newAV ();
403		1041
		1042	hv = newHV ();
		1043	sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
		1044	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		1045
		1046	for (i = 1; i < items; i++)
		1047	av_push (coro->args, newSVsv (ST (i)));
		1048
404	coro->mainstack = 0; /* actual work is done inside transfer */	1049	/*coro->mainstack = 0; *//*actual work is done inside transfer */
405	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1050	/*coro->stack = 0;*/
406		1051	}
407	RETVAL = coro;
408	OUTPUT:	1052	OUTPUT:
409	RETVAL	1053	RETVAL
410		1054
411	void	1055	void
412	transfer(prev,next)	1056	_set_stacklevel (...)
413	Coro::State_or_hashref prev	1057	ALIAS:
414	Coro::State_or_hashref next	1058	Coro::State::transfer = 1
		1059	Coro::schedule = 2
		1060	Coro::cede = 3
		1061	Coro::Cont::yield = 4
415	CODE:	1062	CODE:
		1063	{
		1064	struct transfer_args ta;
416		1065
417	if (prev != next)	1066	switch (ix)
418	{	1067	{
419	PUTBACK;	1068	case 0:
420	SAVE (aTHX_ prev);	1069	ta.prev = (struct coro *)INT2PTR (coro_stack *, SvIV (ST (0)));
		1070	ta.next = 0;
		1071	ta.flags = TRANSFER_SET_STACKLEVEL;
		1072	break;
421		1073
422	/*	1074	case 1:
423	* this could be done in newprocess which would lead to	1075	if (items != 3)
424	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)	1076	croak ("Coro::State::transfer(prev,next,flags) expects three arguments, not %d", items);
425	* code here, but lazy allocation of stacks has also	1077
426	* some virtues and the overhead of the if() is nil.	1078	prepare_transfer (&ta, ST (0), ST (1), SvIV (ST (2)));
427	*/	1079	break;
428	if (next->mainstack)	1080
		1081	case 2:
		1082	prepare_schedule (&ta);
		1083	break;
		1084
		1085	case 3:
		1086	prepare_cede (&ta);
		1087	break;
		1088
		1089	case 4:
429	{	1090	{
430	LOAD (aTHX_ next);	1091	SV *yieldstack;
431	next->mainstack = 0; /* unnecessary but much cleaner */	1092	SV *sv;
		1093	AV *defav = GvAV (PL_defgv);
		1094
		1095	yieldstack = *hv_fetch (
		1096	(HV *)SvRV (GvSV (coro_current)),
		1097	"yieldstack", sizeof ("yieldstack") - 1,
		1098	0
432	SPAGAIN;	1099	);
		1100
		1101	/* set up @_ -- ugly */
		1102	av_clear (defav);
		1103	av_fill (defav, items - 1);
		1104	while (items--)
		1105	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1106
		1107	sv = av_pop ((AV *)SvRV (yieldstack));
		1108	ta.prev = SvSTATE (*av_fetch ((AV *)SvRV (sv), 0, 0));
		1109	ta.next = SvSTATE (*av_fetch ((AV *)SvRV (sv), 1, 0));
		1110	ta.flags = 0;
		1111	SvREFCNT_dec (sv);
433	}	1112	}
434	else	1113	break;
435	{
436	/*
437	* emulate part of the perl startup here.
438	*/
439	UNOP myop;
440		1114
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	}	1115	}
466		1116
		1117	TRANSFER (ta);
		1118	}
		1119
467	void	1120	void
468	DESTROY(coro)	1121	_clone_state_from (SV *dst, SV *src)
469	Coro::State coro	1122	CODE:
		1123	{
		1124	struct coro *coro_src = SvSTATE (src);
		1125
		1126	sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
		1127
		1128	++coro_src->refcnt;
		1129	sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
		1130	}
		1131
		1132	void
		1133	_exit (code)
		1134	int code
		1135	PROTOTYPE: $
		1136	CODE:
		1137	_exit (code);
		1138
		1139	MODULE = Coro::State PACKAGE = Coro
		1140
		1141	BOOT:
		1142	{
		1143	int i;
		1144
		1145	coro_stash = gv_stashpv ("Coro", TRUE);
		1146
		1147	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1148	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1149	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1150	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1151	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1152	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1153
		1154	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1155	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1156
		1157	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1158	coro_ready[i] = newAV ();
		1159
		1160	{
		1161	SV *sv = perl_get_sv("Coro::API", 1);
		1162
		1163	coroapi.schedule = api_schedule;
		1164	coroapi.cede = api_cede;
		1165	coroapi.ready = api_ready;
		1166	coroapi.nready = &coro_nready;
		1167	coroapi.current = coro_current;
		1168
		1169	GCoroAPI = &coroapi;
		1170	sv_setiv (sv, (IV)&coroapi);
		1171	SvREADONLY_on (sv);
		1172	}
		1173	}
		1174
		1175	int
		1176	prio (Coro::State coro, int newprio = 0)
		1177	ALIAS:
		1178	nice = 1
470	CODE:	1179	CODE:
		1180	{
		1181	RETVAL = coro->prio;
471		1182
472	if (coro->mainstack)	1183	if (items > 1)
473	{	1184	{
474	struct coro temp;	1185	if (ix)
		1186	newprio += coro->prio;
475		1187
476	PUTBACK;	1188	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
477	SAVE(aTHX_ (&temp));	1189	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
478	LOAD(aTHX_ coro);
479		1190
480	destroy_stacks ();	1191	coro->prio = newprio;
481	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483	LOAD((&temp));
484	SPAGAIN;
485	}	1192	}
		1193	}
486		1194
487	SvREFCNT_dec (coro->args);	1195	void
488	Safefree (coro);	1196	ready (SV *self)
		1197	PROTOTYPE: $
		1198	CODE:
		1199	api_ready (self);
489		1200
		1201	int
		1202	nready (...)
		1203	PROTOTYPE:
		1204	CODE:
		1205	RETVAL = coro_nready;
		1206	OUTPUT:
		1207	RETVAL
490		1208
		1209	MODULE = Coro::State PACKAGE = Coro::AIO
		1210
		1211	SV *
		1212	_get_state ()
		1213	CODE:
		1214	{
		1215	struct {
		1216	int errorno;
		1217	int laststype;
		1218	int laststatval;
		1219	Stat_t statcache;
		1220	} data;
		1221
		1222	data.errorno = errno;
		1223	data.laststype = PL_laststype;
		1224	data.laststatval = PL_laststatval;
		1225	data.statcache = PL_statcache;
		1226
		1227	RETVAL = newSVpvn ((char *)&data, sizeof data);
		1228	}
		1229	OUTPUT:
		1230	RETVAL
		1231
		1232	void
		1233	_set_state (char *data_)
		1234	PROTOTYPE: $
		1235	CODE:
		1236	{
		1237	struct {
		1238	int errorno;
		1239	int laststype;
		1240	int laststatval;
		1241	Stat_t statcache;
		1242	} *data = (void *)data_;
		1243
		1244	errno = data->errorno;
		1245	PL_laststype = data->laststype;
		1246	PL_laststatval = data->laststatval;
		1247	PL_statcache = data->statcache;
		1248	}

Diff Legend

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