[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.46 by pcg, Wed Nov 5 20:02:46 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); SE
		309
188	static void	310	static void
189	save_state(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	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	477	/*
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	478	* allocate various perl stacks. This is an exact copy
284		479	* of perl.c:init_stacks, except that it uses less memory
285	static void	480	* on the assumption that coroutines do not usually need
286	load_state(pTHX_ Coro__State c)	481	* a lot of stackspace.
		482	*/
		483	STATIC void
		484	coro_init_stacks (pTHX)
287	{	485	{
288	PL_dowarn = c->dowarn;	486	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
289	GvAV (PL_defgv) = c->defav;	487	PL_curstackinfo->si_type = PERLSI_MAIN;
290	PL_curstackinfo = c->curstackinfo;	488	PL_curstack = PL_curstackinfo->si_stack;
291	PL_curstack = c->curstack;	489	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
292	PL_mainstack = c->mainstack;	490
		491	PL_stack_base = AvARRAY(PL_curstack);
293	PL_stack_sp = c->stack_sp;	492	PL_stack_sp = PL_stack_base;
294	PL_op = c->op;	493	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295	PL_curpad = c->curpad;	494
296	PL_stack_base = c->stack_base;	495	New(50,PL_tmps_stack,96,SV*);
297	PL_stack_max = c->stack_max;	496	PL_tmps_floor = -1;
298	PL_tmps_stack = c->tmps_stack;	497	PL_tmps_ix = -1;
299	PL_tmps_floor = c->tmps_floor;	498	PL_tmps_max = 96;
300	PL_tmps_ix = c->tmps_ix;	499
301	PL_tmps_max = c->tmps_max;	500	New(54,PL_markstack,16,I32);
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;	501	PL_markstack_ptr = PL_markstack;
304	PL_markstack_max = c->markstack_max;	502	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		503
316	{	504	#ifdef SET_MARK_OFFSET
317	dSP;	505	SET_MARK_OFFSET;
318	CV *cv;
319
320	/* now do the ugly restore mess */
321	while ((cv = (CV *)POPs))
322	{
323	AV padlist = (AV )POPs;
324
325	put_padlist (cv);
326	CvPADLIST(cv) = padlist;
327	CvDEPTH(cv) = (I32)POPs;
328
329	#ifdef USE_THREADS
330	CvOWNER(cv) = (struct perl_thread *)POPs;
331	error does not work either
332	#endif	506	#endif
333	}
334		507
335	PUTBACK;	508	New(54,PL_scopestack,16,I32);
336	}	509	PL_scopestack_ix = 0;
337	}	510	PL_scopestack_max = 16;
338		511
339	/* 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	*/
340	STATIC void	525	STATIC void
341	destroy_stacks(pTHX)	526	destroy_stacks(pTHX)
342	{	527	{
343	/* die does this while calling POPSTACK, but I just don't see why. */	528	if (!IN_DESTRUCT)
344	/* OTOH, die does not have a memleak, but we do... */	529	{
345	dounwind(-1);
346
347	/* is this ugly, I ask? */	530	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)	531	while (PL_scopestack_ix)
349	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	}
350		538
351	while (PL_curstackinfo->si_next)	539	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;	540	PL_curstackinfo = PL_curstackinfo->si_next;
353		541
354	while (PL_curstackinfo)	542	while (PL_curstackinfo)
355	{	543	{
356	PERL_SI *p = PL_curstackinfo->si_prev;	544	PERL_SI *p = PL_curstackinfo->si_prev;
357		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);
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	555	SvREFCNT_dec(PL_curstackinfo->si_stack);
		556	}
		557
359	Safefree(PL_curstackinfo->si_cxstack);	558	Safefree(PL_curstackinfo->si_cxstack);
360	Safefree(PL_curstackinfo);	559	Safefree(PL_curstackinfo);
361	PL_curstackinfo = p;	560	PL_curstackinfo = p;
362	}	561	}
363		562
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);	563	Safefree(PL_tmps_stack);
378	Safefree(PL_markstack);	564	Safefree(PL_markstack);
379	Safefree(PL_scopestack);	565	Safefree(PL_scopestack);
380	Safefree(PL_savestack);	566	Safefree(PL_savestack);
381	Safefree(PL_retstack);	567	Safefree(PL_retstack);
382	}	568	}
383		569
384	#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	#else
		615	Safefree (stack->sptr);
		616	#endif
		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;
		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	allocate_stack (next, 1);
		771	coro_create (&(next->stack->cctx),
		772	setup_coro, (void *)next,
		773	next->stack->sptr, labs (next->stack->ssize));
		774	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		775	/* don't add any code here */
		776	}
		777	}
		778	else
		779	setup_coro (next);
		780	}
		781
		782	/*
		783	* xnext is now either prev or next, depending on wether
		784	* we switched the c stack or not. that's why I use a global
		785	* variable, that should become thread-specific at one point.
		786	*/
		787	xnext->cursp = stacklevel;
		788	}
		789
		790	if (coro_mortal)
		791	{
		792	SvREFCNT_dec (coro_mortal);
		793	coro_mortal = 0;
		794	}
		795	}
		796
		797	#define SV_CORO(sv,func) \
		798	do { \
		799	if (SvROK (sv)) \
		800	sv = SvRV (sv); \
		801	\
		802	if (SvTYPE(sv) == SVt_PVHV) \
		803	{ \
		804	HE he = hv_fetch_ent((HV )sv, ucoro_state_sv, 0, ucoro_state_hash); \
		805	\
		806	if (!he) \
		807	croak ("%s() -- %s is a hashref but lacks the " UCORO_STATE " key", func, # sv); \
		808	\
		809	(sv) = SvRV (HeVAL(he)); \
		810	} \
		811	\
		812	/* must also be changed inside Coro::Cont::yield */ \
		813	if (!SvOBJECT(sv) \|\| SvSTASH(sv) != coro_state_stash) \
		814	croak ("%s() -- %s is not (and contains not) a Coro::State object", func, # sv); \
		815	\
		816	} while(0)
		817
		818	#define SvSTATE(sv) (struct coro *)SvIV (sv)
		819
		820	static void
		821	api_transfer(pTHX_ SV prev, SV next, int flags)
		822	{
		823	SV_CORO (prev, "Coro::transfer");
		824	SV_CORO (next, "Coro::transfer");
		825
		826	transfer(aTHX_ SvSTATE(prev), SvSTATE(next), flags);
		827	}
		828
		829	/ Coro ******************************************************************/
		830
		831	#define PRIO_MAX 3
		832	#define PRIO_HIGH 1
		833	#define PRIO_NORMAL 0
		834	#define PRIO_LOW -1
		835	#define PRIO_IDLE -3
		836	#define PRIO_MIN -4
		837
		838	/* for Coro.pm */
		839	static GV coro_current, coro_idle;
		840	static AV *coro_ready[PRIO_MAX-PRIO_MIN+1];
		841	static int coro_nready;
		842
		843	static void
		844	coro_enq (SV *sv)
		845	{
		846	if (SvTYPE (sv) == SVt_PVHV)
		847	{
		848	SV *xprio = hv_fetch ((HV )sv, "prio", 4, 0);
		849	int prio = xprio ? SvIV (*xprio) : PRIO_NORMAL;
		850
		851	prio = prio > PRIO_MAX ? PRIO_MAX
		852	: prio < PRIO_MIN ? PRIO_MIN
		853	: prio;
		854
		855	av_push (coro_ready [prio - PRIO_MIN], sv);
		856	coro_nready++;
		857
		858	return;
		859	}
		860
		861	croak ("Coro::ready tried to enqueue something that is not a coroutine");
		862	}
		863
		864	static SV *
		865	coro_deq (int min_prio)
		866	{
		867	int prio = PRIO_MAX - PRIO_MIN;
		868
		869	min_prio -= PRIO_MIN;
		870	if (min_prio < 0)
		871	min_prio = 0;
		872
		873	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= min_prio; )
		874	if (av_len (coro_ready[prio]) >= 0)
		875	{
		876	coro_nready--;
		877	return av_shift (coro_ready[prio]);
		878	}
		879
		880	return 0;
		881	}
		882
		883	static void
		884	api_ready (SV *coro)
		885	{
		886	if (SvROK (coro))
		887	coro = SvRV (coro);
		888
		889	coro_enq (SvREFCNT_inc (coro));
		890	}
		891
		892	static void
		893	api_schedule (void)
		894	{
		895	SV prev, next;
		896
		897	prev = SvRV (GvSV (coro_current));
		898	next = coro_deq (PRIO_MIN);
		899
		900	if (!next)
		901	next = SvREFCNT_inc (SvRV (GvSV (coro_idle)));
		902
		903	/* free this only after the transfer */
		904	coro_mortal = prev;
		905	SV_CORO (prev, "Coro::schedule");
		906
		907	SvRV (GvSV (coro_current)) = next;
		908
		909	SV_CORO (next, "Coro::schedule");
		910
		911	transfer (aTHX_ SvSTATE (prev), SvSTATE (next),
		912	TRANSFER_SAVE_ALL \| TRANSFER_LAZY_STACK);
		913	}
		914
		915	static void
		916	api_cede (void)
		917	{
		918	coro_enq (SvREFCNT_inc (SvRV (GvSV (coro_current))));
		919
		920	api_schedule ();
		921	}
385		922
386	MODULE = Coro::State PACKAGE = Coro::State	923	MODULE = Coro::State PACKAGE = Coro::State
387		924
388	PROTOTYPES: ENABLE	925	PROTOTYPES: ENABLE
389		926
390	BOOT:	927	BOOT:
		928	{ /* {} necessary for stoopid perl-5.6.x */
		929	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		930	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		931	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		932
		933	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		934	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		935	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		936	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		937
391	if (!padlist_cache)	938	if (!padlist_cache)
392	padlist_cache = newHV ();	939	padlist_cache = newHV ();
		940
		941	main_mainstack = PL_mainstack;
		942
		943	coroapi.ver = CORO_API_VERSION;
		944	coroapi.transfer = api_transfer;
		945	}
393		946
394	Coro::State	947	Coro::State
395	_newprocess(args)	948	_newprocess(args)
396	SV * args	949	SV * args
397	PROTOTYPE: $	950	PROTOTYPE: $
398	CODE:	951	CODE:
399	Coro__State coro;	952	Coro__State coro;
400		953
401	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	954	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");	955	croak ("Coro::State::_newprocess expects an arrayref");
403		956
404	New (0, coro, 1, struct coro);	957	New (0, coro, 1, struct coro);
405		958
		959	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
406	coro->mainstack = 0; /* actual work is done inside transfer */	960	coro->mainstack = 0; /* actual work is done inside transfer */
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	961	coro->stack = 0;
		962
		963	/* same as JMPENV_BOOTSTRAP */
		964	/* we might be able to recycle start_env, but safe is safe */
		965	Zero(&coro->start_env, 1, JMPENV);
		966	coro->start_env.je_ret = -1;
		967	coro->start_env.je_mustcatch = TRUE;
408		968
409	RETVAL = coro;	969	RETVAL = coro;
410	OUTPUT:	970	OUTPUT:
411	RETVAL	971	RETVAL
412		972
413	void	973	void
414	transfer(prev,next)	974	transfer(prev, next, flags)
415	Coro::State_or_hashref prev	975	SV *prev
416	Coro::State_or_hashref next	976	SV *next
		977	int flags
		978	PROTOTYPE: @
417	CODE:	979	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;	980	PUTBACK;
461	/*	981	SV_CORO (next, "Coro::transfer");
462	* the next line is slightly wrong, as PL_op->op_next	982	SV_CORO (prev, "Coro::transfer");
463	* is actually being executed so we skip the first op.	983	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
464	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...
466	*/
467	PL_op = Perl_pp_entersub(aTHX);
468	SPAGAIN;	984	SPAGAIN;
469
470	ENTER;
471	}
472	}
473		985
474	void	986	void
475	DESTROY(coro)	987	DESTROY(coro)
476	Coro::State coro	988	Coro::State coro
477	CODE:	989	CODE:
478		990
479	if (coro->mainstack)	991	if (coro->mainstack && coro->mainstack != main_mainstack)
480	{	992	{
481	struct coro temp;	993	struct coro temp;
482		994
		995	PUTBACK;
483	SAVE(aTHX_ (&temp));	996	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
484	LOAD(aTHX_ coro);	997	LOAD(aTHX_ coro);
		998	SPAGAIN;
485		999
486	destroy_stacks ();	1000	destroy_stacks (aTHX);
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
488		1001
489	LOAD((&temp));	1002	LOAD((&temp)); /* this will get rid of defsv etc.. */
		1003	SPAGAIN;
		1004
		1005	coro->mainstack = 0;
490	}	1006	}
491		1007
492	SvREFCNT_dec (coro->args);	1008	deallocate_stack (coro);
		1009
