[ViewVC] Diff of: cvs/Coro/Coro/State.xs

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.50 by pcg, Sun Nov 30 16:59:15 2003 UTC

…		…
1	#include "EXTERN.h"	1	#include "EXTERN.h"
2	#include "perl.h"	2	#include "perl.h"
3	#include "XSUB.h"	3	#include "XSUB.h"
4		4
5	#if 0	5	#include "patchlevel.h"
6	# define CHK(x) (void *)0	6
7	#else	7	#if PATCHLEVEL < 6
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	8	# ifndef PL_ppaddr
		9	# define PL_ppaddr ppaddr
		10	# endif
		11	# ifndef call_sv
		12	# define call_sv perl_call_sv
		13	# endif
		14	# ifndef get_sv
		15	# define get_sv perl_get_sv
		16	# endif
		17	# ifndef get_cv
		18	# define get_cv perl_get_cv
		19	# endif
		20	# ifndef IS_PADGV
		21	# define IS_PADGV(v) 0
		22	# endif
		23	# ifndef IS_PADCONST
		24	# define IS_PADCONST(v) 0
		25	# endif
9	#endif	26	#endif
10		27
		28	#include "libcoro/coro.c"
		29
		30	#include <signal.h>
		31
		32	#ifdef HAVE_MMAP
		33	# include <unistd.h>
		34	# include <sys/mman.h>
		35	# ifndef MAP_ANONYMOUS
		36	# ifdef MAP_ANON
		37	# define MAP_ANONYMOUS MAP_ANON
		38	# else
		39	# undef HAVE_MMAP
		40	# endif
		41	# endif
		42	#endif
		43
		44	#define SUB_INIT "Coro::State::initialize"
		45	#define UCORO_STATE "_coro_state"
		46
		47	/* The next macro should declare a variable stacklevel that contains and approximation
		48	* to the current C stack pointer. Its property is that it changes with each call
		49	* and should be unique. */
		50	#define dSTACKLEVEL void *stacklevel = &stacklevel
		51
		52	#define IN_DESTRUCT (PL_main_cv == Nullcv)
		53
		54	#define labs(l) ((l) >= 0 ? (l) : -(l))
		55
		56	#include "CoroAPI.h"
		57
		58	static struct CoroAPI coroapi;
		59
		60	/* this is actually not only the c stack but also c registers etc... */
		61	typedef struct {
		62	int refcnt; /* pointer reference counter */
		63	int usecnt; /* shared by how many coroutines */
		64	int gencnt; /* generation counter */
		65
		66	coro_context cctx;
		67
		68	void *sptr;
		69	long ssize; /* positive == mmap, otherwise malloc */
		70	} coro_stack;
		71
11	struct coro {	72	struct coro {
		73	/* the top-level JMPENV for each coroutine, needed to catch dies. */
		74	JMPENV start_env;
		75
		76	/* the optional C context */
		77	coro_stack *stack;
		78	void *cursp;
		79	int gencnt;
		80
		81	/* optionally saved, might be zero */
		82	AV *defav;
		83	SV *defsv;
		84	SV *errsv;
		85
		86	/* saved global state not related to stacks */
12	U8 dowarn;	87	U8 dowarn;
13	AV *defav;	88	I32 in_eval;
14		89
		90	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	91	PERL_SI *curstackinfo;
16	AV *curstack;	92	AV *curstack;
17	AV *mainstack;	93	AV *mainstack;
18	SV **stack_sp;	94	SV **stack_sp;
19	OP *op;	95	OP *op;
20	SV **curpad;	96	SV **curpad;
		97	AV *comppad;
21	SV **stack_base;	98	SV **stack_base;
22	SV **stack_max;	99	SV **stack_max;
23	SV **tmps_stack;	100	SV **tmps_stack;
24	I32 tmps_floor;	101	I32 tmps_floor;
25	I32 tmps_ix;	102	I32 tmps_ix;
35	I32 savestack_max;	112	I32 savestack_max;
36	OP **retstack;	113	OP **retstack;
37	I32 retstack_ix;	114	I32 retstack_ix;
38	I32 retstack_max;	115	I32 retstack_max;
39	COP *curcop;	116	COP *curcop;
		117	JMPENV *top_env;
40		118
		119	/* data associated with this coroutine (initial args) */
41	AV *args;	120	AV *args;
42	};	121	};
43		122
44	typedef struct coro *Coro__State;	123	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	124	typedef struct coro *Coro__State_or_hashref;
46		125
		126	static AV main_mainstack; / used to differentiate between $main and others */
		127	static HV *coro_state_stash;
		128	static SV *ucoro_state_sv;
		129	static U32 ucoro_state_hash;
47	static HV *padlist_cache;	130	static HV *padlist_cache;
		131	static SV coro_mortal; / will be freed after next transfer */
