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.87 by root, Fri Nov 24 13:40:36 2006 UTC

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

Diff Legend

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