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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.54 by pcg, Sat Mar 13 06:45:04 2004 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 (pTHX_ 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_state(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	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	471	/*
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	472	* allocate various perl stacks. This is an exact copy
284		473	* of perl.c:init_stacks, except that it uses less memory
285	static void	474	* on the (sometimes correct) assumption that coroutines do
286	load_state(pTHX_ Coro__State c)	475	* not usually need a lot of stackspace.
		476	*/
		477	STATIC void
		478	coro_init_stacks (pTHX)
287	{	479	{
288	PL_dowarn = c->dowarn;	480	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
289	GvAV (PL_defgv) = c->defav;	481	PL_curstackinfo->si_type = PERLSI_MAIN;
290	PL_curstackinfo = c->curstackinfo;	482	PL_curstack = PL_curstackinfo->si_stack;
291	PL_curstack = c->curstack;	483	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
292	PL_mainstack = c->mainstack;	484
		485	PL_stack_base = AvARRAY(PL_curstack);
293	PL_stack_sp = c->stack_sp;	486	PL_stack_sp = PL_stack_base;
294	PL_op = c->op;	487	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295	PL_curpad = c->curpad;	488
296	PL_stack_base = c->stack_base;	489	New(50,PL_tmps_stack,96,SV*);
297	PL_stack_max = c->stack_max;	490	PL_tmps_floor = -1;
298	PL_tmps_stack = c->tmps_stack;	491	PL_tmps_ix = -1;
299	PL_tmps_floor = c->tmps_floor;	492	PL_tmps_max = 96;
300	PL_tmps_ix = c->tmps_ix;	493
301	PL_tmps_max = c->tmps_max;	494	New(54,PL_markstack,16,I32);
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;	495	PL_markstack_ptr = PL_markstack;
304	PL_markstack_max = c->markstack_max;	496	PL_markstack_max = PL_markstack + 16;
305	PL_scopestack = c->scopestack;
306	PL_scopestack_ix = c->scopestack_ix;
307	PL_scopestack_max = c->scopestack_max;
308	PL_savestack = c->savestack;
309	PL_savestack_ix = c->savestack_ix;
310	PL_savestack_max = c->savestack_max;
311	PL_retstack = c->retstack;
312	PL_retstack_ix = c->retstack_ix;
313	PL_retstack_max = c->retstack_max;
314	PL_curcop = c->curcop;
315		497
316	{	498	#ifdef SET_MARK_OFFSET
317	dSP;	499	SET_MARK_OFFSET;
318	CV *cv;
319
320	/* now do the ugly restore mess */
321	while ((cv = (CV *)POPs))
322	{
323	AV padlist = (AV )POPs;
324
325	put_padlist (cv);
326	CvPADLIST(cv) = padlist;
327	CvDEPTH(cv) = (I32)POPs;
328
329	#ifdef USE_THREADS
330	CvOWNER(cv) = (struct perl_thread *)POPs;
331	error does not work either
332	#endif	500	#endif
333	}
334		501
335	PUTBACK;	502	New(54,PL_scopestack,16,I32);
336	}	503	PL_scopestack_ix = 0;
337	}	504	PL_scopestack_max = 16;
338		505
339	/* 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	*/
340	STATIC void	518	STATIC void
341	destroy_stacks(pTHX)	519	destroy_stacks(pTHX)
342	{	520	{
343	/* die does this while calling POPSTACK, but I just don't see why. */	521	if (!IN_DESTRUCT)
344	/* OTOH, die does not have a memleak, but we do... */	522	{
345	dounwind(-1);
346
347	/* is this ugly, I ask? */	523	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)	524	LEAVE_SCOPE (0);
349	LEAVE;	525
		526	/* sure it is, but more important: is it correct?? :/ */
		527	FREETMPS;
		528	}
350		529
351	while (PL_curstackinfo->si_next)	530	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;	531	PL_curstackinfo = PL_curstackinfo->si_next;
353		532
354	while (PL_curstackinfo)	533	while (PL_curstackinfo)
355	{	534	{
356	PERL_SI *p = PL_curstackinfo->si_prev;	535	PERL_SI *p = PL_curstackinfo->si_prev;
357		536
		537	{
		538	dSP;
		539	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		540	PUTBACK; /* possibly superfluous */
		541	}
		542
		543	if (!IN_DESTRUCT)
		544	{
		545	dounwind(-1);
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	546	SvREFCNT_dec(PL_curstackinfo->si_stack);
		547	}
		548
359	Safefree(PL_curstackinfo->si_cxstack);	549	Safefree(PL_curstackinfo->si_cxstack);
360	Safefree(PL_curstackinfo);	550	Safefree(PL_curstackinfo);
361	PL_curstackinfo = p;	551	PL_curstackinfo = p;
362	}	552	}
363		553
364	if (PL_scopestack_ix != 0)
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367	(long)PL_scopestack_ix);
368	if (PL_savestack_ix != 0)
369	Perl_warner(aTHX_ WARN_INTERNAL,
370	"Unbalanced saves: %ld more saves than restores\n",
371	(long)PL_savestack_ix);
372	if (PL_tmps_floor != -1)
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
374	(long)PL_tmps_floor + 1);
375	/*
376	*/
377	Safefree(PL_tmps_stack);	554	Safefree(PL_tmps_stack);
378	Safefree(PL_markstack);	555	Safefree(PL_markstack);
379	Safefree(PL_scopestack);	556	Safefree(PL_scopestack);
380	Safefree(PL_savestack);	557	Safefree(PL_savestack);
381	Safefree(PL_retstack);	558	Safefree(PL_retstack);
382	}	559	}
383		560
384	#define SUB_INIT "Coro::State::_newcoro"	561	static void
		562	allocate_stack (Coro__State ctx, int alloc)
		563	{
		564	coro_stack *stack;
		565
		566	New (0, stack, 1, coro_stack);
		567
		568	stack->refcnt = 1;
		569	stack->usecnt = 1;
		570	stack->gencnt = ctx->gencnt = 0;
		571	if (alloc)
		572	{
		573	#if HAVE_MMAP
		574	stack->ssize = 16384 * sizeof (long); /* mmap should do allocate-on-write for us */
		575	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		576	if (stack->sptr == (void *)-1)
		577	#endif
		578	{
		579	/FIXME//D//* reasonable stack size! */
		580	stack->ssize = - (8192 * sizeof (long));
		581	New (0, stack->sptr, 8192, long);
		582	}
		583	}
		584	else
		585	stack->sptr = 0;
		586
		587	ctx->stack = stack;
		588	}
		589
		590	static void
		591	deallocate_stack (Coro__State ctx)
		592	{
		593	coro_stack *stack = ctx->stack;
		594
		595	ctx->stack = 0;
		596
		597	if (stack)
		598	{
		599	if (!--stack->refcnt)
		600	{
		601	#ifdef HAVE_MMAP
		602	if (stack->ssize > 0 && stack->sptr)
		603	munmap (stack->sptr, stack->ssize);
		604	else
		605	#endif
		606	Safefree (stack->sptr);
		607
		608	Safefree (stack);
		609	}
		610	else if (ctx->gencnt == stack->gencnt)
		611	--stack->usecnt;
		612	}
		613	}
		614
		615	static void
		616	setup_coro (void *arg)
		617	{
		618	/*
		619	* emulate part of the perl startup here.
		620	*/
		621	dSP;
		622	Coro__State ctx = (Coro__State)arg;
		623	SV sub_init = (SV )get_cv (SUB_INIT, FALSE);
		624
		625	coro_init_stacks (aTHX);
		626	/PL_curcop = 0;/
		627	/PL_in_eval = PL_in_eval;/ /* inherit */
		628	SvREFCNT_dec (GvAV (PL_defgv));
		629	GvAV (PL_defgv) = ctx->args; ctx->args = 0;
		630
		631	SPAGAIN;
		632
		633	if (ctx->stack)
		634	{
		635	ctx->cursp = 0;
		636
		637	PUSHMARK(SP);
		638	PUTBACK;
		639	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		640
		641	if (SvTRUE (ERRSV))
		642	croak (NULL);
		643	else
		644	croak ("FATAL: CCTXT coroutine returned!");
		645	}
		646	else
		647	{
		648	UNOP myop;
		649
		650	PL_op = (OP *)&myop;
		651
		652	Zero(&myop, 1, UNOP);
		653	myop.op_next = Nullop;
		654	myop.op_flags = OPf_WANT_VOID;
		655
		656	PUSHMARK(SP);
		657	XPUSHs (sub_init);
		658	/*
		659	* the next line is slightly wrong, as PL_op->op_next
		660	* is actually being executed so we skip the first op.
		661	* that doesn't matter, though, since it is only
		662	* pp_nextstate and we never return...
		663	* ah yes, and I don't care anyways ;)
		664	*/
		665	PUTBACK;
		666	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		667	SPAGAIN;
		668
		669	ENTER; /* necessary e.g. for dounwind */
		670	}
		671	}
		672
		673	static void
		674	continue_coro (void *arg)
		675	{
		676	/*
		677	* this is a _very_ stripped down perl interpreter ;)
		678	*/
		679	Coro__State ctx = (Coro__State)arg;
		680	JMPENV coro_start_env;
		681
		682	PL_top_env = &ctx->start_env;
		683
		684	ctx->cursp = 0;
		685	PL_op = PL_op->op_next;
		686	CALLRUNOPS(aTHX);
		687
		688	abort ();
		689	}
		690
		691	STATIC void
		692	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		693	{
		694	dSTACKLEVEL;
		695	static struct coro *xnext;
		696
		697	if (prev != next)
		698	{
		699	xnext = next;
		700
		701	if (next->mainstack)
		702	{
		703	SAVE (prev, flags);
		704	LOAD (next);
		705
		706	/* mark this state as in-use */
		707	next->mainstack = 0;
		708	next->tmps_ix = -2;
		709
		710	/* stacklevel changed? if yes, grab the stack for us! */
		711	if (flags & TRANSFER_SAVE_CCTXT)
		712	{
		713	if (!prev->stack)
		714	allocate_stack (prev, 0);
		715	else if (prev->cursp != stacklevel
		716	&& prev->stack->usecnt > 1)
		717	{
		718	prev->gencnt = ++prev->stack->gencnt;
		719	prev->stack->usecnt = 1;
		720	}
		721
		722	/* has our stack been invalidated? */
		723	if (next->stack && next->stack->gencnt != next->gencnt)
		724	{
		725	deallocate_stack (next);
		726	allocate_stack (next, 1);
		727	coro_create (&(next->stack->cctx),
		728	continue_coro, (void *)next,
		729	next->stack->sptr, labs (next->stack->ssize));
		730	}
		731
		732	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		733	/* don't add any code here */
		734	}
		735
		736	}
		737	else if (next->tmps_ix == -2)
		738	croak ("tried to transfer to running coroutine");
		739	else
		740	{
		741	SAVE (prev, -1); /* first get rid of the old state */
		742
		743	if (flags & TRANSFER_SAVE_CCTXT)
		744	{
		745	if (!prev->stack)
		746	allocate_stack (prev, 0);
		747
		748	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		749	{
		750	PL_top_env = &next->start_env;
		751
		752	setup_coro (next);
		753
		754	prev->stack->refcnt++;
		755	prev->stack->usecnt++;
		756	next->stack = prev->stack;
		757	next->gencnt = prev->gencnt;
		758	}
		759	else
		760	{
		761	assert (!next->stack);
		762	allocate_stack (next, 1);
		763	coro_create (&(next->stack->cctx),
		764	setup_coro, (void *)next,
		765	next->stack->sptr, labs (next->stack->ssize));
		766	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		767	/* don't add any code here */
		768	}
		769	}
		770	else
		771	setup_coro (next);
		772	}
		773
		774	/*
		775	* xnext is now either prev or next, depending on wether
		776	* we switched the c stack or not. that's why I use a global
		777	* variable, that should become thread-specific at one point.
		778	*/
		779	xnext->cursp = stacklevel;
		780	}
		781
		782	if (coro_mortal)
		783	{
		784	SvREFCNT_dec (coro_mortal);
		785	coro_mortal = 0;
		786	}
		787	}
		788
		789	#define SV_CORO(sv,func) \
		790	do { \
		791	if (SvROK (sv)) \
		792	sv = SvRV (sv); \
		793	\
		794	if (SvTYPE(sv) == SVt_PVHV) \
		795	{ \
		796	HE he = hv_fetch_ent((HV )sv, ucoro_state_sv, 0, ucoro_state_hash); \
		797	\
		798	if (!he) \
		799	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
		800	\
		801	(sv) = SvRV (HeVAL(he)); \
		802	} \
		803	\
		804	/* must also be changed inside Coro::Cont::yield */ \
		805	if (!SvOBJECT(sv) \|\| SvSTASH(sv) != coro_state_stash) \
		806	croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
		807	\
		808	} while(0)
		809
		810	#define SvSTATE(sv) (struct coro *)SvIV (sv)
		811
		812	static void
		813	api_transfer(pTHX_ SV prev, SV next, int flags)
		814	{
		815	SV_CORO (prev, "Coro::transfer");
		816	SV_CORO (next, "Coro::transfer");
		817
		818	transfer(aTHX_ SvSTATE(prev), SvSTATE(next), flags);
		819	}
		820
		821	/ Coro ******************************************************************/
		822
		823	#define PRIO_MAX 3
		824	#define PRIO_HIGH 1
		825	#define PRIO_NORMAL 0
		826	#define PRIO_LOW -1
		827	#define PRIO_IDLE -3
		828	#define PRIO_MIN -4
		829
		830	/* for Coro.pm */
		831	static GV coro_current, coro_idle;
		832	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		833	static int coro_nready;
		834
		835	static void
		836	coro_enq (SV *sv)
		837	{
		838	if (SvTYPE (sv) == SVt_PVHV)
		839	{
		840	SV *xprio = hv_fetch ((HV )sv, "prio", 4, 0);
		841	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		842
		843	prio = prio > PRIO_MAX ? PRIO_MAX
		844	: prio < PRIO_MIN ? PRIO_MIN
		845	: prio;
		846
		847	av_push (coro_ready [prio - PRIO_MIN], sv);
		848	coro_nready++;
		849
		850	return;
		851	}
		852
		853	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		854	}
		855
		856	static SV *
		857	coro_deq (int min_prio)
		858	{
		859	int prio = PRIO_MAX - PRIO_MIN;
		860
		861	min_prio -= PRIO_MIN;
		862	if (min_prio < 0)
		863	min_prio = 0;
		864
		865	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		866	if (av_len (coro_ready[prio]) >= 0)
		867	{
		868	coro_nready--;
		869	return av_shift (coro_ready[prio]);
		870	}
		871
		872	return 0;
		873	}
		874
		875	static void
		876	api_ready (SV *coro)
		877	{
		878	if (SvROK (coro))
		879	coro = SvRV (coro);
		880
		881	coro_enq (SvREFCNT_inc (coro));
		882	}
		883
		884	static void
		885	api_schedule (void)
		886	{
		887	SV prev, next;
		888
		889	prev = SvRV (GvSV (coro_current));
		890	next = coro_deq (PRIO_MIN);
		891
		892	if (!next)
		893	next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
		894
		895	/* free this only after the transfer */
		896	coro_mortal = prev;
		897	SV_CORO (prev, "Coro::schedule");
		898
		899	SvRV (GvSV (coro_current)) = next;
		900
		901	SV_CORO (next, "Coro::schedule");
		902
		903	transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		904	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		905	}
		906
		907	static void
		908	api_cede (void)
		909	{
		910	coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
		911
		912	api_schedule ();
		913	}
