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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs. Revision 1.78 by root, Wed Nov 1 01:21:21 2006 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.78 by root, Wed Nov 1 01:21:21 2006 UTC