[ViewVC] Diff of: cvs/Coro/Coro/State.xs

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.91 by root, Sat Nov 25 01:14:11 2006 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.91 by root, Sat Nov 25 01:14:11 2006 UTC