48		132
49	/* mostly copied from op.c:cv_clone2 */	133	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *	134	STATIC AV *
51	clone_padlist (AV *protopadlist)	135	clone_padlist (AV *protopadlist)
52	{	136	{
…		…
98	sv = (SV *) newAV ();	182	sv = (SV *) newAV ();
99	else if (*name == '%')	183	else if (*name == '%')
100	sv = (SV *) newHV ();	184	sv = (SV *) newHV ();
101	else	185	else
102	sv = NEWSV (0, 0);	186	sv = NEWSV (0, 0);
		187	#ifdef SvPADBUSY
103	if (!SvPADBUSY (sv))	188	if (!SvPADBUSY (sv))
		189	#endif
104	SvPADMY_on (sv);	190	SvPADMY_on (sv);
105	npad[ix] = sv;	191	npad[ix] = sv;
106	}	192	}
107	}	193	}
108	else if (IS_PADGV (ppad[ix]) \|\| IS_PADCONST (ppad[ix]))	194	else if (IS_PADGV (ppad[ix]) \|\| IS_PADCONST (ppad[ix]))
…		…
115	SvPADTMP_on (sv);	201	SvPADTMP_on (sv);
116	npad[ix] = sv;	202	npad[ix] = sv;
117	}	203	}
118	}	204	}
119		205
120	#if 0 /* NONOTUNDERSTOOD */	206	#if 0 /* return -ENOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */	207	/* Now that vars are all in place, clone nested closures. */
122		208
123	for (ix = fpad; ix > 0; ix--) {	209	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	210	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv	211	if (namesv
…		…
138	#endif	224	#endif
139		225
140	return newpadlist;	226	return newpadlist;
141	}	227	}
142		228
143	STATIC AV *	229	STATIC void
144	free_padlist (AV *padlist)	230	free_padlist (AV *padlist)
145	{	231	{
146	/* may be during global destruction */	232	/* may be during global destruction */
147	if (SvREFCNT(padlist))	233	if (SvREFCNT (padlist))
148	{	234	{
149	I32 i = AvFILLp(padlist);	235	I32 i = AvFILLp (padlist);
150	while (i >= 0)	236	while (i >= 0)
151	{	237	{
152	SV **svp = av_fetch(padlist, i--, FALSE);	238	SV **svp = av_fetch (padlist, i--, FALSE);
153	SV sv = svp ? svp : Nullsv;
154	if (sv)	239	if (svp)
		240	{
		241	SV *sv;
		242	while (&PL_sv_undef != (sv = av_pop ((AV )svp)))
155	SvREFCNT_dec(sv);	243	SvREFCNT_dec (sv);
		244
		245	SvREFCNT_dec (*svp);
		246	}
156	}	247	}
157		248
158	SvREFCNT_dec((SV*)padlist);	249	SvREFCNT_dec ((SV*)padlist);
159	}	250	}
160	}	251	}
161		252
		253	STATIC int
		254	coro_cv_free (SV sv, MAGIC mg)
		255	{
		256	AV *padlist;
		257	AV av = (AV )mg->mg_obj;
		258
		259	/* casting is fun. */
		260	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
		261	free_padlist (padlist);
		262	}
		263
		264	#define PERL_MAGIC_coro PERL_MAGIC_ext
		265
		266	static MGVTBL vtbl_coro = {0, 0, 0, 0, coro_cv_free};
		267
162	/* the next tow functions merely cache the padlists */	268	/* the next two functions merely cache the padlists */
163	STATIC void	269	STATIC void
164	get_padlist (CV *cv)	270	get_padlist (CV *cv)
165	{	271	{
166	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);	272	MAGIC mg = mg_find ((SV )cv, PERL_MAGIC_coro);
167		273
168	if (he && AvFILLp ((AV )he) >= 0)	274	if (mg && AvFILLp ((AV *)mg->mg_obj) >= 0)
169	CvPADLIST (cv) = (AV )av_pop ((AV )*he);	275	CvPADLIST (cv) = (AV )av_pop ((AV )mg->mg_obj);
170	else	276	else
171	CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));	277	CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172	}	278	}
173		279
174	STATIC void	280	STATIC void
175	put_padlist (CV *cv)	281	put_padlist (CV *cv)
176	{	282	{
177	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 1);	283	MAGIC mg = mg_find ((SV )cv, PERL_MAGIC_coro);
178		284
179	if (SvTYPE (*he) != SVt_PVAV)	285	if (!mg)
180	{	286	{
181	SvREFCNT_dec (*he);	287	sv_magic ((SV *)cv, 0, PERL_MAGIC_coro, 0, 0);
		288	mg = mg_find ((SV *)cv, PERL_MAGIC_coro);
		289	mg->mg_virtual = &vtbl_coro;
182	he = (SV )newAV ();	290	mg->mg_obj = (SV *)newAV ();
183	}	291	}
184		292
185	av_push ((AV )he, (SV *)CvPADLIST (cv));	293	av_push ((AV )mg->mg_obj, (SV )CvPADLIST (cv));
186	}	294	}
		295
		296	#define SB do {
		297	#define SE } while (0)
		298
		299	#define LOAD(state) load_state(aTHX_ (state));
		300	#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
		301
		302	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE
