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

Diff Legend

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