[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.40 by root, Tue Nov 27 01:41:41 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	#include <signal.h>
		8
		9	#ifdef HAVE_MMAP
		10	# include <unistd.h>
		11	# include <sys/mman.h>
		12	# ifndef MAP_ANONYMOUS
		13	# ifdef MAP_ANON
		14	# define MAP_ANONYMOUS MAP_ANON
7	#else	15	# else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	16	# undef HAVE_MMAP
		17	# endif
		18	# endif
9	#endif	19	#endif
10		20
		21	#define MAY_FLUSH /* increases codesize and is rarely used */
		22
		23	#define SUB_INIT "Coro::State::initialize"
		24	#define UCORO_STATE "_coro_state"
		25
		26	/* The next macro should declare a variable stacklevel that contains and approximation
		27	* to the current C stack pointer. Its property is that it changes with each call
		28	* and should be unique. */
		29	#define dSTACKLEVEL void *stacklevel = &stacklevel
		30
		31	#define IN_DESTRUCT (PL_main_cv == Nullcv)
		32
		33	#define labs(l) ((l) >= 0 ? (l) : -(l))
		34
		35	#include "CoroAPI.h"
		36
		37	static struct CoroAPI coroapi;
		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
11	struct coro {	51	struct coro {
		52	/* the optional C context */
		53	coro_stack *stack;
		54	void *cursp;
		55	int gencnt;
		56
		57	/* optionally saved, might be zero */
		58	AV *defav;
		59	SV *defsv;
		60	SV *errsv;
		61
		62	/* saved global state not related to stacks */
12	U8 dowarn;	63	U8 dowarn;
13	AV *defav;	64	I32 in_eval;
14		65
		66	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	67	PERL_SI *curstackinfo;
16	AV *curstack;	68	AV *curstack;
17	AV *mainstack;	69	AV *mainstack;
18	SV **stack_sp;	70	SV **stack_sp;
19	OP *op;	71	OP *op;
35	I32 savestack_max;	87	I32 savestack_max;
36	OP **retstack;	88	OP **retstack;
37	I32 retstack_ix;	89	I32 retstack_ix;
38	I32 retstack_max;	90	I32 retstack_max;
39	COP *curcop;	91	COP *curcop;
		92	PMOP *curpm;
		93	JMPENV *top_env;
40		94
		95	/* data associated with this coroutine (initial args) */
41	AV *args;	96	AV *args;
42	};	97	};
43		98
44	typedef struct coro *Coro__State;	99	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	100	typedef struct coro *Coro__State_or_hashref;
46		101
		102	static AV main_mainstack; / used to differentiate between $main and others */
		103	static HV *coro_state_stash;
		104	static SV *ucoro_state_sv;
		105	static U32 ucoro_state_hash;
47	static HV *padlist_cache;	106	static HV *padlist_cache;
		107	static SV coro_mortal; / will be freed after next transfer */
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)
52	{	112	{
…		…
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
143	STATIC AV *	203	#ifdef MAY_FLUSH
		204	STATIC void
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))
148	{	209	{
…		…
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) load_state(aTHX_ (state));
		280	#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
		281
		282	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
		283
188	static void	284	static void
189	save_state(pTHX_ Coro__State c)	285	load_state(pTHX_ Coro__State c)
		286	{
		287	PL_dowarn = c->dowarn;
		288	PL_in_eval = c->in_eval;
		289
		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	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	*/
…		…
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? */
…		…
248	}	407	}
249		408
250	PUTBACK;	409	PUTBACK;
251	}	410	}
252		411
		412	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		413	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		414	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		415
253	c->dowarn = PL_dowarn;	416	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);	417	c->in_eval = PL_in_eval;
		418
255	c->curstackinfo = PL_curstackinfo;	419	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	420	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	421	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	422	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	423	c->op = PL_op;
…		…
275	c->savestack_max = PL_savestack_max;	439	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;	440	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;	441	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	442	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;	443	c->curcop = PL_curcop;
		444	c->top_env = PL_top_env;
280	}	445	}
281		446
282	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	447	/*
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	448	* allocate various perl stacks. This is an exact copy
284		449	* of perl.c:init_stacks, except that it uses less memory
285	static void	450	* on the assumption that coroutines do not usually need
286	load_state(pTHX_ Coro__State c)	451	* a lot of stackspace.
		452	*/
		453	STATIC void
		454	coro_init_stacks (pTHX)