187		303
188	static void	304	static void
189	SAVE(pTHX_ Coro__State c)	305	load_state(pTHX_ Coro__State c)
		306	{
		307	PL_dowarn = c->dowarn;
		308	PL_in_eval = c->in_eval;
		309
		310	PL_curstackinfo = c->curstackinfo;
		311	PL_curstack = c->curstack;
		312	PL_mainstack = c->mainstack;
		313	PL_stack_sp = c->stack_sp;
		314	PL_op = c->op;
		315	PL_curpad = c->curpad;
		316	PL_comppad = c->comppad;
		317	PL_stack_base = c->stack_base;
		318	PL_stack_max = c->stack_max;
		319	PL_tmps_stack = c->tmps_stack;
		320	PL_tmps_floor = c->tmps_floor;
		321	PL_tmps_ix = c->tmps_ix;
		322	PL_tmps_max = c->tmps_max;
		323	PL_markstack = c->markstack;
		324	PL_markstack_ptr = c->markstack_ptr;
		325	PL_markstack_max = c->markstack_max;
		326	PL_scopestack = c->scopestack;
		327	PL_scopestack_ix = c->scopestack_ix;
		328	PL_scopestack_max = c->scopestack_max;
		329	PL_savestack = c->savestack;
		330	PL_savestack_ix = c->savestack_ix;
		331	PL_savestack_max = c->savestack_max;
		332	PL_retstack = c->retstack;
		333	PL_retstack_ix = c->retstack_ix;
		334	PL_retstack_max = c->retstack_max;
		335	PL_curcop = c->curcop;
		336	PL_top_env = c->top_env;
		337
		338	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		339	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		340	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		341
		342	{
		343	dSP;
		344	CV *cv;
		345
		346	/* now do the ugly restore mess */
		347	while ((cv = (CV *)POPs))
		348	{
		349	AV padlist = (AV )POPs;
		350
		351	if (padlist)
		352	{
		353	put_padlist (cv); /* mark this padlist as available */
		354	CvPADLIST(cv) = padlist;
		355	#ifdef USE_THREADS
		356	/CvOWNER(cv) = (struct perl_thread )POPs;*/
		357	#endif
		358	}
		359
		360	++CvDEPTH(cv);
		361	}
		362
		363	PUTBACK;
		364	}
		365	}
		366
		367	static void
		368	save_state(pTHX_ Coro__State c, int flags)
190	{	369	{
191	{	370	{
192	dSP;	371	dSP;
193	I32 cxix = cxstack_ix;	372	I32 cxix = cxstack_ix;
		373	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	374	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		375
197	/*	376	/*
198	* the worst thing you can imagine happens first - we have to save	377	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	378	* (and reinitialize) all cv's in the whole callchain :(
200	*/	379	*/
…		…
211	{	390	{
212	CV *cv = cx->blk_sub.cv;	391	CV *cv = cx->blk_sub.cv;
213	if (CvDEPTH(cv))	392	if (CvDEPTH(cv))
214	{	393	{
215	#ifdef USE_THREADS	394	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));	395	/XPUSHs ((SV )CvOWNER(cv));*/
		396	/CvOWNER(cv) = 0;/
		397	/error must unlock this cv etc.. etc.../
217	#endif	398	#endif
218	EXTEND (SP, 3);	399	EXTEND (SP, CvDEPTH(cv)*2);
		400
		401	while (--CvDEPTH(cv))
		402	{
		403	/* this tells the restore code to increment CvDEPTH */
		404	PUSHs (Nullsv);
219	PUSHs ((SV *)CvDEPTH(cv));	405	PUSHs ((SV *)cv);
		406	}
		407
220	PUSHs ((SV *)CvPADLIST(cv));	408	PUSHs ((SV *)CvPADLIST(cv));
221	PUSHs ((SV *)cv);	409	PUSHs ((SV *)cv);
222		410
223	get_padlist (cv);	411	get_padlist (cv); /* this is a monster */
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	}	412	}
233	}	413	}
		414	#ifdef CXt_FORMAT
234	else if (CxTYPE(cx) == CXt_FORMAT)	415	else if (CxTYPE(cx) == CXt_FORMAT)
235	{	416	{
236	/* I never used formats, so how should I know how these are implemented? */	417	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */	418	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	419	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}	420	}
		421	#endif
240	}	422	}
241		423
242	if (top_si->si_type == PERLSI_MAIN)	424	if (top_si->si_type == PERLSI_MAIN)
243	break;	425	break;
244		426
…		…
248	}	430	}
249		431
250	PUTBACK;	432	PUTBACK;
251	}	433	}
252		434
		435	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		436	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		437	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		438
