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.123 by root, Mon Dec 4 21:56:00 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	#ifdef USE_ITHREADS
		96	static perl_mutex coro_mutex;
		97	# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
		98	# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
		99	#else
		100	# define LOCK (void)0
		101	# define UNLOCK (void)0
		102	#endif
		103
		104	struct io_state
		105	{
		106	int errorno;
		107	I32 laststype;
		108	int laststatval;
		109	Stat_t statcache;
		110	};
		111
		112	static struct CoroAPI coroapi;
		113	static AV *main_mainstack; /* used to differentiate between $main and others */
		114	static HV *coro_state_stash, *coro_stash;
		115	static SV *coro_mortal; /* will be freed after next transfer */
		116
		117	static struct coro_cctx *cctx_first;
		118	static int cctx_count, cctx_idle;
		119
		120	/* this is a structure representing a c-level coroutine */
		121	typedef struct coro_cctx {
		122	struct coro_cctx *next;
		123
		124	/* the stack */
		125	void *sptr;
		126	long ssize; /* positive == mmap, otherwise malloc */
		127
		128	/* cpu state */
		129	void *idle_sp; /* sp of top-level transfer/schedule/cede call */
		130	JMPENV *top_env;
		131	coro_context cctx;
		132
		133	int inuse;
		134
		135	#if USE_VALGRIND
		136	int valgrind_id;
		137	#endif
		138	} coro_cctx;
		139
		140	enum {
		141	CF_RUNNING = 0x0001, /* coroutine is running */
		142	CF_READY = 0x0002, /* coroutine is ready */
		143	CF_NEW = 0x0004, /* ahs never been switched to */
		144	};
		145
		146	/* this is a structure representing a perl-level coroutine */
