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

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.77 by root, Tue Oct 31 23:55:33 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.77 by root, Tue Oct 31 23:55:33 2006 UTC