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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs. Revision 1.39 by root, Sun Nov 25 20:04:05 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.39 by root, Sun Nov 25 20:04:05 2001 UTC