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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.48 by pcg, Sat Nov 15 03:53:37 2003 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 "patchlevel.h"
6	# define CHK(x) (void *)0	6
7	#else	7	#if PATCHLEVEL < 6
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	8	# ifndef PL_ppaddr
		9	# define PL_ppaddr ppaddr
9	#endif	10	# endif
		11	# ifndef call_sv
		12	# define call_sv perl_call_sv
		13	# endif
		14	# ifndef get_sv
		15	# define get_sv perl_get_sv
		16	# endif
		17	# ifndef get_cv
		18	# define get_cv perl_get_cv
		19	# endif
		20	# ifndef IS_PADGV
		21	# define IS_PADGV(v) 0
		22	# endif
		23	# ifndef IS_PADCONST
		24	# define IS_PADCONST(v) 0
		25	# endif
		26	#endif
		27
		28	#include "libcoro/coro.c"
		29
		30	#include <signal.h>
		31
		32	#ifdef HAVE_MMAP
		33	# include <unistd.h>
		34	# include <sys/mman.h>
		35	# ifndef MAP_ANONYMOUS
		36	# ifdef MAP_ANON
		37	# define MAP_ANONYMOUS MAP_ANON
		38	# else
		39	# undef HAVE_MMAP
		40	# endif
		41	# endif
		42	#endif
		43
		44	#define MAY_FLUSH /* increases codesize and is rarely used */
		45
		46	#define SUB_INIT "Coro::State::initialize"
		47	#define UCORO_STATE "_coro_state"
		48
		49	/* The next macro should declare a variable stacklevel that contains and approximation
		50	* to the current C stack pointer. Its property is that it changes with each call
		51	* and should be unique. */
		52	#define dSTACKLEVEL void *stacklevel = &stacklevel
		53
		54	#define IN_DESTRUCT (PL_main_cv == Nullcv)
		55
		56	#define labs(l) ((l) >= 0 ? (l) : -(l))
		57
		58	#include "CoroAPI.h"
		59
		60	static struct CoroAPI coroapi;
		61
		62	/* this is actually not only the c stack but also c registers etc... */
		63	typedef struct {
		64	int refcnt; /* pointer reference counter */
		65	int usecnt; /* shared by how many coroutines */
		66	int gencnt; /* generation counter */
		67
		68	coro_context cctx;
		69
		70	void *sptr;
		71	long ssize; /* positive == mmap, otherwise malloc */
		72	} coro_stack;
10		73
11	struct coro {	74	struct coro {
		75	/* the top-level JMPENV for each coroutine, needed to catch dies. */
		76	JMPENV start_env;
		77
		78	/* the optional C context */
		79	coro_stack *stack;
		80	void *cursp;
		81	int gencnt;
		82
		83	/* optionally saved, might be zero */
		84	AV *defav;
		85	SV *defsv;
		86	SV *errsv;
		87
		88	/* saved global state not related to stacks */
12	U8 dowarn;	89	U8 dowarn;
13	AV *defav;	90	I32 in_eval;
14		91
		92	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	93	PERL_SI *curstackinfo;
16	AV *curstack;	94	AV *curstack;
17	AV *mainstack;	95	AV *mainstack;
18	SV **stack_sp;	96	SV **stack_sp;
19	OP *op;	97	OP *op;
20	SV **curpad;	98	SV **curpad;
		99	AV *comppad;
21	SV **stack_base;	100	SV **stack_base;
22	SV **stack_max;	101	SV **stack_max;
23	SV **tmps_stack;	102	SV **tmps_stack;
24	I32 tmps_floor;	103	I32 tmps_floor;
25	I32 tmps_ix;	104	I32 tmps_ix;
35	I32 savestack_max;	114	I32 savestack_max;
36	OP **retstack;	115	OP **retstack;
37	I32 retstack_ix;	116	I32 retstack_ix;
38	I32 retstack_max;	117	I32 retstack_max;
39	COP *curcop;	118	COP *curcop;
		119	JMPENV *top_env;
40		120
		121	/* data associated with this coroutine (initial args) */
41	AV *args;	122	AV *args;
42	};	123	};
43		124
44	typedef struct coro *Coro__State;	125	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	126	typedef struct coro *Coro__State_or_hashref;
46		127
		128	static AV main_mainstack; / used to differentiate between $main and others */
		129	static HV *coro_state_stash;
		130	static SV *ucoro_state_sv;
		131	static U32 ucoro_state_hash;
47	static HV *padlist_cache;	132	static HV *padlist_cache;
		133	static SV coro_mortal; / will be freed after next transfer */
