[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.7 by root, Thu Jul 19 02:45:09 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	#if 1
6	# define CHK(x) (void *)0	6	# define CHK(x) (void *)0
7	#else	7	#else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)
9	#endif	9	#endif
10		10
		11	#define MAY_FLUSH /* increases codesize */
		12
		13	#define SAVE_DEFAV 0x00000001
		14	#define SAVE_DEFSV 0x00000002
		15	#define SAVE_ERRSV 0x00000004
		16
		17	#define SAVE_ALL -1
		18
11	struct coro {	19	struct coro {
		20	/* optionally saved, might be zero */
		21	AV *defav;
		22	SV *defsv;
		23	SV *errsv;
		24
		25	/* saved global state not related to stacks */
12	U8 dowarn;	26	U8 dowarn;
13	AV *defav;	27
14		28	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	29	PERL_SI *curstackinfo;
16	AV *curstack;	30	AV *curstack;
17	AV *mainstack;	31	AV *mainstack;
18	SV **stack_sp;	32	SV **stack_sp;
19	OP *op;	33	OP *op;
36	OP **retstack;	50	OP **retstack;
37	I32 retstack_ix;	51	I32 retstack_ix;
38	I32 retstack_max;	52	I32 retstack_max;
39	COP *curcop;	53	COP *curcop;
40		54
		55	/* data associated with this coroutine (initial args) */
41	AV *args;	56	AV *args;
42	};	57	};
43		58
44	typedef struct coro *Coro__State;	59	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	60	typedef struct coro *Coro__State_or_hashref;
…		…
115	SvPADTMP_on (sv);	130	SvPADTMP_on (sv);
116	npad[ix] = sv;	131	npad[ix] = sv;
117	}	132	}
118	}	133	}
119		134
120	#if 0 /* NONOTUNDERSTOOD */	135	#if 0 /* return -ENOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */	136	/* Now that vars are all in place, clone nested closures. */
122		137
123	for (ix = fpad; ix > 0; ix--) {	138	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	139	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv	140	if (namesv
…		…
138	#endif	153	#endif
139		154
140	return newpadlist;	155	return newpadlist;
141	}	156	}
142		157
		158	#ifdef MAY_FLUSH
143	STATIC AV *	159	STATIC AV *
144	free_padlist (AV *padlist)	160	free_padlist (AV *padlist)
145	{	161	{
146	/* may be during global destruction */	162	/* may be during global destruction */
147	if (SvREFCNT(padlist))	163	if (SvREFCNT(padlist))
…		…
156	}	172	}
157		173
158	SvREFCNT_dec((SV*)padlist);	174	SvREFCNT_dec((SV*)padlist);
159	}	175	}
160	}	176	}
		177	#endif
161		178
162	/* the next tow functions merely cache the padlists */	179	/* the next two functions merely cache the padlists */
163	STATIC void	180	STATIC void
164	get_padlist (CV *cv)	181	get_padlist (CV *cv)
165	{	182	{
166	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);	183	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
167		184
…		…
183	}	200	}
184		201
185	av_push ((AV )he, (SV *)CvPADLIST (cv));	202	av_push ((AV )he, (SV *)CvPADLIST (cv));
186	}	203	}
187		204
		205	#ifdef MAY_FLUSH
		206	STATIC void
		207	flush_padlist_cache ()
		208	{
		209	HV *hv = padlist_cache;
		210	padlist_cache = newHV ();
		211
		212	if (hv_iterinit (hv))
		213	{
		214	HE *he;
		215	AV *padlist;
		216
		217	while (!!(he = hv_iternext (hv)))
		218	{
		219	AV av = (AV )HeVAL(he);
		220
		221	/* casting is fun. */
		222	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
		223	free_padlist (padlist);
		224	}
		225	}
		226
		227	SvREFCNT_dec (hv);
		228	}
		229	#endif
		230
		231	#define SB do {
		232	#define SE } while (0)
		233
		234	#define LOAD(state) SB load_state(aTHX_ state); SPAGAIN; SE
		235	#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ state,flags); SE
		236
		237	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
		238
