[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.84 by root, Fri Nov 24 00:31: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 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	/* never call directly, always through the coro_state_transfer global variable */
		673	static void
		674	transfer_impl (pTHX_ struct coro prev, struct coro next, int flags)
		675	{
		676	dSTACKLEVEL;
		677
		678	if (prev != next)
		679	{
		680	/* has this coro been created yet? */
		681	if (next->mainstack)
		682	{
		683	LOCK;
		684	SAVE (prev, flags);
		685	LOAD (next);
		686	UNLOCK;
		687
		688	/* mark this state as in-use */
		689	next->mainstack = 0;
		690	next->tmps_ix = -2;
		691
		692	/* stacklevel changed? if yes, grab the stack for us! */
		693	if (flags & TRANSFER_SAVE_CCTXT)
		694	{
		695	if (!prev->stack)
		696	allocate_stack (prev, 0);
		697	else if (prev->cursp != stacklevel
		698	&& prev->stack->usecnt > 1)
376	*/	699	{
377	Safefree(PL_tmps_stack);	700	prev->gencnt = ++prev->stack->gencnt;
378	Safefree(PL_markstack);	701	prev->stack->usecnt = 1;
379	Safefree(PL_scopestack);	702	}
380	Safefree(PL_savestack);
381	Safefree(PL_retstack);
382	}
383		703
384	#define SUB_INIT "Coro::State::_newcoro"	704	/* has our stack been invalidated? */
		705	if (next->stack && next->stack->gencnt != next->gencnt)
		706	{
		707	deallocate_stack (next);
		708	allocate_stack (next, 1);
		709	coro_create (&(next->stack->cctx),
		710	continue_coro, (void *)next,
		711	next->stack->sptr, labs (next->stack->ssize));
		712	}
		713
		714	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		715	prev->cursp = stacklevel;
		716	/* don't add any code here */
		717	}
		718	else
		719	next->cursp = stacklevel;
		720	}
		721	else if (next->tmps_ix == -2)
		722	croak ("tried to transfer to running coroutine");
		723	else
		724	{
		725	LOCK;
		726	SAVE (prev, -1); /* first get rid of the old state */
		727	UNLOCK;
		728
		729	/* create the coroutine for the first time */
		730	if (flags & TRANSFER_SAVE_CCTXT)
		731	{
		732	if (!prev->stack)
		733	allocate_stack (prev, 0);
		734
		735	/* the new coroutine starts with start_env again */
		736	PL_top_env = &PL_start_env;
		737
		738	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		739	{
		740	setup_coro (next);
		741	next->cursp = stacklevel;
		742
		743	prev->stack->refcnt++;
		744	prev->stack->usecnt++;
		745	next->stack = prev->stack;
		746	next->gencnt = prev->gencnt;
		747	}
		748	else
		749	{
		750	assert (!next->stack);
		751	allocate_stack (next, 1);
		752	coro_create (&(next->stack->cctx),
		753	setup_coro, (void *)next,
		754	next->stack->sptr, labs (next->stack->ssize));
		755	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		756	prev->cursp = stacklevel;
		757	/* don't add any code here */
		758	}
		759	}
		760	else
		761	{
		762	setup_coro (next);
		763	next->cursp = stacklevel;
		764	}
		765	}
		766	}
		767
		768	LOCK;
		769	if (coro_mortal)
		770	{
		771	SvREFCNT_dec (coro_mortal);
		772	coro_mortal = 0;
		773	}
		774	UNLOCK;
		775	}
		776
		777	void (coro_state_transfer)(pTHX_ struct coro prev, struct coro *next, int flags) = transfer_impl;
		778
		779	#define SV_CORO(sv,func) \
		780	do { \
		781	if (SvROK (sv)) \
		782	sv = SvRV (sv); \
		783	\
		784	if (SvTYPE (sv) == SVt_PVHV) \
		785	{ \
		786	HE he = hv_fetch_ent ((HV )sv, ucoro_state_sv, 0, ucoro_state_hash); \
		787	\
		788	if (!he) \
		789	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
		790	\
		791	(sv) = SvRV (HeVAL(he)); \
		792	} \
		793	\
		794	/* must also be changed inside Coro::Cont::yield */ \
		795	if (!SvOBJECT (sv) \|\| SvSTASH (sv) != coro_state_stash) \
		796	croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
		797	\
		798	} while(0)
		799
		800	#define SvSTATE(sv) INT2PTR (struct coro *, SvIVX (sv))
		801
		802	static void
		803	api_transfer (pTHX_ SV prev, SV next, int flags)
		804	{
		805	SV_CORO (prev, "Coro::transfer");
		806	SV_CORO (next, "Coro::transfer");
		807
		808	coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
		809	}
		810
		811	/ Coro ******************************************************************/
		812
		813	#define PRIO_MAX 3
		814	#define PRIO_HIGH 1
		815	#define PRIO_NORMAL 0
		816	#define PRIO_LOW -1
		817	#define PRIO_IDLE -3
		818	#define PRIO_MIN -4
		819
		820	/* for Coro.pm */
		821	static GV coro_current, coro_idle;
		822	static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
		823	static int coro_nready;
		824
		825	static void
		826	coro_enq (pTHX_ SV *sv)
		827	{
		828	SV **xprio;
		829	int prio;
		830
		831	if (SvTYPE (sv) != SVt_PVHV)
		832	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		833
		834	xprio = hv_fetch ((HV *)sv, "prio", 4, 0);
		835	prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		836
		837	prio = prio > PRIO_MAX ? PRIO_MAX
		838	: prio < PRIO_MIN ? PRIO_MIN
		839	: prio;
		840
		841	av_push (coro_ready [prio - PRIO_MIN], sv);
		842	coro_nready++;
		843	}
		844
		845	static SV *
		846	coro_deq (pTHX_ int min_prio)
		847	{
		848	int prio = PRIO_MAX - PRIO_MIN;
		849
		850	min_prio -= PRIO_MIN;
		851	if (min_prio < 0)
		852	min_prio = 0;
		853
		854	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		855	if (AvFILLp (coro_ready [prio]) >= 0)
		856	{
		857	coro_nready--;
		858	return av_shift (coro_ready [prio]);
		859	}
		860
		861	return 0;
		862	}
		863
		864	static void
		865	api_ready (SV *coro)
		866	{
		867	dTHX;
		868
		869	if (SvROK (coro))
		870	coro = SvRV (coro);
		871
		872	LOCK;
		873	coro_enq (aTHX_ SvREFCNT_inc (coro));
		874	UNLOCK;
		875	}
		876
		877	static void
		878	api_schedule (void)
		879	{
		880	dTHX;
		881
		882	SV prev, next;
		883
		884	LOCK;
		885
		886	prev = SvRV (GvSV (coro_current));
		887	next = coro_deq (aTHX_ PRIO_MIN);
		888
		889	if (!next)
		890	next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
		891
		892	/* free this only after the transfer */
		893	coro_mortal = prev;
		894	SV_CORO (prev, "Coro::schedule");
		895
		896	SvRV (GvSV (coro_current)) = next;
		897
		898	SV_CORO (next, "Coro::schedule");
		899
		900	UNLOCK;
		901
		902	coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		903	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		904	}
		905
		906	static void
		907	api_cede (void)
		908	{
		909	dTHX;
		910
		911	LOCK;
		912	coro_enq (aTHX_ SvREFCNT_inc (SvRV (GvSV (coro_current))));
		913	UNLOCK;
		914
		915	api_schedule ();
		916	}