48		134
49	/* mostly copied from op.c:cv_clone2 */	135	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *	136	STATIC AV *
51	clone_padlist (AV *protopadlist)	137	clone_padlist (AV *protopadlist)
52	{	138	{
…		…
115	SvPADTMP_on (sv);	201	SvPADTMP_on (sv);
116	npad[ix] = sv;	202	npad[ix] = sv;
117	}	203	}
118	}	204	}
119		205
120	#if 0 /* NONOTUNDERSTOOD */	206	#if 0 /* return -ENOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */	207	/* Now that vars are all in place, clone nested closures. */
122		208
123	for (ix = fpad; ix > 0; ix--) {	209	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	210	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv	211	if (namesv
…		…
138	#endif	224	#endif
139		225
140	return newpadlist;	226	return newpadlist;
141	}	227	}
142		228
143	STATIC AV *	229	#ifdef MAY_FLUSH
		230	STATIC void
144	free_padlist (AV *padlist)	231	free_padlist (AV *padlist)
145	{	232	{
146	/* may be during global destruction */	233	/* may be during global destruction */
147	if (SvREFCNT(padlist))	234	if (SvREFCNT(padlist))
148	{	235	{
…		…
156	}	243	}
157		244
158	SvREFCNT_dec((SV*)padlist);	245	SvREFCNT_dec((SV*)padlist);
159	}	246	}
160	}	247	}
		248	#endif
161		249
162	STATIC AV *	250	/* the next two functions merely cache the padlists */
163	unuse_padlist (AV *padlist)	251	STATIC void
		252	get_padlist (CV *cv)
164	{	253	{
		254	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
		255
		256	if (he && AvFILLp ((AV )he) >= 0)
		257	CvPADLIST (cv) = (AV )av_pop ((AV )*he);
		258	else
		259	CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
		260	}
		261
		262	STATIC void
		263	put_padlist (CV *cv)
		264	{
		265	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 1);
		266
		267	if (SvTYPE (*he) != SVt_PVAV)
		268	{
		269	SvREFCNT_dec (*he);
		270	he = (SV )newAV ();
		271	}
		272
		273	av_push ((AV )he, (SV *)CvPADLIST (cv));
		274	}
		275
		276	#ifdef MAY_FLUSH
		277	STATIC void
		278	flush_padlist_cache ()
		279	{
		280	HV *hv = padlist_cache;
		281	padlist_cache = newHV ();
		282
		283	if (hv_iterinit (hv))
		284	{
		285	HE *he;
		286	AV *padlist;
		287
		288	while (!!(he = hv_iternext (hv)))
		289	{
		290	AV av = (AV )HeVAL(he);
		291
		292	/* casting is fun. */
		293	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
165	free_padlist (padlist);	294	free_padlist (padlist);
		295	}
		296	}
		297
		298	SvREFCNT_dec (hv);
166	}	299	}
		300	#endif
		301
		302	#define SB do {
		303	#define SE } while (0)
		304
		305	#define LOAD(state) load_state(aTHX_ (state));
		306	#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
		307
		308	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE
167		309
168	static void	310	static void
169	SAVE(pTHX_ Coro__State c)	311	load_state(pTHX_ Coro__State c)
		312	{
		313	PL_dowarn = c->dowarn;
		314	PL_in_eval = c->in_eval;
		315
		316	PL_curstackinfo = c->curstackinfo;
		317	PL_curstack = c->curstack;
		318	PL_mainstack = c->mainstack;
		319	PL_stack_sp = c->stack_sp;
		320	PL_op = c->op;
		321	PL_curpad = c->curpad;
		322	PL_comppad = c->comppad;
		323	PL_stack_base = c->stack_base;
		324	PL_stack_max = c->stack_max;
		325	PL_tmps_stack = c->tmps_stack;
		326	PL_tmps_floor = c->tmps_floor;
		327	PL_tmps_ix = c->tmps_ix;
		328	PL_tmps_max = c->tmps_max;
		329	PL_markstack = c->markstack;
		330	PL_markstack_ptr = c->markstack_ptr;
		331	PL_markstack_max = c->markstack_max;
		332	PL_scopestack = c->scopestack;
		333	PL_scopestack_ix = c->scopestack_ix;
		334	PL_scopestack_max = c->scopestack_max;
		335	PL_savestack = c->savestack;
		336	PL_savestack_ix = c->savestack_ix;
		337	PL_savestack_max = c->savestack_max;
		338	PL_retstack = c->retstack;
		339	PL_retstack_ix = c->retstack_ix;
		340	PL_retstack_max = c->retstack_max;
		341	PL_curcop = c->curcop;
		342	PL_top_env = c->top_env;
		343
		344	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		345	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		346	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		347
		348	{
		349	dSP;
		350	CV *cv;
		351
		352	/* now do the ugly restore mess */
		353	while ((cv = (CV *)POPs))
		354	{
		355	AV padlist = (AV )POPs;
		356
		357	if (padlist)
		358	{
		359	put_padlist (cv); /* mark this padlist as available */
		360	CvPADLIST(cv) = padlist;
		361	#ifdef USE_THREADS
		362	/CvOWNER(cv) = (struct perl_thread )POPs;*/
		363	#endif
		364	}
		365
		366	++CvDEPTH(cv);
		367	}
		368
		369	PUTBACK;
		370	}
		371	}
		372
		373	static void
		374	save_state(pTHX_ Coro__State c, int flags)
