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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs. Revision 1.22 by root, Sat Aug 11 23:10:56 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.22 by root, Sat Aug 11 23:10:56 2001 UTC