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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.47 by pcg, Sat Nov 15 03:53:10 2003 UTC

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.47 by pcg, Sat Nov 15 03:53:10 2003 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.47 by pcg, Sat Nov 15 03:53:10 2003 UTC