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

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.49 by pcg, Sun Nov 23 03:34:13 2003 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.49 by pcg, Sun Nov 23 03:34:13 2003 UTC