ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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