287	{	455	{
288	PL_dowarn = c->dowarn;	456	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
289	GvAV (PL_defgv) = c->defav;	457	PL_curstackinfo->si_type = PERLSI_MAIN;
290	PL_curstackinfo = c->curstackinfo;	458	PL_curstack = PL_curstackinfo->si_stack;
291	PL_curstack = c->curstack;	459	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
292	PL_mainstack = c->mainstack;	460
		461	PL_stack_base = AvARRAY(PL_curstack);
293	PL_stack_sp = c->stack_sp;	462	PL_stack_sp = PL_stack_base;
294	PL_op = c->op;	463	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295	PL_curpad = c->curpad;	464
296	PL_stack_base = c->stack_base;	465	New(50,PL_tmps_stack,96,SV*);
297	PL_stack_max = c->stack_max;	466	PL_tmps_floor = -1;
298	PL_tmps_stack = c->tmps_stack;	467	PL_tmps_ix = -1;
299	PL_tmps_floor = c->tmps_floor;	468	PL_tmps_max = 96;
300	PL_tmps_ix = c->tmps_ix;	469
301	PL_tmps_max = c->tmps_max;	470	New(54,PL_markstack,16,I32);
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;	471	PL_markstack_ptr = PL_markstack;
304	PL_markstack_max = c->markstack_max;	472	PL_markstack_max = PL_markstack + 16;
305	PL_scopestack = c->scopestack;
306	PL_scopestack_ix = c->scopestack_ix;
307	PL_scopestack_max = c->scopestack_max;
308	PL_savestack = c->savestack;
309	PL_savestack_ix = c->savestack_ix;
310	PL_savestack_max = c->savestack_max;
311	PL_retstack = c->retstack;
312	PL_retstack_ix = c->retstack_ix;
313	PL_retstack_max = c->retstack_max;
314	PL_curcop = c->curcop;
315		473
316	{	474	SET_MARK_OFFSET;
317	dSP;
318	CV *cv;
319		475
320	/* now do the ugly restore mess */	476	New(54,PL_scopestack,16,I32);
321	while ((cv = (CV *)POPs))	477	PL_scopestack_ix = 0;
322	{	478	PL_scopestack_max = 16;
323	AV padlist = (AV )POPs;
324		479
325	put_padlist (cv);	480	New(54,PL_savestack,96,ANY);
326	CvPADLIST(cv) = padlist;	481	PL_savestack_ix = 0;
327	CvDEPTH(cv) = (I32)POPs;	482	PL_savestack_max = 96;
328		483
329	#ifdef USE_THREADS	484	New(54,PL_retstack,8,OP*);
330	CvOWNER(cv) = (struct perl_thread *)POPs;	485	PL_retstack_ix = 0;
331	error does not work either	486	PL_retstack_max = 8;
332	#endif
333	}
334
335	PUTBACK;
336	}
337	}	487	}
338		488
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	489	/*
		490	* destroy the stacks, the callchain etc...
		491	* still there is a memleak of 128 bytes...
		492	*/
