[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.81 by root, Fri Nov 3 00:56:03 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	/* data associated with this coroutine (initial args) */
41	AV *args;	151	AV *args;
42	};	152	};
43		153
44	typedef struct coro *Coro__State;	154	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	155	typedef struct coro *Coro__State_or_hashref;
46		156
47	static HV *padlist_cache;	157	static AV *
48		158	coro_clone_padlist (pTHX_ CV *cv)
49	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *
51	clone_padlist (AV *protopadlist)
52	{	159	{
53	AV *av;	160	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;	161	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		162
72	newpadlist = newAV ();	163	newpadlist = newAV ();
73	AvREAL_off (newpadlist);	164	AvREAL_off (newpadlist);
74	av_store (newpadlist, 0, (SV *) newpad_name);	165	#if PERL_VERSION < 9
		166	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
		167	#else
		168	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
		169	#endif
		170	newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
		171	--AvFILLp (padlist);
		172
		173	av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75	av_store (newpadlist, 1, (SV *) newpad);	174	av_store (newpadlist, 1, (SV *)newpad);
76		175
77	av = newAV (); /* will be @_ */	176	return newpadlist;
78	av_extend (av, 0);	177	}
79	av_store (newpad, 0, (SV *) av);
80	AvFLAGS (av) = AVf_REIFY;
81		178
82	for (ix = fpad; ix > 0; ix--)	179	static void
		180	free_padlist (pTHX_ AV *padlist)
		181	{
		182	/* may be during global destruction */
		183	if (SvREFCNT (padlist))
83	{	184	{
84	SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;	185	I32 i = AvFILLp (padlist);
85	if (namesv && namesv != &PL_sv_undef)	186	while (i >= 0)
86	{	187	{
87	char name = SvPVX (namesv); / XXX */	188	SV **svp = av_fetch (padlist, i--, FALSE);
88	if (SvFLAGS (namesv) & SVf_FAKE \|\| *name == '&')	189	if (svp)
89	{ /* lexical from outside? */
90	npad[ix] = SvREFCNT_inc (ppad[ix]);
91	}	190	{
92	else
93	{ /* our own lexical */
94	SV *sv;	191	SV *sv;
95	if (*name == '&')	192	while (&PL_sv_undef != (sv = av_pop ((AV )svp)))
96	sv = SvREFCNT_inc (ppad[ix]);	193	SvREFCNT_dec (sv);
97	else if (*name == '@')	194
98	sv = (SV *) newAV ();	195	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	}	196	}
107	}	197	}
108	else if (IS_PADGV (ppad[ix]) \|\| IS_PADCONST (ppad[ix]))	198
109	{	199	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	}	200	}
		201	}
119		202
120	#if 0 /* NONOTUNDERSTOOD */	203	static int
121	/* Now that vars are all in place, clone nested closures. */	204	coro_cv_free (pTHX_ SV sv, MAGIC mg)
		205	{
		206	AV *padlist;
		207	AV av = (AV )mg->mg_obj;
122		208
123	for (ix = fpad; ix > 0; ix--) {	209	/* casting is fun. */
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	210	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
125	if (namesv	211	free_padlist (aTHX_ padlist);
126	&& namesv != &PL_sv_undef	212
127	&& !(SvFLAGS(namesv) & SVf_FAKE)	213	SvREFCNT_dec (av);
128	&& *SvPVX(namesv) == '&'	214
129	&& CvCLONE(ppad[ix]))	215	return 0;
130	{	216	}
131	CV kid = cv_clone((CV)ppad[ix]);	217
132	SvREFCNT_dec(ppad[ix]);	218	#define PERL_MAGIC_coro PERL_MAGIC_ext
133	CvCLONE_on(kid);	219
134	SvPADMY_on(kid);	220	static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
135	npad[ix] = (SV*)kid;	221
136	}	222	/* the next two functions merely cache the padlists */
		223	static void
		224	get_padlist (pTHX_ CV *cv)
		225	{
		226	MAGIC mg = mg_find ((SV )cv, PERL_MAGIC_coro);
		227
		228	if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0)
		229	CvPADLIST (cv) = (AV )av_pop ((AV )mg->mg_obj);
		230	else
		231	{
		232	#if 0
		233	/* this should work - but it doesn't :( */
		234	CV *cp = Perl_cv_clone (aTHX_ cv);
		235	CvPADLIST (cv) = CvPADLIST (cp);
		236	CvPADLIST (cp) = 0;
		237	SvREFCNT_dec (cp);
		238	#else
		239	CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
		240	#endif
		241	}
		242	}
		243
		244	static void
		245	put_padlist (pTHX_ CV *cv)
		246	{
		247	MAGIC mg = mg_find ((SV )cv, PERL_MAGIC_coro);
		248
		249	if (!mg)
		250	{
		251	sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
		252	mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
		253	mg->mg_virtual = &vtbl_coro;
		254	mg->mg_obj = (SV *)newAV ();
137	}	255	}
138	#endif
139		256
140	return newpadlist;	257	av_push ((AV )mg->mg_obj, (SV )CvPADLIST (cv));
141	}	258	}
142		259
143	STATIC AV *	260	#define SB do {
144	free_padlist (AV *padlist)	261	#define SE } while (0)
		262
		263	#define LOAD(state) load_state(aTHX_ (state));
		264	#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
		265
		266	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE
		267
		268	static void
		269	load_state(pTHX_ Coro__State c)