253	c->dowarn = PL_dowarn;	439	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);	440	c->in_eval = PL_in_eval;
		441
255	c->curstackinfo = PL_curstackinfo;	442	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	443	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	444	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	445	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	446	c->op = PL_op;
260	c->curpad = PL_curpad;	447	c->curpad = PL_curpad;
		448	c->comppad = PL_comppad;
261	c->stack_base = PL_stack_base;	449	c->stack_base = PL_stack_base;
262	c->stack_max = PL_stack_max;	450	c->stack_max = PL_stack_max;
263	c->tmps_stack = PL_tmps_stack;	451	c->tmps_stack = PL_tmps_stack;
264	c->tmps_floor = PL_tmps_floor;	452	c->tmps_floor = PL_tmps_floor;
265	c->tmps_ix = PL_tmps_ix;	453	c->tmps_ix = PL_tmps_ix;
…		…
275	c->savestack_max = PL_savestack_max;	463	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;	464	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;	465	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	466	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;	467	c->curcop = PL_curcop;
		468	c->top_env = PL_top_env;
280	}	469	}
281		470
282	static void	471	/*
283	LOAD(pTHX_ Coro__State c)	472	* allocate various perl stacks. This is an exact copy
		473	* of perl.c:init_stacks, except that it uses less memory
		474	* on the assumption that coroutines do not usually need
		475	* a lot of stackspace.
		476	*/
		477	STATIC void
		478	coro_init_stacks (pTHX)
284	{	479	{
285	PL_dowarn = c->dowarn;	480	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	481	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	482	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	483	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	484
		485	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	486	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	487	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	488
293	PL_stack_base = c->stack_base;	489	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	490	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	491	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	492	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	493
298	PL_tmps_max = c->tmps_max;	494	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	495	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	496	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		497
313	{	498	#ifdef SET_MARK_OFFSET
314	dSP;	499	SET_MARK_OFFSET;
315	CV *cv;
316
317	/* now do the ugly restore mess */
318	while ((cv = (CV *)POPs))
319	{
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	500	#endif
330	}
331		501
332	PUTBACK;	502	New(54,PL_scopestack,16,I32);
333	}	503	PL_scopestack_ix = 0;
334	}	504	PL_scopestack_max = 16;
335		505
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	506	New(54,PL_savestack,96,ANY);
		507	PL_savestack_ix = 0;
		508	PL_savestack_max = 96;
		509
		510	New(54,PL_retstack,8,OP*);
		511	PL_retstack_ix = 0;
		512	PL_retstack_max = 8;
		513	}
		514
		515	/*
		516	* destroy the stacks, the callchain etc...
		517	*/