340	STATIC void	493	STATIC void
341	destroy_stacks(pTHX)	494	destroy_stacks(pTHX)
342	{	495	{
343	/* die does this while calling POPSTACK, but I just don't see why. */	496	if (!IN_DESTRUCT)
344	/* OTOH, die does not have a memleak, but we do... */	497	{
345	dounwind(-1);
346
347	/* is this ugly, I ask? */	498	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)	499	while (PL_scopestack_ix)
349	LEAVE;	500	LEAVE;
		501
		502	/* sure it is, but more important: is it correct?? :/ */
		503	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		504	FREETMPS;
		505	}
350		506
351	while (PL_curstackinfo->si_next)	507	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;	508	PL_curstackinfo = PL_curstackinfo->si_next;
353		509
354	while (PL_curstackinfo)	510	while (PL_curstackinfo)
355	{	511	{
356	PERL_SI *p = PL_curstackinfo->si_prev;	512	PERL_SI *p = PL_curstackinfo->si_prev;
357		513
		514	{
		515	dSP;
		516	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		517	PUTBACK; /* possibly superfluous */
		518	}
		519
		520	if (!IN_DESTRUCT)
		521	{
		522	dounwind(-1);
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	523	SvREFCNT_dec(PL_curstackinfo->si_stack);
		524	}
		525
359	Safefree(PL_curstackinfo->si_cxstack);	526	Safefree(PL_curstackinfo->si_cxstack);
360	Safefree(PL_curstackinfo);	527	Safefree(PL_curstackinfo);
361	PL_curstackinfo = p;	528	PL_curstackinfo = p;
362	}	529	}
363		530
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);	531	Safefree(PL_tmps_stack);
378	Safefree(PL_markstack);	532	Safefree(PL_markstack);
379	Safefree(PL_scopestack);	533	Safefree(PL_scopestack);
380	Safefree(PL_savestack);	534	Safefree(PL_savestack);
381	Safefree(PL_retstack);	535	Safefree(PL_retstack);
382	}	536	}
383		537
384	#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	#if HAVE_MMAP
		551	stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
		552	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 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	PL_curpm = 0; /* segfault on first access */
		604	/PL_curcop = 0;/
		605	/PL_in_eval = PL_in_eval;/ /* inherit */
		606	SvREFCNT_dec (GvAV (PL_defgv));
		607	GvAV (PL_defgv) = ctx->args;
		608
		609	SPAGAIN;
		610
		611	if (ctx->stack)
		612	{
		613	ctx->cursp = 0;
		614
		615	PUSHMARK(SP);
		616	PUTBACK;
		617	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		618
		619	if (SvTRUE (ERRSV))
		620	croak (NULL);
		621	else
		622	croak ("FATAL: CCTXT coroutine returned!");
		623	}
		624	else
		625	{
		626	UNOP myop;
		627
		628	PL_op = (OP *)&myop;
		629
		630	Zero(&myop, 1, UNOP);
		631	myop.op_next = Nullop;
		632	myop.op_flags = OPf_WANT_VOID;
		633
		634	PUSHMARK(SP);
		635	XPUSHs (sub_init);
		636	/*
		637	* the next line is slightly wrong, as PL_op->op_next
		638	* is actually being executed so we skip the first op.
		639	* that doesn't matter, though, since it is only
		640	* pp_nextstate and we never return...
		641	* ah yes, and I don't care anyways ;)
		642	*/
		643	PUTBACK;
		644	PL_op = pp_entersub();
		645	SPAGAIN;
		646
		647	ENTER; /* necessary e.g. for dounwind */
		648	}
		649	}
		650
		651	static void
		652	continue_coro (void *arg)
		653	{
		654	/*
		655	* this is a _very_ stripped down perl interpreter ;)
		656	*/
		657	Coro__State ctx = (Coro__State)arg;
		658	JMPENV coro_start_env;
		659
		660	/* same as JMPENV_BOOTSTRAP */
		661	Zero(&coro_start_env, 1, JMPENV);
		662	coro_start_env.je_ret = -1;
		663	coro_start_env.je_mustcatch = TRUE;
		664	PL_top_env = &coro_start_env;
		665
		666	ctx->cursp = 0;
		667	PL_op = PL_op->op_next;
		668	CALLRUNOPS(aTHX);
		669
		670	abort ();
		671	}
		672
		673	STATIC void
		674	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		675	{
		676	dSTACKLEVEL;
		677	static struct coro *xnext;
		678
		679	if (prev != next)
		680	{
		681	xnext = next;
		682
		683	if (next->mainstack)
		684	{
		685	SAVE (prev, flags);
		686	LOAD (next);
		687
		688	/* mark this state as in-use */
		689	next->mainstack = 0;
		690	next->tmps_ix = -2;
		691
		692	/* stacklevel changed? if yes, grab the stack for us! */
		693	if (flags & TRANSFER_SAVE_CCTXT)
		694	{
		695	if (!prev->stack)
		696	allocate_stack (prev, 0);
		697	else if (prev->cursp != stacklevel
		698	&& prev->stack->usecnt > 1)
		699	{
		700	prev->gencnt = ++prev->stack->gencnt;
		701	prev->stack->usecnt = 1;
		702	}
		703
		704	/* has our stack been invalidated? */
		705	if (next->stack && next->stack->gencnt != next->gencnt)
		706	{
		707	deallocate_stack (next);
		708	allocate_stack (next, 1);
		709	coro_create (&(next->stack->cctx),
		710	continue_coro, (void *)next,
		711	next->stack->sptr, labs (next->stack->ssize));
		712	}
		713
		714	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		715	/* don't add any code here */
		716	}
		717
		718	}
		719	else if (next->tmps_ix == -2)
		720	croak ("tried to transfer to running coroutine");
		721	else
		722	{
		723	SAVE (prev, -1); /* first get rid of the old state */
		724
		725	if (flags & TRANSFER_SAVE_CCTXT)
		726	{
		727	if (!prev->stack)
		728	allocate_stack (prev, 0);
		729
		730	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		731	{
		732	setup_coro (next);
		733
		734	prev->stack->refcnt++;
		735	prev->stack->usecnt++;
		736	next->stack = prev->stack;
		737	next->gencnt = prev->gencnt;
		738	}
		739	else
		740	{
		741	allocate_stack (next, 1);
		742	coro_create (&(next->stack->cctx),
		743	setup_coro, (void *)next,
		744	next->stack->sptr, labs (next->stack->ssize));
		745	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		746	/* don't add any code here */
		747	}
		748	}
		749	else
		750	setup_coro (next);
		751	}
		752
		753	/*
		754	* xnext is now either prev or next, depending on wether
		755	* we switched the c stack or not. that's why i use a global
		756	* variable, that should become thread-specific at one point.
		757	*/
		758	xnext->cursp = stacklevel;
		759	}
		760
		761	if (coro_mortal)
		762	{
		763	SvREFCNT_dec (coro_mortal);
		764	coro_mortal = 0;
		765	}
		766	}
		767
		768	#define SV_CORO(sv,func) \
		769	do { \
		770	if (SvROK (sv)) \
		771	sv = SvRV (sv); \
		772	\
		773	if (SvTYPE(sv) == SVt_PVHV) \
		774	{ \
		775	HE he = hv_fetch_ent((HV )sv, ucoro_state_sv, 0, ucoro_state_hash); \
		776	\
		777	if (!he) \
		778	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
		779	\
		780	(sv) = SvRV (HeVAL(he)); \
		781	} \
		782	\
		783	/* must also be changed inside Coro::Cont::yield */ \
		784	if (!SvOBJECT(sv) \|\| SvSTASH(sv) != coro_state_stash) \
		785	croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
		786	\
		787	} while(0)
		788
		789	#define SvSTATE(sv) (struct coro *)SvIV (sv)
		790
		791	static void
		792	api_transfer(pTHX_ SV prev, SV next, int flags)
		793	{
		794	SV_CORO (prev, "Coro::transfer");
		795	SV_CORO (next, "Coro::transfer");
		796
		797	transfer(aTHX_ SvSTATE(prev), SvSTATE(next), flags);
		798	}
		799
		800	/ Coro ******************************************************************/
		801
		802	#define PRIO_MAX 3
		803	#define PRIO_HIGH 1
		804	#define PRIO_NORMAL 0
		805	#define PRIO_LOW -1
		806	#define PRIO_IDLE -3
		807	#define PRIO_MIN -4
		808
		809	/* for Coro.pm */
		810	static GV coro_current, coro_idle;
		811	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		812	static int coro_nready;
		813
		814	static void
		815	coro_enq (SV *sv)
		816	{
		817	if (SvTYPE (sv) == SVt_PVHV)
		818	{
		819	SV *xprio = hv_fetch ((HV )sv, "prio", 4, 0);
		820	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		821
		822	prio = prio > PRIO_MAX ? PRIO_MAX
		823	: prio < PRIO_MIN ? PRIO_MIN
		824	: prio;
		825
		826	av_push (coro_ready [prio - PRIO_MIN], sv);
		827	coro_nready++;
		828
		829	return;
		830	}
		831
		832	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		833	}
		834
		835	static SV *
		836	coro_deq (int min_prio)
		837	{
		838	int prio = PRIO_MAX - PRIO_MIN;
		839
		840	min_prio -= PRIO_MIN;
		841	if (min_prio < 0)
		842	min_prio = 0;
		843
		844	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		845	if (av_len (coro_ready[prio]) >= 0)
		846	{
		847	coro_nready--;
		848	return av_shift (coro_ready[prio]);
		849	}
		850
		851	return 0;
		852	}
		853
		854	static void
		855	api_ready (SV *coro)
		856	{
		857	if (SvROK (coro))
		858	coro = SvRV (coro);
		859
		860	coro_enq (SvREFCNT_inc (coro));
		861	}
		862
		863	static void
		864	api_schedule (void)
		865	{
		866	SV prev, next;
		867
		868	prev = SvRV (GvSV (coro_current));
		869	next = coro_deq (PRIO_MIN);
		870
		871	if (!next)
		872	next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
		873
		874	/* free this only after the transfer */
		875	coro_mortal = prev;
		876	SV_CORO (prev, "Coro::schedule");
		877
		878	SvRV (GvSV (coro_current)) = next;
		879
		880	SV_CORO (next, "Coro::schedule");
		881
		882	transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		883	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		884	}
		885
		886	static void
		887	api_cede (void)
		888	{
		889	coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
		890
		891	api_schedule ();
		892	}