170	{	375	{
171	{	376	{
172	dSP;	377	dSP;
173	I32 cxix = cxstack_ix;	378	I32 cxix = cxstack_ix;
		379	PERL_CONTEXT *ccstk = cxstack;
174	PERL_SI *top_si = PL_curstackinfo;	380	PERL_SI *top_si = PL_curstackinfo;
175	PERL_CONTEXT *ccstk = cxstack;
176		381
177	/*	382	/*
178	* the worst thing you can imagine happens first - we have to save	383	* the worst thing you can imagine happens first - we have to save
179	* (and reinitialize) all cv's in the whole callchain :(	384	* (and reinitialize) all cv's in the whole callchain :(
180	*/	385	*/
…		…
183	/* this loop was inspired by pp_caller */	388	/* this loop was inspired by pp_caller */
184	for (;;)	389	for (;;)
185	{	390	{
186	while (cxix >= 0)	391	while (cxix >= 0)
187	{	392	{
188	PERL_CONTEXT *cx = &ccstk[--cxix];	393	PERL_CONTEXT *cx = &ccstk[cxix--];
189		394
190	if (CxTYPE(cx) == CXt_SUB)	395	if (CxTYPE(cx) == CXt_SUB)
191	{	396	{
192	CV *cv = cx->blk_sub.cv;	397	CV *cv = cx->blk_sub.cv;
193	if (CvDEPTH(cv))	398	if (CvDEPTH(cv))
194	{	399	{
195	#ifdef USE_THREADS	400	#ifdef USE_THREADS
196	XPUSHs ((SV *)CvOWNER(cv));	401	/XPUSHs ((SV )CvOWNER(cv));*/
		402	/CvOWNER(cv) = 0;/
		403	/error must unlock this cv etc.. etc.../
197	#endif	404	#endif
198	EXTEND (SP, 3);	405	EXTEND (SP, CvDEPTH(cv)*2);
		406
		407	while (--CvDEPTH(cv))
		408	{
		409	/* this tells the restore code to increment CvDEPTH */
		410	PUSHs (Nullsv);
199	PUSHs ((SV *)CvDEPTH(cv));	411	PUSHs ((SV *)cv);
		412	}
		413
200	PUSHs ((SV *)CvPADLIST(cv));	414	PUSHs ((SV *)CvPADLIST(cv));
201	PUSHs ((SV *)cv);	415	PUSHs ((SV *)cv);
202		416
203	CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));	417	get_padlist (cv); /* this is a monster */
204
205	CvDEPTH(cv) = 0;
206	#ifdef USE_THREADS
207	CvOWNER(cv) = 0;
208	error must unlock this cv etc.. etc...
209	if you are here wondering about this error message then
210	the reason is that it will not work as advertised yet
211	#endif
212	}	418	}
213	}	419	}
		420	#ifdef CXt_FORMAT
214	else if (CxTYPE(cx) == CXt_FORMAT)	421	else if (CxTYPE(cx) == CXt_FORMAT)
215	{	422	{
216	/* I never used formats, so how should I know how these are implemented? */	423	/* I never used formats, so how should I know how these are implemented? */
217	/* my bold guess is as a simple, plain sub... */	424	/* my bold guess is as a simple, plain sub... */
218	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	425	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
219	}	426	}
		427	#endif
220	}	428	}
221		429
222	if (top_si->si_type == PERLSI_MAIN)	430	if (top_si->si_type == PERLSI_MAIN)
223	break;	431	break;
224		432
…		…
228	}	436	}
229		437
230	PUTBACK;	438	PUTBACK;
231	}	439	}
232		440
		441	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		442	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		443	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		444
233	c->dowarn = PL_dowarn;	445	c->dowarn = PL_dowarn;
234	c->defav = GvAV (PL_defgv);	446	c->in_eval = PL_in_eval;
		447
235	c->curstackinfo = PL_curstackinfo;	448	c->curstackinfo = PL_curstackinfo;
236	c->curstack = PL_curstack;	449	c->curstack = PL_curstack;
237	c->mainstack = PL_mainstack;	450	c->mainstack = PL_mainstack;
238	c->stack_sp = PL_stack_sp;	451	c->stack_sp = PL_stack_sp;
239	c->op = PL_op;	452	c->op = PL_op;
240	c->curpad = PL_curpad;	453	c->curpad = PL_curpad;
		454	c->comppad = PL_comppad;