11	struct coro {	147	struct coro {
12	U8 dowarn;	148	/* the c coroutine allocated to this perl coroutine, if any */
13	AV *defav;	149	coro_cctx *cctx;
		150
		151	/* data associated with this coroutine (initial args) */
		152	AV *args;
		153	int refcnt;
		154	int save; /* CORO_SAVE flags */
		155	int flags; /* CF_ flags */
		156
		157	/* optionally saved, might be zero */
		158	AV *defav; /* @_ */
		159	SV *defsv; /* $_ */
		160	SV *errsv; /* $@ */
		161	SV *irssv; /* $/ */
		162	SV *irssv_sv; /* real $/ cache */
14		163
15	PERL_SI *curstackinfo;	164	#define VAR(name,type) type name;
16	AV *curstack;	165	# include "state.h"
17	AV *mainstack;	166	#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		167
41	AV *args;	168	/* coro process data */
		169	int prio;
42	};	170	};
43		171
44	typedef struct coro *Coro__State;	172	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	173	typedef struct coro *Coro__State_or_hashref;
46		174
47	static HV *padlist_cache;	175	static AV *
48		176	coro_clone_padlist (CV *cv)
49	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *
51	clone_padlist (AV *protopadlist)
52	{	177	{
53	AV *av;	178	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;	179	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		180
72	newpadlist = newAV ();	181	newpadlist = newAV ();
73	AvREAL_off (newpadlist);	182	AvREAL_off (newpadlist);
74	av_store (newpadlist, 0, (SV *) newpad_name);	183	#if PERL_VERSION_ATLEAST (5,9,0)
		184	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
		185	#else
		186	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
		187	#endif
		188	newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
		189	--AvFILLp (padlist);
		190
		191	av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75	av_store (newpadlist, 1, (SV *) newpad);	192	av_store (newpadlist, 1, (SV *)newpad);
76		193
77	av = newAV (); /* will be @_ */	194	return newpadlist;
78	av_extend (av, 0);	195	}
79	av_store (newpad, 0, (SV *) av);
80	AvFLAGS (av) = AVf_REIFY;
81		196
82	for (ix = fpad; ix > 0; ix--)	197	static void
		198	free_padlist (AV *padlist)
		199	{
		200	/* may be during global destruction */
		201	if (SvREFCNT (padlist))
83	{	202	{
84	SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;	203	I32 i = AvFILLp (padlist);
85	if (namesv && namesv != &PL_sv_undef)	204	while (i >= 0)
86	{	205	{
87	char *name = SvPVX (namesv); /* XXX */	206	SV **svp = av_fetch (padlist, i--, FALSE);
88	if (SvFLAGS (namesv) & SVf_FAKE || *name == '&')	207	if (svp)
89	{ /* lexical from outside? */
90	npad[ix] = SvREFCNT_inc (ppad[ix]);
91	}	208	{
92	else
93	{ /* our own lexical */
94	SV *sv;	209	SV *sv;
95	if (*name == '&')	210	while (&PL_sv_undef != (sv = av_pop ((AV *)*svp)))
96	sv = SvREFCNT_inc (ppad[ix]);	211	SvREFCNT_dec (sv);
97	else if (*name == '@')	212
98	sv = (SV *) newAV ();	213	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	}	214	}
107	}	215	}
108	else if (IS_PADGV (ppad[ix]) || IS_PADCONST (ppad[ix]))	216
109	{	217	SvREFCNT_dec ((SV*)padlist);
110	npad[ix] = SvREFCNT_inc (ppad[ix]);	218	}
111	}	219	}
		220
		221	static int
		222	coro_cv_free (pTHX_ SV *sv, MAGIC *mg)
		223	{
		224	AV *padlist;
		225	AV *av = (AV *)mg->mg_obj;
		226
		227	/* casting is fun. */
		228	while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
		229	free_padlist (padlist);
		230
		231	SvREFCNT_dec (av);
		232
		233	return 0;
		234	}
		235
		236	#define PERL_MAGIC_coro PERL_MAGIC_ext
		237
		238	static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
		239
		240	#define CORO_MAGIC(cv) \
		241	SvMAGIC (cv) \
		242	? SvMAGIC (cv)->mg_type == PERL_MAGIC_coro \
		243	? SvMAGIC (cv) \
		244	: mg_find ((SV *)cv, PERL_MAGIC_coro) \
		245	: 0
		246
		247	/* the next two functions merely cache the padlists */
		248	static void
		249	get_padlist (CV *cv)
		250	{
		251	MAGIC *mg = CORO_MAGIC (cv);
		252	AV *av;
		253
		254	if (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)
		255	CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
		256	else
		257	{
		258	#if 0
		259	/* this is probably cleaner, but also slower? */
		260	CV *cp = Perl_cv_clone (cv);
		261	CvPADLIST (cv) = CvPADLIST (cp);
		262	CvPADLIST (cp) = 0;
		263	SvREFCNT_dec (cp);
		264	#else
		265	CvPADLIST (cv) = coro_clone_padlist (cv);
		266	#endif
		267	}
		268	}
		269
		270	static void
		271	put_padlist (CV *cv)
		272	{
		273	MAGIC *mg = CORO_MAGIC (cv);
		274	AV *av;
		275
		276	if (!mg)
		277	{
		278	sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
		279	mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
		280	mg->mg_virtual = &vtbl_coro;
		281	mg->mg_obj = (SV *)newAV ();
		282	}
		283
		284	av = (AV *)mg->mg_obj;
		285
		286	if (AvFILLp (av) >= AvMAX (av))
		287	av_extend (av, AvMAX (av) + 1);
		288
		289	AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
		290	}
		291
		292	#define SB do {
		293	#define SE } while (0)
		294
		295	#define REPLACE_SV(sv,val) SB SvREFCNT_dec (sv); (sv) = (val); (val) = 0; SE
		296
		297	static void
		298	load_perl (Coro__State c)
		299	{
		300	#define VAR(name,type) PL_ ## name = c->name;
		301	# include "state.h"
		302	#undef VAR
		303
		304	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		305	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		306	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		307	if (c->irssv)
		308	{
		309	if (c->irssv == PL_rs || sv_eq (PL_rs, c->irssv))
		310	SvREFCNT_dec (c->irssv);
112	else	311	else
113	{	312	{
114	SV *sv = NEWSV (0, 0);	313	REPLACE_SV (PL_rs, c->irssv);
115	SvPADTMP_on (sv);	314	if (!c->irssv_sv) c->irssv_sv = get_sv ("/", 0);
116	npad[ix] = sv;	315	sv_setsv (c->irssv_sv, PL_rs);
117	}	316	}
118	}	317	}
119		318
120	#if 0 /* NONOTUNDERSTOOD */	319	{
121	/* Now that vars are all in place, clone nested closures. */	320	dSP;
		321	CV *cv;
122		322
123	for (ix = fpad; ix > 0; ix--) {	323	/* now do the ugly restore mess */
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	324	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	{	325	{
131	CV *kid = cv_clone((CV*)ppad[ix]);	326	put_padlist (cv); /* mark this padlist as available */
132	SvREFCNT_dec(ppad[ix]);	327	CvDEPTH (cv) = PTR2IV (POPs);
133	CvCLONE_on(kid);	328	CvPADLIST (cv) = (AV *)POPs;
134	SvPADMY_on(kid);
135	npad[ix] = (SV*)kid;
136	}	329	}
137	}
138	#endif
139		330
140	return newpadlist;	331	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	}	332	}
160	}	333	}
161		334
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	335	static void
189	SAVE(pTHX_ Coro__State c)	336	save_perl (Coro__State c)
190	{	337	{
191	{	338	{
192	dSP;	339	dSP;
193	I32 cxix = cxstack_ix;	340	I32 cxix = cxstack_ix;
		341	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	342	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		343
197	/*	344	/*
198	* the worst thing you can imagine happens first - we have to save	345	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	346	* (and reinitialize) all cv's in the whole callchain :(
200	*/	347	*/
…		…
205	{	352	{
206	while (cxix >= 0)	353	while (cxix >= 0)
207	{	354	{
208	PERL_CONTEXT *cx = &ccstk[cxix--];	355	PERL_CONTEXT *cx = &ccstk[cxix--];
209		356
210	if (CxTYPE(cx) == CXt_SUB)	357	if (CxTYPE (cx) == CXt_SUB)
211	{	358	{
212	CV *cv = cx->blk_sub.cv;	359	CV *cv = cx->blk_sub.cv;
		360
213	if (CvDEPTH(cv))	361	if (CvDEPTH (cv))
214	{	362	{
215	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));
217	#endif
218	EXTEND (SP, 3);	363	EXTEND (SP, 3);
219	PUSHs ((SV *)CvDEPTH(cv));	364
220	PUSHs ((SV *)CvPADLIST(cv));	365	PUSHs ((SV *)CvPADLIST (cv));
		366	PUSHs (INT2PTR (SV *, CvDEPTH (cv)));
221	PUSHs ((SV *)cv);	367	PUSHs ((SV *)cv);
222		368
		369	CvDEPTH (cv) = 0;
223	get_padlist (cv);	370	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	}	371	}
233	}	372	}
		373	#ifdef CXt_FORMAT
234	else if (CxTYPE(cx) == CXt_FORMAT)	374	else if (CxTYPE (cx) == CXt_FORMAT)
235	{	375	{
236	/* I never used formats, so how should I know how these are implemented? */	376	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */	377	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	378	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}	379	}
		380	#endif
240	}	381	}
241		382
242	if (top_si->si_type == PERLSI_MAIN)	383	if (top_si->si_type == PERLSI_MAIN)
243	break;	384	break;
244		385
…		…
248	}	389	}
249		390
250	PUTBACK;	391	PUTBACK;
251	}	392	}
252		393
253	c->dowarn = PL_dowarn;	394	c->defav = c->save & CORO_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
254	c->defav = GvAV (PL_defgv);	395	c->defsv = c->save & CORO_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
255	c->curstackinfo = PL_curstackinfo;	396	c->errsv = c->save & CORO_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
256	c->curstack = PL_curstack;	397	c->irssv = c->save & CORO_SAVE_IRSSV ? SvREFCNT_inc (PL_rs) : 0;
257	c->mainstack = PL_mainstack;	398
258	c->stack_sp = PL_stack_sp;	399	#define VAR(name,type)c->name = PL_ ## name;
259	c->op = PL_op;	400	# include "state.h"
260	c->curpad = PL_curpad;	401	#undef VAR
		402	}
		403
		404	/*
		405	* allocate various perl stacks. This is an exact copy
		406	* of perl.c:init_stacks, except that it uses less memory
		407	* on the (sometimes correct) assumption that coroutines do
		408	* not usually need a lot of stackspace.
		409	*/
		410	static void
		411	coro_init_stacks ()
		412	{
		413	PL_curstackinfo = new_stackinfo(128, 1024/sizeof(PERL_CONTEXT));
		414	PL_curstackinfo->si_type = PERLSI_MAIN;
		415	PL_curstack = PL_curstackinfo->si_stack;
		416	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		417
		418	PL_stack_base = AvARRAY(PL_curstack);
261	c->stack_base = PL_stack_base;	419	PL_stack_sp = PL_stack_base;
262	c->stack_max = PL_stack_max;	420	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		421
282	static void	422	New(50,PL_tmps_stack,128,SV*);
283	LOAD(pTHX_ Coro__State c)	423	PL_tmps_floor = -1;
284	{	424	PL_tmps_ix = -1;
285	PL_dowarn = c->dowarn;	425	PL_tmps_max = 128;
286	GvAV (PL_defgv) = c->defav;	426
287	PL_curstackinfo = c->curstackinfo;	427	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;	428	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	429	PL_markstack_max = PL_markstack + 32;
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		430
313	{	431	#ifdef SET_MARK_OFFSET
314	dSP;	432	SET_MARK_OFFSET;
315	CV *cv;	433	#endif
316		434
317	/* now do the ugly restore mess */	435	New(54,PL_scopestack,32,I32);
318	while ((cv = (CV *)POPs))	436	PL_scopestack_ix = 0;
		437	PL_scopestack_max = 32;
		438
		439	New(54,PL_savestack,64,ANY);
		440	PL_savestack_ix = 0;
		441	PL_savestack_max = 64;
		442
		443	#if !PERL_VERSION_ATLEAST (5,9,0)
		444	New(54,PL_retstack,16,OP*);
		445	PL_retstack_ix = 0;
		446	PL_retstack_max = 16;
		447	#endif
		448	}
		449
		450	/*
		451	* destroy the stacks, the callchain etc...
		452	*/
		453	static void
		454	coro_destroy_stacks ()
		455	{
		456	if (!IN_DESTRUCT)
319	{	457	{
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	/* die does this while calling POPSTACK, but I just don't see why. */
341	dounwind(-1);
342
343	/* is this ugly, I ask? */	458	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)	459	LEAVE_SCOPE (0);
345	LEAVE;	460
		461	/* sure it is, but more important: is it correct?? :/ */
		462	FREETMPS;
		463
		464	/*POPSTACK_TO (PL_mainstack);*//*D*//*use*/
		465	}
346		466
347	while (PL_curstackinfo->si_next)	467	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;	468	PL_curstackinfo = PL_curstackinfo->si_next;
349		469
350	while (PL_curstackinfo)	470	while (PL_curstackinfo)
351	{	471	{
352	PERL_SI *p = PL_curstackinfo->si_prev;	472	PERL_SI *p = PL_curstackinfo->si_prev;
353		473
		474	{ /*D*//*remove*/
		475	dSP;
		476	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		477	PUTBACK; /* possibly superfluous */
		478	}
		479
		480	if (!IN_DESTRUCT)
		481	{
		482	dounwind (-1);/*D*//*remove*/
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	483	SvREFCNT_dec (PL_curstackinfo->si_stack);
		484	}
		485
355	Safefree(PL_curstackinfo->si_cxstack);	486	Safefree (PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);	487	Safefree (PL_curstackinfo);
357	PL_curstackinfo = p;	488	PL_curstackinfo = p;
358	}	489	}
359		490
360	if (PL_scopestack_ix != 0)	491	Safefree (PL_tmps_stack);
361	Perl_warner(aTHX_ WARN_INTERNAL,	492	Safefree (PL_markstack);
362	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	493	Safefree (PL_scopestack);
363	(long)PL_scopestack_ix);	494	Safefree (PL_savestack);
364	if (PL_savestack_ix != 0)	495	#if !PERL_VERSION_ATLEAST (5,9,0)
365	Perl_warner(aTHX_ WARN_INTERNAL,	496	Safefree (PL_retstack);
366	"Unbalanced saves: %ld more saves than restores\n",	497	#endif
367	(long)PL_savestack_ix);	498	}
368	if (PL_tmps_floor != -1)	499
369	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	500	static void
370	(long)PL_tmps_floor + 1);	501	setup_coro (struct coro *coro)
		502	{
371	/*	503	/*
372	*/	504	* emulate part of the perl startup here.
373	Safefree(PL_tmps_stack);	505	*/
374	Safefree(PL_markstack);
375	Safefree(PL_scopestack);
376	Safefree(PL_savestack);
377	Safefree(PL_retstack);
378	}
379		506
380	#define SUB_INIT "Coro::State::_newcoro"	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;
		515
		516	{
		517	dSP;
		518	LOGOP myop;
		519
		520	SvREFCNT_dec (GvAV (PL_defgv));
		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	New (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	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		710	else if (prev != next)
		711	{
		712	coro_cctx *prev__cctx;
		713
		714	if (prev->flags & CF_NEW)
		715	{
		716	/* create a new empty context */
		717	Newz (0, prev->cctx, 1, coro_cctx);
		718	prev->cctx->inuse = 1;
		719	prev->flags &= ~CF_NEW;
		720	prev->flags |= CF_RUNNING;
		721	}
		722
		723	/*TODO: must not croak here */
		724	if (!prev->flags & CF_RUNNING)
		725	croak ("Coro::State::transfer called with non-running prev Coro::State, but can only transfer from running states");
		726
		727	if (next->flags & CF_RUNNING)
		728	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		729
		730	prev->flags &= ~CF_RUNNING;
		731	next->flags |= CF_RUNNING;
		732
		733	LOCK;
		734
		735	if (next->flags & CF_NEW)
		736	{
		737	/* need to start coroutine */
		738	next->flags &= ~CF_NEW;
		739	/* first get rid of the old state */
		740	save_perl (prev);
		741	/* setup coroutine call */
		742	setup_coro (next);
		743	/* need a new stack */
		744	assert (!next->stack);
		745	}
		746	else
		747	{
		748	/* coroutine already started */
		749	save_perl (prev);
		750	load_perl (next);
		751	}
		752
		753	prev__cctx = prev->cctx;
		754
		755	/* possibly "free" the cctx */
		756	if (prev__cctx->idle_sp == STACKLEVEL)
		757	{
		758	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		759	assert (PL_top_env == prev__cctx->top_env);
		760
		761	prev->cctx = 0;
		762
		763	cctx_put (prev__cctx);
		764	prev__cctx->inuse = 0;
		765	}
		766
		767	if (!next->cctx)
		768	{
		769	next->cctx = cctx_get ();
		770	assert (!next->cctx->inuse);
		771	next->cctx->inuse = 1;
		772	}
		773
		774	if (prev__cctx != next->cctx)
		775	{
		776	prev__cctx->top_env = PL_top_env;
		777	PL_top_env = next->cctx->top_env;
		778	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		779	}
		780
		781	free_coro_mortal ();
		782
		783	UNLOCK;
		784	}
		785	}
		786
		787	struct transfer_args
		788	{
		789	struct coro *prev, *next;
		790	};
		791
		792	#define TRANSFER(ta) transfer ((ta).prev, (ta).next)
		793
		794	static void
		795	coro_state_destroy (struct coro *coro)
		796	{
		797	if (coro->refcnt--)
		798	return;
		799
		800	if (coro->mainstack && coro->mainstack != main_mainstack)
		801	{
		802	struct coro temp;
		803	Zero (&temp, 1, struct coro);
		804	temp.save = CORO_SAVE_ALL;
		805
		806	if (coro->flags & CF_RUNNING)
		807	croak ("FATAL: tried to destroy currently running coroutine");
		808
		809	save_perl (&temp);
		810	load_perl (coro);
		811
		812	coro_destroy_stacks ();
		813
		814	load_perl (&temp); /* this will get rid of defsv etc.. */
		815
		816	coro->mainstack = 0;
		817	}
		818
		819	cctx_destroy (coro->cctx);
		820	SvREFCNT_dec (coro->args);
		821	Safefree (coro);
		822	}
		823
		824	static int
		825	coro_state_clear (pTHX_ SV *sv, MAGIC *mg)
		826	{
		827	struct coro *coro = (struct coro *)mg->mg_ptr;
		828	mg->mg_ptr = 0;
		829
		830	coro_state_destroy (coro);
		831
		832	return 0;
		833	}
		834
		835	static int
		836	coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
		837	{
		838	struct coro *coro = (struct coro *)mg->mg_ptr;
		839
		840	++coro->refcnt;
		841
		842	return 0;
		843	}
		844
		845	static MGVTBL coro_state_vtbl = {
		846	0, 0, 0, 0,
		847	coro_state_clear,
		848	0,
		849	#ifdef MGf_DUP
		850	coro_state_dup,
		851	#else
		852	# define MGf_DUP 0
		853	#endif
		854	};
		855
		856	static struct coro *
		857	SvSTATE (SV *coro)
		858	{
		859	HV *stash;
		860	MAGIC *mg;
		861
		862	if (SvROK (coro))
		863	coro = SvRV (coro);
		864
		865	stash = SvSTASH (coro);
		866	if (stash != coro_stash && stash != coro_state_stash)
		867	{
		868	/* very slow, but rare, check */
		869	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		870	croak ("Coro::State object required");
		871	}
		872
		873	mg = SvMAGIC (coro);
		874	assert (mg->mg_type == PERL_MAGIC_ext);
		875	return (struct coro *)mg->mg_ptr;
		876	}
		877
		878	static void
		879	prepare_transfer (struct transfer_args *ta, SV *prev_sv, SV *next_sv)
		880	{
		881	ta->prev = SvSTATE (prev_sv);
		882	ta->next = SvSTATE (next_sv);
		883	}
		884
		885	static void
		886	api_transfer (SV *prev_sv, SV *next_sv)
		887	{
		888	struct transfer_args ta;
		889
		890	prepare_transfer (&ta, prev_sv, next_sv);
		891	TRANSFER (ta);
		892	}
		893
		894	static int
		895	api_save (SV *coro_sv, int new_save)
		896	{
		897	struct coro *coro = SvSTATE (coro_sv);
		898	int old_save = coro->save;
		899
		900	if (new_save >= 0)
		901	coro->save = new_save;
		902
		903	return old_save;
		904	}
		905
		906	/** Coro ********************************************************************/
		907
		908	#define PRIO_MAX 3
		909	#define PRIO_HIGH 1
		910	#define PRIO_NORMAL 0
		911	#define PRIO_LOW -1
		912	#define PRIO_IDLE -3
		913	#define PRIO_MIN -4
		914
		915	/* for Coro.pm */
		916	static SV *coro_current;
		917	static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
		918	static int coro_nready;
		919
		920	static void
		921	coro_enq (SV *coro_sv)
		922	{
		923	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		924	coro_nready++;
		925	}
		926
		927	static SV *
		928	coro_deq (int min_prio)
		929	{
		930	int prio = PRIO_MAX - PRIO_MIN;
		931
		932	min_prio -= PRIO_MIN;
		933	if (min_prio < 0)
		934	min_prio = 0;
		935
		936	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		937	if (AvFILLp (coro_ready [prio]) >= 0)
		938	{
		939	coro_nready--;
		940	return av_shift (coro_ready [prio]);
		941	}
		942
		943	return 0;
		944	}
		945
		946	static int
		947	api_ready (SV *coro_sv)
		948	{
		949	struct coro *coro;
		950
		951	if (SvROK (coro_sv))
		952	coro_sv = SvRV (coro_sv);
		953
		954	coro = SvSTATE (coro_sv);
		955
		956	if (coro->flags & CF_READY)
		957	return 0;
		958
		959	#if 0 /* this is actually harmless */
		960	if (coro->flags & CF_RUNNING)
		961	croak ("Coro::ready called on currently running coroutine");
		962	#endif
		963
		964	coro->flags |= CF_READY;
		965
		966	LOCK;
		967	coro_enq (SvREFCNT_inc (coro_sv));
		968	UNLOCK;
		969
		970	return 1;
		971	}
		972
		973	static int
		974	api_is_ready (SV *coro_sv)
		975	{
		976	return !!SvSTATE (coro_sv)->flags & CF_READY;
		977	}
		978
		979	static void
		980	prepare_schedule (struct transfer_args *ta)
		981	{
		982	SV *prev, *next;
		983
		984	for (;;)
		985	{
		986	LOCK;
		987	next = coro_deq (PRIO_MIN);
		988	UNLOCK;
		989
		990	if (next)
		991	break;
		992
		993	{
		994	dSP;
		995
		996	ENTER;
		997	SAVETMPS;
		998
		999	PUSHMARK (SP);
		1000	PUTBACK;
		1001	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1002
		1003	FREETMPS;
		1004	LEAVE;
		1005	}
		1006	}
		1007
		1008	prev = SvRV (coro_current);
		1009	SvRV_set (coro_current, next);
		1010
		1011	/* free this only after the transfer */
		1012	LOCK;
		1013	free_coro_mortal ();
		1014	UNLOCK;
		1015	coro_mortal = prev;
		1016
		1017	assert (!SvROK(prev));//D
		1018	assert (!SvROK(next));//D
		1019
		1020	ta->prev = SvSTATE (prev);
		1021	ta->next = SvSTATE (next);
		1022
		1023	assert (ta->next->flags & CF_READY);
		1024	ta->next->flags &= ~CF_READY;
		1025	}
		1026
		1027	static void
		1028	prepare_cede (struct transfer_args *ta)
		1029	{
		1030	api_ready (coro_current);
		1031
		1032	prepare_schedule (ta);
		1033	}
		1034
		1035	static void
		1036	api_schedule (void)
		1037	{
		1038	struct transfer_args ta;
		1039
		1040	prepare_schedule (&ta);
		1041	TRANSFER (ta);
		1042	}
		1043
		1044	static void
		1045	api_cede (void)
		1046	{
		1047	struct transfer_args ta;
		1048
		1049	prepare_cede (&ta);
		1050	TRANSFER (ta);
		1051	}
381		1052
382	MODULE = Coro::State PACKAGE = Coro::State	1053	MODULE = Coro::State PACKAGE = Coro::State
383		1054
384	PROTOTYPES: ENABLE	1055	PROTOTYPES: DISABLE
385		1056
386	BOOT:	1057	BOOT:
387	if (!padlist_cache)	1058	{
388	padlist_cache = newHV ();	1059	#ifdef USE_ITHREADS
		1060	MUTEX_INIT (&coro_mutex);
		1061	#endif
		1062	BOOT_PAGESIZE;
389		1063
390	Coro::State	1064	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
391	_newprocess(args)	1065
392	SV * args	1066	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (CORO_SAVE_DEFAV));
393	PROTOTYPE: $	1067	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (CORO_SAVE_DEFSV));
		1068	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (CORO_SAVE_ERRSV));
		1069	newCONSTSUB (coro_state_stash, "SAVE_IRSSV", newSViv (CORO_SAVE_IRSSV));
		1070	newCONSTSUB (coro_state_stash, "SAVE_ALL", newSViv (CORO_SAVE_ALL));
		1071
		1072	main_mainstack = PL_mainstack;
		1073
		1074	coroapi.ver = CORO_API_VERSION;
		1075	coroapi.transfer = api_transfer;
		1076
		1077	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1078	}
		1079
		1080	SV *
		1081	new (char *klass, ...)
