[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.41 by root, Tue Nov 27 02:51:03 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;
		106	static SV coro_mortal; / will be freed after next transfer */
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)
52	{	111	{
…		…
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(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	static void	446	/*
283	LOAD(pTHX_ Coro__State c)	447	* allocate various perl stacks. This is an exact copy
		448	* of perl.c:init_stacks, except that it uses less memory
		449	* on the assumption that coroutines do not usually need
		450	* a lot of stackspace.
		451	*/
		452	STATIC void
		453	coro_init_stacks (pTHX)
284	{	454	{
285	PL_dowarn = c->dowarn;	455	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	456	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	457	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	458	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	459
		460	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	461	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	462	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	463
293	PL_stack_base = c->stack_base;	464	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	465	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	466	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	467	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	468
298	PL_tmps_max = c->tmps_max;	469	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	470	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	471	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		472
313	{	473	SET_MARK_OFFSET;
314	dSP;
315	CV *cv;
316		474
317	/* now do the ugly restore mess */	475	New(54,PL_scopestack,16,I32);
318	while ((cv = (CV *)POPs))	476	PL_scopestack_ix = 0;
319	{	477	PL_scopestack_max = 16;
320	AV padlist = (AV )POPs;
321		478
322	put_padlist (cv);	479	New(54,PL_savestack,96,ANY);
323	CvPADLIST(cv) = padlist;	480	PL_savestack_ix = 0;
324	CvDEPTH(cv) = (I32)POPs;	481	PL_savestack_max = 96;
325		482
326	#ifdef USE_THREADS	483	New(54,PL_retstack,8,OP*);
327	CvOWNER(cv) = (struct perl_thread *)POPs;	484	PL_retstack_ix = 0;
328	error does not work either	485	PL_retstack_max = 8;
329	#endif
330	}
331
332	PUTBACK;
333	}
334	}	486	}
335		487
336	/* 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	*/
337	STATIC void	492	STATIC void
338	destroy_stacks(pTHX)	493	destroy_stacks(pTHX)
339	{	494	{
340	/* die does this while calling POPSTACK, but I just don't see why. */	495	if (!IN_DESTRUCT)
341	dounwind(-1);	496	{
342
343	/* is this ugly, I ask? */	497	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)	498	while (PL_scopestack_ix)
345	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	}
346		505
347	while (PL_curstackinfo->si_next)	506	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;	507	PL_curstackinfo = PL_curstackinfo->si_next;
349		508
350	while (PL_curstackinfo)	509	while (PL_curstackinfo)
351	{	510	{
352	PERL_SI *p = PL_curstackinfo->si_prev;	511	PERL_SI *p = PL_curstackinfo->si_prev;
353		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);
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	522	SvREFCNT_dec(PL_curstackinfo->si_stack);
		523	}
		524
355	Safefree(PL_curstackinfo->si_cxstack);	525	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);	526	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;	527	PL_curstackinfo = p;
358	}	528	}
359		529
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);	530	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);	531	Safefree(PL_markstack);
375	Safefree(PL_scopestack);	532	Safefree(PL_scopestack);
376	Safefree(PL_savestack);	533	Safefree(PL_savestack);
377	Safefree(PL_retstack);	534	Safefree(PL_retstack);
378	}	535	}
379		536
380	#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	if (coro_mortal)
		760	{
		761	SvREFCNT_dec (coro_mortal);
		762	coro_mortal = 0;
		763	}
		764	}
		765
		766	#define SV_CORO(sv,func) \
		767	do { \
		768	if (SvROK (sv)) \
		769	sv = SvRV (sv); \
		770	\
		771	if (SvTYPE(sv) == SVt_PVHV) \
		772	{ \
		773	HE he = hv_fetch_ent((HV )sv, ucoro_state_sv, 0, ucoro_state_hash); \
		774	\
		775	if (!he) \
		776	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
		777	\
		778	(sv) = SvRV (HeVAL(he)); \
		779	} \
		780	\
		781	/* must also be changed inside Coro::Cont::yield */ \
		782	if (!SvOBJECT(sv) \|\| SvSTASH(sv) != coro_state_stash) \
		783	croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
		784	\
		785	} while(0)
		786
		787	#define SvSTATE(sv) (struct coro *)SvIV (sv)
		788
		789	static void
		790	api_transfer(pTHX_ SV prev, SV next, int flags)
		791	{
		792	SV_CORO (prev, "Coro::transfer");
		793	SV_CORO (next, "Coro::transfer");
		794
		795	transfer(aTHX_ SvSTATE(prev), SvSTATE(next), flags);
		796	}
		797
		798	/ Coro ******************************************************************/
		799
		800	#define PRIO_MAX 3
		801	#define PRIO_HIGH 1
		802	#define PRIO_NORMAL 0
		803	#define PRIO_LOW -1
		804	#define PRIO_IDLE -3
		805	#define PRIO_MIN -4
		806
		807	/* for Coro.pm */
		808	static GV coro_current, coro_idle;
		809	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		810	static int coro_nready;
		811
		812	static void
		813	coro_enq (SV *sv)
		814	{
		815	if (SvTYPE (sv) == SVt_PVHV)
		816	{
		817	SV *xprio = hv_fetch ((HV )sv, "prio", 4, 0);
		818	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		819
		820	prio = prio > PRIO_MAX ? PRIO_MAX
		821	: prio < PRIO_MIN ? PRIO_MIN
		822	: prio;
		823
		824	av_push (coro_ready [prio - PRIO_MIN], sv);
		825	coro_nready++;
		826
		827	return;
		828	}
		829
		830	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		831	}
		832
		833	static SV *
		834	coro_deq (int min_prio)
		835	{
		836	int prio = PRIO_MAX - PRIO_MIN;
		837
		838	min_prio -= PRIO_MIN;
		839	if (min_prio < 0)
		840	min_prio = 0;
		841
		842	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		843	if (av_len (coro_ready[prio]) >= 0)
		844	{
		845	coro_nready--;
		846	return av_shift (coro_ready[prio]);
		847	}
		848
		849	return 0;
		850	}
		851
		852	static void
		853	api_ready (SV *coro)
		854	{
		855	if (SvROK (coro))
		856	coro = SvRV (coro);
		857
		858	coro_enq (SvREFCNT_inc (coro));
		859	}
		860
		861	static void
		862	api_schedule (void)
		863	{
		864	SV prev, next;
		865
		866	prev = SvRV (GvSV (coro_current));
		867	next = coro_deq (PRIO_MIN);
		868
		869	if (!next)
		870	next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
		871
		872	/* free this only after the transfer */
		873	coro_mortal = prev;
		874	SV_CORO (prev, "Coro::schedule");
		875
		876	SvRV (GvSV (coro_current)) = next;
		877
		878	SV_CORO (next, "Coro::schedule");
		879
		880	transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		881	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		882	}
		883
		884	static void
		885	api_cede (void)
		886	{
		887	coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
		888
		889	api_schedule ();
		890	}