385		914
386	MODULE = Coro::State PACKAGE = Coro::State	915	MODULE = Coro::State PACKAGE = Coro::State
387		916
388	PROTOTYPES: ENABLE	917	PROTOTYPES: ENABLE
389		918
390	BOOT:	919	BOOT:
		920	{ /* {} necessary for stoopid perl-5.6.x */
		921	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		922	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		923	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		924
		925	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		926	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		927	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		928	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		929
391	if (!padlist_cache)	930	if (!padlist_cache)
392	padlist_cache = newHV ();	931	padlist_cache = newHV ();
		932
		933	main_mainstack = PL_mainstack;
		934
		935	coroapi.ver = CORO_API_VERSION;
		936	coroapi.transfer = api_transfer;
		937	}
393		938
394	Coro::State	939	Coro::State
395	_newprocess(args)	940	_newprocess(args)
396	SV * args	941	SV * args
397	PROTOTYPE: $	942	PROTOTYPE: $
398	CODE:	943	CODE:
399	Coro__State coro;	944	Coro__State coro;
400		945
401	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	946	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");	947	croak ("Coro::State::_newprocess expects an arrayref");
403		948
404	New (0, coro, 1, struct coro);	949	Newz (0, coro, 1, struct coro);
405		950
		951	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406	coro->mainstack = 0; /* actual work is done inside transfer */	952	coro->mainstack = 0; /* actual work is done inside transfer */
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	953	coro->stack = 0;
		954
		955	/* same as JMPENV_BOOTSTRAP */
		956	/* we might be able to recycle start_env, but safe is safe */
		957	//Zero(&coro->start_env, 1, JMPENV);
		958	coro->start_env.je_ret = -1;
		959	coro->start_env.je_mustcatch = TRUE;