394	CODE:	1082	CODE:
395	Coro__State coro;	1083	{
		1084	struct coro *coro;
		1085	HV *hv;
		1086	int i;
396		1087
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);	1088	Newz (0, coro, 1, struct coro);
		1089	coro->args = newAV ();
		1090	coro->save = CORO_SAVE_ALL;
		1091	coro->flags = CF_NEW;
401		1092
402	coro->mainstack = 0; /* actual work is done inside transfer */	1093	hv = newHV ();
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1094	sv_magicext ((SV *)hv, 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro, 0)->mg_flags |= MGf_DUP;
		1095	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
404		1096
405	RETVAL = coro;	1097	for (i = 1; i < items; i++)
		1098	av_push (coro->args, newSVsv (ST (i)));
		1099	}
406	OUTPUT:	1100	OUTPUT:
407	RETVAL	1101	RETVAL
408		1102
		1103	int
		1104	save (SV *coro, int new_save = -1)
		1105	CODE:
		1106	RETVAL = api_save (coro, new_save);
		1107	OUTPUT:
		1108	RETVAL
		1109
409	void	1110	void
410	transfer(prev,next)	1111	_set_stacklevel (...)
411	Coro::State_or_hashref prev	1112	ALIAS:
412	Coro::State_or_hashref next	1113	Coro::State::transfer = 1
		1114	Coro::schedule = 2
		1115	Coro::cede = 3
