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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs. Revision 1.38 by root, Wed Nov 7 00:21:06 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.38 by root, Wed Nov 7 00:21:06 2001 UTC