385		917
386	MODULE = Coro::State PACKAGE = Coro::State	918	MODULE = Coro::State PACKAGE = Coro::State
387		919
388	PROTOTYPES: ENABLE	920	PROTOTYPES: ENABLE
389		921
390	BOOT:	922	BOOT:
391	if (!padlist_cache)	923	{ /* {} necessary for stoopid perl-5.6.x */
392	padlist_cache = newHV ();	924	#ifdef USE_ITHREADS
		925	MUTEX_INIT (&coro_mutex);
		926	#endif
		927	BOOT_PAGESIZE;
		928
		929	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		930	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		931	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		932
		933	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		934	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		935	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		936	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		937
		938	main_mainstack = PL_mainstack;
		939
		940	coroapi.ver = CORO_API_VERSION;
		941	coroapi.transfer = api_transfer;
		942	}
393		943
394	Coro::State	944	Coro::State
395	_newprocess(args)	945	_newprocess(args)
396	SV * args	946	SV * args
397	PROTOTYPE: $	947	PROTOTYPE: $
398	CODE:	948	CODE:
399	Coro__State coro;	949	Coro__State coro;
400		950
401	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	951	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");	952	croak ("Coro::State::_newprocess expects an arrayref");
403		953
404	New (0, coro, 1, struct coro);	954	Newz (0, coro, 1, struct coro);
405		955
406	coro->mainstack = 0; /* actual work is done inside transfer */
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	956	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
		957	/coro->mainstack = 0; //actual work is done inside transfer /
		958	/coro->stack = 0;/
408		959
409	RETVAL = coro;	960	RETVAL = coro;
410	OUTPUT:	961	OUTPUT:
411	RETVAL	962	RETVAL
412		963
413	void	964	void
414	transfer(prev,next)	965	transfer(prev, next, flags)
415	Coro::State_or_hashref prev	966	SV *prev
416	Coro::State_or_hashref next	967	SV *next
		968	int flags
		969	PROTOTYPE: @
417	CODE:	970	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;	971	PUTBACK;
461	/*	972	SV_CORO (next, "Coro::transfer");
462	* the next line is slightly wrong, as PL_op->op_next	973	SV_CORO (prev, "Coro::transfer");
463	* is actually being executed so we skip the first op.	974	coro_state_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;	975	SPAGAIN;
469
470	ENTER;
471	}
472	}
473		976
474	void	977	void
475	DESTROY(coro)	978	DESTROY(coro)
476	Coro::State coro	979	Coro::State coro
477	CODE:	980	CODE:
478		981
479	if (coro->mainstack)	982	if (coro->mainstack && coro->mainstack != main_mainstack)
480	{	983	{
481	struct coro temp;	984	struct coro temp;
482		985
		986	PUTBACK;
483	SAVE(aTHX_ (&temp));	987	SAVE (aTHX_ (&temp), TRANSFER_SAVE_ALL);
484	LOAD(aTHX_ coro);	988	LOAD (aTHX_ coro);
		989	SPAGAIN;
485		990
486	destroy_stacks ();	991	destroy_stacks (aTHX);
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488		992
489	LOAD((&temp));	993	LOAD ((&temp)); /* this will get rid of defsv etc.. */
		994	SPAGAIN;
		995
		996	coro->mainstack = 0;