413	CODE:	1116	CODE:
		1117	{
		1118	struct transfer_args ta;
414		1119
415	if (prev != next)	1120	switch (ix)
416	{	1121	{
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	1122	case 0:
		1123	ta.prev = (struct coro *)INT2PTR (coro_cctx *, SvIV (ST (0)));
		1124	ta.next = 0;
433	{	1125	break;
434	/*
435	* emulate part of the perl startup here.
436	*/
437	UNOP myop;
438		1126
439	init_stacks (); /* from perl.c */	1127	case 1:
440	PL_op = (OP *)&myop;	1128	if (items != 2)
441	/*PL_curcop = 0;*/	1129	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
442	GvAV (PL_defgv) = (AV *)SvREFCNT_inc ((SV *)next->args);
443		1130
444	SPAGAIN;	1131	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	}	1132	break;
		1133
		1134	case 2:
		1135	prepare_schedule (&ta);
		1136	break;
		1137
		1138	case 3:
		1139	prepare_cede (&ta);
		1140	break;
463	}	1141	}
464		1142
		1143	TRANSFER (ta);
		1144	}
		1145
465	void	1146	void
466	DESTROY(coro)	1147	_clone_state_from (SV *dst, SV *src)
467	Coro::State coro	1148	CODE:
		1149	{
		1150	struct coro *coro_src = SvSTATE (src);
		1151
		1152	sv_unmagic (SvRV (dst), PERL_MAGIC_ext);
		1153
		1154	++coro_src->refcnt;
		1155	sv_magicext (SvRV (dst), 0, PERL_MAGIC_ext, &coro_state_vtbl, (char *)coro_src, 0)->mg_flags |= MGf_DUP;
		1156	}
		1157
		1158	void
		1159	_exit (code)
		1160	int code
		1161	PROTOTYPE: $
		1162	CODE:
		1163	_exit (code);
		1164
		1165	int
		1166	cctx_count ()
		1167	CODE:
		1168	RETVAL = cctx_count;
		1169	OUTPUT:
		1170	RETVAL
		1171
		1172	int
		1173	cctx_idle ()
		1174	CODE:
		1175	RETVAL = cctx_idle;
		1176	OUTPUT:
		1177	RETVAL
		1178
		1179	MODULE = Coro::State PACKAGE = Coro
		1180
		1181	BOOT:
		1182	{
		1183	int i;
		1184
		1185	coro_stash = gv_stashpv ("Coro", TRUE);
		1186
		1187	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1188	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1189	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1190	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1191	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1192	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1193
		1194	coro_current = get_sv ("Coro::current", FALSE);
		1195	SvREADONLY_on (coro_current);
		1196
		1197	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1198	coro_ready[i] = newAV ();
		1199
		1200	{
		1201	SV *sv = perl_get_sv("Coro::API", 1);
		1202
		1203	coroapi.schedule = api_schedule;
		1204	coroapi.save = api_save;
		1205	coroapi.cede = api_cede;
		1206	coroapi.ready = api_ready;
		1207	coroapi.is_ready = api_is_ready;
		1208	coroapi.nready = &coro_nready;
		1209	coroapi.current = coro_current;
		1210
		1211	GCoroAPI = &coroapi;
		1212	sv_setiv (sv, (IV)&coroapi);
		1213	SvREADONLY_on (sv);
		1214	}
		1215	}
		1216
		1217	void
		1218	_set_current (SV *current)
		1219	PROTOTYPE: $
		1220	CODE:
		1221	SvREFCNT_dec (SvRV (coro_current));
		1222	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1223
		1224	int
		1225	prio (Coro::State coro, int newprio = 0)
		1226	ALIAS:
		1227	nice = 1
468	CODE:	1228	CODE:
		1229	{
		1230	RETVAL = coro->prio;
469		1231
470	if (coro->mainstack)	1232	if (items > 1)
471	{	1233	{
472	struct coro temp;	1234	if (ix)
		1235	newprio += coro->prio;
473		1236
474	PUTBACK;	1237	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
475	SAVE(aTHX_ (&temp));	1238	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
476	LOAD(aTHX_ coro);
477		1239
478	destroy_stacks ();	1240	coro->prio = newprio;
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;
483	}	1241	}
		1242	}
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