ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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