ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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