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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.31 by root, Sun Aug 26 16:36:08 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(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	static void	443	/*
283	LOAD(pTHX_ Coro__State c)	444	* allocate various perl stacks. This is an exact copy
		445	* of perl.c:init_stacks, except that it uses less memory
		446	* on the assumption that coroutines do not usually need
		447	* a lot of stackspace.
		448	*/
		449	STATIC void
		450	coro_init_stacks (pTHX)
284	{	451	{
285	PL_dowarn = c->dowarn;	452	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	453	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	454	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	455	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	456
		457	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	458	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	459	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	460
293	PL_stack_base = c->stack_base;	461	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	462	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	463	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	464	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	465
298	PL_tmps_max = c->tmps_max;	466	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	467	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	468	PL_markstack_max = PL_markstack + 16;
302	PL_scopestack = c->scopestack;
303	PL_scopestack_ix = c->scopestack_ix;
304	PL_scopestack_max = c->scopestack_max;
305	PL_savestack = c->savestack;
306	PL_savestack_ix = c->savestack_ix;
307	PL_savestack_max = c->savestack_max;
308	PL_retstack = c->retstack;
309	PL_retstack_ix = c->retstack_ix;
310	PL_retstack_max = c->retstack_max;
311	PL_curcop = c->curcop;
312		469
313	{	470	SET_MARK_OFFSET;
314	dSP;
315	CV *cv;
316		471
317	/* now do the ugly restore mess */	472	New(54,PL_scopestack,16,I32);
318	while ((cv = (CV *)POPs))	473	PL_scopestack_ix = 0;
319	{	474	PL_scopestack_max = 16;
320	AV padlist = (AV )POPs;
321		475
322	put_padlist (cv);	476	New(54,PL_savestack,96,ANY);
323	CvPADLIST(cv) = padlist;	477	PL_savestack_ix = 0;
324	CvDEPTH(cv) = (I32)POPs;	478	PL_savestack_max = 96;
325		479
326	#ifdef USE_THREADS	480	New(54,PL_retstack,8,OP*);
327	CvOWNER(cv) = (struct perl_thread *)POPs;	481	PL_retstack_ix = 0;
328	error does not work either	482	PL_retstack_max = 8;
329	#endif
330	}
331
332	PUTBACK;
333	}
334	}	483	}
335		484
336	/* 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	*/
337	STATIC void	489	STATIC void
338	destroy_stacks(pTHX)	490	destroy_stacks(pTHX)
339	{	491	{
340	/* die does this while calling POPSTACK, but I just don't see why. */	492	int destruct = PL_main_cv != Nullcv;
341	dounwind(-1);
342		493
		494	if (destruct)
		495	{
343	/* is this ugly, I ask? */	496	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)	497	while (PL_scopestack_ix)
345	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	}
346		504
347	while (PL_curstackinfo->si_next)	505	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;	506	PL_curstackinfo = PL_curstackinfo->si_next;
349		507
350	while (PL_curstackinfo)	508	while (PL_curstackinfo)
351	{	509	{
352	PERL_SI *p = PL_curstackinfo->si_prev;	510	PERL_SI *p = PL_curstackinfo->si_prev;
353		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);
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	521	SvREFCNT_dec(PL_curstackinfo->si_stack);
		522	}
		523
355	Safefree(PL_curstackinfo->si_cxstack);	524	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);	525	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;	526	PL_curstackinfo = p;
358	}	527	}
359		528
360	if (PL_scopestack_ix != 0)
361	Perl_warner(aTHX_ WARN_INTERNAL,
362	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
363	(long)PL_scopestack_ix);
364	if (PL_savestack_ix != 0)
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced saves: %ld more saves than restores\n",
367	(long)PL_savestack_ix);
368	if (PL_tmps_floor != -1)
369	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
370	(long)PL_tmps_floor + 1);
371	/*
372	*/
373	Safefree(PL_tmps_stack);	529	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);	530	Safefree(PL_markstack);
375	Safefree(PL_scopestack);	531	Safefree(PL_scopestack);
376	Safefree(PL_savestack);	532	Safefree(PL_savestack);
377	Safefree(PL_retstack);	533	Safefree(PL_retstack);
378	}	534	}
379		535
380	#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
		656	/FIXME//* must set up top_env here */
		657	ctx->cursp = 0;
		658	PL_op = PL_op->op_next;
		659	CALLRUNOPS(aTHX);
		660
		661	abort ();
		662	}
		663
		664	STATIC void
		665	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		666	{
		667	dSTACKLEVEL;
		668	static struct coro *xnext;
		669
		670	if (prev != next)
		671	{
		672	xnext = next;
		673
		674	if (next->mainstack)
		675	{
		676	SAVE (prev, flags);
		677	LOAD (next);
		678
		679	/* mark this state as in-use */
		680	next->mainstack = 0;
		681	next->tmps_ix = -2;
		682
		683	/* stacklevel changed? if yes, grab the stack for us! */
		684	if (flags & TRANSFER_SAVE_CCTXT)
		685	{
		686	if (!prev->stack)
		687	allocate_stack (prev, 0);
		688	else if (prev->cursp != stacklevel
		689	&& prev->stack->usecnt > 1)
		690	{
		691	prev->gencnt = ++prev->stack->gencnt;
		692	prev->stack->usecnt = 1;
		693	}
		694
		695	/* has our stack been invalidated? */
		696	if (next->stack && next->stack->gencnt != next->gencnt)
		697	{
		698	deallocate_stack (next);
		699	allocate_stack (next, 1);
		700	coro_create (&(next->stack->cctx),
		701	continue_coro, (void *)next,
		702	next->stack->sptr, labs (next->stack->ssize));
		703	}
		704
		705	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		706	/* don't add any code here */
		707	}
		708
		709	}
		710	else if (next->tmps_ix == -2)
		711	croak ("tried to transfer to running coroutine");
		712	else
		713	{
		714	SAVE (prev, -1); /* first get rid of the old state */
		715
		716	if (flags & TRANSFER_SAVE_CCTXT)
		717	{
		718	if (!prev->stack)
		719	allocate_stack (prev, 0);
		720
		721	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		722	{
		723	setup_coro (next);
		724
		725	prev->stack->refcnt++;
		726	prev->stack->usecnt++;
		727	next->stack = prev->stack;
		728	next->gencnt = prev->gencnt;
		729	}
		730	else
		731	{
		732	allocate_stack (next, 1);
		733	coro_create (&(next->stack->cctx),
		734	setup_coro, (void *)next,
		735	next->stack->sptr, labs (next->stack->ssize));
		736	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		737	/* don't add any code here */
		738	}
		739	}
		740	else
		741	setup_coro (next);
		742	}
		743	}
		744
		745	/*
		746	* xnext is now either prev or next, depending on wether
		747	* we switched the c stack or not. that's why i use a global
		748	* variable, that should become thread-specific at one point.
		749	*/
		750	xnext->cursp = stacklevel;
		751	}
		752
		753	static struct coro *
		754	sv_to_coro (SV arg, const char funcname, const char *varname)
		755	{
		756	if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV)
		757	{
		758	HE he = hv_fetch_ent((HV )SvRV(arg), ucoro_state_sv, 0, ucoro_state_hash);
		759
		760	if (!he)
		761	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", funcname, varname);
		762
		763	arg = HeVAL(he);
		764	}
		765
		766	/* must also be changed inside Coro::Cont::yield */
		767	if (SvROK(arg) && SvSTASH(SvRV(arg)) == coro_state_stash)
		768	return (struct coro ) SvIV((SV)SvRV(arg));
		769
		770	croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname);
		771	/NORETURN/
		772	}
		773
		774	static void
		775	api_transfer(pTHX_ SV prev, SV next, int flags)
		776	{
		777	transfer(aTHX_
		778	sv_to_coro (prev, "Coro::transfer", "prev"),
		779	sv_to_coro (next, "Coro::transfer", "next"),
		780	flags);
		781	}
		782
		783	/ Coro ******************************************************************/
		784
		785	#define PRIO_MAX 3
		786	#define PRIO_HIGH 1
		787	#define PRIO_NORMAL 0
		788	#define PRIO_LOW -1
		789	#define PRIO_IDLE -3
		790	#define PRIO_MIN -4
		791
		792	/* for Coro.pm */
		793	static GV coro_current, coro_idle;
		794	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		795	static int coro_nready;
		796
		797	static void
		798	coro_enq (SV *sv)
		799	{
		800	if (SvROK (sv))
		801	{
		802	SV *hv = SvRV (sv);
		803	if (SvTYPE (hv) == SVt_PVHV)
		804	{
		805	SV *xprio = hv_fetch ((HV )hv, "prio", 4, 0);
		806	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		807
		808	prio = prio > PRIO_MAX ? PRIO_MAX
		809	: prio < PRIO_MIN ? PRIO_MIN
		810	: prio;
		811
		812	av_push (coro_ready [prio - PRIO_MIN], sv);
		813	coro_nready++;
		814
		815	return;
		816	}
		817	}
		818
		819	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		820	}
		821
		822	static SV *
		823	coro_deq (int min_prio)
		824	{
		825	int prio = PRIO_MAX - PRIO_MIN;
		826
		827	min_prio -= PRIO_MIN;
		828	if (min_prio < 0)
		829	min_prio = 0;
		830
		831	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		832	if (av_len (coro_ready[prio]) >= 0)
		833	{
		834	coro_nready--;
		835	return av_shift (coro_ready[prio]);
		836	}
		837
		838	return 0;
		839	}
		840
		841	static void
		842	api_ready (SV *coro)
		843	{
		844	coro_enq (SvREFCNT_inc (coro));
		845	}
		846
		847	static void
		848	api_schedule (int cede)
		849	{
		850	SV prev, next;
		851
		852	prev = GvSV (coro_current);
		853
		854	if (cede)
		855	coro_enq (SvREFCNT_inc (prev));
		856
		857	next = coro_deq (PRIO_MIN);
		858
		859	if (!next)
		860	next = SvREFCNT_inc (GvSV (coro_idle));
		861
		862	GvSV (coro_current) = SvREFCNT_inc (next);
		863	transfer (aTHX_
		864	sv_to_coro (prev, "Coro::schedule", "current coroutine"),
		865	sv_to_coro (next, "Coro::schedule", "next coroutine"),
		866	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		867	SvREFCNT_dec (next);
		868	SvREFCNT_dec (prev);
		869	}
381		870
382	MODULE = Coro::State PACKAGE = Coro::State	871	MODULE = Coro::State PACKAGE = Coro::State
383		872
384	PROTOTYPES: ENABLE	873	PROTOTYPES: ENABLE
385		874
386	BOOT:	875	BOOT:
		876	{ /* {} necessary for stoopid perl-5.6.x */
		877	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		878	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		879	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		880
		881	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		882	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		883	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		884	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		885
387	if (!padlist_cache)	886	if (!padlist_cache)
388	padlist_cache = newHV ();	887	padlist_cache = newHV ();
		888
		889	main_mainstack = PL_mainstack;
		890
		891	coroapi.ver = CORO_API_VERSION;
		892	coroapi.transfer = api_transfer;
		893	}
389		894
390	Coro::State	895	Coro::State
391	_newprocess(args)	896	_newprocess(args)
392	SV * args	897	SV * args
393	PROTOTYPE: $	898	PROTOTYPE: $
394	CODE:	899	CODE:
395	Coro__State coro;	900	Coro__State coro;
396		901
397	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	902	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");	903	croak ("Coro::State::_newprocess expects an arrayref");
399		904
400	New (0, coro, 1, struct coro);	905	New (0, coro, 1, struct coro);
401		906
		907	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
402	coro->mainstack = 0; /* actual work is done inside transfer */	908	coro->mainstack = 0; /* actual work is done inside transfer */
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	909	coro->stack = 0;
404		910
405	RETVAL = coro;	911	RETVAL = coro;
406	OUTPUT:	912	OUTPUT:
407	RETVAL	913	RETVAL
408		914
409	void	915	void
410	transfer(prev,next)	916	transfer(prev, next, flags)
411	Coro::State_or_hashref prev	917	Coro::State_or_hashref prev
412	Coro::State_or_hashref next	918	Coro::State_or_hashref next
		919	int flags
		920	PROTOTYPE: @
413	CODE:	921	CODE:
414
415	if (prev != next)
416	{
417	PUTBACK;	922	PUTBACK;
418	SAVE (aTHX_ prev);	923	transfer (aTHX_ prev, next, flags);
419
420	/*
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;	924	SPAGAIN;
431	}
432	else
433	{
434	/*
435	* emulate part of the perl startup here.
436	*/
437	UNOP myop;
438
439	init_stacks (); /* from perl.c */
440	PL_op = (OP *)&myop;
441	/PL_curcop = 0;/
442	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
443
444	SPAGAIN;
445	Zero(&myop, 1, UNOP);
446	myop.op_next = Nullop;
447	myop.op_flags = OPf_WANT_VOID;
448
449	PUSHMARK(SP);
450	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451	PUTBACK;
452	/*
453	* the next line is slightly wrong, as PL_op->op_next
454	* is actually being executed so we skip the first op.
455	* that doesn't matter, though, since it is only
456	* pp_nextstate and we never return...
457	*/
458	PL_op = Perl_pp_entersub(aTHX);
459	SPAGAIN;
460
461	ENTER;
462	}
463	}
464		925
465	void	926	void
466	DESTROY(coro)	927	DESTROY(coro)
467	Coro::State coro	928	Coro::State coro
468	CODE:	929	CODE:
469		930
470	if (coro->mainstack)	931	if (coro->mainstack && coro->mainstack != main_mainstack)
471	{	932	{
472	struct coro temp;	933	struct coro temp;
473		934
474	PUTBACK;	935	PUTBACK;
475	SAVE(aTHX_ (&temp));	936	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
476	LOAD(aTHX_ coro);	937	LOAD(aTHX_ coro);
477
478	destroy_stacks ();
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;	938	SPAGAIN;
		939
		940	destroy_stacks (aTHX);
		941
		942	LOAD((&temp)); /* this will get rid of defsv etc.. */
		943	SPAGAIN;
		944
		945	coro->mainstack = 0;
483	}	946	}
484		947
485	SvREFCNT_dec (coro->args);	948	deallocate_stack (coro);
		949
