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

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.44 by root, Sat Mar 22 18:50:32 2003 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.44 by root, Sat Mar 22 18:50:32 2003 UTC