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.122 by root, Mon Dec 4 13:47:56 2006 UTC

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

Diff Legend

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