408		960
409	RETVAL = coro;	961	RETVAL = coro;
410	OUTPUT:	962	OUTPUT:
411	RETVAL	963	RETVAL
412		964
413	void	965	void
414	transfer(prev,next)	966	transfer(prev, next, flags)
415	Coro::State_or_hashref prev	967	SV *prev
416	Coro::State_or_hashref next	968	SV *next
		969	int flags
		970	PROTOTYPE: @
417	CODE:	971	CODE:
418
419	if (prev != next)
420	{
421	/*
422	* this could be done in newprocess which would lead to
423	* extremely elegant and fast (just SAVE/LOAD)
424	* code here, but lazy allocation of stacks has also
425	* some virtues and the overhead of the if() is nil.
426	*/
427	if (next->mainstack)
428	{
429	SAVE (prev);
430	LOAD (next);
431	/* mark this state as in-use */
432	next->mainstack = 0;
433	next->tmps_ix = -2;
434	}
435	else if (next->tmps_ix == -2)
436	{
437	croak ("tried to transfer to running coroutine");
438	}
439	else
440	{
441	SAVE (prev);
442
443	/*
444	* emulate part of the perl startup here.
445	*/
446	UNOP myop;
447
448	init_stacks (); /* from perl.c */
449	PL_op = (OP *)&myop;
450	/PL_curcop = 0;/
451	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
452
453	SPAGAIN;
454	Zero(&myop, 1, UNOP);
455	myop.op_next = Nullop;
456	myop.op_flags = OPf_WANT_VOID;
457
458	PUSHMARK(SP);
459	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	PUTBACK;	972	PUTBACK;
461	/*	973	SV_CORO (next, "Coro::transfer");
462	* the next line is slightly wrong, as PL_op->op_next	974	SV_CORO (prev, "Coro::transfer");
463	* is actually being executed so we skip the first op.	975	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
464	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...
466	*/
467	PL_op = Perl_pp_entersub(aTHX);
468	SPAGAIN;	976	SPAGAIN;
469
470	ENTER;
471	}
472	}
473		977
474	void	978	void
475	DESTROY(coro)	979	DESTROY(coro)
476	Coro::State coro	980	Coro::State coro
477	CODE:	981	CODE:
478		982
479	if (coro->mainstack)	983	if (coro->mainstack && coro->mainstack != main_mainstack)
480	{	984	{
481	struct coro temp;	985	struct coro temp;
482		986
		987	PUTBACK;
483	SAVE(aTHX_ (&temp));	988	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
484	LOAD(aTHX_ coro);	989	LOAD(aTHX_ coro);
		990	SPAGAIN;
485		991
486	destroy_stacks ();	992	destroy_stacks (aTHX);
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488		993
489	LOAD((&temp));	994	LOAD((&temp)); /* this will get rid of defsv etc.. */
		995	SPAGAIN;
		996
		997	coro->mainstack = 0;
490	}	998	}
491		999
		1000	deallocate_stack (coro);
