ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.99 by root, Sun Nov 26 23:53:20 2006 UTC

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

Diff Legend

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