[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.19 by root, Sun Jul 29 01:11:41 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	#ifdef HAVE_MMAP
		8	# include <unistd.h>
		9	# include <sys/mman.h>
		10	# ifndef MAP_ANON
		11	# ifdef MAP_ANONYMOUS
		12	# define MAP_ANON MAP_ANONYMOUS
		13	# else
		14	# undef HAVE_MMAP
		15	# endif
		16	# endif
		17	#endif
		18
		19	#define MAY_FLUSH /* increases codesize */
		20
		21	/* perl-related */
		22	#define TRANSFER_SAVE_DEFAV 0x00000001
		23	#define TRANSFER_SAVE_DEFSV 0x00000002
		24	#define TRANSFER_SAVE_ERRSV 0x00000004
		25	/* c-related */
		26	#define TRANSFER_SAVE_CCTXT 0x00000008
		27	#ifdef CORO_LAZY_STACK
		28	# define TRANSFER_LAZY_STACK 0x00000010
7	#else	29	#else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	30	# define TRANSFER_LAZY_STACK 0x00000000
9	#endif	31	#endif
		32
		33	#define TRANSFER_SAVE_ALL (TRANSFER_SAVE_DEFAV\|TRANSFER_SAVE_DEFSV \
		34	\|TRANSFER_SAVE_ERRSV\|TRANSFER_SAVE_CCTXT)
		35
		36	#define SUB_INIT "Coro::State::initialize"
		37	#define UCORO_STATE "_coro_state"
		38
		39	/* The next macro should delcare a variable stacklevel that contains and approximation
		40	* to the current C stack pointer. It's property is that it changes with each call
		41	* and should be unique. */
		42	#define dSTACKLEVEL void *stacklevel = &stacklevel
		43
		44	#define labs(l) ((l) >= 0 ? (l) : -(l))
		45
		46	/* this is actually not only the c stack but also c registers etc... */
		47	typedef struct {
		48	int refcnt; /* pointer reference counter */
		49	int usecnt; /* shared by how many coroutines */
		50	int gencnt; /* generation counter */
		51
		52	coro_context cctx;
		53
		54	void *sptr;
		55	long ssize; /* positive == mmap, otherwise malloc */
		56	} coro_stack;
10		57
11	struct coro {	58	struct coro {
		59	/* the optional C context */
		60	coro_stack *stack;
		61	void *cursp;
		62	int gencnt;
		63
		64	/* optionally saved, might be zero */
		65	AV *defav;
		66	SV *defsv;
		67	SV *errsv;
		68
		69	/* saved global state not related to stacks */
12	U8 dowarn;	70	U8 dowarn;
13	AV *defav;	71	I32 in_eval;
14		72
		73	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	74	PERL_SI *curstackinfo;
16	AV *curstack;	75	AV *curstack;
17	AV *mainstack;	76	AV *mainstack;
18	SV **stack_sp;	77	SV **stack_sp;
19	OP *op;	78	OP *op;
35	I32 savestack_max;	94	I32 savestack_max;
36	OP **retstack;	95	OP **retstack;
37	I32 retstack_ix;	96	I32 retstack_ix;
38	I32 retstack_max;	97	I32 retstack_max;
39	COP *curcop;	98	COP *curcop;
		99	JMPENV *top_env;
40		100
		101	/* data associated with this coroutine (initial args) */
41	AV *args;	102	AV *args;
42	};	103	};
43		104
44	typedef struct coro *Coro__State;	105	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	106	typedef struct coro *Coro__State_or_hashref;
46		107
		108	static AV main_mainstack; / used to differentiate between $main and others */
		109	static HV *coro_state_stash;
		110	static SV *ucoro_state_sv;
		111	static U32 ucoro_state_hash;
47	static HV *padlist_cache;	112	static HV *padlist_cache;
48		113
49	/* mostly copied from op.c:cv_clone2 */	114	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *	115	STATIC AV *
51	clone_padlist (AV *protopadlist)	116	clone_padlist (AV *protopadlist)
…		…
115	SvPADTMP_on (sv);	180	SvPADTMP_on (sv);
116	npad[ix] = sv;	181	npad[ix] = sv;
117	}	182	}
118	}	183	}
119		184
120	#if 0 /* NONOTUNDERSTOOD */	185	#if 0 /* return -ENOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */	186	/* Now that vars are all in place, clone nested closures. */
122		187
123	for (ix = fpad; ix > 0; ix--) {	188	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	189	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv	190	if (namesv
…		…
138	#endif	203	#endif
139		204
140	return newpadlist;	205	return newpadlist;
141	}	206	}
142		207
		208	#ifdef MAY_FLUSH
