[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.17 by root, Wed Jul 25 14:01:46 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;
		57
		58	static coro_stack main_stack = { 1, 0, 0 };
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
14		74	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	75	PERL_SI *curstackinfo;
16	AV *curstack;	76	AV *curstack;
17	AV *mainstack;	77	AV *mainstack;
18	SV **stack_sp;	78	SV **stack_sp;
19	OP *op;	79	OP *op;
35	I32 savestack_max;	95	I32 savestack_max;
36	OP **retstack;	96	OP **retstack;
37	I32 retstack_ix;	97	I32 retstack_ix;
38	I32 retstack_max;	98	I32 retstack_max;
39	COP *curcop;	99	COP *curcop;
		100	JMPENV start_env;
		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
		296	PL_curstackinfo = c->curstackinfo;
		297	PL_curstack = c->curstack;
		298	PL_mainstack = c->mainstack;
		299	PL_stack_sp = c->stack_sp;
		300	PL_op = c->op;
		301	PL_curpad = c->curpad;
		302	PL_stack_base = c->stack_base;
		303	PL_stack_max = c->stack_max;
		304	PL_tmps_stack = c->tmps_stack;
		305	PL_tmps_floor = c->tmps_floor;
		306	PL_tmps_ix = c->tmps_ix;
		307	PL_tmps_max = c->tmps_max;
		308	PL_markstack = c->markstack;
		309	PL_markstack_ptr = c->markstack_ptr;
		310	PL_markstack_max = c->markstack_max;
		311	PL_scopestack = c->scopestack;
		312	PL_scopestack_ix = c->scopestack_ix;
		313	PL_scopestack_max = c->scopestack_max;
		314	PL_savestack = c->savestack;
		315	PL_savestack_ix = c->savestack_ix;
		316	PL_savestack_max = c->savestack_max;
		317	PL_retstack = c->retstack;
		318	PL_retstack_ix = c->retstack_ix;
		319	PL_retstack_max = c->retstack_max;
		320	PL_curcop = c->curcop;
		321	PL_start_env = c->start_env;
		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
255	c->curstackinfo = PL_curstackinfo;	431	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	432	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	433	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	434	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	435	c->op = PL_op;
…		…
275	c->savestack_max = PL_savestack_max;	451	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;	452	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;	453	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	454	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;	455	c->curcop = PL_curcop;
		456	c->start_env = PL_start_env;
		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	JMPENV_BOOTSTRAP;
		611	SPAGAIN;
		612
		613	/PL_curcop = 0;/
		614	SvREFCNT_dec (GvAV (PL_defgv));
		615	GvAV (PL_defgv) = ctx->args;
		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);
		624	croak ("FATAL: CCTXT coroutine returned!");
		625	}
		626	else
		627	{
		628	UNOP myop;
		629
		630	PL_op = (OP *)&myop;
		631
		632	Zero(&myop, 1, UNOP);
		633	myop.op_next = Nullop;
		634	myop.op_flags = OPf_WANT_VOID;
		635
		636	PUSHMARK(SP);
		637	XPUSHs (sub_init);
		638	/*
		639	* the next line is slightly wrong, as PL_op->op_next
		640	* is actually being executed so we skip the first op.
		641	* that doesn't matter, though, since it is only
		642	* pp_nextstate and we never return...
		643	* ah yes, and I don't care anyways ;)
		644	*/
		645	PUTBACK;
		646	PL_op = pp_entersub();
		647	SPAGAIN;
		648
		649	ENTER; /* necessary e.g. for dounwind */
		650	}
		651	}
		652
		653	static void
		654	continue_coro (void *arg)
		655	{
		656	/*
		657	* this is a _very_ stripped down perl interpreter ;)
		658	*/
		659	Coro__State ctx = (Coro__State)arg;
		660
		661	ctx->cursp = 0;
		662	PL_op = PL_op->op_next;
		663	CALLRUNOPS(aTHX);
		664	/NORETURN/
		665	abort ();
		666	}
		667
		668	STATIC void
		669	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		670	{
		671	dSP;
		672	dSTACKLEVEL;
		673
		674	if (prev != next)
		675	{
		676	if (next->mainstack)
		677	{
		678	SAVE (prev, flags);
		679	LOAD (next);
		680
		681	/* mark this state as in-use */
		682	next->mainstack = 0;
		683	next->tmps_ix = -2;
		684
		685	/* stacklevel changed? if yes, grab the stack for us! */
		686	if (flags & TRANSFER_SAVE_CCTXT)
		687	{
		688	if (!prev->stack)
		689	allocate_stack (prev, 0);
		690	else if (prev->cursp != stacklevel
		691	&& prev->stack->usecnt > 1)
		692	{
		693	prev->gencnt = ++prev->stack->gencnt;
		694	prev->stack->usecnt = 1;
		695	}
		696
		697	/* has our stack been invalidated? */
		698	if (next->stack && next->stack->gencnt != next->gencnt)
		699	{
		700	deallocate_stack (next);
		701	allocate_stack (next, 1);
		702	coro_create (&(next->stack->cctx),
		703	continue_coro, (void *)next,
		704	next->stack->sptr, labs (next->stack->ssize));
		705	}
		706
		707	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		708	}
		709
		710	}
		711	else if (next->tmps_ix == -2)
		712	croak ("tried to transfer to running coroutine");
		713	else
		714	{
		715	SAVE (prev, -1); /* first get rid of the old state */
		716
		717	if (flags & TRANSFER_SAVE_CCTXT)
		718	{
		719	if (!prev->stack)
		720	allocate_stack (prev, 0);
		721
		722	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		723	{
		724	setup_coro (next);
		725
		726	prev->stack->refcnt++;
		727	prev->stack->usecnt++;
		728	next->stack = prev->stack;
		729	next->gencnt = prev->gencnt;
		730	}
		731	else
		732	{
		733	allocate_stack (next, 1);
		734	coro_create (&(next->stack->cctx),
		735	setup_coro, (void *)next,
		736	next->stack->sptr, labs (next->stack->ssize));
		737	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		738	}
		739	}
		740	else
		741	setup_coro (next);
		742	}
		743	}
		744
		745	next->cursp = stacklevel;
		746	}