241	c->stack_base = PL_stack_base;	455	c->stack_base = PL_stack_base;
242	c->stack_max = PL_stack_max;	456	c->stack_max = PL_stack_max;
243	c->tmps_stack = PL_tmps_stack;	457	c->tmps_stack = PL_tmps_stack;
244	c->tmps_floor = PL_tmps_floor;	458	c->tmps_floor = PL_tmps_floor;
245	c->tmps_ix = PL_tmps_ix;	459	c->tmps_ix = PL_tmps_ix;
…		…
255	c->savestack_max = PL_savestack_max;	469	c->savestack_max = PL_savestack_max;
256	c->retstack = PL_retstack;	470	c->retstack = PL_retstack;
257	c->retstack_ix = PL_retstack_ix;	471	c->retstack_ix = PL_retstack_ix;
258	c->retstack_max = PL_retstack_max;	472	c->retstack_max = PL_retstack_max;
259	c->curcop = PL_curcop;	473	c->curcop = PL_curcop;
		474	c->top_env = PL_top_env;
		475	}
		476
		477	/*
		478	* allocate various perl stacks. This is an exact copy
		479	* of perl.c:init_stacks, except that it uses less memory
		480	* on the assumption that coroutines do not usually need
		481	* a lot of stackspace.
		482	*/
		483	STATIC void
		484	coro_init_stacks (pTHX)
		485	{
		486	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
		487	PL_curstackinfo->si_type = PERLSI_MAIN;
		488	PL_curstack = PL_curstackinfo->si_stack;
		489	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		490
		491	PL_stack_base = AvARRAY(PL_curstack);
		492	PL_stack_sp = PL_stack_base;
		493	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
		494
		495	New(50,PL_tmps_stack,96,SV*);
		496	PL_tmps_floor = -1;
		497	PL_tmps_ix = -1;
		498	PL_tmps_max = 96;
		499
		500	New(54,PL_markstack,16,I32);
		501	PL_markstack_ptr = PL_markstack;
		502	PL_markstack_max = PL_markstack + 16;
		503
		504	#ifdef SET_MARK_OFFSET
		505	SET_MARK_OFFSET;
		506	#endif
		507
		508	New(54,PL_scopestack,16,I32);
		509	PL_scopestack_ix = 0;
		510	PL_scopestack_max = 16;
		511
		512	New(54,PL_savestack,96,ANY);
		513	PL_savestack_ix = 0;
		514	PL_savestack_max = 96;
		515
		516	New(54,PL_retstack,8,OP*);
		517	PL_retstack_ix = 0;
		518	PL_retstack_max = 8;
		519	}
		520
		521	/*
		522	* destroy the stacks, the callchain etc...
		523	*/
		524	STATIC void
		525	destroy_stacks(pTHX)
		526	{
		527	if (!IN_DESTRUCT)
		528	{
		529	/* is this ugly, I ask? */
		530	while (PL_scopestack_ix)
		531	LEAVE;
		532
		533	/* sure it is, but more important: is it correct?? :/ */
		534	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		535	FREETMPS;
		536	}
		537
		538	while (PL_curstackinfo->si_next)
		539	PL_curstackinfo = PL_curstackinfo->si_next;
		540
		541	while (PL_curstackinfo)
		542	{
		543	PERL_SI *p = PL_curstackinfo->si_prev;
		544
		545	{
		546	dSP;
		547	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		548	PUTBACK; /* possibly superfluous */
		549	}
		550
		551	if (!IN_DESTRUCT)
		552	{
		553	dounwind(-1);
		554	SvREFCNT_dec(PL_curstackinfo->si_stack);
		555	}
		556
		557	Safefree(PL_curstackinfo->si_cxstack);
		558	Safefree(PL_curstackinfo);
		559	PL_curstackinfo = p;
		560	}
		561
		562	Safefree(PL_tmps_stack);
		563	Safefree(PL_markstack);
		564	Safefree(PL_scopestack);
		565	Safefree(PL_savestack);
		566	Safefree(PL_retstack);
260	}	567	}
261		568
262	static void	569	static void
263	LOAD(pTHX_ Coro__State c)	570	allocate_stack (Coro__State ctx, int alloc)
264	{	571	{
265	PL_dowarn = c->dowarn;	572	coro_stack *stack;
266	GvAV (PL_defgv) = c->defav;
267	PL_curstackinfo = c->curstackinfo;
268	PL_curstack = c->curstack;
269	PL_mainstack = c->mainstack;
270	PL_stack_sp = c->stack_sp;
271	PL_op = c->op;
272	PL_curpad = c->curpad;
273	PL_stack_base = c->stack_base;
274	PL_stack_max = c->stack_max;
275	PL_tmps_stack = c->tmps_stack;
276	PL_tmps_floor = c->tmps_floor;
277	PL_tmps_ix = c->tmps_ix;
278	PL_tmps_max = c->tmps_max;
279	PL_markstack = c->markstack;
280	PL_markstack_ptr = c->markstack_ptr;
281	PL_markstack_max = c->markstack_max;
282	PL_scopestack = c->scopestack;
283	PL_scopestack_ix = c->scopestack_ix;
284	PL_scopestack_max = c->scopestack_max;
285	PL_savestack = c->savestack;
286	PL_savestack_ix = c->savestack_ix;
287	PL_savestack_max = c->savestack_max;
288	PL_retstack = c->retstack;
289	PL_retstack_ix = c->retstack_ix;
290	PL_retstack_max = c->retstack_max;
291	PL_curcop = c->curcop;
292		573
		574	New (0, stack, 1, coro_stack);
		575
		576	stack->refcnt = 1;
		577	stack->usecnt = 1;
		578	stack->gencnt = ctx->gencnt = 0;
		579	if (alloc)
293	{	580	{
		581	#if HAVE_MMAP
		582	stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
		583	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		584	if (stack->sptr == (void *)-1)
		585	#endif
		586	{
		587	/FIXME//D//* reasonable stack size! */
		588	stack->ssize = -4096 * sizeof (long);
		589	New (0, stack->sptr, 4096, long);
		590	}
		591	}
		592	else
		593	stack->sptr = 0;
		594
		595	ctx->stack = stack;
		596	}
		597
		598	static void
		599	deallocate_stack (Coro__State ctx)
		600	{
		601	coro_stack *stack = ctx->stack;
		602
		603	ctx->stack = 0;
		604
		605	if (stack)
		606	{
		607	if (!--stack->refcnt)
		608	{
		609	#ifdef HAVE_MMAP
		610	if (stack->ssize > 0 && stack->sptr)
		611	munmap (stack->sptr, stack->ssize);
		612	else
		613	#endif
		614	Safefree (stack->sptr);
		615
		616	Safefree (stack);
		617	}
		618	else if (ctx->gencnt == stack->gencnt)
		619	--stack->usecnt;
		620	}
		621	}
		622
		623	static void
		624	setup_coro (void *arg)
		625	{
		626	/*
		627	* emulate part of the perl startup here.
		628	*/
294	dSP;	629	dSP;
295	CV *cv;	630	Coro__State ctx = (Coro__State)arg;
		631	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
296		632
297	/* now do the ugly restore mess */	633	coro_init_stacks (aTHX);
298	while ((cv = (CV *)POPs))	634	/PL_curcop = 0;/
		635	/PL_in_eval = PL_in_eval;/ /* inherit */
		636	SvREFCNT_dec (GvAV (PL_defgv));
		637	GvAV (PL_defgv) = ctx->args; ctx->args = 0;
		638
		639	SPAGAIN;
		640
		641	if (ctx->stack)
		642	{
		643	ctx->cursp = 0;
		644
		645	PUSHMARK(SP);
		646	PUTBACK;
		647	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		648
		649	if (SvTRUE (ERRSV))
		650	croak (NULL);
		651	else
		652	croak ("FATAL: CCTXT coroutine returned!");
		653	}
		654	else
		655	{
		656	UNOP myop;
		657
		658	PL_op = (OP *)&myop;
		659
		660	Zero(&myop, 1, UNOP);
		661	myop.op_next = Nullop;
		662	myop.op_flags = OPf_WANT_VOID;
		663
		664	PUSHMARK(SP);
		665	XPUSHs (sub_init);
		666	/*
		667	* the next line is slightly wrong, as PL_op->op_next
		668	* is actually being executed so we skip the first op.
		669	* that doesn't matter, though, since it is only
		670	* pp_nextstate and we never return...
		671	* ah yes, and I don't care anyways ;)
		672	*/
		673	PUTBACK;
		674	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		675	SPAGAIN;
		676
		677	ENTER; /* necessary e.g. for dounwind */
		678	}
		679	}
		680
		681	static void
		682	continue_coro (void *arg)
		683	{
		684	/*
		685	* this is a _very_ stripped down perl interpreter ;)
		686	*/
		687	Coro__State ctx = (Coro__State)arg;
		688	JMPENV coro_start_env;
		689
		690	PL_top_env = &ctx->start_env;
		691
		692	ctx->cursp = 0;
		693	PL_op = PL_op->op_next;
		694	CALLRUNOPS(aTHX);
		695
		696	abort ();
		697	}
		698
		699	STATIC void
		700	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		701	{
		702	dSTACKLEVEL;
		703	static struct coro *xnext;
		704
		705	if (prev != next)
		706	{
		707	xnext = next;
		708
		709	if (next->mainstack)
		710	{
		711	SAVE (prev, flags);
		712	LOAD (next);
		713
		714	/* mark this state as in-use */
		715	next->mainstack = 0;
		716	next->tmps_ix = -2;
		717
		718	/* stacklevel changed? if yes, grab the stack for us! */
		719	if (flags & TRANSFER_SAVE_CCTXT)
		720	{
		721	if (!prev->stack)
		722	allocate_stack (prev, 0);
		723	else if (prev->cursp != stacklevel
		724	&& prev->stack->usecnt > 1)
		725	{
		726	prev->gencnt = ++prev->stack->gencnt;
		727	prev->stack->usecnt = 1;
		728	}
		729
		730	/* has our stack been invalidated? */
		731	if (next->stack && next->stack->gencnt != next->gencnt)
		732	{
		733	deallocate_stack (next);
		734	allocate_stack (next, 1);
		735	coro_create (&(next->stack->cctx),
		736	continue_coro, (void *)next,
		737	next->stack->sptr, labs (next->stack->ssize));
		738	}
		739
		740	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		741	/* don't add any code here */
		742	}
		743
		744	}
		745	else if (next->tmps_ix == -2)
		746	croak ("tried to transfer to running coroutine");
		747	else
		748	{
		749	SAVE (prev, -1); /* first get rid of the old state */
		750
		751	if (flags & TRANSFER_SAVE_CCTXT)
		752	{
		753	if (!prev->stack)
		754	allocate_stack (prev, 0);
		755
		756	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		757	{
		758	PL_top_env = &next->start_env;
		759
		760	setup_coro (next);
		761
		762	prev->stack->refcnt++;
		763	prev->stack->usecnt++;
		764	next->stack = prev->stack;
		765	next->gencnt = prev->gencnt;
		766	}
		767	else
		768	{
		769	assert (!next->stack);
		770	allocate_stack (next, 1);
		771	coro_create (&(next->stack->cctx),
		772	setup_coro, (void *)next,
		773	next->stack->sptr, labs (next->stack->ssize));
		774	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		775	/* don't add any code here */
		776	}
		777	}
		778	else
		779	setup_coro (next);
		780	}
		781
		782	/*
		783	* xnext is now either prev or next, depending on wether
		784	* we switched the c stack or not. that's why I use a global
		785	* variable, that should become thread-specific at one point.
		786	*/
		787	xnext->cursp = stacklevel;
		788	}
		789
		790	if (coro_mortal)
		791	{
		792	SvREFCNT_dec (coro_mortal);
		793	coro_mortal = 0;
		794	}
		795	}
		796
		797	#define SV_CORO(sv,func) \
		798	do { \
		799	if (SvROK (sv)) \
		800	sv = SvRV (sv); \
		801	\
		802	if (SvTYPE(sv) == SVt_PVHV) \
		803	{ \
		804	HE he = hv_fetch_ent((HV )sv, ucoro_state_sv, 0, ucoro_state_hash); \
		805	\
		806	if (!he) \
		807	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
		808	\
		809	(sv) = SvRV (HeVAL(he)); \
		810	} \
		811	\
		812	/* must also be changed inside Coro::Cont::yield */ \
		813	if (!SvOBJECT(sv) \|\| SvSTASH(sv) != coro_state_stash) \
		814	croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
		815	\
		816	} while(0)
		817
		818	#define SvSTATE(sv) (struct coro *)SvIV (sv)
		819
		820	static void
		821	api_transfer(pTHX_ SV prev, SV next, int flags)
		822	{
		823	SV_CORO (prev, "Coro::transfer");
		824	SV_CORO (next, "Coro::transfer");
		825
		826	transfer(aTHX_ SvSTATE(prev), SvSTATE(next), flags);
		827	}
		828
		829	/ Coro ******************************************************************/
		830
		831	#define PRIO_MAX 3
		832	#define PRIO_HIGH 1
		833	#define PRIO_NORMAL 0
		834	#define PRIO_LOW -1
		835	#define PRIO_IDLE -3
		836	#define PRIO_MIN -4
		837
		838	/* for Coro.pm */
		839	static GV coro_current, coro_idle;
		840	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		841	static int coro_nready;
		842
		843	static void
		844	coro_enq (SV *sv)
		845	{
		846	if (SvTYPE (sv) == SVt_PVHV)
		847	{
		848	SV *xprio = hv_fetch ((HV )sv, "prio", 4, 0);
		849	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		850
		851	prio = prio > PRIO_MAX ? PRIO_MAX
		852	: prio < PRIO_MIN ? PRIO_MIN
		853	: prio;
		854
		855	av_push (coro_ready [prio - PRIO_MIN], sv);
		856	coro_nready++;
		857
		858	return;
		859	}
		860
		861	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		862	}
		863
		864	static SV *
		865	coro_deq (int min_prio)
		866	{
		867	int prio = PRIO_MAX - PRIO_MIN;
		868
		869	min_prio -= PRIO_MIN;
		870	if (min_prio < 0)
		871	min_prio = 0;
		872
		873	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		874	if (av_len (coro_ready[prio]) >= 0)
299	{	875	{
300	AV padlist = (AV )POPs;	876	coro_nready--;
301		877	return av_shift (coro_ready[prio]);
302	unuse_padlist (CvPADLIST(cv));
303	CvPADLIST(cv) = padlist;
304	CvDEPTH(cv) = (I32)POPs;
305
306	#ifdef USE_THREADS
307	CvOWNER(cv) = (struct perl_thread *)POPs;
308	error does not work either
309	#endif
310	}	878	}
311		879
312	PUTBACK;	880	return 0;
313	}
314	}	881	}
315		882
316	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	883	static void
317	STATIC void	884	api_ready (SV *coro)
318	S_nuke_stacks(pTHX)
319	{	885	{
320	while (PL_curstackinfo->si_next)	886	if (SvROK (coro))
321	PL_curstackinfo = PL_curstackinfo->si_next;	887	coro = SvRV (coro);
322	while (PL_curstackinfo) {
323	PERL_SI *p = PL_curstackinfo->si_prev;
324	/* curstackinfo->si_stack got nuked by sv_free_arenas() */
325	Safefree(PL_curstackinfo->si_cxstack);
326	Safefree(PL_curstackinfo);
327	PL_curstackinfo = p;
328	}
329	Safefree(PL_tmps_stack);
330	Safefree(PL_markstack);
331	Safefree(PL_scopestack);
332	Safefree(PL_savestack);
333	Safefree(PL_retstack);
334	}
335		888
336	#define SUB_INIT "Coro::State::_newcoro"	889	coro_enq (SvREFCNT_inc (coro));
		890	}
		891
		892	static void
		893	api_schedule (void)
		894	{
		895	SV prev, next;
		896
		897	prev = SvRV (GvSV (coro_current));
		898	next = coro_deq (PRIO_MIN);
		899
		900	if (!next)
		901	next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
		902
		903	/* free this only after the transfer */
		904	coro_mortal = prev;
		905	SV_CORO (prev, "Coro::schedule");
		906
		907	SvRV (GvSV (coro_current)) = next;
		908
		909	SV_CORO (next, "Coro::schedule");
		910
		911	transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		912	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		913	}
		914
		915	static void
		916	api_cede (void)
		917	{
		918	coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
		919
		920	api_schedule ();
		921	}