381		891
382	MODULE = Coro::State PACKAGE = Coro::State	892	MODULE = Coro::State PACKAGE = Coro::State
383		893
384	PROTOTYPES: ENABLE	894	PROTOTYPES: ENABLE
385		895
386	BOOT:	896	BOOT:
		897	{ /* {} necessary for stoopid perl-5.6.x */
		898	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		899	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		900	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		901
		902	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		903	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		904	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		905	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		906
387	if (!padlist_cache)	907	if (!padlist_cache)
388	padlist_cache = newHV ();	908	padlist_cache = newHV ();
		909
		910	main_mainstack = PL_mainstack;
		911
		912	coroapi.ver = CORO_API_VERSION;
		913	coroapi.transfer = api_transfer;
		914	}
389		915
390	Coro::State	916	Coro::State
391	_newprocess(args)	917	_newprocess(args)
392	SV * args	918	SV * args
393	PROTOTYPE: $	919	PROTOTYPE: $
394	CODE:	920	CODE:
395	Coro__State coro;	921	Coro__State coro;
396		922
397	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	923	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");	924	croak ("Coro::State::_newprocess expects an arrayref");
399		925
400	New (0, coro, 1, struct coro);	926	New (0, coro, 1, struct coro);
401		927
		928	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
402	coro->mainstack = 0; /* actual work is done inside transfer */	929	coro->mainstack = 0; /* actual work is done inside transfer */
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	930	coro->stack = 0;
404		931
405	RETVAL = coro;	932	RETVAL = coro;
406	OUTPUT:	933	OUTPUT:
407	RETVAL	934	RETVAL
408		935
409	void	936	void
410	transfer(prev,next)	937	transfer(prev, next, flags)
411	Coro::State_or_hashref prev	938	SV *prev
412	Coro::State_or_hashref next	939	SV *next
		940	int flags
		941	PROTOTYPE: @