337	STATIC void	518	STATIC void
338	destroy_stacks(pTHX)	519	destroy_stacks(pTHX)
339	{	520	{
340	dSP;	521	if (!IN_DESTRUCT)
341		522	{
342	/* die does this while calling POPSTACK, but I just don't see why. */
343	dounwind(-1);
344
345	/* is this ugly, I ask? */	523	/* is this ugly, I ask? */
346	while (PL_scopestack_ix)	524	while (PL_scopestack_ix)
347	LEAVE;	525	LEAVE;
		526
		527	/* sure it is, but more important: is it correct?? :/ */
		528	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		529	FREETMPS;
		530	}
348		531
349	while (PL_curstackinfo->si_next)	532	while (PL_curstackinfo->si_next)
350	PL_curstackinfo = PL_curstackinfo->si_next;	533	PL_curstackinfo = PL_curstackinfo->si_next;
351		534
352	while (PL_curstackinfo)	535	while (PL_curstackinfo)
353	{	536	{
354	PERL_SI *p = PL_curstackinfo->si_prev;	537	PERL_SI *p = PL_curstackinfo->si_prev;
355		538
		539	{
		540	dSP;
		541	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		542	PUTBACK; /* possibly superfluous */
		543	}
		544
		545	if (!IN_DESTRUCT)
		546	{
		547	dounwind(-1);
356	SvREFCNT_dec(PL_curstackinfo->si_stack);	548	SvREFCNT_dec(PL_curstackinfo->si_stack);
		549	}
		550
357	Safefree(PL_curstackinfo->si_cxstack);	551	Safefree(PL_curstackinfo->si_cxstack);
358	Safefree(PL_curstackinfo);	552	Safefree(PL_curstackinfo);
359	PL_curstackinfo = p;	553	PL_curstackinfo = p;
360	}	554	}
361		555
362	if (PL_scopestack_ix != 0)
363	Perl_warner(aTHX_ WARN_INTERNAL,
364	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365	(long)PL_scopestack_ix);
366	if (PL_savestack_ix != 0)
367	Perl_warner(aTHX_ WARN_INTERNAL,
368	"Unbalanced saves: %ld more saves than restores\n",
369	(long)PL_savestack_ix);
370	if (PL_tmps_floor != -1)
371	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372	(long)PL_tmps_floor + 1);
373	/*
374	*/
375	Safefree(PL_tmps_stack);	556	Safefree(PL_tmps_stack);
376	Safefree(PL_markstack);	557	Safefree(PL_markstack);
377	Safefree(PL_scopestack);	558	Safefree(PL_scopestack);
378	Safefree(PL_savestack);	559	Safefree(PL_savestack);
379	Safefree(PL_retstack);	560	Safefree(PL_retstack);
380	}	561	}
381		562
382	#define SUB_INIT "Coro::State::_newcoro"	563	static void
		564	allocate_stack (Coro__State ctx, int alloc)
		565	{
		566	coro_stack *stack;
		567
		568	New (0, stack, 1, coro_stack);
		569
		570	stack->refcnt = 1;
		571	stack->usecnt = 1;
		572	stack->gencnt = ctx->gencnt = 0;
		573	if (alloc)
		574	{
		575	#if HAVE_MMAP
		576	stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
		577	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		578	if (stack->sptr == (void *)-1)
		579	#endif
		580	{
		581	/FIXME//D//* reasonable stack size! */
		582	stack->ssize = -4096 * sizeof (long);
		583	New (0, stack->sptr, 4096, long);
		584	}
		585	}
		586	else
		587	stack->sptr = 0;
		588
		589	ctx->stack = stack;
		590	}
		591
		592	static void
		593	deallocate_stack (Coro__State ctx)
		594	{
		595	coro_stack *stack = ctx->stack;
		596
		597	ctx->stack = 0;
		598
		599	if (stack)
		600	{
		601	if (!--stack->refcnt)
		602	{
		603	#ifdef HAVE_MMAP
		604	if (stack->ssize > 0 && stack->sptr)
		605	munmap (stack->sptr, stack->ssize);
		606	else
		607	#endif
		608	Safefree (stack->sptr);
		609
		610	Safefree (stack);
		611	}
		612	else if (ctx->gencnt == stack->gencnt)
		613	--stack->usecnt;
		614	}
		615	}
		616
		617	static void
		618	setup_coro (void *arg)
		619	{
		620	/*
		621	* emulate part of the perl startup here.
		622	*/
		623	dSP;
		624	Coro__State ctx = (Coro__State)arg;
		625	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
		626
		627	coro_init_stacks (aTHX);
		628	/PL_curcop = 0;/
		629	/PL_in_eval = PL_in_eval;/ /* inherit */
		630	SvREFCNT_dec (GvAV (PL_defgv));
		631	GvAV (PL_defgv) = ctx->args; ctx->args = 0;
		632
		633	SPAGAIN;
		634
		635	if (ctx->stack)
		636	{
		637	ctx->cursp = 0;
		638
		639	PUSHMARK(SP);
		640	PUTBACK;
		641	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		642
		643	if (SvTRUE (ERRSV))
		644	croak (NULL);
		645	else
		646	croak ("FATAL: CCTXT coroutine returned!");
		647	}
		648	else
		649	{
		650	UNOP myop;
		651
		652	PL_op = (OP *)&myop;
		653
		654	Zero(&myop, 1, UNOP);
		655	myop.op_next = Nullop;
		656	myop.op_flags = OPf_WANT_VOID;
		657
		658	PUSHMARK(SP);
		659	XPUSHs (sub_init);
		660	/*
		661	* the next line is slightly wrong, as PL_op->op_next
		662	* is actually being executed so we skip the first op.
		663	* that doesn't matter, though, since it is only
		664	* pp_nextstate and we never return...
		665	* ah yes, and I don't care anyways ;)
		666	*/
		667	PUTBACK;
		668	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		669	SPAGAIN;
		670
		671	ENTER; /* necessary e.g. for dounwind */
		672	}
		673	}
		674
		675	static void
		676	continue_coro (void *arg)
		677	{
		678	/*
		679	* this is a _very_ stripped down perl interpreter ;)
		680	*/
		681	Coro__State ctx = (Coro__State)arg;
		682	JMPENV coro_start_env;
		683
		684	PL_top_env = &ctx->start_env;
		685
		686	ctx->cursp = 0;
		687	PL_op = PL_op->op_next;
		688	CALLRUNOPS(aTHX);
		689
		690	abort ();
		691	}
		692
		693	STATIC void
		694	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		695	{
		696	dSTACKLEVEL;
		697	static struct coro *xnext;
		698
		699	if (prev != next)
		700	{
		701	xnext = next;
		702
		703	if (next->mainstack)
		704	{
		705	SAVE (prev, flags);
		706	LOAD (next);
		707
		708	/* mark this state as in-use */
		709	next->mainstack = 0;
		710	next->tmps_ix = -2;
		711
		712	/* stacklevel changed? if yes, grab the stack for us! */
		713	if (flags & TRANSFER_SAVE_CCTXT)
		714	{
		715	if (!prev->stack)
		716	allocate_stack (prev, 0);
		717	else if (prev->cursp != stacklevel
		718	&& prev->stack->usecnt > 1)
		719	{
		720	prev->gencnt = ++prev->stack->gencnt;
		721	prev->stack->usecnt = 1;
		722	}
		723
		724	/* has our stack been invalidated? */
		725	if (next->stack && next->stack->gencnt != next->gencnt)
		726	{
		727	deallocate_stack (next);
		728	allocate_stack (next, 1);
		729	coro_create (&(next->stack->cctx),
		730	continue_coro, (void *)next,
		731	next->stack->sptr, labs (next->stack->ssize));
		732	}
		733
		734	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		735	/* don't add any code here */
		736	}
		737
		738	}
		739	else if (next->tmps_ix == -2)
		740	croak ("tried to transfer to running coroutine");
		741	else
		742	{
		743	SAVE (prev, -1); /* first get rid of the old state */
		744
		745	if (flags & TRANSFER_SAVE_CCTXT)
		746	{
		747	if (!prev->stack)
		748	allocate_stack (prev, 0);
		749
		750	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		751	{
		752	PL_top_env = &next->start_env;
		753
		754	setup_coro (next);
		755
		756	prev->stack->refcnt++;
		757	prev->stack->usecnt++;
		758	next->stack = prev->stack;
		759	next->gencnt = prev->gencnt;
		760	}
		761	else
		762	{
		763	assert (!next->stack);
		764	allocate_stack (next, 1);
		765	coro_create (&(next->stack->cctx),
		766	setup_coro, (void *)next,
		767	next->stack->sptr, labs (next->stack->ssize));
		768	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		769	/* don't add any code here */
		770	}
		771	}
		772	else
		773	setup_coro (next);
		774	}
		775
		776	/*
		777	* xnext is now either prev or next, depending on wether
		778	* we switched the c stack or not. that's why I use a global
		779	* variable, that should become thread-specific at one point.
		780	*/
		781	xnext->cursp = stacklevel;
		782	}
		783
		784	if (coro_mortal)
		785	{
		786	SvREFCNT_dec (coro_mortal);
		787	coro_mortal = 0;
		788	}
		789	}
		790
		791	#define SV_CORO(sv,func) \
		792	do { \
		793	if (SvROK (sv)) \
		794	sv = SvRV (sv); \
		795	\
		796	if (SvTYPE(sv) == SVt_PVHV) \
		797	{ \
		798	HE he = hv_fetch_ent((HV )sv, ucoro_state_sv, 0, ucoro_state_hash); \
		799	\
		800	if (!he) \
		801	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
		802	\
		803	(sv) = SvRV (HeVAL(he)); \
		804	} \
		805	\
		806	/* must also be changed inside Coro::Cont::yield */ \
		807	if (!SvOBJECT(sv) \|\| SvSTASH(sv) != coro_state_stash) \
		808	croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
		809	\
		810	} while(0)
		811
		812	#define SvSTATE(sv) (struct coro *)SvIV (sv)
		813
		814	static void
		815	api_transfer(pTHX_ SV prev, SV next, int flags)
		816	{
		817	SV_CORO (prev, "Coro::transfer");
		818	SV_CORO (next, "Coro::transfer");
		819
		820	transfer(aTHX_ SvSTATE(prev), SvSTATE(next), flags);
		821	}
		822
		823	/ Coro ******************************************************************/
		824
		825	#define PRIO_MAX 3
		826	#define PRIO_HIGH 1
		827	#define PRIO_NORMAL 0
		828	#define PRIO_LOW -1
		829	#define PRIO_IDLE -3
		830	#define PRIO_MIN -4
		831
		832	/* for Coro.pm */
		833	static GV coro_current, coro_idle;
		834	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		835	static int coro_nready;
		836
		837	static void
		838	coro_enq (SV *sv)
		839	{
		840	if (SvTYPE (sv) == SVt_PVHV)
		841	{
		842	SV *xprio = hv_fetch ((HV )sv, "prio", 4, 0);
		843	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		844
		845	prio = prio > PRIO_MAX ? PRIO_MAX
		846	: prio < PRIO_MIN ? PRIO_MIN
		847	: prio;
		848
		849	av_push (coro_ready [prio - PRIO_MIN], sv);
		850	coro_nready++;
		851
		852	return;
		853	}
		854
		855	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		856	}
		857
		858	static SV *
		859	coro_deq (int min_prio)
		860	{
		861	int prio = PRIO_MAX - PRIO_MIN;
		862
		863	min_prio -= PRIO_MIN;
		864	if (min_prio < 0)
		865	min_prio = 0;
		866
		867	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		868	if (av_len (coro_ready[prio]) >= 0)
		869	{
		870	coro_nready--;
		871	return av_shift (coro_ready[prio]);
		872	}
		873
		874	return 0;
		875	}
		876
		877	static void
		878	api_ready (SV *coro)
		879	{
		880	if (SvROK (coro))
		881	coro = SvRV (coro);
		882
		883	coro_enq (SvREFCNT_inc (coro));
		884	}
		885
		886	static void
		887	api_schedule (void)
		888	{
		889	SV prev, next;
		890
		891	prev = SvRV (GvSV (coro_current));
		892	next = coro_deq (PRIO_MIN);
		893
		894	if (!next)
		895	next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
		896
		897	/* free this only after the transfer */
		898	coro_mortal = prev;
		899	SV_CORO (prev, "Coro::schedule");
		900
		901	SvRV (GvSV (coro_current)) = next;
		902
		903	SV_CORO (next, "Coro::schedule");
		904
		905	transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		906	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		907	}
		908
		909	static void
		910	api_cede (void)
		911	{
		912	coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
		913
		914	api_schedule ();
		915	}
