ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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