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

Diff Legend

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