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

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

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

Diff Legend

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

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

Diff Legend

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