145	{	270	{
146	/* may be during global destruction */	271	PL_dowarn = c->dowarn;
147	if (SvREFCNT(padlist))	272	PL_in_eval = c->in_eval;
		273
		274	PL_curstackinfo = c->curstackinfo;
		275	PL_curstack = c->curstack;
		276	PL_mainstack = c->mainstack;
		277	PL_stack_sp = c->stack_sp;
		278	PL_op = c->op;
		279	PL_curpad = c->curpad;
		280	PL_comppad = c->comppad;
		281	PL_compcv = c->compcv;
		282	PL_stack_base = c->stack_base;
		283	PL_stack_max = c->stack_max;
		284	PL_tmps_stack = c->tmps_stack;
		285	PL_tmps_floor = c->tmps_floor;
		286	PL_tmps_ix = c->tmps_ix;
		287	PL_tmps_max = c->tmps_max;
		288	PL_markstack = c->markstack;
		289	PL_markstack_ptr = c->markstack_ptr;
		290	PL_markstack_max = c->markstack_max;
		291	PL_scopestack = c->scopestack;
		292	PL_scopestack_ix = c->scopestack_ix;
		293	PL_scopestack_max = c->scopestack_max;
		294	PL_savestack = c->savestack;
		295	PL_savestack_ix = c->savestack_ix;
		296	PL_savestack_max = c->savestack_max;
		297	#if PERL_VERSION < 9
		298	PL_retstack = c->retstack;
		299	PL_retstack_ix = c->retstack_ix;
		300	PL_retstack_max = c->retstack_max;
		301	#endif
		302	PL_curpm = c->curpm;
		303	PL_curcop = c->curcop;
		304	PL_top_env = c->top_env;
		305
		306	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		307	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		308	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		309
		310	{
		311	dSP;
		312	CV *cv;
		313
		314	/* now do the ugly restore mess */
		315	while ((cv = (CV *)POPs))
148	{	316	{
149	I32 i = AvFILLp(padlist);	317	AV padlist = (AV )POPs;
150	while (i >= 0)	318
		319	if (padlist)
151	{	320	{
152	SV **svp = av_fetch(padlist, i--, FALSE);	321	put_padlist (aTHX_ cv); /* mark this padlist as available */
153	SV sv = svp ? svp : Nullsv;	322	CvPADLIST(cv) = padlist;
154	if (sv)
155	SvREFCNT_dec(sv);
156	}	323	}
157		324
158	SvREFCNT_dec((SV*)padlist);	325	++CvDEPTH(cv);
		326	}
		327
		328	PUTBACK;
159	}	329	}
160	}	330	}
161		331
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	332	static void
189	save_state(pTHX_ Coro__State c)	333	save_state(pTHX_ Coro__State c, int flags)
190	{	334	{
191	{	335	{
192	dSP;	336	dSP;
193	I32 cxix = cxstack_ix;	337	I32 cxix = cxstack_ix;
		338	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	339	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		340
197	/*	341	/*
198	* the worst thing you can imagine happens first - we have to save	342	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	343	* (and reinitialize) all cv's in the whole callchain :(
200	*/	344	*/
…		…
210	if (CxTYPE(cx) == CXt_SUB)	354	if (CxTYPE(cx) == CXt_SUB)
211	{	355	{
212	CV *cv = cx->blk_sub.cv;	356	CV *cv = cx->blk_sub.cv;
213	if (CvDEPTH(cv))	357	if (CvDEPTH(cv))
214	{	358	{
215	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));
217	#endif
218	EXTEND (SP, 3);	359	EXTEND (SP, CvDEPTH(cv)*2);
		360
		361	while (--CvDEPTH(cv))
		362	{
		363	/* this tells the restore code to increment CvDEPTH */
		364	PUSHs (Nullsv);
219	PUSHs ((SV *)CvDEPTH(cv));	365	PUSHs ((SV *)cv);
		366	}
		367
220	PUSHs ((SV *)CvPADLIST(cv));	368	PUSHs ((SV *)CvPADLIST(cv));
221	PUSHs ((SV *)cv);	369	PUSHs ((SV *)cv);
222		370
223	get_padlist (cv);	371	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	}	372	}
233	}	373	}
		374	#ifdef CXt_FORMAT
234	else if (CxTYPE(cx) == CXt_FORMAT)	375	else if (CxTYPE(cx) == CXt_FORMAT)
235	{	376	{
236	/* I never used formats, so how should I know how these are implemented? */	377	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */	378	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	379	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}	380	}
		381	#endif
240	}	382	}
241		383
242	if (top_si->si_type == PERLSI_MAIN)	384	if (top_si->si_type == PERLSI_MAIN)
243	break;	385	break;
244		386
…		…
248	}	390	}
249		391
250	PUTBACK;	392	PUTBACK;
251	}	393	}
252		394
		395	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		396	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		397	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		398
