ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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