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

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.76 by root, Thu Oct 26 08:45:56 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.76 by root, Thu Oct 26 08:45:56 2006 UTC