188	static void	239	static void
189	save_state(pTHX_ Coro__State c)	240	load_state(pTHX_ Coro__State c)
		241	{
		242	PL_dowarn = c->dowarn;
		243
		244	PL_curstackinfo = c->curstackinfo;
		245	PL_curstack = c->curstack;
		246	PL_mainstack = c->mainstack;
		247	PL_stack_sp = c->stack_sp;
		248	PL_op = c->op;
		249	PL_curpad = c->curpad;
		250	PL_stack_base = c->stack_base;
		251	PL_stack_max = c->stack_max;
		252	PL_tmps_stack = c->tmps_stack;
		253	PL_tmps_floor = c->tmps_floor;
		254	PL_tmps_ix = c->tmps_ix;
		255	PL_tmps_max = c->tmps_max;
		256	PL_markstack = c->markstack;
		257	PL_markstack_ptr = c->markstack_ptr;
		258	PL_markstack_max = c->markstack_max;
		259	PL_scopestack = c->scopestack;
		260	PL_scopestack_ix = c->scopestack_ix;
		261	PL_scopestack_max = c->scopestack_max;
		262	PL_savestack = c->savestack;
		263	PL_savestack_ix = c->savestack_ix;
		264	PL_savestack_max = c->savestack_max;
		265	PL_retstack = c->retstack;
		266	PL_retstack_ix = c->retstack_ix;
		267	PL_retstack_max = c->retstack_max;
		268	PL_curcop = c->curcop;
		269
		270	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		271	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		272	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		273
		274	{
		275	dSP;
		276	CV *cv;
		277
		278	/* now do the ugly restore mess */
		279	while ((cv = (CV *)POPs))
		280	{
		281	AV padlist = (AV )POPs;
		282
		283	if (padlist)
		284	{
		285	put_padlist (cv); /* mark this padlist as available */
		286	CvPADLIST(cv) = padlist;
		287	#ifdef USE_THREADS
		288	/CvOWNER(cv) = (struct perl_thread )POPs;*/
		289	#endif
		290	}
		291
		292	++CvDEPTH(cv);
		293	}
		294
		295	PUTBACK;
		296	}
		297	}
		298
		299	static void
		300	save_state(pTHX_ Coro__State c, int flags)
