[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.23 by root, Tue Aug 14 04:33:58 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 */
		22
		23	#define SUB_INIT "Coro::State::initialize"
		24	#define UCORO_STATE "_coro_state"
		25
		26	/* The next macro should delcare 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
		199	#ifdef MAY_FLUSH
143	STATIC AV *	200	STATIC AV *
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))
…		…
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) SB load_state(aTHX_ (state)); SPAGAIN; SE
		276	#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
		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
		413	/* I have not the slightest idea of why av_reify is necessary */
		414	/* but if it's missing the defav contents magically get replaced sometimes */
		415	if (c->defav)
		416	av_reify (c->defav);
		417
253	c->dowarn = PL_dowarn;	418	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);	419	c->in_eval = PL_in_eval;
		420
255	c->curstackinfo = PL_curstackinfo;	421	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	422	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	423	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	424	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	425	c->op = PL_op;
…		…
275	c->savestack_max = PL_savestack_max;	441	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;	442	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;	443	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	444	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;	445	c->curcop = PL_curcop;
		446	c->top_env = PL_top_env;
280	}	447	}
281		448
282	static void	449	/*
283	LOAD(pTHX_ Coro__State c)	450	* allocate various perl stacks. This is an exact copy
		451	* of perl.c:init_stacks, except that it uses less memory
		452	* on the assumption that coroutines do not usually need
		453	* a lot of stackspace.
		454	*/
		455	STATIC void
		456	coro_init_stacks (pTHX)
284	{	457	{
285	PL_dowarn = c->dowarn;	458	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	459	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	460	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	461	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	462
		463	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	464	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	465	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	466
293	PL_stack_base = c->stack_base;	467	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	468	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	469	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	470	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	471
298	PL_tmps_max = c->tmps_max;	472	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	473	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	474	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		475
313	{	476	SET_MARK_OFFSET;
314	dSP;
315	CV *cv;
316		477
317	/* now do the ugly restore mess */	478	New(54,PL_scopestack,16,I32);
318	while ((cv = (CV *)POPs))	479	PL_scopestack_ix = 0;
319	{	480	PL_scopestack_max = 16;
320	AV padlist = (AV )POPs;
321		481
322	put_padlist (cv);	482	New(54,PL_savestack,96,ANY);
323	CvPADLIST(cv) = padlist;	483	PL_savestack_ix = 0;
324	CvDEPTH(cv) = (I32)POPs;	484	PL_savestack_max = 96;
325		485
326	#ifdef USE_THREADS	486	New(54,PL_retstack,8,OP*);
327	CvOWNER(cv) = (struct perl_thread *)POPs;	487	PL_retstack_ix = 0;
328	error does not work either	488	PL_retstack_max = 8;
329	#endif
330	}
331
332	PUTBACK;
333	}
334	}	489	}
335		490
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	491	/*
		492	* destroy the stacks, the callchain etc...
		493	* still there is a memleak of 128 bytes...
		494	*/
