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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.7 by root, Thu Jul 19 02:45:09 2001 UTC vs.
Revision 1.14 by root, Mon Jul 23 23:48:05 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 1	5	#include "libcoro/coro.c"
6	# define CHK(x) (void *)0	6
7	#else	7	#ifdef HAVE_MMAP
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	8	# include <unistd.h>
		9	# include <sys/mman.h>
9	#endif	10	#endif
10		11
11	#define MAY_FLUSH /* increases codesize */	12	#define MAY_FLUSH /* increases codesize */
12		13
13	#define SAVE_DEFAV 0x00000001	14	#define TRANSFER_SAVE_DEFAV 0x00000001
14	#define SAVE_DEFSV 0x00000002	15	#define TRANSFER_SAVE_DEFSV 0x00000002
15	#define SAVE_ERRSV 0x00000004	16	#define TRANSFER_SAVE_ERRSV 0x00000004
		17	#define TRANSFER_SAVE_CCTXT 0x00000008
16		18
17	#define SAVE_ALL -1	19	#define TRANSFER_SAVE_ALL -1
		20
		21	#define SUB_INIT "Coro::State::initialize"
		22	#define UCORO_STATE "_coro_state"
18		23
19	struct coro {	24	struct coro {
		25	/* the optional C context */
		26	coro_context cctx;
		27	void *sptr;
		28	long ssize;
		29
20	/* optionally saved, might be zero */	30	/* optionally saved, might be zero */
21	AV *defav;	31	AV *defav;
22	SV *defsv;	32	SV *defsv;
23	SV *errsv;	33	SV *errsv;
24		34
49	I32 savestack_max;	59	I32 savestack_max;
50	OP **retstack;	60	OP **retstack;
51	I32 retstack_ix;	61	I32 retstack_ix;
52	I32 retstack_max;	62	I32 retstack_max;
53	COP *curcop;	63	COP *curcop;
		64	JMPENV start_env;
		65	JMPENV *top_env;
54		66
55	/* data associated with this coroutine (initial args) */	67	/* data associated with this coroutine (initial args) */
56	AV *args;	68	AV *args;
57	};	69	};
58		70
59	typedef struct coro *Coro__State;	71	typedef struct coro *Coro__State;
60	typedef struct coro *Coro__State_or_hashref;	72	typedef struct coro *Coro__State_or_hashref;
61		73
		74	static AV main_mainstack; / used to differentiate between $main and others */
		75	static HV *coro_state_stash;
		76	static SV *ucoro_state_sv;
		77	static U32 ucoro_state_hash;
62	static HV *padlist_cache;	78	static HV *padlist_cache;
63		79
64	/* mostly copied from op.c:cv_clone2 */	80	/* mostly copied from op.c:cv_clone2 */
65	STATIC AV *	81	STATIC AV *
66	clone_padlist (AV *protopadlist)	82	clone_padlist (AV *protopadlist)
…		…
229	#endif	245	#endif
230		246
231	#define SB do {	247	#define SB do {
232	#define SE } while (0)	248	#define SE } while (0)
233		249
234	#define LOAD(state) SB load_state(aTHX_ state); SPAGAIN; SE	250	#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE
235	#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ state,flags); SE	251	#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
236		252
237	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE	253	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
238		254
239	static void	255	static void
240	load_state(pTHX_ Coro__State c)	256	load_state(pTHX_ Coro__State c)
…		…
264	PL_savestack_max = c->savestack_max;	280	PL_savestack_max = c->savestack_max;
265	PL_retstack = c->retstack;	281	PL_retstack = c->retstack;
266	PL_retstack_ix = c->retstack_ix;	282	PL_retstack_ix = c->retstack_ix;
267	PL_retstack_max = c->retstack_max;	283	PL_retstack_max = c->retstack_max;
268	PL_curcop = c->curcop;	284	PL_curcop = c->curcop;
		285	PL_start_env = c->start_env;
		286	PL_top_env = c->top_env;
