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.95 by root, Sun Nov 26 17:35:42 2006 UTC

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

Diff Legend

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