143	STATIC AV *	209	STATIC AV *
144	free_padlist (AV *padlist)	210	free_padlist (AV *padlist)
145	{	211	{
146	/* may be during global destruction */	212	/* may be during global destruction */
147	if (SvREFCNT(padlist))	213	if (SvREFCNT(padlist))
…		…
156	}	222	}
157		223
158	SvREFCNT_dec((SV*)padlist);	224	SvREFCNT_dec((SV*)padlist);
159	}	225	}
160	}	226	}
		227	#endif
161		228
162	/* the next tow functions merely cache the padlists */	229	/* the next two functions merely cache the padlists */
163	STATIC void	230	STATIC void
164	get_padlist (CV *cv)	231	get_padlist (CV *cv)
165	{	232	{
166	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);	233	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
167		234
…		…
183	}	250	}
184		251
185	av_push ((AV )he, (SV *)CvPADLIST (cv));	252	av_push ((AV )he, (SV *)CvPADLIST (cv));
186	}	253	}
187		254
		255	#ifdef MAY_FLUSH
		256	STATIC void
		257	flush_padlist_cache ()
		258	{
		259	HV *hv = padlist_cache;
		260	padlist_cache = newHV ();
		261
		262	if (hv_iterinit (hv))
		263	{
		264	HE *he;
		265	AV *padlist;
		266
		267	while (!!(he = hv_iternext (hv)))
		268	{
		269	AV av = (AV )HeVAL(he);
		270
		271	/* casting is fun. */
		272	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
		273	free_padlist (padlist);
		274	}
		275	}
		276
		277	SvREFCNT_dec (hv);
		278	}
		279	#endif
		280
		281	#define SB do {
		282	#define SE } while (0)
		283
		284	#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE
		285	#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
		286
		287	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
		288
188	static void	289	static void
189	SAVE(pTHX_ Coro__State c)	290	load_state(pTHX_ Coro__State c)
		291	{
		292	PL_dowarn = c->dowarn;
		293	PL_in_eval = c->in_eval;
		294
		295	PL_curstackinfo = c->curstackinfo;
		296	PL_curstack = c->curstack;
		297	PL_mainstack = c->mainstack;
		298	PL_stack_sp = c->stack_sp;
		299	PL_op = c->op;
		300	PL_curpad = c->curpad;
		301	PL_stack_base = c->stack_base;
		302	PL_stack_max = c->stack_max;
		303	PL_tmps_stack = c->tmps_stack;
		304	PL_tmps_floor = c->tmps_floor;
		305	PL_tmps_ix = c->tmps_ix;
		306	PL_tmps_max = c->tmps_max;
		307	PL_markstack = c->markstack;
		308	PL_markstack_ptr = c->markstack_ptr;
		309	PL_markstack_max = c->markstack_max;
		310	PL_scopestack = c->scopestack;
		311	PL_scopestack_ix = c->scopestack_ix;
		312	PL_scopestack_max = c->scopestack_max;
		313	PL_savestack = c->savestack;
		314	PL_savestack_ix = c->savestack_ix;
		315	PL_savestack_max = c->savestack_max;
		316	PL_retstack = c->retstack;
		317	PL_retstack_ix = c->retstack_ix;
		318	PL_retstack_max = c->retstack_max;
		319	PL_curcop = c->curcop;
		320	PL_top_env = c->top_env;
		321
		322	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		323	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		324	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		325
		326	{
		327	dSP;
		328	CV *cv;
		329
		330	/* now do the ugly restore mess */
		331	while ((cv = (CV *)POPs))
		332	{
		333	AV padlist = (AV )POPs;
		334
		335	if (padlist)
		336	{
		337	put_padlist (cv); /* mark this padlist as available */
		338	CvPADLIST(cv) = padlist;
		339	#ifdef USE_THREADS
		340	/CvOWNER(cv) = (struct perl_thread )POPs;*/
		341	#endif
		342	}
		343
		344	++CvDEPTH(cv);
		345	}
		346
		347	PUTBACK;
		348	}
		349	}
		350
		351	static void
		352	save_state(pTHX_ Coro__State c, int flags)
