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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.45 by root, Tue May 27 01:15:31 2003 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.45 by root, Tue May 27 01:15:31 2003 UTC