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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.15 by root, Wed Jul 25 04:14:38 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.15 by root, Wed Jul 25 04:14:38 2001 UTC