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

Diff Legend

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