383		916
384	MODULE = Coro::State PACKAGE = Coro::State	917	MODULE = Coro::State PACKAGE = Coro::State
385		918
386	PROTOTYPES: ENABLE	919	PROTOTYPES: ENABLE
387		920
388	BOOT:	921	BOOT:
		922	{ /* {} necessary for stoopid perl-5.6.x */
		923	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		924	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		925	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		926
		927	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		928	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		929	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		930	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		931
389	if (!padlist_cache)	932	if (!padlist_cache)
390	padlist_cache = newHV ();	933	padlist_cache = newHV ();
		934
		935	main_mainstack = PL_mainstack;
		936
		937	coroapi.ver = CORO_API_VERSION;
		938	coroapi.transfer = api_transfer;
		939	}
391		940
392	Coro::State	941	Coro::State
393	_newprocess(args)	942	_newprocess(args)
394	SV * args	943	SV * args
395	PROTOTYPE: $	944	PROTOTYPE: $
396	CODE:	945	CODE:
397	Coro__State coro;	946	Coro__State coro;
398		947
399	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	948	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
400	croak ("Coro::State::newprocess expects an arrayref");	949	croak ("Coro::State::_newprocess expects an arrayref");
401		950
402	New (0, coro, 1, struct coro);	951	Newz (0, coro, 1, struct coro);
403		952
		953	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
