ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.88 by root, Fri Nov 24 15:34: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	#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 only the c stack but also c registers etc... */
		90	typedef struct {
		91	int refcnt; /* pointer reference counter */
		92	int usecnt; /* shared by how many coroutines */
		93	int gencnt; /* generation counter */
		94
		95	coro_context cctx;
		96
		97	void *sptr;
		98	long ssize; /* positive == mmap, otherwise malloc */
		99	} coro_stack;
10		100
11	struct coro {	101	struct coro {
		102	/* the optional C context */
		103	coro_stack *stack;
		104	void *cursp;
		105	int gencnt;
		106
		107	/* optionally saved, might be zero */
		108	AV *defav;
		109	SV *defsv;
		110	SV *errsv;
		111
		112	/* saved global state not related to stacks */
12	U8 dowarn;	113	U8 dowarn;
13	AV *defav;	114	I32 in_eval;
14		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_state(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
282	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	436	/*
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	437	* allocate various perl stacks. This is an exact copy
284		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	*/
285	static void	442	static void
286	load_state(pTHX_ Coro__State c)	443	coro_init_stacks (pTHX)
287	{	444	{
288	PL_dowarn = c->dowarn;	445	LOCK;
289	GvAV (PL_defgv) = c->defav;	446
290	PL_curstackinfo = c->curstackinfo;	447	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
291	PL_curstack = c->curstack;	448	PL_curstackinfo->si_type = PERLSI_MAIN;
292	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);
293	PL_stack_sp = c->stack_sp;	453	PL_stack_sp = PL_stack_base;
294	PL_op = c->op;	454	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295	PL_curpad = c->curpad;	455
296	PL_stack_base = c->stack_base;	456	New(50,PL_tmps_stack,96,SV*);
297	PL_stack_max = c->stack_max;	457	PL_tmps_floor = -1;
298	PL_tmps_stack = c->tmps_stack;	458	PL_tmps_ix = -1;
299	PL_tmps_floor = c->tmps_floor;	459	PL_tmps_max = 96;
300	PL_tmps_ix = c->tmps_ix;	460
301	PL_tmps_max = c->tmps_max;	461	New(54,PL_markstack,16,I32);
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;	462	PL_markstack_ptr = PL_markstack;
304	PL_markstack_max = c->markstack_max;	463	PL_markstack_max = PL_markstack + 16;
305	PL_scopestack = c->scopestack;
306	PL_scopestack_ix = c->scopestack_ix;
307	PL_scopestack_max = c->scopestack_max;
308	PL_savestack = c->savestack;
309	PL_savestack_ix = c->savestack_ix;
310	PL_savestack_max = c->savestack_max;
311	PL_retstack = c->retstack;
312	PL_retstack_ix = c->retstack_ix;
313	PL_retstack_max = c->retstack_max;
314	PL_curcop = c->curcop;
315		464
316	{	465	#ifdef SET_MARK_OFFSET
317	dSP;	466	SET_MARK_OFFSET;
318	CV *cv;
319
320	/* now do the ugly restore mess */
321	while ((cv = (CV *)POPs))
322	{
323	AV *padlist = (AV *)POPs;
324
325	put_padlist (cv);
326	CvPADLIST(cv) = padlist;
327	CvDEPTH(cv) = (I32)POPs;
328
329	#ifdef USE_THREADS
330	CvOWNER(cv) = (struct perl_thread *)POPs;
331	error does not work either
332	#endif	467	#endif
333	}
334		468
335	PUTBACK;	469	New(54,PL_scopestack,16,I32);
336	}	470	PL_scopestack_ix = 0;
337	}	471	PL_scopestack_max = 16;
338		472
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	473	New(54,PL_savestack,96,ANY);
340	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
341	destroy_stacks(pTHX)	490	destroy_stacks(pTHX)
342	{	491	{
343	/* die does this while calling POPSTACK, but I just don't see why. */	492	if (!IN_DESTRUCT)
344	/* OTOH, die does not have a memleak, but we do... */	493	{
345	dounwind(-1);
346
347	/* is this ugly, I ask? */	494	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)	495	LEAVE_SCOPE (0);
349	LEAVE;	496
		497	/* sure it is, but more important: is it correct?? :/ */
		498	FREETMPS;
		499
		500	/*POPSTACK_TO (PL_mainstack);*//*D*//*use*/
		501	}
350		502
351	while (PL_curstackinfo->si_next)	503	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;	504	PL_curstackinfo = PL_curstackinfo->si_next;
353		505
354	while (PL_curstackinfo)	506	while (PL_curstackinfo)
355	{	507	{
356	PERL_SI *p = PL_curstackinfo->si_prev;	508	PERL_SI *p = PL_curstackinfo->si_prev;
357		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*/
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	519	SvREFCNT_dec (PL_curstackinfo->si_stack);
		520	}
		521
359	Safefree(PL_curstackinfo->si_cxstack);	522	Safefree (PL_curstackinfo->si_cxstack);
360	Safefree(PL_curstackinfo);	523	Safefree (PL_curstackinfo);
361	PL_curstackinfo = p;	524	PL_curstackinfo = p;
362	}	525	}
363		526
364	if (PL_scopestack_ix != 0)	527	Safefree (PL_tmps_stack);
365	Perl_warner(aTHX_ WARN_INTERNAL,	528	Safefree (PL_markstack);
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	529	Safefree (PL_scopestack);
367	(long)PL_scopestack_ix);	530	Safefree (PL_savestack);
368	if (PL_savestack_ix != 0)	531	#if PERL_VERSION < 9
369	Perl_warner(aTHX_ WARN_INTERNAL,	532	Safefree (PL_retstack);
370	"Unbalanced saves: %ld more saves than restores\n",	533	#endif
371	(long)PL_savestack_ix);	534	}
372	if (PL_tmps_floor != -1)	535
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	536	static void
374	(long)PL_tmps_floor + 1);	537	allocate_stack (Coro__State ctx, int alloc)
		538	{
		539	coro_stack *stack;
		540
		541	New (0, stack, 1, coro_stack);
		542
		543	stack->refcnt = 1;
		544	stack->usecnt = 1;
		545	stack->gencnt = ctx->gencnt = 0;
		546
		547	if (alloc)
		548	{
		549	#if HAVE_MMAP
		550	stack->ssize = ((STACKSIZE * sizeof (long) + PAGESIZE - 1) / PAGESIZE + STACKGUARD) * PAGESIZE; /* mmap should do allocate-on-write for us */
		551	stack->sptr = mmap (0, stack->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0);
		552	if (stack->sptr != (void *)-1)
		553	{
		554	# if STACKGUARD
		555	mprotect (stack->sptr, STACKGUARD * PAGESIZE, PROT_NONE);
		556	# endif
		557	}
		558	else
		559	#endif
		560	{
		561	stack->ssize = - (STACKSIZE * (long)sizeof (long));
		562	New (0, stack->sptr, STACKSIZE, long);
		563	}
		564	}
		565	else
		566	stack->sptr = 0;
		567
		568	ctx->stack = stack;
		569	}
		570
		571	static void
		572	deallocate_stack (Coro__State ctx)
		573	{
		574	coro_stack *stack = ctx->stack;
		575
		576	ctx->stack = 0;
		577
		578	if (stack)
		579	{
		580	if (!--stack->refcnt)
		581	{
		582	#ifdef HAVE_MMAP
		583	if (stack->ssize > 0 && stack->sptr)
		584	munmap (stack->sptr, stack->ssize);
		585	else
		586	#endif
		587	Safefree (stack->sptr);
		588
		589	Safefree (stack);
		590	}
		591	else if (ctx->gencnt == stack->gencnt)
		592	--stack->usecnt;
		593	}
		594	}
		595
		596	static void
		597	setup_coro (void *arg)
		598	{
375	/*	599	/*
		600	* emulate part of the perl startup here.
		601	*/
		602	dTHX;
		603	dSP;
		604	Coro__State ctx = (Coro__State)arg;
		605	SV *sub_init = (SV *)get_cv (SUB_INIT, FALSE);
		606
		607	coro_init_stacks (aTHX);
		608	/*PL_curcop = 0;*/
		609	/*PL_in_eval = PL_in_eval;*/ /* inherit */
		610	SvREFCNT_dec (GvAV (PL_defgv));
		611	GvAV (PL_defgv) = ctx->args; ctx->args = 0;
		612
		613	SPAGAIN;
		614
		615	if (ctx->stack)
		616	{
		617	ctx->cursp = 0;
		618
		619	PUSHMARK(SP);
		620	PUTBACK;
		621	(void) call_sv (sub_init, G_VOID|G_NOARGS|G_EVAL);
		622
		623	if (SvTRUE (ERRSV))
		624	croak (NULL);
		625	else
		626	croak ("FATAL: CCTXT coroutine returned!");
		627	}
		628	else
		629	{
		630	UNOP myop;
		631
		632	Zero(&myop, 1, UNOP);
		633	myop.op_next = Nullop;
		634	myop.op_flags = OPf_WANT_VOID;
		635
		636	PL_op = (OP *)&myop;
		637
		638	PUSHMARK(SP);
		639	XPUSHs (sub_init);
		640	/*
		641	* the next line is slightly wrong, as PL_op->op_next
		642	* is actually being executed so we skip the first op.
		643	* that doesn't matter, though, since it is only
		644	* pp_nextstate and we never return...
		645	* ah yes, and I don't care anyways ;)
		646	*/
		647	PUTBACK;
		648	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		649	SPAGAIN;
		650
		651	ENTER; /* necessary e.g. for dounwind */
		652	}
		653	}
		654
		655	static void
		656	continue_coro (void *arg)
		657	{
		658	/*
		659	* this is a _very_ stripped down perl interpreter ;)
		660	*/
		661	dTHX;
		662	Coro__State ctx = (Coro__State)arg;
		663
		664	PL_top_env = &PL_start_env;
		665
		666	ctx->cursp = 0;
		667	PL_op = PL_op->op_next;
		668	CALLRUNOPS(aTHX);
		669
		670	abort ();
		671	}
		672
		673	/* never call directly, always through the coro_state_transfer global variable */
		674	static void
		675	transfer_impl (pTHX_ struct coro *prev, struct coro *next, int flags)
		676	{
		677	dSTACKLEVEL;
		678
		679	if (prev != next)
		680	{
		681	/* has this coro been created yet? */
		682	if (next->mainstack)
		683	{
		684	LOCK;
		685	SAVE (prev, flags);
		686	LOAD (next);
		687	UNLOCK;
		688
		689	/* mark this state as in-use */
		690	next->mainstack = 0;
		691	next->tmps_ix = -2;
		692
		693	/* stacklevel changed? if yes, grab the stack for us! */
		694	if (flags & TRANSFER_SAVE_CCTXT)
		695	{
		696	if (!prev->stack)
		697	allocate_stack (prev, 0);
		698	else if (prev->cursp != stacklevel
		699	&& prev->stack->usecnt > 1)
376	*/	700	{
377	Safefree(PL_tmps_stack);	701	prev->gencnt = ++prev->stack->gencnt;
378	Safefree(PL_markstack);	702	prev->stack->usecnt = 1;
379	Safefree(PL_scopestack);	703	}
380	Safefree(PL_savestack);
381	Safefree(PL_retstack);
382	}
383		704
384	#define SUB_INIT "Coro::State::_newcoro"	705	/* has our stack been invalidated? */
		706	if (next->stack && next->stack->gencnt != next->gencnt)
		707	{
		708	deallocate_stack (next);
		709	allocate_stack (next, 1);
		710	coro_create (&(next->stack->cctx),
		711	continue_coro, (void *)next,
		712	next->stack->sptr, labs (next->stack->ssize));
		713	}
		714
		715	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		716	prev->cursp = stacklevel;
		717	/* don't add any code here */
		718	}
		719	else
		720	next->cursp = stacklevel;
		721	}
		722	else if (next->tmps_ix == -2)
		723	croak ("tried to transfer to running coroutine");
		724	else
		725	{
		726	LOCK;
		727	SAVE (prev, -1); /* first get rid of the old state */
		728	UNLOCK;
		729
		730	/* create the coroutine for the first time */
		731	if (flags & TRANSFER_SAVE_CCTXT)
		732	{
		733	if (!prev->stack)
		734	allocate_stack (prev, 0);
		735
		736	/* the new coroutine starts with start_env again */
		737	PL_top_env = &PL_start_env;
		738
		739	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		740	{
		741	setup_coro (next);
		742	next->cursp = stacklevel;
		743
		744	prev->stack->refcnt++;
		745	prev->stack->usecnt++;
		746	next->stack = prev->stack;
		747	next->gencnt = prev->gencnt;
		748	}
		749	else
		750	{
		751	assert (!next->stack);
		752	allocate_stack (next, 1);
		753	coro_create (&(next->stack->cctx),
		754	setup_coro, (void *)next,
		755	next->stack->sptr, labs (next->stack->ssize));
		756	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		757	prev->cursp = stacklevel;
		758	/* don't add any code here */
		759	}
		760	}
		761	else
		762	{
		763	setup_coro (next);
		764	next->cursp = stacklevel;
		765	}
		766	}
		767	}
		768
		769	LOCK;
		770	if (coro_mortal)
		771	{
		772	SvREFCNT_dec (coro_mortal);
		773	coro_mortal = 0;
		774	}
		775	UNLOCK;
		776	}
		777
		778	/* use this function pointer to call the above function */
		779	/* this is done to increase chances of the compiler not inlining the call */
		780	void (*coro_state_transfer)(pTHX_ struct coro *prev, struct coro *next, int flags) = transfer_impl;
		781
		782	static void
		783	coro_state_destroy (struct coro *coro)
		784	{
		785	if (coro->refcnt--)
		786	return;
		787
		788	if (coro->mainstack && coro->mainstack != main_mainstack)
		789	{
		790	struct coro temp;
		791
		792	SAVE (aTHX_ (&temp), TRANSFER_SAVE_ALL);
		793	LOAD (aTHX_ coro);
		794
		795	destroy_stacks (aTHX);
		796
		797	LOAD ((&temp)); /* this will get rid of defsv etc.. */
		798
		799	coro->mainstack = 0;
		800	}
		801
		802	deallocate_stack (coro);
		803	SvREFCNT_dec (coro->args);
		804	Safefree (coro);
		805	}
		806
		807	static int
		808	coro_state_clear (SV *sv, MAGIC *mg)
		809	{
		810	struct coro *coro = (struct coro *)mg->mg_ptr;
		811	mg->mg_ptr = 0;
		812
		813	coro_state_destroy (coro);
		814
		815	return 0;
		816	}
		817
		818	static int
		819	coro_state_dup (MAGIC *mg, CLONE_PARAMS *params)
		820	{
		821	struct coro *coro = (struct coro *)mg->mg_ptr;
		822
		823	++coro->refcnt;
		824
		825	return 0;
		826	}
		827
		828	static MGVTBL coro_state_vtbl = { 0, 0, 0, 0, coro_state_clear, 0, coro_state_dup, 0 };
		829
		830	static struct coro *
		831	SvSTATE (SV *coro)
		832	{
		833	HV *stash;
		834	MAGIC *mg;
		835
		836	if (SvROK (coro))
		837	coro = SvRV (coro);
		838
		839	stash = SvSTASH (coro);
		840	if (stash != coro_stash && stash != coro_state_stash)
		841	{
		842	/* very slow, but rare, check */
		843	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		844	croak ("Coro::State object required");
		845	}
		846
		847	mg = SvMAGIC (coro);
		848	assert (mg->mg_type == PERL_MAGIC_ext);
		849	return (struct coro *)mg->mg_ptr;
		850	}
		851
		852	static void
		853	api_transfer (pTHX_ SV *prev, SV *next, int flags)
		854	{
		855	coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
		856	}
		857
		858	/** Coro ********************************************************************/
		859
		860	#define PRIO_MAX 3
		861	#define PRIO_HIGH 1
		862	#define PRIO_NORMAL 0
		863	#define PRIO_LOW -1
		864	#define PRIO_IDLE -3
		865	#define PRIO_MIN -4
		866
		867	/* for Coro.pm */
		868	static GV *coro_current, *coro_idle;
		869	static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
		870	static int coro_nready;
		871
		872	static void
		873	coro_enq (pTHX_ SV *sv)
		874	{
		875	int prio;
		876
		877	if (SvTYPE (sv) != SVt_PVHV)
		878	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		879
		880	prio = SvSTATE (sv)->prio;
		881
		882	av_push (coro_ready [prio - PRIO_MIN], sv);
		883	coro_nready++;
		884	}
		885
		886	static SV *
		887	coro_deq (pTHX_ int min_prio)
		888	{
		889	int prio = PRIO_MAX - PRIO_MIN;
		890
		891	min_prio -= PRIO_MIN;
		892	if (min_prio < 0)
		893	min_prio = 0;
		894
		895	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		896	if (AvFILLp (coro_ready [prio]) >= 0)
		897	{
		898	coro_nready--;
		899	return av_shift (coro_ready [prio]);
		900	}
		901
		902	return 0;
		903	}
		904
		905	static void
		906	api_ready (SV *coro)
		907	{
		908	dTHX;
		909
		910	if (SvROK (coro))
		911	coro = SvRV (coro);
		912
		913	LOCK;
		914	coro_enq (aTHX_ SvREFCNT_inc (coro));
		915	UNLOCK;
		916	}
		917
		918	static void
		919	api_schedule (void)
		920	{
		921	dTHX;
		922
		923	SV *prev, *next;
		924	SV *current = GvSV (coro_current);
		925
		926	for (;;)
		927	{
		928	LOCK;
		929
		930	next = coro_deq (aTHX_ PRIO_MIN);
		931
		932	if (next)
		933	break;
		934
		935	UNLOCK;
		936
		937	{
		938	dSP;
		939
		940	ENTER;
		941	SAVETMPS;
		942
		943	PUSHMARK (SP);
		944	PUTBACK;
		945	call_sv (GvSV (coro_idle), G_DISCARD);
		946
		947	FREETMPS;
		948	LEAVE;
		949	}
		950	}
		951
		952	prev = SvRV (current);
		953	SvRV (current) = next;
		954
		955	/* free this only after the transfer */
		956	coro_mortal = prev;
		957
		958	UNLOCK;
		959
		960	coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		961	TRANSFER_SAVE_ALL | TRANSFER_LAZY_STACK);
		962	}
		963
		964	static void
		965	api_cede (void)
		966	{
		967	dTHX;
		968
		969	LOCK;
		970	coro_enq (aTHX_ SvREFCNT_inc (SvRV (GvSV (coro_current))));
		971	UNLOCK;
		972
		973	api_schedule ();
		974	}