190	{	301	{
191	{	302	{
192	dSP;	303	dSP;
193	I32 cxix = cxstack_ix;	304	I32 cxix = cxstack_ix;
194	PERL_SI *top_si = PL_curstackinfo;	305	PERL_SI *top_si = PL_curstackinfo;
…		…
201		312
202	PUSHs (Nullsv);	313	PUSHs (Nullsv);
203	/* this loop was inspired by pp_caller */	314	/* this loop was inspired by pp_caller */
204	for (;;)	315	for (;;)
205	{	316	{
206	while (cxix >= 0)	317	do
207	{	318	{
208	PERL_CONTEXT *cx = &ccstk[cxix--];	319	PERL_CONTEXT *cx = &ccstk[cxix--];
209		320
210	if (CxTYPE(cx) == CXt_SUB)	321	if (CxTYPE(cx) == CXt_SUB)
211	{	322	{
212	CV *cv = cx->blk_sub.cv;	323	CV *cv = cx->blk_sub.cv;
213	if (CvDEPTH(cv))	324	if (CvDEPTH(cv))
214	{	325	{
215	#ifdef USE_THREADS	326	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));	327	/XPUSHs ((SV )CvOWNER(cv));*/
		328	/CvOWNER(cv) = 0;/
		329	/error must unlock this cv etc.. etc.../
217	#endif	330	#endif
218	EXTEND (SP, 3);	331	EXTEND (SP, CvDEPTH(cv)*2);
		332
		333	while (--CvDEPTH(cv))
		334	{
		335	/* this tells the restore code to increment CvDEPTH */
		336	PUSHs (Nullsv);
219	PUSHs ((SV *)CvDEPTH(cv));	337	PUSHs ((SV *)cv);
		338	}
		339
220	PUSHs ((SV *)CvPADLIST(cv));	340	PUSHs ((SV *)CvPADLIST(cv));
221	PUSHs ((SV *)cv);	341	PUSHs ((SV *)cv);
222		342
223	get_padlist (cv);	343	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	}	344	}
233	}	345	}
234	else if (CxTYPE(cx) == CXt_FORMAT)	346	else if (CxTYPE(cx) == CXt_FORMAT)
235	{	347	{
236	/* I never used formats, so how should I know how these are implemented? */	348	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */	349	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	350	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}	351	}
240	}	352	}
		353	while (cxix >= 0);
241		354
242	if (top_si->si_type == PERLSI_MAIN)	355	if (top_si->si_type == PERLSI_MAIN)
243	break;	356	break;
244		357
245	top_si = top_si->si_prev;	358	top_si = top_si->si_prev;
…		…
248	}	361	}
249		362
250	PUTBACK;	363	PUTBACK;
251	}	364	}
252		365
		366	c->defav = flags & SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		367	c->defsv = flags & SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		368	c->errsv = flags & SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		369
253	c->dowarn = PL_dowarn;	370	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);	371
255	c->curstackinfo = PL_curstackinfo;	372	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	373	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	374	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	375	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	376	c->op = PL_op;
…		…
277	c->retstack_ix = PL_retstack_ix;	394	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	395	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;	396	c->curcop = PL_curcop;
280	}	397	}
281		398
282	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	399	/*
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	400	* destroy the stacks, the callchain etc...
284		401	* still there is a memleak of 128 bytes...
285	static void	402	*/
286	load_state(pTHX_ Coro__State c)
287	{
288	PL_dowarn = c->dowarn;
289	GvAV (PL_defgv) = c->defav;
290	PL_curstackinfo = c->curstackinfo;
291	PL_curstack = c->curstack;
292	PL_mainstack = c->mainstack;
293	PL_stack_sp = c->stack_sp;
294	PL_op = c->op;
295	PL_curpad = c->curpad;
296	PL_stack_base = c->stack_base;
297	PL_stack_max = c->stack_max;
298	PL_tmps_stack = c->tmps_stack;
299	PL_tmps_floor = c->tmps_floor;
300	PL_tmps_ix = c->tmps_ix;
301	PL_tmps_max = c->tmps_max;
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;
304	PL_markstack_max = c->markstack_max;
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
316	{
317	dSP;
318	CV *cv;
319
320	/* now do the ugly restore mess */
321	while ((cv = (CV *)POPs))
322	{
323	AV padlist = (AV )POPs;
324
325	put_padlist (cv);
326	CvPADLIST(cv) = padlist;
327	CvDEPTH(cv) = (I32)POPs;
328
329	#ifdef USE_THREADS
330	CvOWNER(cv) = (struct perl_thread *)POPs;
331	error does not work either
332	#endif
333	}
334
335	PUTBACK;
336	}
337	}
338
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */
340	STATIC void	403	STATIC void
341	destroy_stacks(pTHX)	404	destroy_stacks(pTHX)
342	{	405	{
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? */	406	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)	407	while (PL_scopestack_ix)
349	LEAVE;	408	LEAVE;
350		409
		410	/* sure it is, but more important: is it correct?? :/ */
		411	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		412	FREETMPS;
		413
351	while (PL_curstackinfo->si_next)	414	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;	415	PL_curstackinfo = PL_curstackinfo->si_next;
353		416
354	while (PL_curstackinfo)	417	while (PL_curstackinfo)
355	{	418	{
356	PERL_SI *p = PL_curstackinfo->si_prev;	419	PERL_SI *p = PL_curstackinfo->si_prev;
		420
		421	{
		422	dSP;
		423	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		424	PUTBACK; /* possibly superfluous */
		425	}
		426
		427	dounwind(-1);
357		428
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	429	SvREFCNT_dec(PL_curstackinfo->si_stack);
359	Safefree(PL_curstackinfo->si_cxstack);	430	Safefree(PL_curstackinfo->si_cxstack);
360	Safefree(PL_curstackinfo);	431	Safefree(PL_curstackinfo);
361	PL_curstackinfo = p;	432	PL_curstackinfo = p;
362	}	433	}
363		434
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);	435	Safefree(PL_tmps_stack);
378	Safefree(PL_markstack);	436	Safefree(PL_markstack);
379	Safefree(PL_scopestack);	437	Safefree(PL_scopestack);
380	Safefree(PL_savestack);	438	Safefree(PL_savestack);
381	Safefree(PL_retstack);	439	Safefree(PL_retstack);
…		…
386	MODULE = Coro::State PACKAGE = Coro::State	444	MODULE = Coro::State PACKAGE = Coro::State
387		445
388	PROTOTYPES: ENABLE	446	PROTOTYPES: ENABLE
389		447
390	BOOT:	448	BOOT:
		449	HV * stash = gv_stashpvn("Coro::State", 10, TRUE);
		450
		451	newCONSTSUB (stash, "SAVE_DEFAV", newSViv (SAVE_DEFAV));
		452	newCONSTSUB (stash, "SAVE_DEFSV", newSViv (SAVE_DEFSV));
		453	newCONSTSUB (stash, "SAVE_ERRSV", newSViv (SAVE_ERRSV));
		454
