[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.20 by root, Fri Aug 3 12:51: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
		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;
10		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(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	static void	460	/*
283	LOAD(pTHX_ Coro__State c)	461	* allocate various perl stacks. This is an exact copy
		462	* of perl.c:init_stacks, except that it uses less memory
		463	* on the assumption that coroutines do not usually need
		464	* a lot of stackspace.
		465	*/
		466	STATIC void
		467	coro_init_stacks (pTHX)
284	{	468	{
285	PL_dowarn = c->dowarn;	469	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	470	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	471	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	472	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	473
		474	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	475	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	476	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	477
293	PL_stack_base = c->stack_base;	478	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	479	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	480	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	481	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	482
298	PL_tmps_max = c->tmps_max;	483	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	484	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	485	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		486
313	{	487	SET_MARK_OFFSET;
314	dSP;
315	CV *cv;
316		488
317	/* now do the ugly restore mess */	489	New(54,PL_scopestack,16,I32);
318	while ((cv = (CV *)POPs))	490	PL_scopestack_ix = 0;
319	{	491	PL_scopestack_max = 16;
320	AV padlist = (AV )POPs;
321		492
322	put_padlist (cv);	493	New(54,PL_savestack,96,ANY);
323	CvPADLIST(cv) = padlist;	494	PL_savestack_ix = 0;
324	CvDEPTH(cv) = (I32)POPs;	495	PL_savestack_max = 96;
325		496
326	#ifdef USE_THREADS	497	New(54,PL_retstack,8,OP*);
327	CvOWNER(cv) = (struct perl_thread *)POPs;	498	PL_retstack_ix = 0;
328	error does not work either	499	PL_retstack_max = 8;
329	#endif
330	}
331
332	PUTBACK;
333	}
334	}	500	}
335		501
336	/* 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	*/
337	STATIC void	506	STATIC void
338	destroy_stacks(pTHX)	507	destroy_stacks(pTHX)
339	{	508	{
340	/* die does this while calling POPSTACK, but I just don't see why. */
341	dounwind(-1);
342
343	/* is this ugly, I ask? */	509	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)	510	while (PL_scopestack_ix)
345	LEAVE;	511	LEAVE;
346		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
347	while (PL_curstackinfo->si_next)	517	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;	518	PL_curstackinfo = PL_curstackinfo->si_next;
349		519
350	while (PL_curstackinfo)	520	while (PL_curstackinfo)
351	{	521	{
352	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);
353		531
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	532	SvREFCNT_dec(PL_curstackinfo->si_stack);
355	Safefree(PL_curstackinfo->si_cxstack);	533	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);	534	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;	535	PL_curstackinfo = p;
358	}	536	}
359		537
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);	538	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);	539	Safefree(PL_markstack);
375	Safefree(PL_scopestack);	540	Safefree(PL_scopestack);
376	Safefree(PL_savestack);	541	Safefree(PL_savestack);
377	Safefree(PL_retstack);	542	Safefree(PL_retstack);
378	}	543	}
379		544
380	#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	}
381		752
382	MODULE = Coro::State PACKAGE = Coro::State	753	MODULE = Coro::State PACKAGE = Coro::State
383		754
384	PROTOTYPES: ENABLE	755	PROTOTYPES: ENABLE
385		756
386	BOOT:	757	BOOT:
		758	{ /* {} necessary for stoopid perl-5.6.x */
		759	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		760	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		761	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		762
		763	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		764	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		765	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		766	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		767
387	if (!padlist_cache)	768	if (!padlist_cache)
388	padlist_cache = newHV ();	769	padlist_cache = newHV ();
		770
		771	main_mainstack = PL_mainstack;
		772	}
389		773
390	Coro::State	774	Coro::State
391	_newprocess(args)	775	_newprocess(args)
392	SV * args	776	SV * args
393	PROTOTYPE: $	777	PROTOTYPE: $
394	CODE:	778	CODE:
395	Coro__State coro;	779	Coro__State coro;
396		780
397	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	781	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");	782	croak ("Coro::State::_newprocess expects an arrayref");
399		783
400	New (0, coro, 1, struct coro);	784	New (0, coro, 1, struct coro);
401		785
		786	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
402	coro->mainstack = 0; /* actual work is done inside transfer */	787	coro->mainstack = 0; /* actual work is done inside transfer */
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	788	coro->stack = 0;
404		789
405	RETVAL = coro;	790	RETVAL = coro;
406	OUTPUT:	791	OUTPUT:
407	RETVAL	792	RETVAL
408		793
409	void	794	void
410	transfer(prev,next)	795	transfer(prev, next, flags = TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK)
411	Coro::State_or_hashref prev	796	Coro::State_or_hashref prev
412	Coro::State_or_hashref next	797	Coro::State_or_hashref next
		798	int flags
		799	PROTOTYPE: @
413	CODE:	800	CODE:
414
415	if (prev != next)
416	{
417	PUTBACK;	801	PUTBACK;
418	SAVE (aTHX_ prev);	802	transfer (aTHX_ prev, next, flags);
419
420	/*
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;	803	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		804
465	void	805	void
466	DESTROY(coro)	806	DESTROY(coro)
467	Coro::State coro	807	Coro::State coro
468	CODE:	808	CODE:
469		809
470	if (coro->mainstack)	810	if (coro->mainstack && coro->mainstack != main_mainstack)
471	{	811	{
472	struct coro temp;	812	struct coro temp;
473		813
474	PUTBACK;
475	SAVE(aTHX_ (&temp));	814	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
476	LOAD(aTHX_ coro);	815	LOAD(aTHX_ coro);
477		816
478	destroy_stacks ();	817	destroy_stacks (aTHX);
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480		818
481	LOAD((&temp));	819	LOAD((&temp)); /* this will get rid of defsv etc.. */
482	SPAGAIN;	820
		821	coro->mainstack = 0;
483	}	822	}
484		823
485	SvREFCNT_dec (coro->args);	824	deallocate_stack (coro);
		825
486	Safefree (coro);	826	Safefree (coro);
487		827
		828	void
		829	flush()
		830	CODE:
		831	#ifdef MAY_FLUSH
		832	flush_padlist_cache ();
		833	#endif
488		834
		835	void
		836	_exit(code)
		837	int code
		838	PROTOTYPE: $
		839	CODE:
		840	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		841	_exit (code);
		842	#else
		843	signal (SIGTERM, SIG_DFL);
		844	raise (SIGTERM);
		845	exit (code);
		846	#endif
		847
		848	MODULE = Coro::State PACKAGE = Coro::Cont
		849
		850	# this is slightly dirty
		851
		852	void
		853	yield(...)
		854	PROTOTYPE: @
		855	CODE:
		856	static SV *returnstk;
		857	SV *sv;
		858	AV *defav = GvAV (PL_defgv);
		859	struct coro prev, next;
		860
		861	if (!returnstk)
		862	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		863
		864	/* set up @_ -- ugly */
		865	av_clear (defav);
		866	av_fill (defav, items - 1);
		867	while (items--)
		868	av_store (defav, items, SvREFCNT_inc (ST(items)));
		869
		870	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		871	sv = av_pop ((AV *)SvRV (returnstk));
		872	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		873	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		874	SvREFCNT_dec (sv);
		875
		876	transfer(aTHX_ prev, next, 0);
		877

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.20 by root, Fri Aug 3 12:51:56 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.20 by root, Fri Aug 3 12:51:56 2001 UTC