190	{	353	{
191	{	354	{
192	dSP;	355	dSP;
193	I32 cxix = cxstack_ix;	356	I32 cxix = cxstack_ix;
		357	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	358	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		359
197	/*	360	/*
198	* the worst thing you can imagine happens first - we have to save	361	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	362	* (and reinitialize) all cv's in the whole callchain :(
200	*/	363	*/
201		364
202	PUSHs (Nullsv);	365	PUSHs (Nullsv);
203	/* this loop was inspired by pp_caller */	366	/* this loop was inspired by pp_caller */
204	for (;;)	367	for (;;)
205	{	368	{
206	while (cxix >= 0)	369	do
207	{	370	{
208	PERL_CONTEXT *cx = &ccstk[cxix--];	371	PERL_CONTEXT *cx = &ccstk[cxix--];
209		372
210	if (CxTYPE(cx) == CXt_SUB)	373	if (CxTYPE(cx) == CXt_SUB)
211	{	374	{
212	CV *cv = cx->blk_sub.cv;	375	CV *cv = cx->blk_sub.cv;
213	if (CvDEPTH(cv))	376	if (CvDEPTH(cv))
214	{	377	{
215	#ifdef USE_THREADS	378	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));	379	/XPUSHs ((SV )CvOWNER(cv));*/
		380	/CvOWNER(cv) = 0;/
		381	/error must unlock this cv etc.. etc.../
217	#endif	382	#endif
218	EXTEND (SP, 3);	383	EXTEND (SP, CvDEPTH(cv)*2);
		384
		385	while (--CvDEPTH(cv))
		386	{
		387	/* this tells the restore code to increment CvDEPTH */
		388	PUSHs (Nullsv);
219	PUSHs ((SV *)CvDEPTH(cv));	389	PUSHs ((SV *)cv);
		390	}
		391
220	PUSHs ((SV *)CvPADLIST(cv));	392	PUSHs ((SV *)CvPADLIST(cv));
221	PUSHs ((SV *)cv);	393	PUSHs ((SV *)cv);
222		394
223	get_padlist (cv);	395	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	}	396	}
233	}	397	}
234	else if (CxTYPE(cx) == CXt_FORMAT)	398	else if (CxTYPE(cx) == CXt_FORMAT)
235	{	399	{
236	/* I never used formats, so how should I know how these are implemented? */	400	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */	401	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	402	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}	403	}
240	}	404	}
		405	while (cxix >= 0);
241		406
242	if (top_si->si_type == PERLSI_MAIN)	407	if (top_si->si_type == PERLSI_MAIN)
243	break;	408	break;
244		409
245	top_si = top_si->si_prev;	410	top_si = top_si->si_prev;
…		…
248	}	413	}
249		414
250	PUTBACK;	415	PUTBACK;
251	}	416	}
252		417
		418	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		419	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		420	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		421
		422	/* I have not the slightest idea of why av_reify is necessary */
		423	/* but if it's missing the defav contents magically get replaced sometimes */
		424	if (c->defav)
		425	av_reify (c->defav);
		426
253	c->dowarn = PL_dowarn;	427	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);	428	c->in_eval = PL_in_eval;
		429
255	c->curstackinfo = PL_curstackinfo;	430	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	431	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	432	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	433	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	434	c->op = PL_op;
…		…
275	c->savestack_max = PL_savestack_max;	450	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;	451	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;	452	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	453	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;	454	c->curcop = PL_curcop;
		455	c->top_env = PL_top_env;
280	}	456	}
281		457
282	static void	458	/*
283	LOAD(pTHX_ Coro__State c)	459	* allocate various perl stacks. This is an exact copy
		460	* of perl.c:init_stacks, except that it uses less memory
		461	* on the assumption that coroutines do not usually need
		462	* a lot of stackspace.
		463	*/
		464	STATIC void
		465	coro_init_stacks (pTHX)
284	{	466	{
285	PL_dowarn = c->dowarn;	467	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	468	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	469	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	470	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	471
		472	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	473	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	474	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	475
293	PL_stack_base = c->stack_base;	476	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	477	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	478	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	479	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	480
298	PL_tmps_max = c->tmps_max;	481	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	482	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	483	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		484
313	{	485	SET_MARK_OFFSET;
314	dSP;
315	CV *cv;
316		486
317	/* now do the ugly restore mess */	487	New(54,PL_scopestack,16,I32);
318	while ((cv = (CV *)POPs))	488	PL_scopestack_ix = 0;
319	{	489	PL_scopestack_max = 16;
320	AV padlist = (AV )POPs;
321		490
322	put_padlist (cv);	491	New(54,PL_savestack,96,ANY);
323	CvPADLIST(cv) = padlist;	492	PL_savestack_ix = 0;
324	CvDEPTH(cv) = (I32)POPs;	493	PL_savestack_max = 96;
325		494
326	#ifdef USE_THREADS	495	New(54,PL_retstack,8,OP*);
327	CvOWNER(cv) = (struct perl_thread *)POPs;	496	PL_retstack_ix = 0;
328	error does not work either	497	PL_retstack_max = 8;
329	#endif
330	}
331
332	PUTBACK;
333	}
334	}	498	}
335		499
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	500	/*
		501	* destroy the stacks, the callchain etc...
		502	* still there is a memleak of 128 bytes...
		503	*/