492	SvREFCNT_dec (coro->args);	1001	SvREFCNT_dec (coro->args);
493	Safefree (coro);	1002	Safefree (coro);
494		1003
		1004	void
		1005	_exit(code)
		1006	int code
		1007	PROTOTYPE: $
		1008	CODE:
		1009	_exit (code);
495		1010
		1011	MODULE = Coro::State PACKAGE = Coro::Cont
		1012
		1013	# this is slightly dirty (should expose a c-level api)
		1014
		1015	void
		1016	yield(...)
		1017	PROTOTYPE: @
		1018	CODE:
		1019	static SV *returnstk;
		1020	SV *sv;
		1021	AV *defav = GvAV (PL_defgv);
		1022	struct coro prev, next;
		1023
		1024	if (!returnstk)
		1025	returnstk = SvRV ((SV *)get_sv ("Coro::Cont::return", FALSE));
		1026
		1027	/* set up @_ -- ugly */
		1028	av_clear (defav);
		1029	av_fill (defav, items - 1);
		1030	while (items--)
		1031	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1032
		1033	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		1034	sv = av_pop ((AV *)SvRV (returnstk));
		1035	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		1036	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		1037	SvREFCNT_dec (sv);
		1038
		1039	transfer(aTHX_ prev, next, 0);
		1040
		1041	MODULE = Coro::State PACKAGE = Coro
		1042
		1043	# this is slightly dirty (should expose a c-level api)
		1044
		1045	BOOT:
		1046	{
		1047	int i;
		1048	HV *stash = gv_stashpv ("Coro", TRUE);
		1049
		1050	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1051	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1052	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1053	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1054	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1055	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1056
		1057	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1058	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1059
		1060	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1061	coro_ready[i] = newAV ();
		1062
		1063	{
		1064	SV *sv = perl_get_sv("Coro::API", 1);
		1065
		1066	coroapi.schedule = api_schedule;
		1067	coroapi.cede = api_cede;
		1068	coroapi.ready = api_ready;
		1069	coroapi.nready = &coro_nready;
		1070	coroapi.current = coro_current;
		1071
		1072	GCoroAPI = &coroapi;
		1073	sv_setiv(sv, (IV)&coroapi);
		1074	SvREADONLY_on(sv);
		1075	}
		1076	}
		1077
		1078	#if !PERL_MICRO
		1079
		1080	void
		1081	ready(self)
		1082	SV * self
		1083	PROTOTYPE: $
		1084	CODE:
		1085	api_ready (self);
		1086
		1087	#endif
		1088
		1089	int
		1090	nready(...)
		1091	PROTOTYPE:
		1092	CODE:
		1093	RETVAL = coro_nready;
		1094	OUTPUT:
		1095	RETVAL
		1096
		1097	void
		1098	schedule(...)
		1099	PROTOTYPE:
		1100	CODE:
		1101	api_schedule ();
		1102
		1103	void
		1104	cede(...)
		1105	PROTOTYPE:
		1106	CODE:
		1107	api_cede ();
		1108

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs. Revision 1.54 by pcg, Sat Mar 13 06:45:04 2004 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.54 by pcg, Sat Mar 13 06:45:04 2004 UTC