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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.30 by root, Sat Aug 25 22:19:05 2001 UTC

…		…
1	#include "EXTERN.h"	1	#include "EXTERN.h"
2	#include "perl.h"	2	#include "perl.h"
3	#include "XSUB.h"	3	#include "XSUB.h"
4		4
5	#if 0	5	#include "libcoro/coro.c"
6	# define CHK(x) (void *)0	6
		7	#include <signal.h>
		8
		9	#ifdef HAVE_MMAP
		10	# include <unistd.h>
		11	# include <sys/mman.h>
		12	# ifndef MAP_ANON
		13	# ifdef MAP_ANONYMOUS
		14	# define MAP_ANON MAP_ANONYMOUS
7	#else	15	# else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	16	# undef HAVE_MMAP
		17	# endif
		18	# endif
9	#endif	19	#endif
10		20
		21	#define MAY_FLUSH /* increases codesize and is rarely used */
		22
		23	#define SUB_INIT "Coro::State::initialize"
		24	#define UCORO_STATE "_coro_state"
		25
		26	/* The next macro should declare a variable stacklevel that contains and approximation
		27	* to the current C stack pointer. Its property is that it changes with each call
		28	* and should be unique. */
		29	#define dSTACKLEVEL void *stacklevel = &stacklevel
		30
		31	#define labs(l) ((l) >= 0 ? (l) : -(l))
		32
		33	#include "CoroAPI.h"
		34
		35	static struct CoroAPI coroapi;
		36
		37	/* this is actually not only the c stack but also c registers etc... */
		38	typedef struct {
		39	int refcnt; /* pointer reference counter */
		40	int usecnt; /* shared by how many coroutines */
		41	int gencnt; /* generation counter */
		42
		43	coro_context cctx;
		44
		45	void *sptr;
		46	long ssize; /* positive == mmap, otherwise malloc */
		47	} coro_stack;
		48
11	struct coro {	49	struct coro {
		50	/* the optional C context */
		51	coro_stack *stack;
		52	void *cursp;
		53	int gencnt;
		54
		55	/* optionally saved, might be zero */
		56	AV *defav;
		57	SV *defsv;
		58	SV *errsv;
		59
		60	/* saved global state not related to stacks */
12	U8 dowarn;	61	U8 dowarn;
13	AV *defav;	62	I32 in_eval;
14		63
		64	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	65	PERL_SI *curstackinfo;
16	AV *curstack;	66	AV *curstack;
17	AV *mainstack;	67	AV *mainstack;
18	SV **stack_sp;	68	SV **stack_sp;
19	OP *op;	69	OP *op;
35	I32 savestack_max;	85	I32 savestack_max;
36	OP **retstack;	86	OP **retstack;
37	I32 retstack_ix;	87	I32 retstack_ix;
38	I32 retstack_max;	88	I32 retstack_max;
39	COP *curcop;	89	COP *curcop;
		90	JMPENV *top_env;
40		91
		92	/* data associated with this coroutine (initial args) */
41	AV *args;	93	AV *args;
42	};	94	};
43		95
44	typedef struct coro *Coro__State;	96	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	97	typedef struct coro *Coro__State_or_hashref;
46		98
		99	static AV main_mainstack; / used to differentiate between $main and others */
		100	static HV *coro_state_stash;
		101	static SV *ucoro_state_sv;
		102	static U32 ucoro_state_hash;
47	static HV *padlist_cache;	103	static HV *padlist_cache;
48		104
49	/* mostly copied from op.c:cv_clone2 */	105	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *	106	STATIC AV *
51	clone_padlist (AV *protopadlist)	107	clone_padlist (AV *protopadlist)
…		…
115	SvPADTMP_on (sv);	171	SvPADTMP_on (sv);
116	npad[ix] = sv;	172	npad[ix] = sv;
117	}	173	}
118	}	174	}
119		175
120	#if 0 /* NONOTUNDERSTOOD */	176	#if 0 /* return -ENOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */	177	/* Now that vars are all in place, clone nested closures. */
122		178
123	for (ix = fpad; ix > 0; ix--) {	179	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	180	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv	181	if (namesv
…		…
138	#endif	194	#endif
139		195
140	return newpadlist;	196	return newpadlist;
141	}	197	}
142		198
143	STATIC AV *	199	#ifdef MAY_FLUSH
		200	STATIC void
