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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 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(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	static void	447	/*
283	LOAD(pTHX_ Coro__State c)	448	* allocate various perl stacks. This is an exact copy
		449	* of perl.c:init_stacks, except that it uses less memory
		450	* on the assumption that coroutines do not usually need
		451	* a lot of stackspace.
		452	*/
		453	STATIC void
		454	coro_init_stacks (pTHX)
284	{	455	{
285	PL_dowarn = c->dowarn;	456	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	457	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	458	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	459	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	460
		461	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	462	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	463	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	464
293	PL_stack_base = c->stack_base;	465	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	466	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	467	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	468	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	469
298	PL_tmps_max = c->tmps_max;	470	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	471	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	472	PL_markstack_max = PL_markstack + 16;
302	PL_scopestack = c->scopestack;
303	PL_scopestack_ix = c->scopestack_ix;
304	PL_scopestack_max = c->scopestack_max;
305	PL_savestack = c->savestack;
306	PL_savestack_ix = c->savestack_ix;
307	PL_savestack_max = c->savestack_max;
308	PL_retstack = c->retstack;
309	PL_retstack_ix = c->retstack_ix;
310	PL_retstack_max = c->retstack_max;
311	PL_curcop = c->curcop;
312		473
313	{	474	SET_MARK_OFFSET;
314	dSP;
315	CV *cv;
316		475
317	/* now do the ugly restore mess */	476	New(54,PL_scopestack,16,I32);
318	while ((cv = (CV *)POPs))	477	PL_scopestack_ix = 0;
319	{	478	PL_scopestack_max = 16;
320	AV padlist = (AV )POPs;
321		479
322	put_padlist (cv);	480	New(54,PL_savestack,96,ANY);
323	CvPADLIST(cv) = padlist;	481	PL_savestack_ix = 0;
324	CvDEPTH(cv) = (I32)POPs;	482	PL_savestack_max = 96;
325		483
326	#ifdef USE_THREADS	484	New(54,PL_retstack,8,OP*);
327	CvOWNER(cv) = (struct perl_thread *)POPs;	485	PL_retstack_ix = 0;
328	error does not work either	486	PL_retstack_max = 8;
329	#endif
330	}
331
332	PUTBACK;
333	}
334	}	487	}
335		488
336	/* 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	*/
337	STATIC void	493	STATIC void
338	destroy_stacks(pTHX)	494	destroy_stacks(pTHX)
339	{	495	{
340	/* die does this while calling POPSTACK, but I just don't see why. */	496	if (!IN_DESTRUCT)
341	dounwind(-1);	497	{
342
343	/* is this ugly, I ask? */	498	/* is this ugly, I ask? */
344	while (PL_scopestack_ix)	499	while (PL_scopestack_ix)
345	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	}
346		506
347	while (PL_curstackinfo->si_next)	507	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;	508	PL_curstackinfo = PL_curstackinfo->si_next;
349		509
350	while (PL_curstackinfo)	510	while (PL_curstackinfo)
351	{	511	{
352	PERL_SI *p = PL_curstackinfo->si_prev;	512	PERL_SI *p = PL_curstackinfo->si_prev;
353		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);
354	SvREFCNT_dec(PL_curstackinfo->si_stack);	523	SvREFCNT_dec(PL_curstackinfo->si_stack);
		524	}
		525
355	Safefree(PL_curstackinfo->si_cxstack);	526	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);	527	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;	528	PL_curstackinfo = p;
358	}	529	}
359		530
360	if (PL_scopestack_ix != 0)
361	Perl_warner(aTHX_ WARN_INTERNAL,
362	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
363	(long)PL_scopestack_ix);
364	if (PL_savestack_ix != 0)
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced saves: %ld more saves than restores\n",
367	(long)PL_savestack_ix);
368	if (PL_tmps_floor != -1)
369	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
370	(long)PL_tmps_floor + 1);
371	/*
372	*/
373	Safefree(PL_tmps_stack);	531	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);	532	Safefree(PL_markstack);
375	Safefree(PL_scopestack);	533	Safefree(PL_scopestack);
376	Safefree(PL_savestack);	534	Safefree(PL_savestack);
377	Safefree(PL_retstack);	535	Safefree(PL_retstack);
378	}	536	}
379		537
380	#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	}
381		893
382	MODULE = Coro::State PACKAGE = Coro::State	894	MODULE = Coro::State PACKAGE = Coro::State
383		895
384	PROTOTYPES: ENABLE	896	PROTOTYPES: ENABLE
385		897
386	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
387	if (!padlist_cache)	910	if (!padlist_cache)
388	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	}
389		918
390	Coro::State	919	Coro::State
391	_newprocess(args)	920	_newprocess(args)
392	SV * args	921	SV * args
393	PROTOTYPE: $	922	PROTOTYPE: $
394	CODE:	923	CODE:
395	Coro__State coro;	924	Coro__State coro;
396		925
397	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	926	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");	927	croak ("Coro::State::_newprocess expects an arrayref");
399		928
400	New (0, coro, 1, struct coro);	929	New (0, coro, 1, struct coro);
401		930
		931	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
