[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.24 by root, Tue Aug 14 14:56:22 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 */
		22
		23	#define SUB_INIT "Coro::State::initialize"
		24	#define UCORO_STATE "_coro_state"
		25
		26	/* The next macro should delcare 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
		199	#ifdef MAY_FLUSH
143	STATIC AV *	200	STATIC AV *
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))
…		…
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) SB load_state(aTHX_ (state)); SPAGAIN; SE
		276	#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
		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
		413	/* I have not the slightest idea of why av_reify is necessary */
		414	/* but if it's missing the defav contents magically get replaced sometimes */
		415	if (c->defav)
		416	av_reify (c->defav);
		417
233	c->dowarn = PL_dowarn;	418	c->dowarn = PL_dowarn;
234	c->defav = GvAV (PL_defgv);	419	c->in_eval = PL_in_eval;
		420
235	c->curstackinfo = PL_curstackinfo;	421	c->curstackinfo = PL_curstackinfo;
236	c->curstack = PL_curstack;	422	c->curstack = PL_curstack;
237	c->mainstack = PL_mainstack;	423	c->mainstack = PL_mainstack;
238	c->stack_sp = PL_stack_sp;	424	c->stack_sp = PL_stack_sp;
239	c->op = PL_op;	425	c->op = PL_op;
…		…
255	c->savestack_max = PL_savestack_max;	441	c->savestack_max = PL_savestack_max;
256	c->retstack = PL_retstack;	442	c->retstack = PL_retstack;
257	c->retstack_ix = PL_retstack_ix;	443	c->retstack_ix = PL_retstack_ix;
258	c->retstack_max = PL_retstack_max;	444	c->retstack_max = PL_retstack_max;
259	c->curcop = PL_curcop;	445	c->curcop = PL_curcop;
		446	c->top_env = PL_top_env;
		447	}
		448
		449	/*
		450	* allocate various perl stacks. This is an exact copy
		451	* of perl.c:init_stacks, except that it uses less memory
		452	* on the assumption that coroutines do not usually need
		453	* a lot of stackspace.
		454	*/
		455	STATIC void
		456	coro_init_stacks (pTHX)
		457	{
		458	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
		459	PL_curstackinfo->si_type = PERLSI_MAIN;
		460	PL_curstack = PL_curstackinfo->si_stack;
		461	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		462
		463	PL_stack_base = AvARRAY(PL_curstack);
		464	PL_stack_sp = PL_stack_base;
		465	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
		466
		467	New(50,PL_tmps_stack,96,SV*);
		468	PL_tmps_floor = -1;
		469	PL_tmps_ix = -1;
		470	PL_tmps_max = 96;
		471
		472	New(54,PL_markstack,16,I32);
		473	PL_markstack_ptr = PL_markstack;
		474	PL_markstack_max = PL_markstack + 16;
		475
		476	SET_MARK_OFFSET;
		477
		478	New(54,PL_scopestack,16,I32);
		479	PL_scopestack_ix = 0;
		480	PL_scopestack_max = 16;
		481
		482	New(54,PL_savestack,96,ANY);
		483	PL_savestack_ix = 0;
		484	PL_savestack_max = 96;
		485
		486	New(54,PL_retstack,8,OP*);
		487	PL_retstack_ix = 0;
		488	PL_retstack_max = 8;
		489	}
		490
		491	/*
		492	* destroy the stacks, the callchain etc...
		493	* still there is a memleak of 128 bytes...
		494	*/
		495	STATIC void
		496	destroy_stacks(pTHX)
		497	{
		498	/* is this ugly, I ask? */
		499	while (PL_scopestack_ix)
		500	LEAVE;
		501
		502	/* sure it is, but more important: is it correct?? :/ */
		503	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		504	FREETMPS;
		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 (PL_main_cv != Nullcv) /* don't during destruction. hack? */
		520	dounwind(-1);
		521
		522	SvREFCNT_dec(PL_curstackinfo->si_stack);
		523	Safefree(PL_curstackinfo->si_cxstack);
		524	Safefree(PL_curstackinfo);
		525	PL_curstackinfo = p;
		526	}
		527
		528	Safefree(PL_tmps_stack);
		529	Safefree(PL_markstack);
		530	Safefree(PL_scopestack);
		531	Safefree(PL_savestack);
		532	Safefree(PL_retstack);