404	coro->mainstack = 0; /* actual work is done inside transfer */	954	coro->mainstack = 0; /* actual work is done inside transfer */
405	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	955	coro->stack = 0;
		956
		957	/* same as JMPENV_BOOTSTRAP */
		958	/* we might be able to recycle start_env, but safe is safe */
		959	//Zero(&coro->start_env, 1, JMPENV);
		960	coro->start_env.je_ret = -1;
		961	coro->start_env.je_mustcatch = TRUE;
406		962
407	RETVAL = coro;	963	RETVAL = coro;
408	OUTPUT:	964	OUTPUT:
409	RETVAL	965	RETVAL
410		966
411	void	967	void
412	transfer(prev,next)	968	transfer(prev, next, flags)
413	Coro::State_or_hashref prev	969	SV *prev
414	Coro::State_or_hashref next	970	SV *next
		971	int flags
		972	PROTOTYPE: @
415	CODE:	973	CODE:
416
417	if (prev != next)
418	{
419	PUTBACK;	974	PUTBACK;
420	SAVE (aTHX_ prev);	975	SV_CORO (next, "Coro::transfer");
421		976	SV_CORO (prev, "Coro::transfer");
422	/*	977	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
423	* this could be done in newprocess which would lead to
424	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425	* code here, but lazy allocation of stacks has also
426	* some virtues and the overhead of the if() is nil.
427	*/
428	if (next->mainstack)
429	{
430	LOAD (aTHX_ next);
431	next->mainstack = 0; /* unnecessary but much cleaner */
432	SPAGAIN;	978	SPAGAIN;
433	}
434	else
435	{
436	/*
437	* emulate part of the perl startup here.
438	*/
439	UNOP myop;
440
441	init_stacks (); /* from perl.c */
442	PL_op = (OP *)&myop;
443	/PL_curcop = 0;/
444	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445
446	SPAGAIN;
447	Zero(&myop, 1, UNOP);
448	myop.op_next = Nullop;
449	myop.op_flags = OPf_WANT_VOID;
450
451	PUSHMARK(SP);
452	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453	PUTBACK;
454	/*
455	* the next line is slightly wrong, as PL_op->op_next
456	* is actually being executed so we skip the first op.
457	* that doesn't matter, though, since it is only
458	* pp_nextstate and we never return...
459	*/
460	PL_op = Perl_pp_entersub(aTHX);
461	SPAGAIN;
462
463	ENTER;
464	}
465	}
466		979
467	void	980	void
468	DESTROY(coro)	981	DESTROY(coro)
469	Coro::State coro	982	Coro::State coro
470	CODE:	983	CODE:
471		984
472	if (coro->mainstack)	985	if (coro->mainstack && coro->mainstack != main_mainstack)
473	{	986	{
474	struct coro temp;	987	struct coro temp;
475		988
476	PUTBACK;	989	PUTBACK;
477	SAVE(aTHX_ (&temp));	990	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
478	LOAD(aTHX_ coro);	991	LOAD(aTHX_ coro);
479
480	destroy_stacks ();
481	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483	LOAD((&temp));
484	SPAGAIN;	992	SPAGAIN;
		993
		994	destroy_stacks (aTHX);
		995
		996	LOAD((&temp)); /* this will get rid of defsv etc.. */
		997	SPAGAIN;
		998
		999	coro->mainstack = 0;
485	}	1000	}
486		1001
		1002	deallocate_stack (coro);