486	Safefree (coro);	950	Safefree (coro);
487		951
		952	void
		953	flush()
		954	CODE:
		955	#ifdef MAY_FLUSH
		956	flush_padlist_cache ();
		957	#endif
488		958
		959	void
		960	_exit(code)
		961	int code
		962	PROTOTYPE: $
		963	CODE:
		964	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		965	_exit (code);
		966	#else
		967	signal (SIGTERM, SIG_DFL);
		968	raise (SIGTERM);
		969	exit (code);
		970	#endif
		971
		972	MODULE = Coro::State PACKAGE = Coro::Cont
		973
		974	# this is slightly dirty (should expose a c-level api)
		975
		976	void
		977	yield(...)
		978	PROTOTYPE: @
		979	CODE:
		980	static SV *returnstk;
		981	SV *sv;
		982	AV *defav = GvAV (PL_defgv);
		983	struct coro prev, next;
		984
		985	if (!returnstk)
		986	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		987
		988	/* set up @_ -- ugly */
		989	av_clear (defav);
		990	av_fill (defav, items - 1);
		991	while (items--)
		992	av_store (defav, items, SvREFCNT_inc (ST(items)));
		993
		994	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		995	sv = av_pop ((AV *)SvRV (returnstk));
		996	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		997	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		998	SvREFCNT_dec (sv);
		999
		1000	transfer(aTHX_ prev, next, 0);
		1001
		1002	MODULE = Coro::State PACKAGE = Coro
		1003
		1004	# this is slightly dirty (should expose a c-level api)
		1005
		1006	BOOT:
		1007	{
		1008	int i;
		1009	HV *stash = gv_stashpv ("Coro", TRUE);
		1010
		1011	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1012	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1013	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1014	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1015	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1016	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1017
		1018	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1019	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1020
		1021	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1022	coro_ready[i] = newAV ();
		1023
		1024	{
		1025	SV *sv = perl_get_sv("Coro::API", 1);
		1026
		1027	coroapi.schedule = api_schedule;
		1028	coroapi.ready = api_ready;
		1029	coroapi.nready = &coro_nready;
		1030	coroapi.current = coro_current;
		1031
		1032	GCoroAPI = &coroapi;
		1033	sv_setiv(sv, (IV)&coroapi);
		1034	SvREADONLY_on(sv);
		1035	}
		1036	}
		1037
		1038	void
		1039	ready(self)
		1040	SV * self
		1041	CODE:
		1042	api_ready (self);
		1043
		1044	int
		1045	nready(...)
		1046	PROTOTYPE:
		1047	CODE:
		1048	RETVAL = coro_nready;
		1049	OUTPUT:
		1050	RETVAL
		1051
		1052	void
		1053	schedule(...)
		1054	PROTOTYPE:
		1055	ALIAS:
		1056	cede = 1
		1057	CODE:
		1058	api_schedule (ix);
		1059

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs. Revision 1.31 by root, Sun Aug 26 16:36:08 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.31 by root, Sun Aug 26 16:36:08 2001 UTC