385		747
386	MODULE = Coro::State PACKAGE = Coro::State	748	MODULE = Coro::State PACKAGE = Coro::State
387		749
388	PROTOTYPES: ENABLE	750	PROTOTYPES: ENABLE
389		751
390	BOOT:	752	BOOT:
		753	{ /* {} necessary for stoopid perl-5.6.x */
		754	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		755	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		756	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		757
		758	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		759	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		760	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		761	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		762
391	if (!padlist_cache)	763	if (!padlist_cache)
392	padlist_cache = newHV ();	764	padlist_cache = newHV ();
		765
		766	main_mainstack = PL_mainstack;
		767	}
393		768
394	Coro::State	769	Coro::State
395	_newprocess(args)	770	_newprocess(args)
396	SV * args	771	SV * args
397	PROTOTYPE: $	772	PROTOTYPE: $
398	CODE:	773	CODE:
399	Coro__State coro;	774	Coro__State coro;
400		775
401	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	776	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");	777	croak ("Coro::State::_newprocess expects an arrayref");
403		778
404	New (0, coro, 1, struct coro);	779	New (0, coro, 1, struct coro);
405		780
		781	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406	coro->mainstack = 0; /* actual work is done inside transfer */	782	coro->mainstack = 0; /* actual work is done inside transfer */
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	783	coro->stack = 0;
408		784
409	RETVAL = coro;	785	RETVAL = coro;
410	OUTPUT:	786	OUTPUT:
411	RETVAL	787	RETVAL
412		788
413	void	789	void
414	transfer(prev,next)	790	transfer(prev, next, flags = TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK)
415	Coro::State_or_hashref prev	791	Coro::State_or_hashref prev
416	Coro::State_or_hashref next	792	Coro::State_or_hashref next
		793	int flags
		794	PROTOTYPE: @
417	CODE:	795	CODE:
418		796	transfer (aTHX_ prev, next, flags);
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;
461	/*
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;
469
470	ENTER;
471	}
472	}
473		797
474	void	798	void
475	DESTROY(coro)	799	DESTROY(coro)
476	Coro::State coro	800	Coro::State coro
477	CODE:	801	CODE:
478		802
479	if (coro->mainstack)	803	if (coro->mainstack && coro->mainstack != main_mainstack)
480	{	804	{
481	struct coro temp;	805	struct coro temp;
482		806
483	SAVE(aTHX_ (&temp));	807	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
484	LOAD(aTHX_ coro);	808	LOAD(aTHX_ coro);
485		809
486	destroy_stacks ();	810	destroy_stacks (aTHX);
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488		811
489	LOAD((&temp));	812	LOAD((&temp)); /* this will get rid of defsv etc.. */
		813
		814	coro->mainstack = 0;
490	}	815	}
491		816
492	SvREFCNT_dec (coro->args);	817	deallocate_stack (coro);
		818
493	Safefree (coro);	819	Safefree (coro);
494		820
		821	void
		822	flush()
		823	CODE:
		824	#ifdef MAY_FLUSH
		825	flush_padlist_cache ();
		826	#endif
495		827
		828	MODULE = Coro::State PACKAGE = Coro::Cont
		829
		830	# this is slightly dirty
		831
		832	void
		833	yield(...)
		834	PROTOTYPE: @
		835	CODE:
		836	static SV *returnstk;
		837	SV *sv;
		838	AV *defav = GvAV (PL_defgv);
		839	struct coro prev, next;
		840
		841	if (!returnstk)
		842	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		843
		844	/* set up @_ -- ugly */
		845	av_clear (defav);
		846	av_fill (defav, items - 1);
		847	while (items--)
		848	av_store (defav, items, SvREFCNT_inc (ST(items)));
		849
		850	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		851	sv = av_pop ((AV *)SvRV (returnstk));
		852	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		853	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		854	SvREFCNT_dec (sv);
		855
		856	transfer(aTHX_ prev, next, 0);
		857

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.17 by root, Wed Jul 25 14:01:46 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.17 by root, Wed Jul 25 14:01:46 2001 UTC