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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs. Revision 1.36 by root, Fri Oct 5 14:20:10 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.36 by root, Fri Oct 5 14:20:10 2001 UTC