253	c->dowarn = PL_dowarn;	399	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);	400	c->in_eval = PL_in_eval;
		401
255	c->curstackinfo = PL_curstackinfo;	402	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	403	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	404	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	405	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	406	c->op = PL_op;
260	c->curpad = PL_curpad;	407	c->curpad = PL_curpad;
		408	c->comppad = PL_comppad;
		409	c->compcv = PL_compcv;
261	c->stack_base = PL_stack_base;	410	c->stack_base = PL_stack_base;
262	c->stack_max = PL_stack_max;	411	c->stack_max = PL_stack_max;
263	c->tmps_stack = PL_tmps_stack;	412	c->tmps_stack = PL_tmps_stack;
264	c->tmps_floor = PL_tmps_floor;	413	c->tmps_floor = PL_tmps_floor;
265	c->tmps_ix = PL_tmps_ix;	414	c->tmps_ix = PL_tmps_ix;
…		…
271	c->scopestack_ix = PL_scopestack_ix;	420	c->scopestack_ix = PL_scopestack_ix;
272	c->scopestack_max = PL_scopestack_max;	421	c->scopestack_max = PL_scopestack_max;
273	c->savestack = PL_savestack;	422	c->savestack = PL_savestack;
274	c->savestack_ix = PL_savestack_ix;	423	c->savestack_ix = PL_savestack_ix;
275	c->savestack_max = PL_savestack_max;	424	c->savestack_max = PL_savestack_max;
		425	#if PERL_VERSION < 9
276	c->retstack = PL_retstack;	426	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;	427	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	428	c->retstack_max = PL_retstack_max;
		429	#endif
		430	c->curpm = PL_curpm;
279	c->curcop = PL_curcop;	431	c->curcop = PL_curcop;
		432	c->top_env = PL_top_env;
280	}	433	}
281		434
282	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	435	/*
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	436	* allocate various perl stacks. This is an exact copy
284		437	* of perl.c:init_stacks, except that it uses less memory
		438	* on the (sometimes correct) assumption that coroutines do
		439	* not usually need a lot of stackspace.
		440	*/
