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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs. Revision 1.80 by root, Thu Nov 2 20:00:00 2006 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.80 by root, Thu Nov 2 20:00:00 2006 UTC