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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs. Revision 1.32 by root, Sun Aug 26 17:01:54 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.32 by root, Sun Aug 26 17:01:54 2001 UTC