269		287
270	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);	288	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
271	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);	289	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
272	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);	290	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
273		291
…		…
300	save_state(pTHX_ Coro__State c, int flags)	318	save_state(pTHX_ Coro__State c, int flags)
301	{	319	{
302	{	320	{
303	dSP;	321	dSP;
304	I32 cxix = cxstack_ix;	322	I32 cxix = cxstack_ix;
		323	PERL_CONTEXT *ccstk = cxstack;
305	PERL_SI *top_si = PL_curstackinfo;	324	PERL_SI *top_si = PL_curstackinfo;
306	PERL_CONTEXT *ccstk = cxstack;
307		325
308	/*	326	/*
309	* the worst thing you can imagine happens first - we have to save	327	* the worst thing you can imagine happens first - we have to save
310	* (and reinitialize) all cv's in the whole callchain :(	328	* (and reinitialize) all cv's in the whole callchain :(
311	*/	329	*/
312		330
313	PUSHs (Nullsv);	331	PUSHs (Nullsv);
314	/* this loop was inspired by pp_caller */	332	/* this loop was inspired by pp_caller */
315	for (;;)	333	for (;;)
316	{	334	{
317	do	335	do
318	{	336	{
319	PERL_CONTEXT *cx = &ccstk[cxix--];	337	PERL_CONTEXT *cx = &ccstk[cxix--];
320		338
321	if (CxTYPE(cx) == CXt_SUB)	339	if (CxTYPE(cx) == CXt_SUB)
322	{	340	{
…		…
361	}	379	}
362		380
363	PUTBACK;	381	PUTBACK;
364	}	382	}
365		383
366	c->defav = flags & SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;	384	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
367	c->defsv = flags & SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;	385	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
368	c->errsv = flags & SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;	386	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		387
		388	/* I have not the slightest idea of why av_reify is necessary */
		389	/* but if it's missing the defav contents magically get replaced sometimes */
		390	if (c->defav)
		391	av_reify (c->defav);
369		392
370	c->dowarn = PL_dowarn;	393	c->dowarn = PL_dowarn;
371		394
372	c->curstackinfo = PL_curstackinfo;	395	c->curstackinfo = PL_curstackinfo;
373	c->curstack = PL_curstack;	396	c->curstack = PL_curstack;
…		…
392	c->savestack_max = PL_savestack_max;	415	c->savestack_max = PL_savestack_max;
393	c->retstack = PL_retstack;	416	c->retstack = PL_retstack;
394	c->retstack_ix = PL_retstack_ix;	417	c->retstack_ix = PL_retstack_ix;
395	c->retstack_max = PL_retstack_max;	418	c->retstack_max = PL_retstack_max;
396	c->curcop = PL_curcop;	419	c->curcop = PL_curcop;
		420	c->start_env = PL_start_env;
		421	c->top_env = PL_top_env;
		422	}
		423
		424	/*
		425	* allocate various perl stacks. This is an exact copy
		426	* of perl.c:init_stacks, except that it uses less memory
		427	* on the assumption that coroutines do not usually need
		428	* a lot of stackspace.
		429	*/
		430	STATIC void
		431	coro_init_stacks (pTHX)
		432	{
		433	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
		434	PL_curstackinfo->si_type = PERLSI_MAIN;
		435	PL_curstack = PL_curstackinfo->si_stack;
		436	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		437
		438	PL_stack_base = AvARRAY(PL_curstack);
		439	PL_stack_sp = PL_stack_base;
		440	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
		441
		442	New(50,PL_tmps_stack,64,SV*);
		443	PL_tmps_floor = -1;
		444	PL_tmps_ix = -1;
		445	PL_tmps_max = 64;
		446
		447	New(54,PL_markstack,12,I32);
		448	PL_markstack_ptr = PL_markstack;
		449	PL_markstack_max = PL_markstack + 12;
		450
		451	SET_MARK_OFFSET;
		452
		453	New(54,PL_scopestack,12,I32);
		454	PL_scopestack_ix = 0;
		455	PL_scopestack_max = 12;
		456
		457	New(54,PL_savestack,64,ANY);
		458	PL_savestack_ix = 0;
		459	PL_savestack_max = 64;
		460
		461	New(54,PL_retstack,8,OP*);
		462	PL_retstack_ix = 0;
		463	PL_retstack_max = 8;
397	}	464	}
398		465
399	/*	466	/*
400	* destroy the stacks, the callchain etc...	467	* destroy the stacks, the callchain etc...
401	* still there is a memleak of 128 bytes...	468	* still there is a memleak of 128 bytes...
…		…
437	Safefree(PL_scopestack);	504	Safefree(PL_scopestack);
438	Safefree(PL_savestack);	505	Safefree(PL_savestack);
439	Safefree(PL_retstack);	506	Safefree(PL_retstack);
440	}	507	}
441		508
442	#define SUB_INIT "Coro::State::_newcoro"	509	static void
		510	allocate_stack (Coro__State ctx)
		511	{
		512	#ifdef HAVE_MMAP
		513	ctx->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-use */
		514	ctx->sptr = mmap (0, ctx->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANON, 0, 0);
		515	if (ctx->sptr == (void *)-1)
		516	#endif
		517	{
		518	/FIXME//D//* reasonable stack size! */
		519	ctx->ssize = 4096 * sizeof (long);
		520	New (0, ctx->sptr, 4096, long);
		521	}
		522	}
		523
		524	static void
		525	deallocate_stack (Coro__State ctx)
		526	{
		527	#ifdef HAVE_MMAP
		528	munmap (ctx->sptr, ctx->ssize);
		529	#else
		530	Safefree (ctx->sptr);
		531	#endif
		532	}
		533
		534	/* might go away together with optional SAVE_CCTXT */
		535	static void
		536	setup_coro (void *arg)
		537	{
		538	/*
		539	* emulate part of the perl startup here.
		540	*/
		541	dSP;
		542	Coro__State ctx = (Coro__State)arg;
		543	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
		544
		545	coro_init_stacks (aTHX);
		546	JMPENV_BOOTSTRAP;
		547	SPAGAIN;
		548
		549	/PL_curcop = 0;/
		550	SvREFCNT_dec (GvAV (PL_defgv));
		551	GvAV (PL_defgv) = ctx->args;
		552
		553	if (ctx->sptr)
		554	{
		555	PUSHMARK(SP);
		556	PUTBACK;
		557	(void) call_sv (sub_init, G_VOID\|G_NOARGS);
		558	croak ("FATAL: CCTXT coroutine returned!");
		559	}
		560	else
		561	{
		562	UNOP myop;
		563
		564	PL_op = (OP *)&myop;
		565
		566	Zero(&myop, 1, UNOP);
		567	myop.op_next = Nullop;
		568	myop.op_flags = OPf_WANT_VOID;
		569
		570	PUSHMARK(SP);
		571	XPUSHs (sub_init);
		572	/*
		573	* the next line is slightly wrong, as PL_op->op_next
		574	* is actually being executed so we skip the first op.
		575	* that doesn't matter, though, since it is only
		576	* pp_nextstate and we never return...
		577	* ah yes, and I don't care anyways ;)
		578	*/
		579	PUTBACK;
		580	PL_op = pp_entersub();
		581	SPAGAIN;
		582
		583	ENTER; /* necessary e.g. for dounwind */
		584	}
		585	}
		586
		587	STATIC void
		588	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		589	{
		590	dSP;
		591
		592	if (prev != next)
		593	{
		594	/*
		595	* this could be done in newprocess which would lead to
		596	* extremely elegant and fast (basically just SAVE/LOAD)
		597	* code here, but lazy allocation of stacks has also
		598	* some virtues and the overhead of the if() is nil.
		599	*/
		600	if (next->mainstack)
		601	{
		602	SAVE (prev, flags);
		603	LOAD (next);
		604
		605	/* mark this state as in-use */
		606	next->mainstack = 0;
		607	next->tmps_ix = -2;
		608
		609	if (flags & TRANSFER_SAVE_CCTXT)
		610	{
		611	if (!next->ssize)
		612	croak ("destination coroutine has no CCTXT (%p, %d)", next->sptr, next->ssize);
		613
		614	if (!prev->ssize)
		615	prev->ssize = 1; /* mark cctx as valid ;) */
		616
		617	coro_transfer (&(prev->cctx), &(next->cctx));
		618	}
		619
		620	}
		621	else if (next->tmps_ix == -2)
		622	croak ("tried to transfer to running coroutine");
		623	else
		624	{
		625	SAVE (prev, -1); /* first get rid of the old state */
		626
		627	if (flags & TRANSFER_SAVE_CCTXT)
		628	{
		629	if (!next->ssize)
		630	{
		631	allocate_stack (next);
		632	coro_create (&(next->cctx),
		633	setup_coro, (void *)next,
		634	next->sptr, next->ssize);
		635	}
		636
		637	if (!prev->ssize)
		638	prev->ssize = 1; /* mark cctx as valid ;) */
		639
		640	coro_transfer (&(prev->cctx), &(next->cctx));
		641	}
		642	else
		643	setup_coro (next);
		644	}
		645	}
		646	}
443		647
444	MODULE = Coro::State PACKAGE = Coro::State	648	MODULE = Coro::State PACKAGE = Coro::State
445		649
446	PROTOTYPES: ENABLE	650	PROTOTYPES: ENABLE
447		651
448	BOOT:	652	BOOT:
		653	{ /* {} necessary for stoopid perl-5.6.x */
		654	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		655	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
449	HV * stash = gv_stashpvn("Coro::State", 10, TRUE);	656	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
450		657
451	newCONSTSUB (stash, "SAVE_DEFAV", newSViv (SAVE_DEFAV));	658	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
452	newCONSTSUB (stash, "SAVE_DEFSV", newSViv (SAVE_DEFSV));	659	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
453	newCONSTSUB (stash, "SAVE_ERRSV", newSViv (SAVE_ERRSV));	660	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		661	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
454		662
455	if (!padlist_cache)	663	if (!padlist_cache)
456	padlist_cache = newHV ();	664	padlist_cache = newHV ();
		665
		666	main_mainstack = PL_mainstack;
		667	}
457		668
458	Coro::State	669	Coro::State
459	_newprocess(args)	670	_newprocess(args)
460	SV * args	671	SV * args
461	PROTOTYPE: $	672	PROTOTYPE: $
…		…
465	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	676	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
466	croak ("Coro::State::_newprocess expects an arrayref");	677	croak ("Coro::State::_newprocess expects an arrayref");
467		678
468	New (0, coro, 1, struct coro);	679	New (0, coro, 1, struct coro);
469		680
		681	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
470	coro->mainstack = 0; /* actual work is done inside transfer */	682	coro->mainstack = 0; /* actual work is done inside transfer */
471	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	683	coro->sptr = 0;
		684	coro->ssize = 0;
472		685
473	RETVAL = coro;	686	RETVAL = coro;
474	OUTPUT:	687	OUTPUT:
475	RETVAL	688	RETVAL
476		689
477	void	690	void
478	transfer(prev, next, flags = SAVE_DEFAV)	691	transfer(prev, next, flags = TRANSFER_SAVE_ALL)
479	Coro::State_or_hashref prev	692	Coro::State_or_hashref prev
480	Coro::State_or_hashref next	693	Coro::State_or_hashref next
481	int flags	694	int flags
		695	PROTOTYPE: @
482	CODE:	696	CODE:
483		697	transfer (aTHX_ prev, next, flags);
484	if (prev != next)
485	{
486	/*
487	* this could be done in newprocess which would lead to
488	* extremely elegant and fast (just SAVE/LOAD)
489	* code here, but lazy allocation of stacks has also
490	* some virtues and the overhead of the if() is nil.
491	*/
492	if (next->mainstack)
493	{
494	SAVE (prev, flags);
495	LOAD (next);
496	/* mark this state as in-use */
497	next->mainstack = 0;
498	next->tmps_ix = -2;
499	}
500	else if (next->tmps_ix == -2)
501	{
502	croak ("tried to transfer to running coroutine");
503	}
504	else
505	{
506	/*
507	* emulate part of the perl startup here.
508	*/
509	UNOP myop;
510
511	SAVE (prev, -1); /* first get rid of the old state */
512
513	init_stacks (); /* from perl.c */
514	SPAGAIN;
515
516	PL_op = (OP *)&myop;
517	/PL_curcop = 0;/
518	SvREFCNT_dec (GvAV (PL_defgv));
519	GvAV (PL_defgv) = next->args;
520
521	Zero(&myop, 1, UNOP);
522	myop.op_next = Nullop;
523	myop.op_flags = OPf_WANT_VOID;
524
525	PUSHMARK(SP);
526	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
527	/*
528	* the next line is slightly wrong, as PL_op->op_next
529	* is actually being executed so we skip the first op.
530	* that doesn't matter, though, since it is only
531	* pp_nextstate and we never return...
532	* ah yes, and I don't care anyways ;)
533	*/
534	PUTBACK;
535	PL_op = pp_entersub(aTHX);
536	SPAGAIN;
537
538	ENTER; /* necessary e.g. for dounwind */
539	}
540	}
541		698
542	void	699	void
543	DESTROY(coro)	700	DESTROY(coro)
544	Coro::State coro	701	Coro::State coro
545	CODE:	702	CODE:
546		703
547	if (coro->mainstack)	704	if (coro->mainstack && coro->mainstack != main_mainstack)
548	{	705	{
549	struct coro temp;	706	struct coro temp;
550		707
551	SAVE(aTHX_ (&temp), SAVE_ALL);	708	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
552	LOAD(aTHX_ coro);	709	LOAD(aTHX_ coro);
553		710
554	destroy_stacks ();	711	destroy_stacks (aTHX);
555		712
556	LOAD((&temp)); /* this will get rid of defsv etc.. */	713	LOAD((&temp)); /* this will get rid of defsv etc.. */
		714
		715	coro->mainstack = 0;
		716	}
		717
		718	if (coro->sptr)
		719	{
		720	deallocate_stack (coro);
		721	coro->sptr = 0;
557	}	722	}
558		723
559	Safefree (coro);	724	Safefree (coro);
560		725
561	void	726	void
…		…
563	CODE:	728	CODE:
564	#ifdef MAY_FLUSH	729	#ifdef MAY_FLUSH
565	flush_padlist_cache ();	730	flush_padlist_cache ();
566	#endif	731	#endif
567		732
		733	MODULE = Coro::State PACKAGE = Coro::Cont
568		734
		735	# this is slightly dirty
		736
		737	void
		738	yield(...)
		739	PROTOTYPE: @
		740	CODE:
		741	static SV *returnstk;
		742	SV *sv;
		743	AV *defav = GvAV (PL_defgv);
		744	struct coro prev, next;
		745
		746	if (!returnstk)
		747	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		748
		749	/* set up @_ -- ugly */
		750	av_clear (defav);
		751	av_fill (defav, items - 1);
		752	while (items--)
		753	av_store (defav, items, SvREFCNT_inc (ST(items)));
		754
		755	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		756	sv = av_pop ((AV *)SvRV (returnstk));
		757	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		758	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		759	SvREFCNT_dec (sv);
		760
		761	transfer(aTHX_ prev, next, 0);
		762

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.7 by root, Thu Jul 19 02:45:09 2001 UTC vs. Revision 1.14 by root, Mon Jul 23 23:48:05 2001 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.7 by root, Thu Jul 19 02:45:09 2001 UTC vs.
Revision 1.14 by root, Mon Jul 23 23:48:05 2001 UTC