487	SvREFCNT_dec (coro->args);	1003	SvREFCNT_dec (coro->args);
488	Safefree (coro);	1004	Safefree (coro);
489		1005
		1006	void
		1007	_exit(code)
		1008	int code
		1009	PROTOTYPE: $
		1010	CODE:
		1011	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		1012	_exit (code);
		1013	#else
		1014	signal (SIGTERM, SIG_DFL);
		1015	raise (SIGTERM);
		1016	exit (code);
		1017	#endif
490		1018
		1019	MODULE = Coro::State PACKAGE = Coro::Cont
		1020
		1021	# this is slightly dirty (should expose a c-level api)
		1022
		1023	void
		1024	yield(...)
		1025	PROTOTYPE: @
		1026	CODE:
		1027	static SV *returnstk;
		1028	SV *sv;
		1029	AV *defav = GvAV (PL_defgv);
		1030	struct coro prev, next;
		1031
		1032	if (!returnstk)
		1033	returnstk = SvRV ((SV *)get_sv ("Coro::Cont::return", FALSE));
		1034
		1035	/* set up @_ -- ugly */
		1036	av_clear (defav);
		1037	av_fill (defav, items - 1);
		1038	while (items--)
		1039	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1040
		1041	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		1042	sv = av_pop ((AV *)SvRV (returnstk));
		1043	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		1044	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		1045	SvREFCNT_dec (sv);
		1046
		1047	transfer(aTHX_ prev, next, 0);
		1048
		1049	MODULE = Coro::State PACKAGE = Coro
		1050
		1051	# this is slightly dirty (should expose a c-level api)
		1052
		1053	BOOT:
		1054	{
		1055	int i;
		1056	HV *stash = gv_stashpv ("Coro", TRUE);
		1057
		1058	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1059	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1060	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1061	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1062	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1063	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1064
		1065	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1066	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1067
		1068	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1069	coro_ready[i] = newAV ();
		1070
		1071	{
		1072	SV *sv = perl_get_sv("Coro::API", 1);
		1073
		1074	coroapi.schedule = api_schedule;
		1075	coroapi.cede = api_cede;
		1076	coroapi.ready = api_ready;
		1077	coroapi.nready = &coro_nready;
		1078	coroapi.current = coro_current;
		1079
		1080	GCoroAPI = &coroapi;
		1081	sv_setiv(sv, (IV)&coroapi);
		1082	SvREADONLY_on(sv);
		1083	}
		1084	}
		1085
		1086	#if !PERL_MICRO
		1087
		1088	void
		1089	ready(self)
		1090	SV * self
		1091	PROTOTYPE: $
		1092	CODE:
		1093	api_ready (self);
		1094
		1095	#endif
		1096
		1097	int
		1098	nready(...)
		1099	PROTOTYPE:
		1100	CODE:
		1101	RETVAL = coro_nready;
		1102	OUTPUT:
		1103	RETVAL
		1104
		1105	void
		1106	schedule(...)
		1107	PROTOTYPE:
		1108	CODE:
		1109	api_schedule ();
		1110
		1111	void
		1112	cede(...)
		1113	PROTOTYPE:
		1114	CODE:
		1115	api_cede ();
		1116

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.50 by pcg, Sun Nov 30 16:59:15 2003 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.50 by pcg, Sun Nov 30 16:59:15 2003 UTC