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

Diff Legend

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