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

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.55 by pcg, Thu Apr 1 02:29:05 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.55 by pcg, Thu Apr 1 02:29:05 2004 UTC