337	STATIC void	504	STATIC void
338	destroy_stacks(pTHX)	505	destroy_stacks(pTHX)
339	{	506	{
340	/* die does this while calling POPSTACK, but I just don't see why. */
341	dounwind(-1);
342
343	/* is this ugly, I ask? */	507	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)	508	while (PL_scopestack_ix)
345	LEAVE;	509	LEAVE;
346		510
		511	/* sure it is, but more important: is it correct?? :/ */
		512	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		513	FREETMPS;
		514
347	while (PL_curstackinfo->si_next)	515	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;	516	PL_curstackinfo = PL_curstackinfo->si_next;
349		517
350	while (PL_curstackinfo)	518	while (PL_curstackinfo)
351	{	519	{
352	PERL_SI *p = PL_curstackinfo->si_prev;	520	PERL_SI *p = PL_curstackinfo->si_prev;
		521
		522	{
		523	dSP;
		524	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		525	PUTBACK; /* possibly superfluous */
		526	}
		527
		528	dounwind(-1);
353		529
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	530	SvREFCNT_dec(PL_curstackinfo->si_stack);
355	Safefree(PL_curstackinfo->si_cxstack);	531	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);	532	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;	533	PL_curstackinfo = p;
358	}	534	}
359		535
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);	536	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);	537	Safefree(PL_markstack);
375	Safefree(PL_scopestack);	538	Safefree(PL_scopestack);
376	Safefree(PL_savestack);	539	Safefree(PL_savestack);
377	Safefree(PL_retstack);	540	Safefree(PL_retstack);
378	}	541	}
379		542
380	#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	#ifdef 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_ANON, 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 = pp_entersub();
		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
		663	/FIXME//* must set up top_env here */
		664	ctx->cursp = 0;
		665	PL_op = PL_op->op_next;
		666	CALLRUNOPS(aTHX);
		667
		668	abort ();
		669	}
		670
		671	STATIC void
		672	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		673	{
		674	dSP;
		675	dSTACKLEVEL;
		676
		677	if (prev != next)
		678	{
		679	if (next->mainstack)
		680	{
		681	SAVE (prev, flags);
		682	LOAD (next);
		683
		684	/* mark this state as in-use */
		685	next->mainstack = 0;
		686	next->tmps_ix = -2;
		687
		688	/* stacklevel changed? if yes, grab the stack for us! */
		689	if (flags & TRANSFER_SAVE_CCTXT)
		690	{
		691	if (!prev->stack)
		692	allocate_stack (prev, 0);
		693	else if (prev->cursp != stacklevel
		694	&& prev->stack->usecnt > 1)
		695	{
		696	prev->gencnt = ++prev->stack->gencnt;
		697	prev->stack->usecnt = 1;
		698	}
		699
		700	/* has our stack been invalidated? */
		701	if (next->stack && next->stack->gencnt != next->gencnt)
		702	{
		703	deallocate_stack (next);
		704	allocate_stack (next, 1);
		705	coro_create (&(next->stack->cctx),
		706	continue_coro, (void *)next,
		707	next->stack->sptr, labs (next->stack->ssize));
		708	}
		709
		710	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		711	}
		712
		713	}
		714	else if (next->tmps_ix == -2)
		715	croak ("tried to transfer to running coroutine");
		716	else
		717	{
		718	SAVE (prev, -1); /* first get rid of the old state */
		719
		720	if (flags & TRANSFER_SAVE_CCTXT)
		721	{
		722	if (!prev->stack)
		723	allocate_stack (prev, 0);
		724
		725	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		726	{
		727	setup_coro (next);
		728
		729	prev->stack->refcnt++;
		730	prev->stack->usecnt++;
		731	next->stack = prev->stack;
		732	next->gencnt = prev->gencnt;
		733	}
		734	else
		735	{
		736	allocate_stack (next, 1);
		737	coro_create (&(next->stack->cctx),
		738	setup_coro, (void *)next,
		739	next->stack->sptr, labs (next->stack->ssize));
		740	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		741	}
		742	}
		743	else
		744	setup_coro (next);
		745	}
		746	}
		747
		748	next->cursp = stacklevel;
		749	}