490	}	997	}
491		998
		999	deallocate_stack (coro);
492	SvREFCNT_dec (coro->args);	1000	SvREFCNT_dec (coro->args);
493	Safefree (coro);	1001	Safefree (coro);
494		1002
		1003	void
		1004	_exit(code)
		1005	int code
		1006	PROTOTYPE: $
		1007	CODE:
		1008	_exit (code);
495		1009
		1010	MODULE = Coro::State PACKAGE = Coro::Cont
		1011
		1012	void
		1013	yield(...)
		1014	PROTOTYPE: @
		1015	CODE:
		1016	SV *yieldstack;
		1017	SV *sv;
		1018	AV *defav = GvAV (PL_defgv);
		1019	struct coro prev, next;
		1020
		1021	yieldstack = *hv_fetch (
		1022	(HV *)SvRV (GvSV (coro_current)),
		1023	"yieldstack", sizeof ("yieldstack") - 1,
		1024	0
		1025	);
		1026
		1027	/* set up @_ -- ugly */
		1028	av_clear (defav);
		1029	av_fill (defav, items - 1);
		1030	while (items--)
		1031	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1032
		1033	sv = av_pop ((AV *)SvRV (yieldstack));
		1034	prev = SvSTATE ((SV)SvRV (av_fetch ((AV *)SvRV (sv), 0, 0)));
		1035	next = SvSTATE ((SV)SvRV (av_fetch ((AV *)SvRV (sv), 1, 0)));
		1036	SvREFCNT_dec (sv);
		1037
		1038	coro_state_transfer (aTHX_ prev, next, 0);
		1039
		1040	MODULE = Coro::State PACKAGE = Coro
		1041
		1042	BOOT:
		1043	{
		1044	int i;
		1045	HV *stash = gv_stashpv ("Coro", TRUE);
		1046
		1047	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1048	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1049	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1050	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1051	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1052	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1053
		1054	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1055	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1056
		1057	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1058	coro_ready[i] = newAV ();
		1059
		1060	{
		1061	SV *sv = perl_get_sv("Coro::API", 1);
		1062
		1063	coroapi.schedule = api_schedule;
		1064	coroapi.cede = api_cede;
		1065	coroapi.ready = api_ready;
		1066	coroapi.nready = &coro_nready;
		1067	coroapi.current = coro_current;
		1068
		1069	GCoroAPI = &coroapi;
		1070	sv_setiv (sv, (IV)&coroapi);
		1071	SvREADONLY_on (sv);
		1072	}
		1073	}
		1074
		1075	#if !PERL_MICRO
		1076
		1077	void
		1078	ready(self)
		1079	SV * self
		1080	PROTOTYPE: $
		1081	CODE:
		1082	api_ready (self);
		1083
		1084	#endif
		1085
		1086	int
		1087	nready(...)
		1088	PROTOTYPE:
		1089	CODE:
		1090	RETVAL = coro_nready;
		1091	OUTPUT:
		1092	RETVAL
		1093
		1094	void
		1095	schedule(...)
		1096	PROTOTYPE:
		1097	CODE:
		1098	api_schedule ();
		1099
		1100	void
		1101	cede(...)
		1102	PROTOTYPE:
		1103	CODE:
		1104	api_cede ();
		1105
		1106	# and these are hacks
		1107	SV *
		1108	_aio_get_state ()
		1109	CODE:
		1110	{
		1111	struct {
		1112	int errorno;
		1113	int laststype;
		1114	int laststatval;
		1115	Stat_t statcache;
		1116	} data;
		1117
		1118	data.errorno = errno;
		1119	data.laststype = PL_laststype;
		1120	data.laststatval = PL_laststatval;
		1121	data.statcache = PL_statcache;
		1122
		1123	RETVAL = newSVpvn ((char *)&data, sizeof data);
		1124	}
		1125	OUTPUT:
		1126	RETVAL
		1127
		1128	void
		1129	_aio_set_state (char *data_)
		1130	PROTOTYPE: $
		1131	CODE:
		1132	{
		1133	struct {
		1134	int errorno;
		1135	int laststype;
		1136	int laststatval;
		1137	Stat_t statcache;
		1138	} data = (void )data_;
		1139
		1140	errno = data->errorno;
		1141	PL_laststype = data->laststype;
		1142	PL_laststatval = data->laststatval;
		1143	PL_statcache = data->statcache;
		1144	}

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.84 by root, Fri Nov 24 00:31:21 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.84 by root, Fri Nov 24 00:31:21 2006 UTC