385		975
386	MODULE = Coro::State PACKAGE = Coro::State	976	MODULE = Coro::State PACKAGE = Coro::State
387		977
388	PROTOTYPES: ENABLE	978	PROTOTYPES: DISABLE
389		979
390	BOOT:	980	BOOT:
391	if (!padlist_cache)	981	{
392	padlist_cache = newHV ();	982	#ifdef USE_ITHREADS
		983	MUTEX_INIT (&coro_mutex);
		984	#endif
		985	BOOT_PAGESIZE;
393		986
394	Coro::State	987	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
395	_newprocess(args)	988
396	SV * args	989	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
397	PROTOTYPE: $	990	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		991	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		992	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		993
		994	main_mainstack = PL_mainstack;
		995
		996	coroapi.ver = CORO_API_VERSION;
		997	coroapi.transfer = api_transfer;
		998
		999	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1000	}
		1001
		1002	SV *
		1003	new (char *klass, ...)
398	CODE:	1004	CODE:
399	Coro__State coro;	1005	{
		1006	struct coro *coro;
		1007	HV *hv;
		1008	int i;
400		1009
401	if (!SvROK (args) || SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");
403
404	New (0, coro, 1, struct coro);	1010	Newz (0, coro, 1, struct coro);
		1011	coro->args = newAV ();
405		1012
		1013	for (i = 1; i < items; i++)
		1014	av_push (coro->args, newSVsv (ST (i)));
		1015
406	coro->mainstack = 0; /* actual work is done inside transfer */	1016	/*coro->mainstack = 0; *//*actual work is done inside transfer */
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1017	/*coro->stack = 0;*/
408		1018
409	RETVAL = coro;	1019	hv = newHV ();
		1020	sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
		1021	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		1022	}
410	OUTPUT:	1023	OUTPUT:
411	RETVAL	1024	RETVAL
412		1025
413	void	1026	void
414	transfer(prev,next)	1027	transfer(prev, next, flags)
415	Coro::State_or_hashref prev	1028	SV *prev
416	Coro::State_or_hashref next	1029	SV *next
		1030	int flags
417	CODE:	1031	CODE:
		1032	PUTBACK;
		1033	coro_state_transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
		1034	SPAGAIN;
418		1035
419	if (prev != next)	1036	int
		1037	prio (Coro::State coro, int newprio = 0)
		1038	ALIAS:
		1039	nice = 1
		1040	CODE:
		1041	{
		1042	RETVAL = coro->prio;
		1043
		1044	if (items > 1)
420	{	1045	{
421	/*	1046	if (ix)
422	* this could be done in newprocess which would lead to	1047	newprio += coro->prio;
423	* extremely elegant and fast (just SAVE/LOAD)
424	* code here, but lazy allocation of stacks has also
425	* some virtues and the overhead of the if() is nil.
426	*/
427	if (next->mainstack)
428	{
429	SAVE (prev);
430	LOAD (next);
431	/* mark this state as in-use */
432	next->mainstack = 0;
433	next->tmps_ix = -2;
434	}
435	else if (next->tmps_ix == -2)
436	{
437	croak ("tried to transfer to running coroutine");
438	}
439	else
440	{
441	SAVE (prev);
442		1048
443	/*	1049	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
444	* emulate part of the perl startup here.	1050	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
445	*/
446	UNOP myop;
447		1051
448	init_stacks (); /* from perl.c */	1052	coro->prio = newprio;
449	PL_op = (OP *)&myop;
450	/*PL_curcop = 0;*/
451	GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
452
453	SPAGAIN;
454	Zero(&myop, 1, UNOP);
455	myop.op_next = Nullop;
456	myop.op_flags = OPf_WANT_VOID;
457
458	PUSHMARK(SP);
459	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	PUTBACK;
461	/*
462	* the next line is slightly wrong, as PL_op->op_next
463	* is actually being executed so we skip the first op.
464	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...
466	*/
467	PL_op = Perl_pp_entersub(aTHX);
468	SPAGAIN;
469
470	ENTER;
471	}
472	}	1053	}
		1054	}
473		1055
474	void	1056	void
475	DESTROY(coro)	1057	_clone_state_from (SV *dst, SV *src)
476	Coro::State coro	1058	CODE:
		1059	{
		1060	struct coro *coro_src = SvSTATE (src);
		1061
		1062	sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
		1063
		1064	++coro_src->refcnt;
		1065	sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
		1066	}
		1067
		1068	void
		1069	_exit (code)
		1070	int code
		1071	PROTOTYPE: $
		1072	CODE:
		1073	_exit (code);
		1074
		1075	MODULE = Coro::State PACKAGE = Coro::Cont
		1076
		1077	void
		1078	yield (...)
		1079	PROTOTYPE: @
477	CODE:	1080	CODE:
		1081	{
		1082	SV *yieldstack;
		1083	SV *sv;
		1084	AV *defav = GvAV (PL_defgv);
		1085	struct coro *prev, *next;
478		1086
479	if (coro->mainstack)	1087	yieldstack = *hv_fetch (
		1088	(HV *)SvRV (GvSV (coro_current)),
		1089	"yieldstack", sizeof ("yieldstack") - 1,
		1090	0
		1091	);
		1092
		1093	/* set up @_ -- ugly */
		1094	av_clear (defav);
		1095	av_fill (defav, items - 1);
		1096	while (items--)
		1097	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1098
		1099	sv = av_pop ((AV *)SvRV (yieldstack));
		1100	prev = SvSTATE (*av_fetch ((AV *)SvRV (sv), 0, 0));
		1101	next = SvSTATE (*av_fetch ((AV *)SvRV (sv), 1, 0));
		1102	SvREFCNT_dec (sv);
		1103
		1104	coro_state_transfer (aTHX_ prev, next, 0);
		1105	}
		1106
		1107	MODULE = Coro::State PACKAGE = Coro
		1108
		1109	BOOT:
		1110	{
		1111	int i;
		1112
		1113	coro_stash = gv_stashpv ("Coro", TRUE);
		1114
		1115	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1116	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1117	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1118	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1119	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1120	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1121
		1122	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1123	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1124
		1125	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1126	coro_ready[i] = newAV ();
		1127
480	{	1128	{
481	struct coro temp;	1129	SV *sv = perl_get_sv("Coro::API", 1);
482		1130
483	SAVE(aTHX_ (&temp));	1131	coroapi.schedule = api_schedule;
484	LOAD(aTHX_ coro);	1132	coroapi.cede = api_cede;
		1133	coroapi.ready = api_ready;
		1134	coroapi.nready = &coro_nready;
		1135	coroapi.current = coro_current;
485		1136
486	destroy_stacks ();	1137	GCoroAPI = &coroapi;
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));	1138	sv_setiv (sv, (IV)&coroapi);
488		1139	SvREADONLY_on (sv);
489	LOAD((&temp));
490	}	1140	}
		1141	}