381		750
382	MODULE = Coro::State PACKAGE = Coro::State	751	MODULE = Coro::State PACKAGE = Coro::State
383		752
384	PROTOTYPES: ENABLE	753	PROTOTYPES: ENABLE
385		754
386	BOOT:	755	BOOT:
		756	{ /* {} necessary for stoopid perl-5.6.x */
		757	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		758	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		759	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		760
		761	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		762	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		763	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		764	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		765
387	if (!padlist_cache)	766	if (!padlist_cache)
388	padlist_cache = newHV ();	767	padlist_cache = newHV ();
		768
		769	main_mainstack = PL_mainstack;
		770	}
389		771
390	Coro::State	772	Coro::State
391	_newprocess(args)	773	_newprocess(args)
392	SV * args	774	SV * args
393	PROTOTYPE: $	775	PROTOTYPE: $
394	CODE:	776	CODE:
395	Coro__State coro;	777	Coro__State coro;
396		778
397	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	779	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");	780	croak ("Coro::State::_newprocess expects an arrayref");
399		781
400	New (0, coro, 1, struct coro);	782	New (0, coro, 1, struct coro);
401		783
		784	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
402	coro->mainstack = 0; /* actual work is done inside transfer */	785	coro->mainstack = 0; /* actual work is done inside transfer */
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	786	coro->stack = 0;
404		787
405	RETVAL = coro;	788	RETVAL = coro;
406	OUTPUT:	789	OUTPUT:
407	RETVAL	790	RETVAL
408		791
409	void	792	void
410	transfer(prev,next)	793	transfer(prev, next, flags = TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK)
411	Coro::State_or_hashref prev	794	Coro::State_or_hashref prev
412	Coro::State_or_hashref next	795	Coro::State_or_hashref next
		796	int flags
		797	PROTOTYPE: @
413	CODE:	798	CODE:
414		799	transfer (aTHX_ prev, next, flags);
415	if (prev != next)
416	{
417	PUTBACK;
418	SAVE (aTHX_ prev);
419
420	/*
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;
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		800
465	void	801	void
466	DESTROY(coro)	802	DESTROY(coro)
467	Coro::State coro	803	Coro::State coro
468	CODE:	804	CODE:
469		805
470	if (coro->mainstack)	806	if (coro->mainstack && coro->mainstack != main_mainstack)
471	{	807	{
472	struct coro temp;	808	struct coro temp;
473		809
474	PUTBACK;
475	SAVE(aTHX_ (&temp));	810	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
476	LOAD(aTHX_ coro);	811	LOAD(aTHX_ coro);
477		812
478	destroy_stacks ();	813	destroy_stacks (aTHX);
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480		814
481	LOAD((&temp));	815	LOAD((&temp)); /* this will get rid of defsv etc.. */
482	SPAGAIN;	816
		817	coro->mainstack = 0;
483	}	818	}
484		819
485	SvREFCNT_dec (coro->args);	820	deallocate_stack (coro);
		821
486	Safefree (coro);	822	Safefree (coro);
487		823
		824	void
		825	flush()
		826	CODE:
		827	#ifdef MAY_FLUSH
		828	flush_padlist_cache ();
		829	#endif
488		830
		831	MODULE = Coro::State PACKAGE = Coro::Cont
		832
		833	# this is slightly dirty
		834
		835	void
		836	yield(...)
		837	PROTOTYPE: @
		838	CODE:
		839	static SV *returnstk;
		840	SV *sv;
		841	AV *defav = GvAV (PL_defgv);
		842	struct coro prev, next;
		843
		844	if (!returnstk)
		845	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		846
		847	/* set up @_ -- ugly */
		848	av_clear (defav);
		849	av_fill (defav, items - 1);
		850	while (items--)
		851	av_store (defav, items, SvREFCNT_inc (ST(items)));
		852
		853	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		854	sv = av_pop ((AV *)SvRV (returnstk));
		855	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		856	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		857	SvREFCNT_dec (sv);
		858
		859	transfer(aTHX_ prev, next, 0);
		860

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.19 by root, Sun Jul 29 01:11:41 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.19 by root, Sun Jul 29 01:11:41 2001 UTC