391	if (!padlist_cache)	455	if (!padlist_cache)
392	padlist_cache = newHV ();	456	padlist_cache = newHV ();
393		457
394	Coro::State	458	Coro::State
395	_newprocess(args)	459	_newprocess(args)
…		…
397	PROTOTYPE: $	461	PROTOTYPE: $
398	CODE:	462	CODE:
399	Coro__State coro;	463	Coro__State coro;
400		464
401	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	465	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");	466	croak ("Coro::State::_newprocess expects an arrayref");
403		467
404	New (0, coro, 1, struct coro);	468	New (0, coro, 1, struct coro);
405		469
406	coro->mainstack = 0; /* actual work is done inside transfer */	470	coro->mainstack = 0; /* actual work is done inside transfer */
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	471	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
…		…
409	RETVAL = coro;	473	RETVAL = coro;
410	OUTPUT:	474	OUTPUT:
411	RETVAL	475	RETVAL
412		476
413	void	477	void
414	transfer(prev,next)	478	transfer(prev, next, flags = SAVE_DEFAV)
415	Coro::State_or_hashref prev	479	Coro::State_or_hashref prev
416	Coro::State_or_hashref next	480	Coro::State_or_hashref next
		481	int flags
417	CODE:	482	CODE:
418		483
419	if (prev != next)	484	if (prev != next)
420	{	485	{
421	/*	486	/*
…		…
424	* code here, but lazy allocation of stacks has also	489	* code here, but lazy allocation of stacks has also
425	* some virtues and the overhead of the if() is nil.	490	* some virtues and the overhead of the if() is nil.
426	*/	491	*/
427	if (next->mainstack)	492	if (next->mainstack)
428	{	493	{
429	SAVE (prev);	494	SAVE (prev, flags);
430	LOAD (next);	495	LOAD (next);
431	/* mark this state as in-use */	496	/* mark this state as in-use */
432	next->mainstack = 0;	497	next->mainstack = 0;
433	next->tmps_ix = -2;	498	next->tmps_ix = -2;
434	}	499	}
…		…
436	{	501	{
437	croak ("tried to transfer to running coroutine");	502	croak ("tried to transfer to running coroutine");
438	}	503	}
439	else	504	else
440	{	505	{
441	SAVE (prev);
442
443	/*	506	/*
444	* emulate part of the perl startup here.	507	* emulate part of the perl startup here.
445	*/	508	*/
446	UNOP myop;	509	UNOP myop;
447		510
		511	SAVE (prev, -1); /* first get rid of the old state */
		512
448	init_stacks (); /* from perl.c */	513	init_stacks (); /* from perl.c */
		514	SPAGAIN;
		515
449	PL_op = (OP *)&myop;	516	PL_op = (OP *)&myop;
450	/PL_curcop = 0;/	517	/PL_curcop = 0;/
		518	SvREFCNT_dec (GvAV (PL_defgv));
451	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);	519	GvAV (PL_defgv) = next->args;
452		520
453	SPAGAIN;
454	Zero(&myop, 1, UNOP);	521	Zero(&myop, 1, UNOP);
455	myop.op_next = Nullop;	522	myop.op_next = Nullop;
456	myop.op_flags = OPf_WANT_VOID;	523	myop.op_flags = OPf_WANT_VOID;
457		524
458	PUSHMARK(SP);	525	PUSHMARK(SP);
459	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));	526	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	PUTBACK;
461	/*	527	/*
462	* the next line is slightly wrong, as PL_op->op_next	528	* the next line is slightly wrong, as PL_op->op_next
463	* is actually being executed so we skip the first op.	529	* is actually being executed so we skip the first op.
464	* that doesn't matter, though, since it is only	530	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...	531	* pp_nextstate and we never return...
		532	* ah yes, and I don't care anyways ;)
466	*/	533	*/
		534	PUTBACK;
467	PL_op = Perl_pp_entersub(aTHX);	535	PL_op = pp_entersub(aTHX);
468	SPAGAIN;	536	SPAGAIN;
469		537
470	ENTER;	538	ENTER; /* necessary e.g. for dounwind */
471	}	539	}
472	}	540	}
473		541
474	void	542	void
475	DESTROY(coro)	543	DESTROY(coro)
…		…
478		546
479	if (coro->mainstack)	547	if (coro->mainstack)
480	{	548	{
481	struct coro temp;	549	struct coro temp;
482		550
483	SAVE(aTHX_ (&temp));	551	SAVE(aTHX_ (&temp), SAVE_ALL);
484	LOAD(aTHX_ coro);	552	LOAD(aTHX_ coro);
485		553
486	destroy_stacks ();	554	destroy_stacks ();
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488		555
489	LOAD((&temp));	556	LOAD((&temp)); /* this will get rid of defsv etc.. */
490	}	557	}
491		558
492	SvREFCNT_dec (coro->args);
493	Safefree (coro);	559	Safefree (coro);
494		560
		561	void
		562	flush()
		563	CODE:
		564	#ifdef MAY_FLUSH
		565	flush_padlist_cache ();
		566	#endif
495		567
		568

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.7 by root, Thu Jul 19 02:45:09 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.7 by root, Thu Jul 19 02:45:09 2001 UTC