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

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.25 by root, Wed Aug 15 03:24:07 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.25 by root, Wed Aug 15 03:24:07 2001 UTC