144	free_padlist (AV *padlist)	201	free_padlist (AV *padlist)
145	{	202	{
146	/* may be during global destruction */	203	/* may be during global destruction */
147	if (SvREFCNT(padlist))	204	if (SvREFCNT(padlist))
148	{	205	{
…		…
156	}	213	}
157		214
158	SvREFCNT_dec((SV*)padlist);	215	SvREFCNT_dec((SV*)padlist);
159	}	216	}
160	}	217	}
		218	#endif
161		219
162	/* 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	dSP;
341
342	/* die does this while calling POPSTACK, but I just don't see why. */
343	dounwind(-1);
344
345	/* is this ugly, I ask? */	492	/* is this ugly, I ask? */
346	while (PL_scopestack_ix)	493	while (PL_scopestack_ix)
347	LEAVE;	494	LEAVE;
348		495
		496	/* sure it is, but more important: is it correct?? :/ */
		497	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		498	FREETMPS;
		499
349	while (PL_curstackinfo->si_next)	500	while (PL_curstackinfo->si_next)
350	PL_curstackinfo = PL_curstackinfo->si_next;	501	PL_curstackinfo = PL_curstackinfo->si_next;
351		502
352	while (PL_curstackinfo)	503	while (PL_curstackinfo)
353	{	504	{
354	PERL_SI *p = PL_curstackinfo->si_prev;	505	PERL_SI *p = PL_curstackinfo->si_prev;
		506
		507	{
		508	dSP;
		509	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		510	PUTBACK; /* possibly superfluous */
		511	}
		512
		513	if (PL_main_cv != Nullcv) /* don't during destruction. hack? */
		514	dounwind(-1);
355		515
356	SvREFCNT_dec(PL_curstackinfo->si_stack);	516	SvREFCNT_dec(PL_curstackinfo->si_stack);
357	Safefree(PL_curstackinfo->si_cxstack);	517	Safefree(PL_curstackinfo->si_cxstack);
358	Safefree(PL_curstackinfo);	518	Safefree(PL_curstackinfo);
359	PL_curstackinfo = p;	519	PL_curstackinfo = p;
360	}	520	}
361		521
362	if (PL_scopestack_ix != 0)
363	Perl_warner(aTHX_ WARN_INTERNAL,
364	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365	(long)PL_scopestack_ix);
366	if (PL_savestack_ix != 0)
367	Perl_warner(aTHX_ WARN_INTERNAL,
368	"Unbalanced saves: %ld more saves than restores\n",
369	(long)PL_savestack_ix);
370	if (PL_tmps_floor != -1)
371	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372	(long)PL_tmps_floor + 1);
373	/*
374	*/
375	Safefree(PL_tmps_stack);	522	Safefree(PL_tmps_stack);
376	Safefree(PL_markstack);	523	Safefree(PL_markstack);
377	Safefree(PL_scopestack);	524	Safefree(PL_scopestack);
378	Safefree(PL_savestack);	525	Safefree(PL_savestack);
379	Safefree(PL_retstack);	526	Safefree(PL_retstack);
380	}	527	}
381		528
382	#define SUB_INIT "Coro::State::_newcoro"	529	static void
		530	allocate_stack (Coro__State ctx, int alloc)
		531	{
		532	coro_stack *stack;
		533
		534	New (0, stack, 1, coro_stack);
		535
		536	stack->refcnt = 1;
		537	stack->usecnt = 1;
		538	stack->gencnt = ctx->gencnt = 0;
		539	if (alloc)
		540	{
		541	#ifdef HAVE_MMAP
		542	stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
		543	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANON, 0, 0);
		544	if (stack->sptr == (void *)-1)
		545	#endif
		546	{
		547	/FIXME//D//* reasonable stack size! */
		548	stack->ssize = -4096 * sizeof (long);
		549	New (0, stack->sptr, 4096, long);
		550	}
		551	}
		552	else
		553	stack->sptr = 0;
		554
		555	ctx->stack = stack;
		556	}
		557
		558	static void
		559	deallocate_stack (Coro__State ctx)
		560	{
		561	coro_stack *stack = ctx->stack;
		562
		563	ctx->stack = 0;
		564
		565	if (stack)
		566	{
		567	if (!--stack->refcnt)
		568	{
		569	#ifdef HAVE_MMAP
		570	if (stack->ssize > 0 && stack->sptr)
		571	munmap (stack->sptr, stack->ssize);
		572	else
		573	#else
		574	Safefree (stack->sptr);
		575	#endif
		576	Safefree (stack);
		577	}
		578	else if (ctx->gencnt == stack->gencnt)
		579	--stack->usecnt;
		580	}
		581	}
		582
		583	static void
		584	setup_coro (void *arg)
		585	{
		586	/*
		587	* emulate part of the perl startup here.
		588	*/
		589	dSP;
		590	Coro__State ctx = (Coro__State)arg;
		591	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
		592
		593	coro_init_stacks (aTHX);
		594	/PL_curcop = 0;/
		595	/PL_in_eval = PL_in_eval;/ /* inherit */
		596	SvREFCNT_dec (GvAV (PL_defgv));
		597	GvAV (PL_defgv) = ctx->args;
		598
		599	SPAGAIN;
		600
		601	if (ctx->stack)
		602	{
		603	ctx->cursp = 0;
		604
		605	PUSHMARK(SP);
		606	PUTBACK;
		607	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		608
		609	if (SvTRUE (ERRSV))
		610	croak (NULL);
		611	else
		612	croak ("FATAL: CCTXT coroutine returned!");
		613	}
		614	else
		615	{
		616	UNOP myop;
		617
		618	PL_op = (OP *)&myop;
		619
		620	Zero(&myop, 1, UNOP);
		621	myop.op_next = Nullop;
		622	myop.op_flags = OPf_WANT_VOID;
		623
		624	PUSHMARK(SP);
		625	XPUSHs (sub_init);
		626	/*
		627	* the next line is slightly wrong, as PL_op->op_next
		628	* is actually being executed so we skip the first op.
		629	* that doesn't matter, though, since it is only
		630	* pp_nextstate and we never return...
		631	* ah yes, and I don't care anyways ;)
		632	*/
		633	PUTBACK;
		634	PL_op = pp_entersub();
		635	SPAGAIN;
		636
		637	ENTER; /* necessary e.g. for dounwind */
		638	}
		639	}
		640
		641	static void
		642	continue_coro (void *arg)
		643	{
		644	/*
		645	* this is a _very_ stripped down perl interpreter ;)
		646	*/
		647	Coro__State ctx = (Coro__State)arg;
		648
		649	/FIXME//* must set up top_env here */
		650	ctx->cursp = 0;
		651	PL_op = PL_op->op_next;
		652	CALLRUNOPS(aTHX);
		653
		654	abort ();
		655	}
		656
		657	STATIC void
		658	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		659	{
		660	dSTACKLEVEL;
		661	static struct coro *xnext;
		662
		663	if (prev != next)
		664	{
		665	xnext = next;
		666
		667	if (next->mainstack)
		668	{
		669	SAVE (prev, flags);
		670	LOAD (next);
		671
		672	/* mark this state as in-use */
		673	next->mainstack = 0;
		674	next->tmps_ix = -2;
		675
		676	/* stacklevel changed? if yes, grab the stack for us! */
		677	if (flags & TRANSFER_SAVE_CCTXT)
		678	{
		679	if (!prev->stack)
		680	allocate_stack (prev, 0);
		681	else if (prev->cursp != stacklevel
		682	&& prev->stack->usecnt > 1)
		683	{
		684	prev->gencnt = ++prev->stack->gencnt;
		685	prev->stack->usecnt = 1;
		686	}
		687
		688	/* has our stack been invalidated? */
		689	if (next->stack && next->stack->gencnt != next->gencnt)
		690	{
		691	deallocate_stack (next);
		692	allocate_stack (next, 1);
		693	coro_create (&(next->stack->cctx),
		694	continue_coro, (void *)next,
		695	next->stack->sptr, labs (next->stack->ssize));
		696	}
		697
		698	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		699	/* don't add any code here */
		700	}
		701
		702	}
		703	else if (next->tmps_ix == -2)
		704	croak ("tried to transfer to running coroutine");
		705	else
		706	{
		707	SAVE (prev, -1); /* first get rid of the old state */
		708
		709	if (flags & TRANSFER_SAVE_CCTXT)
		710	{
		711	if (!prev->stack)
		712	allocate_stack (prev, 0);
		713
		714	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		715	{
		716	setup_coro (next);
		717
		718	prev->stack->refcnt++;
		719	prev->stack->usecnt++;
		720	next->stack = prev->stack;
		721	next->gencnt = prev->gencnt;
		722	}
		723	else
		724	{
		725	allocate_stack (next, 1);
		726	coro_create (&(next->stack->cctx),
		727	setup_coro, (void *)next,
		728	next->stack->sptr, labs (next->stack->ssize));
		729	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		730	/* don't add any code here */
		731	}
		732	}
		733	else
		734	setup_coro (next);
		735	}
		736	}
		737
		738	/*
		739	* xnext is now either prev or next, depending on wether
		740	* we switched the c stack or not. that's why i use a global
		741	* variable, that should become thread-specific at one point.
		742	*/
		743	xnext->cursp = stacklevel;
		744	}
		745
		746	static struct coro *
		747	sv_to_coro (SV arg, const char funcname, const char *varname)
		748	{
		749	if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV)
		750	{
		751	HE he = hv_fetch_ent((HV )SvRV(arg), ucoro_state_sv, 0, ucoro_state_hash);
		752
		753	if (!he)
		754	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", funcname, varname);
		755
		756	arg = HeVAL(he);
		757	}
		758
		759	/* must also be changed inside Coro::Cont::yield */
		760	if (SvROK(arg) && SvSTASH(SvRV(arg)) == coro_state_stash)
		761	return (struct coro ) SvIV((SV)SvRV(arg));
		762
		763	croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname);
		764	/NORETURN/
		765	}
		766
		767	static void
		768	api_transfer(pTHX_ SV prev, SV next, int flags)
		769	{
		770	transfer(aTHX_
		771	sv_to_coro (prev, "Coro::transfer", "prev"),
		772	sv_to_coro (next, "Coro::transfer", "next"),
		773	flags);
		774	}
		775
		776	/ Coro ******************************************************************/
		777
		778	#define PRIO_MAX 3
		779	#define PRIO_HIGH 1
		780	#define PRIO_NORMAL 0
		781	#define PRIO_LOW -1
		782	#define PRIO_IDLE -3
		783	#define PRIO_MIN -4
		784
		785	/* for Coro.pm */
		786	static GV coro_current, coro_idle;
		787	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		788	static int coro_nready;
		789
		790	static void
		791	coro_enq (SV *sv)
		792	{
		793	if (SvROK (sv))
		794	{
		795	SV *hv = SvRV (sv);
		796	if (SvTYPE (hv) == SVt_PVHV)
		797	{
		798	SV *xprio = hv_fetch ((HV )hv, "prio", 4, 0);
		799	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		800
		801	prio = prio > PRIO_MAX ? PRIO_MAX
		802	: prio < PRIO_MIN ? PRIO_MIN
		803	: prio;
		804
		805	av_push (coro_ready [prio - PRIO_MIN], sv);
		806	coro_nready++;
		807
		808	return;
		809	}
		810	}
		811
		812	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		813	}
		814
		815	static SV *
		816	coro_deq (int min_prio)
		817	{
		818	int prio = PRIO_MAX - PRIO_MIN;
		819
		820	min_prio -= PRIO_MIN;
		821	if (min_prio < 0)
		822	min_prio = 0;
		823
		824	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		825	if (av_len (coro_ready[prio]) >= 0)
		826	{
		827	coro_nready--;
		828	return av_shift (coro_ready[prio]);
		829	}
		830
		831	return 0;
		832	}
		833
		834	static void
		835	api_ready (SV *coro)
		836	{
		837	coro_enq (SvREFCNT_inc (coro));
		838	}
		839
		840	static void
		841	api_schedule (int cede)
		842	{
		843	SV prev, next;
		844
		845	prev = GvSV (coro_current);
		846
		847	if (cede)
		848	coro_enq (SvREFCNT_inc (prev));
		849
		850	next = coro_deq (PRIO_MIN);
		851
		852	if (!next)
		853	next = SvREFCNT_inc (GvSV (coro_idle));
		854
		855	GvSV (coro_current) = SvREFCNT_inc (next);
		856	transfer (aTHX_
		857	sv_to_coro (prev, "Coro::schedule", "current coroutine"),
		858	sv_to_coro (next, "Coro::schedule", "next coroutine"),
		859	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		860	SvREFCNT_dec (next);
		861	SvREFCNT_dec (prev);
		862	}
383		863
384	MODULE = Coro::State PACKAGE = Coro::State	864	MODULE = Coro::State PACKAGE = Coro::State
385		865
386	PROTOTYPES: ENABLE	866	PROTOTYPES: ENABLE
387		867
388	BOOT:	868	BOOT:
		869	{ /* {} necessary for stoopid perl-5.6.x */
		870	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		871	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		872	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		873
		874	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		875	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		876	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		877	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		878
389	if (!padlist_cache)	879	if (!padlist_cache)
390	padlist_cache = newHV ();	880	padlist_cache = newHV ();
		881
		882	main_mainstack = PL_mainstack;
		883
		884	coroapi.ver = CORO_API_VERSION;
		885	coroapi.transfer = api_transfer;
		886	}
391		887
392	Coro::State	888	Coro::State
393	_newprocess(args)	889	_newprocess(args)
394	SV * args	890	SV * args
395	PROTOTYPE: $	891	PROTOTYPE: $
396	CODE:	892	CODE:
397	Coro__State coro;	893	Coro__State coro;
398		894
399	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	895	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
400	croak ("Coro::State::newprocess expects an arrayref");	896	croak ("Coro::State::_newprocess expects an arrayref");
401		897
402	New (0, coro, 1, struct coro);	898	New (0, coro, 1, struct coro);
403		899
		900	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
404	coro->mainstack = 0; /* actual work is done inside transfer */	901	coro->mainstack = 0; /* actual work is done inside transfer */
405	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	902	coro->stack = 0;
406		903
407	RETVAL = coro;	904	RETVAL = coro;
408	OUTPUT:	905	OUTPUT:
409	RETVAL	906	RETVAL
410		907
411	void	908	void
412	transfer(prev,next)	909	transfer(prev, next, flags)
413	Coro::State_or_hashref prev	910	Coro::State_or_hashref prev
414	Coro::State_or_hashref next	911	Coro::State_or_hashref next
		912	int flags
		913	PROTOTYPE: @
415	CODE:	914	CODE:
416
417	if (prev != next)
418	{
419	PUTBACK;	915	PUTBACK;
420	SAVE (aTHX_ prev);	916	transfer (aTHX_ prev, next, flags);
421
422	/*
423	* this could be done in newprocess which would lead to
424	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425	* code here, but lazy allocation of stacks has also
426	* some virtues and the overhead of the if() is nil.
427	*/
428	if (next->mainstack)
429	{
430	LOAD (aTHX_ next);
431	next->mainstack = 0; /* unnecessary but much cleaner */
432	SPAGAIN;	917	SPAGAIN;
433	}
434	else
435	{
436	/*
437	* emulate part of the perl startup here.
438	*/
439	UNOP myop;
440
441	init_stacks (); /* from perl.c */
442	PL_op = (OP *)&myop;
443	/PL_curcop = 0;/
444	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445
446	SPAGAIN;
447	Zero(&myop, 1, UNOP);
448	myop.op_next = Nullop;
449	myop.op_flags = OPf_WANT_VOID;
450
451	PUSHMARK(SP);
452	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453	PUTBACK;
454	/*
455	* the next line is slightly wrong, as PL_op->op_next
456	* is actually being executed so we skip the first op.
457	* that doesn't matter, though, since it is only
458	* pp_nextstate and we never return...
459	*/
460	PL_op = Perl_pp_entersub(aTHX);
461	SPAGAIN;
462
463	ENTER;
464	}
465	}
466		918
467	void	919	void
468	DESTROY(coro)	920	DESTROY(coro)
469	Coro::State coro	921	Coro::State coro
470	CODE:	922	CODE:
471		923
472	if (coro->mainstack)	924	if (coro->mainstack && coro->mainstack != main_mainstack)
473	{	925	{
474	struct coro temp;	926	struct coro temp;
475		927
476	PUTBACK;	928	PUTBACK;
477	SAVE(aTHX_ (&temp));	929	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
478	LOAD(aTHX_ coro);	930	LOAD(aTHX_ coro);
479
480	destroy_stacks ();
481	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483	LOAD((&temp));
484	SPAGAIN;	931	SPAGAIN;
		932
		933	destroy_stacks (aTHX);
		934
		935	LOAD((&temp)); /* this will get rid of defsv etc.. */
		936	SPAGAIN;
		937
		938	coro->mainstack = 0;
485	}	939	}
486		940
487	SvREFCNT_dec (coro->args);	941	deallocate_stack (coro);
		942
488	Safefree (coro);	943	Safefree (coro);
489		944
		945	void
		946	flush()
		947	CODE:
		948	#ifdef MAY_FLUSH
		949	flush_padlist_cache ();
		950	#endif
490		951
		952	void
		953	_exit(code)
		954	int code
		955	PROTOTYPE: $
		956	CODE:
		957	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		958	_exit (code);
		959	#else
		960	signal (SIGTERM, SIG_DFL);
		961	raise (SIGTERM);
		962	exit (code);
		963	#endif
		964
		965	MODULE = Coro::State PACKAGE = Coro::Cont
		966
		967	# this is slightly dirty (should expose a c-level api)
		968
		969	void
		970	yield(...)
		971	PROTOTYPE: @
		972	CODE:
		973	static SV *returnstk;
		974	SV *sv;
		975	AV *defav = GvAV (PL_defgv);
		976	struct coro prev, next;
		977
		978	if (!returnstk)
		979	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		980
		981	/* set up @_ -- ugly */
		982	av_clear (defav);
		983	av_fill (defav, items - 1);
		984	while (items--)
		985	av_store (defav, items, SvREFCNT_inc (ST(items)));
		986
		987	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		988	sv = av_pop ((AV *)SvRV (returnstk));
		989	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		990	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		991	SvREFCNT_dec (sv);
		992
		993	transfer(aTHX_ prev, next, 0);
		994
		995	MODULE = Coro::State PACKAGE = Coro
		996
		997	# this is slightly dirty (should expose a c-level api)
		998
		999	BOOT:
		1000	{
		1001	int i;
		1002	HV *stash = gv_stashpv ("Coro", TRUE);
		1003
		1004	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1005	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1006	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1007	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1008	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1009	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1010
		1011	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1012	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1013
		1014	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1015	coro_ready[i] = newAV ();
		1016
		1017	{
		1018	SV *sv = perl_get_sv("Coro::API", 1);
		1019
		1020	coroapi.schedule = api_schedule;
		1021	coroapi.ready = api_ready;
		1022	coroapi.nready = &coro_nready;
		1023	coroapi.current = coro_current;
		1024
		1025	GCoroAPI = &coroapi;
		1026	sv_setiv(sv, (IV)&coroapi);
		1027	SvREADONLY_on(sv);
		1028	}
		1029	}
		1030
		1031	void
		1032	ready(self)
		1033	SV * self
		1034	CODE:
		1035	api_ready (self);
		1036
		1037	int
		1038	nready(...)
		1039	PROTOTYPE:
		1040	CODE:
		1041	RETVAL = coro_nready;
		1042	OUTPUT:
		1043	RETVAL
		1044
		1045	void
		1046	schedule(...)
		1047	PROTOTYPE:
		1048	ALIAS:
		1049	cede = 1
		1050	CODE:
		1051	api_schedule (ix);
		1052

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.30 by root, Sat Aug 25 22:19:05 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.30 by root, Sat Aug 25 22:19:05 2001 UTC