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

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.28 by root, Sat Aug 25 21:32:05 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.28 by root, Sat Aug 25 21:32:05 2001 UTC