493	Safefree (coro);	1010	Safefree (coro);
494		1011
		1012	void
		1013	flush()
		1014	CODE:
		1015	#ifdef MAY_FLUSH
		1016	flush_padlist_cache ();
		1017	#endif
495		1018
		1019	void
		1020	_exit(code)
		1021	int code
		1022	PROTOTYPE: $
		1023	CODE:
		1024	#if defined(__GLIBC__) \|\| _POSIX_C_SOURCE
		1025	_exit (code);
		1026	#else
		1027	signal (SIGTERM, SIG_DFL);
		1028	raise (SIGTERM);
		1029	exit (code);
		1030	#endif
		1031
		1032	MODULE = Coro::State PACKAGE = Coro::Cont
		1033
		1034	# this is slightly dirty (should expose a c-level api)
		1035
		1036	void
		1037	yield(...)
		1038	PROTOTYPE: @
		1039	CODE:
		1040	static SV *returnstk;
		1041	SV *sv;
		1042	AV *defav = GvAV (PL_defgv);
		1043	struct coro prev, next;
		1044
		1045	if (!returnstk)
		1046	returnstk = SvRV ((SV *)get_sv ("Coro::Cont::return", FALSE));
		1047
		1048	/* set up @_ -- ugly */
		1049	av_clear (defav);
		1050	av_fill (defav, items - 1);
		1051	while (items--)
		1052	av_store (defav, items, SvREFCNT_inc (ST(items)));
		1053
		1054	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		1055	sv = av_pop ((AV *)SvRV (returnstk));
		1056	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		1057	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		1058	SvREFCNT_dec (sv);
		1059
		1060	transfer(aTHX_ prev, next, 0);
		1061
		1062	MODULE = Coro::State PACKAGE = Coro
		1063
		1064	# this is slightly dirty (should expose a c-level api)
		1065
		1066	BOOT:
		1067	{
		1068	int i;
		1069	HV *stash = gv_stashpv ("Coro", TRUE);
		1070
		1071	newCONSTSUB (stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1072	newCONSTSUB (stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1073	newCONSTSUB (stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1074	newCONSTSUB (stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1075	newCONSTSUB (stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1076	newCONSTSUB (stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1077
		1078	coro_current = gv_fetchpv ("Coro::current", TRUE, SVt_PV);
		1079	coro_idle = gv_fetchpv ("Coro::idle" , TRUE, SVt_PV);
		1080
		1081	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1082	coro_ready[i] = newAV ();
		1083
		1084	{
		1085	SV *sv = perl_get_sv("Coro::API", 1);
		1086
		1087	coroapi.schedule = api_schedule;
		1088	coroapi.cede = api_cede;
		1089	coroapi.ready = api_ready;
		1090	coroapi.nready = &coro_nready;
		1091	coroapi.current = coro_current;
		1092
		1093	GCoroAPI = &coroapi;
		1094	sv_setiv(sv, (IV)&coroapi);
		1095	SvREADONLY_on(sv);
		1096	}
		1097	}
		1098
		1099	void
		1100	ready(self)
		1101	SV * self
		1102	PROTOTYPE: $
		1103	CODE:
		1104	api_ready (self);
		1105
		1106	int
		1107	nready(...)
		1108	PROTOTYPE:
		1109	CODE:
		1110	RETVAL = coro_nready;
		1111	OUTPUT:
		1112	RETVAL
		1113
		1114	void
		1115	schedule(...)
		1116	PROTOTYPE:
		1117	CODE:
		1118	api_schedule ();
		1119
		1120	void
		1121	cede(...)
		1122	PROTOTYPE:
		1123	CODE:
		1124	api_cede ();
		1125

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs. Revision 1.46 by pcg, Wed Nov 5 20:02:46 2003 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.46 by pcg, Wed Nov 5 20:02:46 2003 UTC