ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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