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

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.44 by root, Sat Mar 22 18:50:32 2003 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.44 by root, Sat Mar 22 18:50:32 2003 UTC