337		922
338	MODULE = Coro::State PACKAGE = Coro::State	923	MODULE = Coro::State PACKAGE = Coro::State
339		924
340	PROTOTYPES: ENABLE	925	PROTOTYPES: ENABLE
341		926
342	BOOT:	927	BOOT:
		928	{ /* {} necessary for stoopid perl-5.6.x */
		929	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		930	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		931	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		932
		933	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		934	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		935	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		936	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		937
343	if (!padlist_cache)	938	if (!padlist_cache)
344	padlist_cache = newHV ();	939	padlist_cache = newHV ();
		940
		941	main_mainstack = PL_mainstack;
		942
		943	coroapi.ver = CORO_API_VERSION;
		944	coroapi.transfer = api_transfer;
		945	}
345		946
346	Coro::State	947	Coro::State
347	_newprocess(args)	948	_newprocess(args)
348	SV * args	949	SV * args
349	PROTOTYPE: $	950	PROTOTYPE: $
350	CODE:	951	CODE:
351	Coro__State coro;	952	Coro__State coro;
352		953
353	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	954	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
354	croak ("Coro::State::newprocess expects an arrayref");	955	croak ("Coro::State::_newprocess expects an arrayref");
355		956
356	New (0, coro, 1, struct coro);	957	Newz (0, coro, 1, struct coro);
357		958
		959	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358	coro->mainstack = 0; /* actual work is done inside transfer */	960	coro->mainstack = 0; /* actual work is done inside transfer */