402	coro->mainstack = 0; /* actual work is done inside transfer */	932	coro->mainstack = 0; /* actual work is done inside transfer */
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	933	coro->stack = 0;
404		934
405	RETVAL = coro;	935	RETVAL = coro;
406	OUTPUT:	936	OUTPUT:
407	RETVAL	937	RETVAL
408		938
409	void	939	void
410	transfer(prev,next)	940	transfer(prev, next, flags)
411	Coro::State_or_hashref prev	941	SV *prev
412	Coro::State_or_hashref next	942	SV *next
		943	int flags
		944	PROTOTYPE: @
413	CODE:	945	CODE:
414
415	if (prev != next)
416	{
417	PUTBACK;	946	PUTBACK;
418	SAVE (aTHX_ prev);	947	SV_CORO (next, "Coro::transfer");
419		948	SV_CORO (prev, "Coro::transfer");
420	/*	949	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;	950	SPAGAIN;
431	}
432	else
433	{
434	/*
435	* emulate part of the perl startup here.
436	*/
437	UNOP myop;
438
439	init_stacks (); /* from perl.c */
440	PL_op = (OP *)&myop;
441	/PL_curcop = 0;/
442	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
443
444	SPAGAIN;
445	Zero(&myop, 1, UNOP);
446	myop.op_next = Nullop;
447	myop.op_flags = OPf_WANT_VOID;
448
449	PUSHMARK(SP);
450	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451	PUTBACK;
452	/*
453	* the next line is slightly wrong, as PL_op->op_next
454	* is actually being executed so we skip the first op.
455	* that doesn't matter, though, since it is only
456	* pp_nextstate and we never return...
457	*/
458	PL_op = Perl_pp_entersub(aTHX);
459	SPAGAIN;
460
461	ENTER;
462	}
463	}
464		951
465	void	952	void
466	DESTROY(coro)	953	DESTROY(coro)
467	Coro::State coro	954	Coro::State coro
468	CODE:	955	CODE:
469		956
470	if (coro->mainstack)	957	if (coro->mainstack && coro->mainstack != main_mainstack)
471	{	958	{
472	struct coro temp;	959	struct coro temp;
473		960
474	PUTBACK;	961	PUTBACK;
475	SAVE(aTHX_ (&temp));	962	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
476	LOAD(aTHX_ coro);	963	LOAD(aTHX_ coro);
477
478	destroy_stacks ();
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;	964	SPAGAIN;
		965
		966	destroy_stacks (aTHX);
		967
		968	LOAD((&temp)); /* this will get rid of defsv etc.. */
		969	SPAGAIN;
		970
		971	coro->mainstack = 0;
483	}	972	}
484		973
485	SvREFCNT_dec (coro->args);	974	deallocate_stack (coro);
		975
486	Safefree (coro);	976	Safefree (coro);
487		977
		978	void
		979	flush()
		980	CODE:
		981	#ifdef MAY_FLUSH
		982	flush_padlist_cache ();
		983	#endif
488		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.5 by root, Tue Jul 17 02:55:29 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.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.40 by root, Tue Nov 27 01:41:41 2001 UTC