337	STATIC void	495	STATIC void
338	destroy_stacks(pTHX)	496	destroy_stacks(pTHX)
339	{	497	{
340	/* die does this while calling POPSTACK, but I just don't see why. */
341	dounwind(-1);
342
343	/* is this ugly, I ask? */	498	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)	499	while (PL_scopestack_ix)
345	LEAVE;	500	LEAVE;
346		501
		502	/* sure it is, but more important: is it correct?? :/ */
		503	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		504	FREETMPS;
		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;
		512
		513	{
		514	dSP;
		515	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		516	PUTBACK; /* possibly superfluous */
		517	}
		518
		519	dounwind(-1);
353		520
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	521	SvREFCNT_dec(PL_curstackinfo->si_stack);
355	Safefree(PL_curstackinfo->si_cxstack);	522	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);	523	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;	524	PL_curstackinfo = p;
358	}	525	}
359		526
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);	527	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);	528	Safefree(PL_markstack);
375	Safefree(PL_scopestack);	529	Safefree(PL_scopestack);
376	Safefree(PL_savestack);	530	Safefree(PL_savestack);
377	Safefree(PL_retstack);	531	Safefree(PL_retstack);
378	}	532	}
379		533
380	#define SUB_INIT "Coro::State::_newcoro"	534	static void
		535	allocate_stack (Coro__State ctx, int alloc)
		536	{
		537	coro_stack *stack;
		538
		539	New (0, stack, 1, coro_stack);
		540
		541	stack->refcnt = 1;
		542	stack->usecnt = 1;
		543	stack->gencnt = ctx->gencnt = 0;
		544	if (alloc)
		545	{
		546	#ifdef HAVE_MMAP
		547	stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
		548	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANON, 0, 0);
		549	if (stack->sptr == (void *)-1)
		550	#endif
		551	{
		552	/FIXME//D//* reasonable stack size! */
		553	stack->ssize = -4096 * sizeof (long);
		554	New (0, stack->sptr, 4096, long);
		555	}
		556	}
		557	else
		558	stack->sptr = 0;
		559
		560	ctx->stack = stack;
		561	}
		562
		563	static void
		564	deallocate_stack (Coro__State ctx)
		565	{
		566	coro_stack *stack = ctx->stack;
		567
		568	ctx->stack = 0;
		569
		570	if (stack)
		571	{
		572	if (!--stack->refcnt)
		573	{
		574	#ifdef HAVE_MMAP
		575	if (stack->ssize > 0 && stack->sptr)
		576	munmap (stack->sptr, stack->ssize);
		577	else
		578	#else
		579	Safefree (stack->sptr);
		580	#endif
		581	Safefree (stack);
		582	}
		583	else if (ctx->gencnt == stack->gencnt)
		584	--stack->usecnt;
		585	}
		586	}
		587
		588	static void
		589	setup_coro (void *arg)
		590	{
		591	/*
		592	* emulate part of the perl startup here.
		593	*/
		594	dSP;
		595	Coro__State ctx = (Coro__State)arg;
		596	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
		597
		598	coro_init_stacks (aTHX);
		599	/PL_curcop = 0;/
		600	/PL_in_eval = PL_in_eval;/ /* inherit */
		601	SvREFCNT_dec (GvAV (PL_defgv));
		602	GvAV (PL_defgv) = ctx->args;
		603
		604	SPAGAIN;
		605
		606	if (ctx->stack)
		607	{
		608	ctx->cursp = 0;
		609
		610	PUSHMARK(SP);
		611	PUTBACK;
		612	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		613
		614	if (SvTRUE (ERRSV))
		615	croak (NULL);
		616	else
		617	croak ("FATAL: CCTXT coroutine returned!");
		618	}
		619	else
		620	{
		621	UNOP myop;
		622
		623	PL_op = (OP *)&myop;
		624
		625	Zero(&myop, 1, UNOP);
		626	myop.op_next = Nullop;
		627	myop.op_flags = OPf_WANT_VOID;
		628
		629	PUSHMARK(SP);
		630	XPUSHs (sub_init);
		631	/*
		632	* the next line is slightly wrong, as PL_op->op_next
		633	* is actually being executed so we skip the first op.
		634	* that doesn't matter, though, since it is only
		635	* pp_nextstate and we never return...
		636	* ah yes, and I don't care anyways ;)
		637	*/
		638	PUTBACK;
		639	PL_op = pp_entersub();
		640	SPAGAIN;
		641
		642	ENTER; /* necessary e.g. for dounwind */
		643	}
		644	}
		645
		646	static void
		647	continue_coro (void *arg)
		648	{
		649	/*
		650	* this is a _very_ stripped down perl interpreter ;)
		651	*/
		652	Coro__State ctx = (Coro__State)arg;
		653
		654	/FIXME//* must set up top_env here */
		655	ctx->cursp = 0;
		656	PL_op = PL_op->op_next;
		657	CALLRUNOPS(aTHX);
		658
		659	abort ();
		660	}
		661
		662	STATIC void
		663	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		664	{
		665	dSP;
		666	dSTACKLEVEL;
		667
		668	if (prev != next)
		669	{
		670	if (next->mainstack)
		671	{
		672	SAVE (prev, flags);
		673	LOAD (next);
		674
		675	/* mark this state as in-use */
		676	next->mainstack = 0;
		677	next->tmps_ix = -2;
		678
		679	/* stacklevel changed? if yes, grab the stack for us! */
		680	if (flags & TRANSFER_SAVE_CCTXT)
		681	{
		682	if (!prev->stack)
		683	allocate_stack (prev, 0);
		684	else if (prev->cursp != stacklevel
		685	&& prev->stack->usecnt > 1)
		686	{
		687	prev->gencnt = ++prev->stack->gencnt;
		688	prev->stack->usecnt = 1;
		689	}
		690
		691	/* has our stack been invalidated? */
		692	if (next->stack && next->stack->gencnt != next->gencnt)
		693	{
		694	deallocate_stack (next);
		695	allocate_stack (next, 1);
		696	coro_create (&(next->stack->cctx),
		697	continue_coro, (void *)next,
		698	next->stack->sptr, labs (next->stack->ssize));
		699	}
		700
		701	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		702	}
		703
		704	}
		705	else if (next->tmps_ix == -2)
		706	croak ("tried to transfer to running coroutine");
		707	else
		708	{
		709	SAVE (prev, -1); /* first get rid of the old state */
		710
		711	if (flags & TRANSFER_SAVE_CCTXT)
		712	{
		713	if (!prev->stack)
		714	allocate_stack (prev, 0);
		715
		716	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		717	{
		718	setup_coro (next);
		719
		720	prev->stack->refcnt++;
		721	prev->stack->usecnt++;
		722	next->stack = prev->stack;
		723	next->gencnt = prev->gencnt;
		724	}
		725	else
		726	{
		727	allocate_stack (next, 1);
		728	coro_create (&(next->stack->cctx),
		729	setup_coro, (void *)next,
		730	next->stack->sptr, labs (next->stack->ssize));
		731	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		732	}
		733	}
		734	else
		735	setup_coro (next);
		736	}
		737	}
		738
		739	next->cursp = stacklevel;
		740	}
		741
		742	static struct coro *
		743	sv_to_coro (SV arg, const char funcname, const char *varname)
		744	{
		745	if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVHV)
		746	{
		747	HE he = hv_fetch_ent((HV )SvRV(arg), ucoro_state_sv, 0, ucoro_state_hash);
		748
		749	if (!he)
		750	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", funcname, varname);
		751
		752	arg = HeVAL(he);
		753	}
		754
		755	/* must also be changed inside Coro::Cont::yield */
		756	if (SvROK(arg) && SvSTASH(SvRV(arg)) == coro_state_stash)
		757	return (struct coro ) SvIV((SV)SvRV(arg));
		758	else
		759	croak ("%s() -- %s is not (and contains not) a Coro::State object", funcname, varname);
		760	}
		761
		762	static void
		763	api_transfer(pTHX_ SV prev, SV next, int flags)
		764	{
		765	transfer(aTHX_ sv_to_coro (prev, "Coro::transfer", "prev"),
		766	sv_to_coro (next, "Coro::transfer", "next"),
		767	flags);
		768	}
		769
		770	/ Coro ******************************************************************/
		771
		772	#define PRIO_MAX 3
		773	#define PRIO_HIGH 1
		774	#define PRIO_NORMAL 0
		775	#define PRIO_LOW -1
		776	#define PRIO_IDLE -3
		777	#define PRIO_MIN -4
		778
		779	/* for Coro.pm */
		780	static GV coro_current, coro_idle;
		781	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		782
		783	static void
		784	coro_enq (SV *sv)
		785	{
		786	if (SvROK (sv))
		787	{
		788	SV *hv = SvRV (sv);
		789	if (SvTYPE (hv) == SVt_PVHV)
		790	{
		791	SV *xprio = hv_fetch ((HV )hv, "prio", 4, 0);
		792	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		793
		794	prio = prio > PRIO_MAX ? PRIO_MAX
		795	: prio < PRIO_MIN ? PRIO_MIN
		796	: prio;
		797
		798	av_push (coro_ready [prio - PRIO_MIN], sv);
		799
		800	return;
		801	}
		802	}
		803
		804	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		805	}
		806
		807	static SV *
		808	coro_deq (int min_prio)
		809	{
		810	int prio = PRIO_MAX - PRIO_MIN;
		811
		812	min_prio -= PRIO_MIN;
		813	if (min_prio < 0)
		814	min_prio = 0;
		815
		816	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		817	if (av_len (coro_ready[prio]) >= 0)
		818	return av_shift (coro_ready[prio]);
		819
		820	return 0;
		821	}
		822
		823	static void
		824	api_ready (SV *coro)
		825	{
		826	coro_enq (SvREFCNT_inc (coro));
		827	}
		828
		829	static void
		830	api_schedule (int cede)
		831	{
		832	SV prev, next;
		833
		834	prev = GvSV (coro_current);
		835
		836	if (cede)
		837	coro_enq (SvREFCNT_inc (prev));
		838
		839	next = coro_deq (PRIO_MIN);
		840
		841	if (!next)
		842	next = SvREFCNT_inc (GvSV (coro_idle));
		843
		844	GvSV (coro_current) = SvREFCNT_inc (next);
		845	transfer (sv_to_coro (prev, "Coro::schedule", "current coroutine"),
		846	sv_to_coro (next, "Coro::schedule", "next coroutine"),
		847	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		848	SvREFCNT_dec (next);
		849	SvREFCNT_dec (prev);
		850	}
381		851
382	MODULE = Coro::State PACKAGE = Coro::State	852	MODULE = Coro::State PACKAGE = Coro::State
383		853
384	PROTOTYPES: ENABLE	854	PROTOTYPES: ENABLE
385		855
386	BOOT:	856	BOOT:
		857	{ /* {} necessary for stoopid perl-5.6.x */
		858	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		859	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		860	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		861
		862	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		863	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		864	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		865	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		866
387	if (!padlist_cache)	867	if (!padlist_cache)
388	padlist_cache = newHV ();	868	padlist_cache = newHV ();
		869
		870	main_mainstack = PL_mainstack;
		871
		872	{
		873	SV *sv = perl_get_sv("Coro::API", 1);
		874
		875	coroapi.ver = CORO_API_VERSION - 1;
		876	coroapi.transfer = api_transfer;
		877	coroapi.schedule = api_schedule;
		878	coroapi.ready = api_ready;
		879
		880	GCoroAPI = &coroapi;
		881	sv_setiv(sv, (IV)&coroapi);
		882	SvREADONLY_on(sv);
		883	}
		884	}
389		885
390	Coro::State	886	Coro::State
391	_newprocess(args)	887	_newprocess(args)
392	SV * args	888	SV * args
393	PROTOTYPE: $	889	PROTOTYPE: $
394	CODE:	890	CODE:
395	Coro__State coro;	891	Coro__State coro;
396		892
397	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	893	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");	894	croak ("Coro::State::_newprocess expects an arrayref");
399		895
400	New (0, coro, 1, struct coro);	896	New (0, coro, 1, struct coro);
401		897
		898	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
402	coro->mainstack = 0; /* actual work is done inside transfer */	899	coro->mainstack = 0; /* actual work is done inside transfer */
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	900	coro->stack = 0;
404		901
405	RETVAL = coro;	902	RETVAL = coro;
406	OUTPUT:	903	OUTPUT:
407	RETVAL	904	RETVAL
408		905
409	void	906	void
410	transfer(prev,next)	907	transfer(prev, next, flags)
411	Coro::State_or_hashref prev	908	Coro::State_or_hashref prev
412	Coro::State_or_hashref next	909	Coro::State_or_hashref next
		910	int flags
		911	PROTOTYPE: @
413	CODE:	912	CODE:
414
415	if (prev != next)
416	{
417	PUTBACK;	913	PUTBACK;
418	SAVE (aTHX_ prev);	914	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;	915	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		916
465	void	917	void
466	DESTROY(coro)	918	DESTROY(coro)
467	Coro::State coro	919	Coro::State coro
468	CODE:	920	CODE:
469		921
470	if (coro->mainstack)	922	if (coro->mainstack && coro->mainstack != main_mainstack)
471	{	923	{
472	struct coro temp;	924	struct coro temp;
473		925
474	PUTBACK;
475	SAVE(aTHX_ (&temp));	926	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
476	LOAD(aTHX_ coro);	927	LOAD(aTHX_ coro);
477		928
478	destroy_stacks ();	929	destroy_stacks (aTHX);
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480		930
481	LOAD((&temp));	931	LOAD((&temp)); /* this will get rid of defsv etc.. */
482	SPAGAIN;	932
		933	coro->mainstack = 0;
483	}	934	}
484		935
485	SvREFCNT_dec (coro->args);	936	deallocate_stack (coro);
		937
486	Safefree (coro);	938	Safefree (coro);
487		939
		940	void
		941	flush()
		942	CODE:
		943	#ifdef MAY_FLUSH
		944	flush_padlist_cache ();
		945	#endif
488		946
		947	void
		948	_exit(code)
		949	int code
		950	PROTOTYPE: $
		951	CODE:
		952	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		953	_exit (code);
		954	#else
		955	signal (SIGTERM, SIG_DFL);
		956	raise (SIGTERM);
		957	exit (code);
		958	#endif
		959
		960	MODULE = Coro::State PACKAGE = Coro::Cont
		961
		962	# this is slightly dirty (should expose a c-level api)
		963
		964	void
		965	yield(...)
		966	PROTOTYPE: @
		967	CODE:
		968	static SV *returnstk;
		969	SV *sv;
		970	AV *defav = GvAV (PL_defgv);
		971	struct coro prev, next;
		972
		973	if (!returnstk)
		974	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		975
		976	/* set up @_ -- ugly */
		977	av_clear (defav);
		978	av_fill (defav, items - 1);
		979	while (items--)
		980	av_store (defav, items, SvREFCNT_inc (ST(items)));
		981
		982	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		983	sv = av_pop ((AV *)SvRV (returnstk));
		984	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		985	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		986	SvREFCNT_dec (sv);
		987
		988	transfer(aTHX_ prev, next, 0);
		989
		990	MODULE = Coro::State PACKAGE = Coro
		991
		992	# this is slightly dirty (should expose a c-level api)
		993
		994	BOOT:
		995	{
		996	int i;
		997	HV *stash = gv_stashpv ("Coro", TRUE);
		998
		999	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1000	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1001	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1002	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1003	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1004	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1005
		1006	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1007	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1008
		1009	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1010	coro_ready[i] = newAV ();
		1011	}
		1012
		1013	void
		1014	ready(self)
		1015	SV * self
		1016	CODE:
		1017	api_ready (self);
		1018
		1019	void
		1020	schedule(...)
		1021	ALIAS:
		1022	cede = 1
		1023	CODE:
		1024	api_schedule (ix);
		1025

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.23 by root, Tue Aug 14 04:33:58 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.23 by root, Tue Aug 14 04:33:58 2001 UTC