359	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	961	coro->stack = 0;
		962
		963	/* same as JMPENV_BOOTSTRAP */
		964	/* we might be able to recycle start_env, but safe is safe */
		965	//Zero(&coro->start_env, 1, JMPENV);
		966	coro->start_env.je_ret = -1;
		967	coro->start_env.je_mustcatch = TRUE;
360		968
361	RETVAL = coro;	969	RETVAL = coro;
362	OUTPUT:	970	OUTPUT:
363	RETVAL	971	RETVAL
364		972
365	void	973	void
366	transfer(prev,next)	974	transfer(prev, next, flags)
367	Coro::State_or_hashref prev	975	SV *prev
368	Coro::State_or_hashref next	976	SV *next
		977	int flags
		978	PROTOTYPE: @
369	CODE:	979	CODE:
370
371	if (prev != next)
372	{
373	PUTBACK;	980	PUTBACK;
374	SAVE (aTHX_ prev);	981	SV_CORO (next, "Coro::transfer");
375		982	SV_CORO (prev, "Coro::transfer");
376	/*	983	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
377	* this could be done in newprocess which would lead to
378	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
379	* code here, but lazy allocation of stacks has also
380	* some virtues and the overhead of the if() is nil.
381	*/
382	if (next->mainstack)
383	{
384	LOAD (aTHX_ next);
385	next->mainstack = 0; /* unnecessary but much cleaner */
386	SPAGAIN;	984	SPAGAIN;
387	}
388	else
389	{
390	/*
391	* emulate part of the perl startup here.
392	*/
393	UNOP myop;
394
395	init_stacks ();
396	PL_op = (OP *)&myop;
397	/PL_curcop = 0;/
398	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
399
400	SPAGAIN;
401	Zero(&myop, 1, UNOP);
402	myop.op_next = Nullop;
403	myop.op_flags = OPf_WANT_VOID;
404
405	PUSHMARK(SP);
406	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
407	PUTBACK;
408	/*
409	* the next line is slightly wrong, as PL_op->op_next
410	* is actually being executed so we skip the first op.
411	* that doesn't matter, though, since it is only
412	* pp_nextstate and we never return...
413	*/
414	PL_op = Perl_pp_entersub(aTHX);
415	SPAGAIN;
416
417	ENTER;
418	}
419	}
420		985
421	void	986	void
422	DESTROY(coro)	987	DESTROY(coro)
423	Coro::State coro	988	Coro::State coro
424	CODE:	989	CODE:
425		990
426	if (coro->mainstack)	991	if (coro->mainstack && coro->mainstack != main_mainstack)
427	{	992	{
428	struct coro temp;	993	struct coro temp;
429		994
430	PUTBACK;	995	PUTBACK;
431	SAVE(aTHX_ (&temp));	996	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432	LOAD(aTHX_ coro);	997	LOAD(aTHX_ coro);
433
434	S_nuke_stacks ();
435	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436
437	LOAD((&temp));
438	SPAGAIN;	998	SPAGAIN;
		999
		1000	destroy_stacks (aTHX);
		1001
		1002	LOAD((&temp)); /* this will get rid of defsv etc.. */
		1003	SPAGAIN;
		1004
		1005	coro->mainstack = 0;
439	}	1006	}
440		1007
		1008	deallocate_stack (coro);