285	static void	441	static void
286	load_state(pTHX_ Coro__State c)	442	coro_init_stacks (pTHX)
287	{	443	{
288	PL_dowarn = c->dowarn;	444	LOCK;
289	GvAV (PL_defgv) = c->defav;	445
290	PL_curstackinfo = c->curstackinfo;	446	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
291	PL_curstack = c->curstack;	447	PL_curstackinfo->si_type = PERLSI_MAIN;
292	PL_mainstack = c->mainstack;	448	PL_curstack = PL_curstackinfo->si_stack;
		449	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		450
		451	PL_stack_base = AvARRAY(PL_curstack);
293	PL_stack_sp = c->stack_sp;	452	PL_stack_sp = PL_stack_base;
294	PL_op = c->op;	453	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295	PL_curpad = c->curpad;	454
296	PL_stack_base = c->stack_base;	455	New(50,PL_tmps_stack,96,SV*);
297	PL_stack_max = c->stack_max;	456	PL_tmps_floor = -1;
298	PL_tmps_stack = c->tmps_stack;	457	PL_tmps_ix = -1;
299	PL_tmps_floor = c->tmps_floor;	458	PL_tmps_max = 96;
300	PL_tmps_ix = c->tmps_ix;	459
301	PL_tmps_max = c->tmps_max;	460	New(54,PL_markstack,16,I32);
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;	461	PL_markstack_ptr = PL_markstack;
304	PL_markstack_max = c->markstack_max;	462	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		463
316	{	464	#ifdef SET_MARK_OFFSET
317	dSP;	465	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	466	#endif
333	}
334		467
335	PUTBACK;	468	New(54,PL_scopestack,16,I32);
336	}	469	PL_scopestack_ix = 0;
337	}	470	PL_scopestack_max = 16;
338		471
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	472	New(54,PL_savestack,96,ANY);
340	STATIC void	473	PL_savestack_ix = 0;
		474	PL_savestack_max = 96;
		475
		476	#if PERL_VERSION < 9
		477	New(54,PL_retstack,8,OP*);
		478	PL_retstack_ix = 0;
		479	PL_retstack_max = 8;
		480	#endif
		481
		482	UNLOCK;
		483	}
		484
		485	/*
		486	* destroy the stacks, the callchain etc...
		487	*/
		488	static void