385		893
386	MODULE = Coro::State PACKAGE = Coro::State	894	MODULE = Coro::State PACKAGE = Coro::State
387		895
388	PROTOTYPES: ENABLE	896	PROTOTYPES: ENABLE
389		897
390	BOOT:	898	BOOT:
		899	{ /* {} necessary for stoopid perl-5.6.x */
		900	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		901	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		902	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		903
		904	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		905	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		906	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		907	newCONSTSUB (coro_state_stash, "SAVE_CURPM", newSViv (TRANSFER_SAVE_CURPM));
		908	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		909
391	if (!padlist_cache)	910	if (!padlist_cache)
392	padlist_cache = newHV ();	911	padlist_cache = newHV ();
		912
		913	main_mainstack = PL_mainstack;
		914
		915	coroapi.ver = CORO_API_VERSION;
		916	coroapi.transfer = api_transfer;
		917	}
393		918
394	Coro::State	919	Coro::State
395	_newprocess(args)	920	_newprocess(args)
396	SV * args	921	SV * args
397	PROTOTYPE: $	922	PROTOTYPE: $
398	CODE:	923	CODE:
399	Coro__State coro;	924	Coro__State coro;
400		925
401	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	926	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");	927	croak ("Coro::State::_newprocess expects an arrayref");
403		928
404	New (0, coro, 1, struct coro);	929	New (0, coro, 1, struct coro);
405		930
		931	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406	coro->mainstack = 0; /* actual work is done inside transfer */	932	coro->mainstack = 0; /* actual work is done inside transfer */
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	933	coro->stack = 0;
408		934
409	RETVAL = coro;	935	RETVAL = coro;
410	OUTPUT:	936	OUTPUT:
411	RETVAL	937	RETVAL
412		938
413	void	939	void
414	transfer(prev,next)	940	transfer(prev, next, flags)
415	Coro::State_or_hashref prev	941	SV *prev
416	Coro::State_or_hashref next	942	SV *next
		943	int flags
		944	PROTOTYPE: @
