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

Diff Legend

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