491		1142
492	SvREFCNT_dec (coro->args);	1143	#if !PERL_MICRO
493	Safefree (coro);
494		1144
		1145	void
		1146	ready (self)
		1147	SV * self
		1148	PROTOTYPE: $
		1149	CODE:
		1150	api_ready (self);
495		1151
		1152	#endif
		1153
		1154	int
		1155	nready (...)
		1156	PROTOTYPE:
		1157	CODE:
		1158	RETVAL = coro_nready;
		1159	OUTPUT:
		1160	RETVAL
		1161
		1162	void
		1163	schedule (...)
		1164	PROTOTYPE:
		1165	CODE:
		1166	api_schedule ();
		1167
		1168	void
		1169	cede (...)
		1170	PROTOTYPE:
		1171	CODE:
		1172	api_cede ();
		1173
		1174	# and these are hacks
		1175	SV *
		1176	_aio_get_state ()
		1177	CODE:
		1178	{
		1179	struct {
		1180	int errorno;
		1181	int laststype;
		1182	int laststatval;
		1183	Stat_t statcache;
		1184	} data;
		1185
		1186	data.errorno = errno;
		1187	data.laststype = PL_laststype;
		1188	data.laststatval = PL_laststatval;
		1189	data.statcache = PL_statcache;
		1190
		1191	RETVAL = newSVpvn ((char *)&data, sizeof data);
		1192	}
		1193	OUTPUT:
		1194	RETVAL
		1195
		1196	void
		1197	_aio_set_state (char *data_)
		1198	PROTOTYPE: $
		1199	CODE:
		1200	{
		1201	struct {
		1202	int errorno;
		1203	int laststype;
		1204	int laststatval;
		1205	Stat_t statcache;
		1206	} *data = (void *)data_;
		1207
		1208	errno = data->errorno;
		1209	PL_laststype = data->laststype;
		1210	PL_laststatval = data->laststatval;
		1211	PL_statcache = data->statcache;
		1212	}

Diff Legend

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