260	}	533	}
261		534
262	static void	535	static void
263	LOAD(pTHX_ Coro__State c)	536	allocate_stack (Coro__State ctx, int alloc)
264	{	537	{
265	PL_dowarn = c->dowarn;	538	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		539
293	{	540	New (0, stack, 1, coro_stack);
294	dSP;
295	CV *cv;
296		541
297	/* now do the ugly restore mess */	542	stack->refcnt = 1;
298	while ((cv = (CV *)POPs))	543	stack->usecnt = 1;
		544	stack->gencnt = ctx->gencnt = 0;
		545	if (alloc)
299	{	546	{
300	AV padlist = (AV )POPs;	547	#ifdef HAVE_MMAP
301		548	stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
302	unuse_padlist (CvPADLIST(cv));	549	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANON, 0, 0);
303	CvPADLIST(cv) = padlist;	550	if (stack->sptr == (void *)-1)
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	551	#endif
		552	{
		553	/FIXME//D//* reasonable stack size! */
		554	stack->ssize = -4096 * sizeof (long);
		555	New (0, stack->sptr, 4096, long);
310	}	556	}
		557	}
		558	else
		559	stack->sptr = 0;
311		560
		561	ctx->stack = stack;
		562	}
		563
		564	static void
		565	deallocate_stack (Coro__State ctx)
		566	{
		567	coro_stack *stack = ctx->stack;
		568
		569	ctx->stack = 0;
		570
		571	if (stack)
		572	{
		573	if (!--stack->refcnt)
		574	{
		575	#ifdef HAVE_MMAP
		576	if (stack->ssize > 0 && stack->sptr)
		577	munmap (stack->sptr, stack->ssize);
		578	else
		579	#else
		580	Safefree (stack->sptr);
		581	#endif
		582	Safefree (stack);
		583	}
		584	else if (ctx->gencnt == stack->gencnt)
		585	--stack->usecnt;
		586	}
		587	}
		588
		589	static void
		590	setup_coro (void *arg)
		591	{
		592	/*
		593	* emulate part of the perl startup here.
		594	*/
		595	dSP;
		596	Coro__State ctx = (Coro__State)arg;
		597	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
		598
		599	coro_init_stacks (aTHX);
		600	/PL_curcop = 0;/
		601	/PL_in_eval = PL_in_eval;/ /* inherit */
		602	SvREFCNT_dec (GvAV (PL_defgv));
		603	GvAV (PL_defgv) = ctx->args;
		604
		605	SPAGAIN;
		606
		607	if (ctx->stack)
		608	{
		609	ctx->cursp = 0;
		610
		611	PUSHMARK(SP);
312	PUTBACK;	612	PUTBACK;
		613	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		614
		615	if (SvTRUE (ERRSV))
		616	croak (NULL);
		617	else
		618	croak ("FATAL: CCTXT coroutine returned!");
313	}	619	}
314	}	620	else
		621	{
		622	UNOP myop;
315		623
316	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	624	PL_op = (OP *)&myop;
		625
		626	Zero(&myop, 1, UNOP);
		627	myop.op_next = Nullop;
		628	myop.op_flags = OPf_WANT_VOID;
		629
		630	PUSHMARK(SP);
		631	XPUSHs (sub_init);
		632	/*
		633	* the next line is slightly wrong, as PL_op->op_next
		634	* is actually being executed so we skip the first op.
		635	* that doesn't matter, though, since it is only
		636	* pp_nextstate and we never return...
		637	* ah yes, and I don't care anyways ;)
		638	*/
		639	PUTBACK;
		640	PL_op = pp_entersub();
		641	SPAGAIN;
		642
		643	ENTER; /* necessary e.g. for dounwind */
		644	}
		645	}
		646
		647	static void
		648	continue_coro (void *arg)
		649	{
		650	/*
		651	* this is a _very_ stripped down perl interpreter ;)
		652	*/
		653	Coro__State ctx = (Coro__State)arg;
		654
		655	/FIXME//* must set up top_env here */
		656	ctx->cursp = 0;
		657	PL_op = PL_op->op_next;
		658	CALLRUNOPS(aTHX);
		659
		660	abort ();
		661	}
		662
