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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs. Revision 1.42 by root, Mon Dec 31 20:41:45 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.42 by root, Mon Dec 31 20:41:45 2001 UTC