441	SvREFCNT_dec (coro->args);	1009	SvREFCNT_dec (coro->args);
442	Safefree (coro);	1010	Safefree (coro);
443		1011
		1012	void
		1013	flush()
		1014	CODE:
		1015	#ifdef MAY_FLUSH
		1016	flush_padlist_cache ();
		1017	#endif
444		1018
		1019	void
		1020	_exit(code)
		1021	int code
		1022	PROTOTYPE: $
		1023	CODE:
		1024	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		1025	_exit (code);
		1026	#else
		1027	signal (SIGTERM, SIG_DFL);
		1028	raise (SIGTERM);
		1029	exit (code);
		1030	#endif
		1031
		1032	MODULE = Coro::State PACKAGE = Coro::Cont
		1033
		1034	# this is slightly dirty (should expose a c-level api)
		1035
		1036	void
		1037	yield(...)
		1038	PROTOTYPE: @
		1039	CODE:
		1040	static SV *returnstk;
		1041	SV *sv;
		1042	AV *defav = GvAV (PL_defgv);
		1043	struct coro prev, next;
		1044
		1045	if (!returnstk)
		1046	returnstk = SvRV ((SV *)get_sv ("Coro::Cont::return", FALSE));
		1047
		1048	/* set up @_ -- ugly */
		1049	av_clear (defav);
		1050	av_fill (defav, items - 1);
		1051	while (items--)
		1052	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1053
		1054	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		1055	sv = av_pop ((AV *)SvRV (returnstk));
		1056	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		1057	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		1058	SvREFCNT_dec (sv);
		1059
		1060	transfer(aTHX_ prev, next, 0);
		1061
		1062	MODULE = Coro::State PACKAGE = Coro
		1063
		1064	# this is slightly dirty (should expose a c-level api)
		1065
		1066	BOOT:
		1067	{
		1068	int i;
		1069	HV *stash = gv_stashpv ("Coro", TRUE);
		1070
		1071	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1072	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1073	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1074	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1075	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1076	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1077
		1078	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1079	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1080
		1081	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1082	coro_ready[i] = newAV ();
		1083
		1084	{
		1085	SV *sv = perl_get_sv("Coro::API", 1);
		1086
		1087	coroapi.schedule = api_schedule;
		1088	coroapi.cede = api_cede;
		1089	coroapi.ready = api_ready;
		1090	coroapi.nready = &coro_nready;
		1091	coroapi.current = coro_current;
		1092
		1093	GCoroAPI = &coroapi;
		1094	sv_setiv(sv, (IV)&coroapi);
		1095	SvREADONLY_on(sv);
		1096	}
		1097	}
		1098
		1099	void
		1100	ready(self)
		1101	SV * self
		1102	PROTOTYPE: $
		1103	CODE:
		1104	api_ready (self);
		1105
		1106	int
		1107	nready(...)
		1108	PROTOTYPE:
		1109	CODE:
		1110	RETVAL = coro_nready;
		1111	OUTPUT:
		1112	RETVAL
		1113
		1114	void
		1115	schedule(...)
		1116	PROTOTYPE:
		1117	CODE:
		1118	api_schedule ();
		1119
		1120	void
		1121	cede(...)
		1122	PROTOTYPE:
		1123	CODE:
		1124	api_cede ();
		1125

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs. Revision 1.48 by pcg, Sat Nov 15 03:53:37 2003 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.48 by pcg, Sat Nov 15 03:53:37 2003 UTC