413	CODE:	942	CODE:
414
415	if (prev != next)
416	{
417	PUTBACK;	943	PUTBACK;
418	SAVE (aTHX_ prev);	944	SV_CORO (next, "Coro::transfer");
419		945	SV_CORO (prev, "Coro::transfer");
420	/*	946	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
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;	947	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		948
465	void	949	void
466	DESTROY(coro)	950	DESTROY(coro)
467	Coro::State coro	951	Coro::State coro
468	CODE:	952	CODE:
469		953
470	if (coro->mainstack)	954	if (coro->mainstack && coro->mainstack != main_mainstack)
471	{	955	{
472	struct coro temp;	956	struct coro temp;
473		957
474	PUTBACK;	958	PUTBACK;
475	SAVE(aTHX_ (&temp));	959	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
476	LOAD(aTHX_ coro);	960	LOAD(aTHX_ coro);
477
478	destroy_stacks ();
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;	961	SPAGAIN;
		962
		963	destroy_stacks (aTHX);
		964
		965	LOAD((&temp)); /* this will get rid of defsv etc.. */
		966	SPAGAIN;
		967
		968	coro->mainstack = 0;
483	}	969	}
484		970
485	SvREFCNT_dec (coro->args);	971	deallocate_stack (coro);
		972
486	Safefree (coro);	973	Safefree (coro);
487		974
		975	void
		976	flush()
		977	CODE:
		978	#ifdef MAY_FLUSH
		979	flush_padlist_cache ();
		980	#endif
488		981
		982	void
		983	_exit(code)
		984	int code
		985	PROTOTYPE: $
		986	CODE:
		987	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		988	_exit (code);
		989	#else
		990	signal (SIGTERM, SIG_DFL);
		991	raise (SIGTERM);
		992	exit (code);
		993	#endif
		994
		995	MODULE = Coro::State PACKAGE = Coro::Cont
		996
		997	# this is slightly dirty (should expose a c-level api)
		998
		999	void
		1000	yield(...)
		1001	PROTOTYPE: @
		1002	CODE:
		1003	static SV *returnstk;
		1004	SV *sv;
		1005	AV *defav = GvAV (PL_defgv);
		1006	struct coro prev, next;
		1007
		1008	if (!returnstk)
		1009	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		1010
		1011	/* set up @_ -- ugly */
		1012	av_clear (defav);
		1013	av_fill (defav, items - 1);
		1014	while (items--)
		1015	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1016
		1017	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		1018	sv = av_pop ((AV *)SvRV (returnstk));
		1019	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		1020	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		1021	SvREFCNT_dec (sv);
		1022
		1023	transfer(aTHX_ prev, next, 0);
		1024
		1025	MODULE = Coro::State PACKAGE = Coro
		1026
		1027	# this is slightly dirty (should expose a c-level api)
		1028
		1029	BOOT:
		1030	{
		1031	int i;
		1032	HV *stash = gv_stashpv ("Coro", TRUE);
		1033
		1034	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1035	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1036	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1037	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1038	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1039	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1040
		1041	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1042	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1043
		1044	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1045	coro_ready[i] = newAV ();
		1046
		1047	{
		1048	SV *sv = perl_get_sv("Coro::API", 1);
		1049
		1050	coroapi.schedule = api_schedule;
		1051	coroapi.cede = api_cede;
		1052	coroapi.ready = api_ready;
		1053	coroapi.nready = &coro_nready;
		1054	coroapi.current = coro_current;
		1055
		1056	GCoroAPI = &coroapi;
		1057	sv_setiv(sv, (IV)&coroapi);
		1058	SvREADONLY_on(sv);
		1059	}
		1060	}
		1061
		1062	void
		1063	ready(self)
		1064	SV * self
		1065	PROTOTYPE: $
		1066	CODE:
		1067	api_ready (self);
		1068
		1069	int
		1070	nready(...)
		1071	PROTOTYPE:
		1072	CODE:
		1073	RETVAL = coro_nready;
		1074	OUTPUT:
		1075	RETVAL
		1076
		1077	void
		1078	schedule(...)
		1079	PROTOTYPE:
		1080	CODE:
		1081	api_schedule ();
		1082
		1083	void
		1084	cede(...)
		1085	PROTOTYPE:
		1086	CODE:
		1087	api_cede ();
		1088

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs. Revision 1.41 by root, Tue Nov 27 02:51:03 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.41 by root, Tue Nov 27 02:51:03 2001 UTC