341	destroy_stacks(pTHX)	489	destroy_stacks(pTHX)
342	{	490	{
343	/* die does this while calling POPSTACK, but I just don't see why. */	491	if (!IN_DESTRUCT)
344	/* OTOH, die does not have a memleak, but we do... */	492	{
345	dounwind(-1);
346
347	/* is this ugly, I ask? */	493	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)	494	LEAVE_SCOPE (0);
349	LEAVE;	495
		496	/* sure it is, but more important: is it correct?? :/ */
		497	FREETMPS;
		498
		499	/POPSTACK_TO (PL_mainstack);//D//use/
		500	}
350		501
351	while (PL_curstackinfo->si_next)	502	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;	503	PL_curstackinfo = PL_curstackinfo->si_next;
353		504
354	while (PL_curstackinfo)	505	while (PL_curstackinfo)
355	{	506	{
356	PERL_SI *p = PL_curstackinfo->si_prev;	507	PERL_SI *p = PL_curstackinfo->si_prev;
357		508
		509	{ /D//remove/
		510	dSP;
		511	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		512	PUTBACK; /* possibly superfluous */
		513	}
		514
		515	if (!IN_DESTRUCT)
		516	{
		517	dounwind (-1);/D//remove/
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	518	SvREFCNT_dec (PL_curstackinfo->si_stack);
		519	}
		520
359	Safefree(PL_curstackinfo->si_cxstack);	521	Safefree (PL_curstackinfo->si_cxstack);
360	Safefree(PL_curstackinfo);	522	Safefree (PL_curstackinfo);
361	PL_curstackinfo = p;	523	PL_curstackinfo = p;
362	}	524	}
363		525
364	if (PL_scopestack_ix != 0)	526	Safefree (PL_tmps_stack);
365	Perl_warner(aTHX_ WARN_INTERNAL,	527	Safefree (PL_markstack);
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	528	Safefree (PL_scopestack);
367	(long)PL_scopestack_ix);	529	Safefree (PL_savestack);
368	if (PL_savestack_ix != 0)	530	#if PERL_VERSION < 9
369	Perl_warner(aTHX_ WARN_INTERNAL,	531	Safefree (PL_retstack);
370	"Unbalanced saves: %ld more saves than restores\n",	532	#endif
371	(long)PL_savestack_ix);	533	}
372	if (PL_tmps_floor != -1)	534
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	535	static void
374	(long)PL_tmps_floor + 1);	536	allocate_stack (Coro__State ctx, int alloc)
		537	{
		538	coro_stack *stack;
		539
		540	New (0, stack, 1, coro_stack);
		541
		542	stack->refcnt = 1;
		543	stack->usecnt = 1;
		544	stack->gencnt = ctx->gencnt = 0;
		545
		546	if (alloc)
		547	{
		548	#if HAVE_MMAP
		549	stack->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE; /* mmap should do allocate-on-write for us */
		550	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		551	if (stack->sptr != (void *)-1)
		552	{
		553	# if STACKGUARD
		554	mprotect (stack->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
		555	# endif
		556	}
		557	else
		558	#endif
		559	{
		560	stack->ssize = - (STACKSIZE * (long)sizeof (long));
		561	New (0, stack->sptr, STACKSIZE, long);
		562	}
		563	}
		564	else
		565	stack->sptr = 0;
		566
		567	ctx->stack = stack;
		568	}
		569
		570	static void
		571	deallocate_stack (Coro__State ctx)
		572	{
		573	coro_stack *stack = ctx->stack;
		574
		575	ctx->stack = 0;
		576
		577	if (stack)
		578	{
		579	if (!--stack->refcnt)
		580	{
		581	#ifdef HAVE_MMAP
		582	if (stack->ssize > 0 && stack->sptr)
		583	munmap (stack->sptr, stack->ssize);
		584	else
		585	#endif
		586	Safefree (stack->sptr);
		587
		588	Safefree (stack);
		589	}
		590	else if (ctx->gencnt == stack->gencnt)
		591	--stack->usecnt;
		592	}
		593	}
		594
		595	static void
		596	setup_coro (void *arg)
		597	{
375	/*	598	/*
		599	* emulate part of the perl startup here.
		600	*/
		601	dTHX;
		602	dSP;
		603	Coro__State ctx = (Coro__State)arg;
		604	SV sub_init = (SV )get_cv (SUB_INIT, FALSE);
		605
		606	coro_init_stacks (aTHX);
		607	/PL_curcop = 0;/
		608	/PL_in_eval = PL_in_eval;/ /* inherit */
		609	SvREFCNT_dec (GvAV (PL_defgv));
		610	GvAV (PL_defgv) = ctx->args; ctx->args = 0;
		611
		612	SPAGAIN;
		613
		614	if (ctx->stack)
		615	{
		616	ctx->cursp = 0;
		617
		618	PUSHMARK(SP);
		619	PUTBACK;
		620	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		621
		622	if (SvTRUE (ERRSV))
		623	croak (NULL);
		624	else
		625	croak ("FATAL: CCTXT coroutine returned!");
		626	}
		627	else
		628	{
		629	UNOP myop;
		630
		631	Zero(&myop, 1, UNOP);
		632	myop.op_next = Nullop;
		633	myop.op_flags = OPf_WANT_VOID;
		634
		635	PL_op = (OP *)&myop;
		636
		637	PUSHMARK(SP);
		638	XPUSHs (sub_init);
		639	/*
		640	* the next line is slightly wrong, as PL_op->op_next
		641	* is actually being executed so we skip the first op.
		642	* that doesn't matter, though, since it is only
		643	* pp_nextstate and we never return...
		644	* ah yes, and I don't care anyways ;)
		645	*/
		646	PUTBACK;
		647	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		648	SPAGAIN;
		649
		650	ENTER; /* necessary e.g. for dounwind */
		651	}
		652	}
		653
		654	static void
		655	continue_coro (void *arg)
		656	{
		657	/*
		658	* this is a _very_ stripped down perl interpreter ;)
		659	*/
		660	dTHX;
		661	Coro__State ctx = (Coro__State)arg;
		662
		663	PL_top_env = &PL_start_env;
		664
		665	ctx->cursp = 0;
		666	PL_op = PL_op->op_next;
		667	CALLRUNOPS(aTHX);
		668
		669	abort ();
		670	}
		671
		672	static void
		673	transfer (pTHX_ struct coro prev, struct coro next, int flags)
		674	{
		675	dSTACKLEVEL;
		676
		677	if (prev != next)
		678	{
		679	/* has this coro been created yet? */
		680	if (next->mainstack)
		681	{
		682	LOCK;
		683	SAVE (prev, flags);
		684	LOAD (next);
		685	UNLOCK;
		686
		687	/* mark this state as in-use */
		688	next->mainstack = 0;
		689	next->tmps_ix = -2;
		690
		691	/* stacklevel changed? if yes, grab the stack for us! */
		692	if (flags & TRANSFER_SAVE_CCTXT)
		693	{
		694	if (!prev->stack)
		695	allocate_stack (prev, 0);
		696	else if (prev->cursp != stacklevel
		697	&& prev->stack->usecnt > 1)
376	*/	698	{
377	Safefree(PL_tmps_stack);	699	prev->gencnt = ++prev->stack->gencnt;
378	Safefree(PL_markstack);	700	prev->stack->usecnt = 1;
379	Safefree(PL_scopestack);	701	}
380	Safefree(PL_savestack);
381	Safefree(PL_retstack);
382	}
383		702
384	#define SUB_INIT "Coro::State::_newcoro"	703	/* has our stack been invalidated? */
		704	if (next->stack && next->stack->gencnt != next->gencnt)
		705	{
		706	deallocate_stack (next);
		707	allocate_stack (next, 1);
		708	coro_create (&(next->stack->cctx),
		709	continue_coro, (void *)next,
		710	next->stack->sptr, labs (next->stack->ssize));
		711	}
		712
		713	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		714	prev->cursp = stacklevel;
		715	/* don't add any code here */
		716	}
		717	else
		718	next->cursp = stacklevel;
		719	}
		720	else if (next->tmps_ix == -2)
		721	croak ("tried to transfer to running coroutine");
		722	else
		723	{
		724	LOCK;
		725	SAVE (prev, -1); /* first get rid of the old state */
		726	UNLOCK;
		727
		728	/* create the coroutine for the first time */
		729	if (flags & TRANSFER_SAVE_CCTXT)
		730	{
		731	if (!prev->stack)
		732	allocate_stack (prev, 0);
		733
		734	/* the new coroutine starts with start_env again */
		735	PL_top_env = &PL_start_env;
		736
		737	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		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;/
408		956
409	RETVAL = coro;	957	RETVAL = coro;
410	OUTPUT:	958	OUTPUT:
411	RETVAL	959	RETVAL
412		960
413	void	961	void
414	transfer(prev,next)	962	transfer(prev, next, flags)
415	Coro::State_or_hashref prev	963	SV *prev
416	Coro::State_or_hashref next	964	SV *next
		965	int flags
		966	PROTOTYPE: @
417	CODE:	967	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;	968	PUTBACK;
461	/*	969	SV_CORO (next, "Coro::transfer");
462	* the next line is slightly wrong, as PL_op->op_next	970	SV_CORO (prev, "Coro::transfer");
463	* is actually being executed so we skip the first op.	971	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;	972	SPAGAIN;
469
470	ENTER;
471	}
472	}
473		973
474	void	974	void
475	DESTROY(coro)	975	DESTROY(coro)
476	Coro::State coro	976	Coro::State coro
477	CODE:	977	CODE:
478		978
479	if (coro->mainstack)	979	if (coro->mainstack && coro->mainstack != main_mainstack)
480	{	980	{
481	struct coro temp;	981	struct coro temp;
482		982
		983	PUTBACK;
483	SAVE(aTHX_ (&temp));	984	SAVE (aTHX_ (&temp), TRANSFER_SAVE_ALL);
484	LOAD(aTHX_ coro);	985	LOAD (aTHX_ coro);
		986	SPAGAIN;
485		987
486	destroy_stacks ();	988	destroy_stacks (aTHX);
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488		989
489	LOAD((&temp));	990	LOAD ((&temp)); /* this will get rid of defsv etc.. */
		991	SPAGAIN;
		992
		993	coro->mainstack = 0;
490	}	994	}
491		995
		996	deallocate_stack (coro);
492	SvREFCNT_dec (coro->args);	997	SvREFCNT_dec (coro->args);
493	Safefree (coro);	998	Safefree (coro);
494		999
		1000	void
		1001	_exit(code)
		1002	int code
		1003	PROTOTYPE: $
		1004	CODE:
		1005	_exit (code);
495		1006
		1007	MODULE = Coro::State PACKAGE = Coro::Cont
		1008
		1009	void
		1010	yield(...)
		1011	PROTOTYPE: @
		1012	CODE:
		1013	SV *yieldstack;
		1014	SV *sv;
		1015	AV *defav = GvAV (PL_defgv);
		1016	struct coro prev, next;
		1017
		1018	yieldstack = *hv_fetch (
		1019	(HV *)SvRV (GvSV (coro_current)),
		1020	"yieldstack", sizeof ("yieldstack") - 1,
		1021	0
		1022	);
		1023
		1024	/* set up @_ -- ugly */
		1025	av_clear (defav);
		1026	av_fill (defav, items - 1);
		1027	while (items--)
		1028	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1029
		1030	sv = av_pop ((AV *)SvRV (yieldstack));
		1031	prev = INT2PTR (struct coro , SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0))));
		1032	next = INT2PTR (struct coro , SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0))));
		1033	SvREFCNT_dec (sv);
		1034
		1035	transfer (aTHX_ prev, next, 0);
		1036
		1037	MODULE = Coro::State PACKAGE = Coro
		1038
		1039	BOOT:
		1040	{
		1041	int i;
		1042	HV *stash = gv_stashpv ("Coro", TRUE);
		1043
		1044	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1045	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1046	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1047	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1048	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1049	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1050
		1051	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1052	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1053
		1054	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1055	coro_ready[i] = newAV ();
		1056
		1057	{
		1058	SV *sv = perl_get_sv("Coro::API", 1);
		1059
		1060	coroapi.schedule = api_schedule;
		1061	coroapi.cede = api_cede;
		1062	coroapi.ready = api_ready;
		1063	coroapi.nready = &coro_nready;
		1064	coroapi.current = coro_current;
		1065
		1066	GCoroAPI = &coroapi;
		1067	sv_setiv (sv, (IV)&coroapi);
		1068	SvREADONLY_on (sv);
		1069	}
		1070	}
		1071
		1072	#if !PERL_MICRO
		1073
		1074	void
		1075	ready(self)
		1076	SV * self
		1077	PROTOTYPE: $
		1078	CODE:
		1079	api_ready (self);
		1080
		1081	#endif
		1082
		1083	int
		1084	nready(...)
		1085	PROTOTYPE:
		1086	CODE:
		1087	RETVAL = coro_nready;
		1088	OUTPUT:
		1089	RETVAL
		1090
		1091	void
		1092	schedule(...)
		1093	PROTOTYPE:
		1094	CODE:
		1095	api_schedule ();
		1096
		1097	void
		1098	cede(...)
		1099	PROTOTYPE:
		1100	CODE:
		1101	api_cede ();
		1102
		1103	# and these are hacks
		1104	SV *
		1105	_aio_get_state ()
		1106	CODE:
		1107	{
		1108	struct {
		1109	int errorno;
		1110	int laststype;
		1111	int laststatval;
		1112	Stat_t statcache;
		1113	} data;
		1114
		1115	data.errorno = errno;
		1116	data.laststype = PL_laststype;
		1117	data.laststatval = PL_laststatval;
		1118	data.statcache = PL_statcache;
		1119
		1120	RETVAL = newSVpvn ((char *)&data, sizeof data);
		1121	}
		1122	OUTPUT:
		1123	RETVAL
		1124
		1125	void
		1126	_aio_set_state (char *data_)
		1127	PROTOTYPE: $
		1128	CODE:
		1129	{
		1130	struct {
		1131	int errorno;
		1132	int laststype;
		1133	int laststatval;
		1134	Stat_t statcache;
		1135	} data = (void )data_;
		1136
		1137	errno = data->errorno;
		1138	PL_laststype = data->laststype;
		1139	PL_laststatval = data->laststatval;
		1140	PL_statcache = data->statcache;
		1141	}

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.81 by root, Fri Nov 3 00:56:03 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.81 by root, Fri Nov 3 00:56:03 2006 UTC