317	STATIC void	663	STATIC void
318	S_nuke_stacks(pTHX)	664	transfer(pTHX_ struct coro prev, struct coro next, int flags)
319	{	665	{
320	while (PL_curstackinfo->si_next)	666	dSP;
321	PL_curstackinfo = PL_curstackinfo->si_next;	667	dSTACKLEVEL;
322	while (PL_curstackinfo) {	668
323	PERL_SI *p = PL_curstackinfo->si_prev;	669	if (prev != next)
324	/* curstackinfo->si_stack got nuked by sv_free_arenas() */	670	{
325	Safefree(PL_curstackinfo->si_cxstack);	671	if (next->mainstack)
326	Safefree(PL_curstackinfo);	672	{
327	PL_curstackinfo = p;	673	SAVE (prev, flags);
		674	LOAD (next);
		675
		676	/* mark this state as in-use */
		677	next->mainstack = 0;
		678	next->tmps_ix = -2;
		679
		680	/* stacklevel changed? if yes, grab the stack for us! */
		681	if (flags & TRANSFER_SAVE_CCTXT)
		682	{
		683	if (!prev->stack)
		684	allocate_stack (prev, 0);
		685	else if (prev->cursp != stacklevel
		686	&& prev->stack->usecnt > 1)
		687	{
		688	prev->gencnt = ++prev->stack->gencnt;
		689	prev->stack->usecnt = 1;
		690	}
		691
		692	/* has our stack been invalidated? */
		693	if (next->stack && next->stack->gencnt != next->gencnt)
		694	{
		695	deallocate_stack (next);
		696	allocate_stack (next, 1);
		697	coro_create (&(next->stack->cctx),
		698	continue_coro, (void *)next,
		699	next->stack->sptr, labs (next->stack->ssize));
		700	}
		701
		702	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		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	}
		734	}
		735	else
		736	setup_coro (next);
		737	}
328	}	738	}
329	Safefree(PL_tmps_stack);
330	Safefree(PL_markstack);
331	Safefree(PL_scopestack);
332	Safefree(PL_savestack);
333	Safefree(PL_retstack);
334	}
335		739
336	#define SUB_INIT "Coro::State::_newcoro"	740	next->cursp = stacklevel;
		741	}
		742
		743	static struct coro *
		744	sv_to_coro (SV arg, const char funcname, const char *varname)
		745	{
		746	if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV)
		747	{
		748	HE he = hv_fetch_ent((HV )SvRV(arg), ucoro_state_sv, 0, ucoro_state_hash);
		749
		750	if (!he)
		751	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", funcname, varname);
		752
		753	arg = HeVAL(he);
		754	}
		755
		756	/* must also be changed inside Coro::Cont::yield */
		757	if (SvROK(arg) && SvSTASH(SvRV(arg)) == coro_state_stash)
		758	return (struct coro ) SvIV((SV)SvRV(arg));
		759	else
		760	croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname);
		761	}
		762
		763	static void
		764	api_transfer(pTHX_ SV prev, SV next, int flags)
		765	{
		766	transfer(aTHX_ sv_to_coro (prev, "Coro::transfer", "prev"),
		767	sv_to_coro (next, "Coro::transfer", "next"),
		768	flags);
		769	}
		770
		771	/ Coro ******************************************************************/
		772
		773	#define PRIO_MAX 3
		774	#define PRIO_HIGH 1
		775	#define PRIO_NORMAL 0
		776	#define PRIO_LOW -1
		777	#define PRIO_IDLE -3
		778	#define PRIO_MIN -4
		779
		780	/* for Coro.pm */
		781	static GV coro_current, coro_idle;
		782	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		783
		784	static void
		785	coro_enq (SV *sv)
		786	{
		787	if (SvROK (sv))
		788	{
		789	SV *hv = SvRV (sv);
		790	if (SvTYPE (hv) == SVt_PVHV)
		791	{
		792	SV *xprio = hv_fetch ((HV )hv, "prio", 4, 0);
		793	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		794
		795	prio = prio > PRIO_MAX ? PRIO_MAX
		796	: prio < PRIO_MIN ? PRIO_MIN
		797	: prio;
		798
		799	av_push (coro_ready [prio - PRIO_MIN], sv);
		800
		801	return;
		802	}
		803	}
		804
		805	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		806	}
		807
		808	static SV *
		809	coro_deq (int min_prio)
		810	{
		811	int prio = PRIO_MAX - PRIO_MIN;
		812
		813	min_prio -= PRIO_MIN;
		814	if (min_prio < 0)
		815	min_prio = 0;
		816
		817	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		818	if (av_len (coro_ready[prio]) >= 0)
		819	return av_shift (coro_ready[prio]);
		820
		821	return 0;
		822	}
		823
		824	static void
		825	api_ready (SV *coro)
		826	{
		827	coro_enq (SvREFCNT_inc (coro));
		828	}
		829
		830	static void
		831	api_schedule (int cede)
		832	{
		833	SV prev, next;
		834
		835	prev = GvSV (coro_current);
		836
		837	if (cede)
		838	coro_enq (SvREFCNT_inc (prev));
		839
		840	next = coro_deq (PRIO_MIN);
		841
		842	if (!next)
		843	next = SvREFCNT_inc (GvSV (coro_idle));
		844
		845	GvSV (coro_current) = SvREFCNT_inc (next);
		846	transfer (sv_to_coro (prev, "Coro::schedule", "current coroutine"),
		847	sv_to_coro (next, "Coro::schedule", "next coroutine"),
		848	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		849	SvREFCNT_dec (next);
		850	SvREFCNT_dec (prev);
		851	}
337		852
338	MODULE = Coro::State PACKAGE = Coro::State	853	MODULE = Coro::State PACKAGE = Coro::State
339		854
340	PROTOTYPES: ENABLE	855	PROTOTYPES: ENABLE
341		856
342	BOOT:	857	BOOT:
		858	{ /* {} necessary for stoopid perl-5.6.x */
		859	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		860	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		861	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		862
		863	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		864	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		865	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		866	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		867
343	if (!padlist_cache)	868	if (!padlist_cache)
344	padlist_cache = newHV ();	869	padlist_cache = newHV ();
		870
		871	main_mainstack = PL_mainstack;
		872
		873	{
		874	SV *sv = perl_get_sv("Coro::API", 1);
		875
		876	coroapi.ver = CORO_API_VERSION - 1;
		877	coroapi.transfer = api_transfer;
		878	coroapi.schedule = api_schedule;
		879	coroapi.ready = api_ready;
		880
		881	GCoroAPI = &coroapi;
		882	sv_setiv(sv, (IV)&coroapi);
		883	SvREADONLY_on(sv);
		884	}
		885	}
345		886
346	Coro::State	887	Coro::State
347	_newprocess(args)	888	_newprocess(args)
348	SV * args	889	SV * args
349	PROTOTYPE: $	890	PROTOTYPE: $
350	CODE:	891	CODE:
351	Coro__State coro;	892	Coro__State coro;
352		893
353	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	894	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
354	croak ("Coro::State::newprocess expects an arrayref");	895	croak ("Coro::State::_newprocess expects an arrayref");
355		896
356	New (0, coro, 1, struct coro);	897	New (0, coro, 1, struct coro);
357		898
		899	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358	coro->mainstack = 0; /* actual work is done inside transfer */	900	coro->mainstack = 0; /* actual work is done inside transfer */
359	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	901	coro->stack = 0;
360		902
361	RETVAL = coro;	903	RETVAL = coro;
362	OUTPUT:	904	OUTPUT:
363	RETVAL	905	RETVAL
364		906
365	void	907	void
366	transfer(prev,next)	908	transfer(prev, next, flags)
367	Coro::State_or_hashref prev	909	Coro::State_or_hashref prev
368	Coro::State_or_hashref next	910	Coro::State_or_hashref next
		911	int flags
		912	PROTOTYPE: @
369	CODE:	913	CODE:
370
371	if (prev != next)
372	{
373	PUTBACK;	914	PUTBACK;
374	SAVE (aTHX_ prev);	915	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;	916	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		917
421	void	918	void
422	DESTROY(coro)	919	DESTROY(coro)
423	Coro::State coro	920	Coro::State coro
424	CODE:	921	CODE:
425		922
426	if (coro->mainstack)	923	if (coro->mainstack && coro->mainstack != main_mainstack)
427	{	924	{
428	struct coro temp;	925	struct coro temp;
429		926
430	PUTBACK;
431	SAVE(aTHX_ (&temp));	927	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432	LOAD(aTHX_ coro);	928	LOAD(aTHX_ coro);
433		929
434	S_nuke_stacks ();	930	destroy_stacks (aTHX);
435	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436		931
437	LOAD((&temp));	932	LOAD((&temp)); /* this will get rid of defsv etc.. */
438	SPAGAIN;	933
		934	coro->mainstack = 0;
439	}	935	}
440		936
441	SvREFCNT_dec (coro->args);	937	deallocate_stack (coro);
		938
442	Safefree (coro);	939	Safefree (coro);
443		940
		941	void
		942	flush()
		943	CODE:
		944	#ifdef MAY_FLUSH
		945	flush_padlist_cache ();
		946	#endif
444		947
		948	void
		949	_exit(code)
		950	int code
		951	PROTOTYPE: $
		952	CODE:
		953	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		954	_exit (code);
		955	#else
		956	signal (SIGTERM, SIG_DFL);
		957	raise (SIGTERM);
		958	exit (code);
		959	#endif
		960
		961	MODULE = Coro::State PACKAGE = Coro::Cont
		962
		963	# this is slightly dirty (should expose a c-level api)
		964
		965	void
		966	yield(...)
		967	PROTOTYPE: @
		968	CODE:
		969	static SV *returnstk;
		970	SV *sv;
		971	AV *defav = GvAV (PL_defgv);
		972	struct coro prev, next;
		973
		974	if (!returnstk)
		975	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		976
		977	/* set up @_ -- ugly */
		978	av_clear (defav);
		979	av_fill (defav, items - 1);
		980	while (items--)
		981	av_store (defav, items, SvREFCNT_inc (ST(items)));
		982
		983	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		984	sv = av_pop ((AV *)SvRV (returnstk));
		985	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		986	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		987	SvREFCNT_dec (sv);
		988
		989	transfer(aTHX_ prev, next, 0);
		990
		991	MODULE = Coro::State PACKAGE = Coro
		992
		993	# this is slightly dirty (should expose a c-level api)
		994
		995	BOOT:
		996	{
		997	int i;
		998	HV *stash = gv_stashpv ("Coro", TRUE);
		999
		1000	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1001	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1002	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1003	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1004	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1005	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1006
		1007	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1008	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1009
		1010	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1011	coro_ready[i] = newAV ();
		1012	}
		1013
		1014	void
		1015	ready(self)
		1016	SV * self
		1017	CODE:
		1018	api_ready (self);
		1019
		1020	void
		1021	schedule(...)
		1022	ALIAS:
		1023	cede = 1
		1024	CODE:
		1025	api_schedule (ix);
		1026

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.24 by root, Tue Aug 14 14:56:22 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.24 by root, Tue Aug 14 14:56:22 2001 UTC