417	CODE:	945	CODE:
418
419	if (prev != next)
420	{
421	/*
422	* this could be done in newprocess which would lead to
423	* extremely elegant and fast (just SAVE/LOAD)
424	* code here, but lazy allocation of stacks has also
425	* some virtues and the overhead of the if() is nil.
426	*/
427	if (next->mainstack)
428	{
429	SAVE (prev);
430	LOAD (next);
431	/* mark this state as in-use */
432	next->mainstack = 0;
433	next->tmps_ix = -2;
434	}
435	else if (next->tmps_ix == -2)
436	{
437	croak ("tried to transfer to running coroutine");
438	}
439	else
440	{
441	SAVE (prev);
442
443	/*
444	* emulate part of the perl startup here.
445	*/
446	UNOP myop;
447
448	init_stacks (); /* from perl.c */
449	PL_op = (OP *)&myop;
450	/PL_curcop = 0;/
451	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
452
453	SPAGAIN;
454	Zero(&myop, 1, UNOP);
455	myop.op_next = Nullop;
456	myop.op_flags = OPf_WANT_VOID;
457
458	PUSHMARK(SP);
459	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	PUTBACK;	946	PUTBACK;
461	/*	947	SV_CORO (next, "Coro::transfer");
462	* the next line is slightly wrong, as PL_op->op_next	948	SV_CORO (prev, "Coro::transfer");
463	* is actually being executed so we skip the first op.	949	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
464	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...
466	*/
467	PL_op = Perl_pp_entersub(aTHX);
468	SPAGAIN;	950	SPAGAIN;
469
470	ENTER;
471	}
472	}
473		951
474	void	952	void
475	DESTROY(coro)	953	DESTROY(coro)
476	Coro::State coro	954	Coro::State coro
477	CODE:	955	CODE:
478		956
479	if (coro->mainstack)	957	if (coro->mainstack && coro->mainstack != main_mainstack)
480	{	958	{
481	struct coro temp;	959	struct coro temp;
482		960
		961	PUTBACK;
483	SAVE(aTHX_ (&temp));	962	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
484	LOAD(aTHX_ coro);	963	LOAD(aTHX_ coro);
		964	SPAGAIN;
485		965
486	destroy_stacks ();	966	destroy_stacks (aTHX);
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488		967
489	LOAD((&temp));	968	LOAD((&temp)); /* this will get rid of defsv etc.. */
		969	SPAGAIN;
		970
		971	coro->mainstack = 0;
490	}	972	}
491		973
492	SvREFCNT_dec (coro->args);	974	deallocate_stack (coro);
		975
