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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.60 by root, Mon Aug 9 02:41:27 2004 UTC

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs. Revision 1.60 by root, Mon Aug 9 02:41:27 2004 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.3 by root, Tue Jul 17 00:24:15 2001 UTC vs.
Revision 1.60 by root, Mon Aug 9 02:41:27 2004 UTC