493	Safefree (coro);	976	Safefree (coro);
494		977
		978	void
		979	flush()
		980	CODE:
		981	#ifdef MAY_FLUSH
		982	flush_padlist_cache ();
		983	#endif
495		984
		985	void
		986	_exit(code)
		987	int code
		988	PROTOTYPE: $
		989	CODE:
		990	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		991	_exit (code);
		992	#else
		993	signal (SIGTERM, SIG_DFL);
		994	raise (SIGTERM);
		995	exit (code);
		996	#endif
		997
		998	MODULE = Coro::State PACKAGE = Coro::Cont
		999
		1000	# this is slightly dirty (should expose a c-level api)
		1001
		1002	void
		1003	yield(...)
		1004	PROTOTYPE: @
		1005	CODE:
		1006	static SV *returnstk;
		1007	SV *sv;
		1008	AV *defav = GvAV (PL_defgv);
		1009	struct coro prev, next;
		1010
		1011	if (!returnstk)
		1012	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		1013
		1014	/* set up @_ -- ugly */
		1015	av_clear (defav);
		1016	av_fill (defav, items - 1);
		1017	while (items--)
		1018	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1019
		1020	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		1021	sv = av_pop ((AV *)SvRV (returnstk));
		1022	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		1023	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		1024	SvREFCNT_dec (sv);
		1025
		1026	transfer(aTHX_ prev, next, 0);
		1027
		1028	MODULE = Coro::State PACKAGE = Coro
		1029
		1030	# this is slightly dirty (should expose a c-level api)
		1031
		1032	BOOT:
		1033	{
		1034	int i;
		1035	HV *stash = gv_stashpv ("Coro", TRUE);
		1036
		1037	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1038	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1039	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1040	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1041	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1042	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1043
		1044	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1045	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1046
		1047	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1048	coro_ready[i] = newAV ();
		1049
		1050	{
		1051	SV *sv = perl_get_sv("Coro::API", 1);
		1052
		1053	coroapi.schedule = api_schedule;
		1054	coroapi.cede = api_cede;
		1055	coroapi.ready = api_ready;
		1056	coroapi.nready = &coro_nready;
		1057	coroapi.current = coro_current;
		1058
		1059	GCoroAPI = &coroapi;
		1060	sv_setiv(sv, (IV)&coroapi);
		1061	SvREADONLY_on(sv);
		1062	}
		1063	}
		1064
		1065	void
		1066	ready(self)
		1067	SV * self
		1068	PROTOTYPE: $
		1069	CODE:
		1070	api_ready (self);
		1071
		1072	int
		1073	nready(...)
		1074	PROTOTYPE:
		1075	CODE:
		1076	RETVAL = coro_nready;
		1077	OUTPUT:
		1078	RETVAL
		1079
		1080	void
		1081	schedule(...)
		1082	PROTOTYPE:
		1083	CODE:
		1084	api_schedule ();
		1085
		1086	void
		1087	cede(...)
		1088	PROTOTYPE:
		1089	CODE:
		1090	api_cede ();
		1091

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.40 by root, Tue Nov 27 01:41:41 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.40 by root, Tue Nov 27 01:41:41 2001 UTC