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

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

…		…
1	#include "EXTERN.h"	1	#include "EXTERN.h"
2	#include "perl.h"	2	#include "perl.h"
3	#include "XSUB.h"	3	#include "XSUB.h"
4		4
5	#if 0	5	#include "patchlevel.h"
6	# define CHK(x) (void *)0	6
7	#else	7	#if PATCHLEVEL < 6
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	8	# ifndef PL_ppaddr
		9	# define PL_ppaddr ppaddr
9	#endif	10	# endif
		11	# ifndef call_sv
		12	# define call_sv perl_call_sv
		13	# endif
		14	# ifndef get_sv
		15	# define get_sv perl_get_sv
		16	# endif
		17	# ifndef get_cv
		18	# define get_cv perl_get_cv
		19	# endif
		20	# ifndef IS_PADGV
		21	# define IS_PADGV(v) 0
		22	# endif
		23	# ifndef IS_PADCONST
		24	# define IS_PADCONST(v) 0
		25	# endif
		26	#endif
		27
		28	#include "libcoro/coro.c"
		29
		30	#include <signal.h>
		31
		32	#ifdef HAVE_MMAP
		33	# include <unistd.h>
		34	# include <sys/mman.h>
		35	# ifndef MAP_ANONYMOUS
		36	# ifdef MAP_ANON
		37	# define MAP_ANONYMOUS MAP_ANON
		38	# else
		39	# undef HAVE_MMAP
		40	# endif
		41	# endif
		42	#endif
		43
		44	#define MAY_FLUSH /* increases codesize and is rarely used */
		45
		46	#define SUB_INIT "Coro::State::initialize"
		47	#define UCORO_STATE "_coro_state"
		48
		49	/* The next macro should declare a variable stacklevel that contains and approximation
		50	* to the current C stack pointer. Its property is that it changes with each call
		51	* and should be unique. */
		52	#define dSTACKLEVEL void *stacklevel = &stacklevel
		53
		54	#define IN_DESTRUCT (PL_main_cv == Nullcv)
		55
		56	#define labs(l) ((l) >= 0 ? (l) : -(l))
		57
		58	#include "CoroAPI.h"
		59
		60	static struct CoroAPI coroapi;
		61
		62	/* this is actually not only the c stack but also c registers etc... */
		63	typedef struct {
		64	int refcnt; /* pointer reference counter */
		65	int usecnt; /* shared by how many coroutines */
		66	int gencnt; /* generation counter */
		67
		68	coro_context cctx;
		69
		70	void *sptr;
		71	long ssize; /* positive == mmap, otherwise malloc */
		72	} coro_stack;
10		73
11	struct coro {	74	struct coro {
		75	/* the top-level JMPENV for each coroutine, needed to catch dies. */
		76	JMPENV start_env;
		77
		78	/* the optional C context */
		79	coro_stack *stack;
		80	void *cursp;
		81	int gencnt;
		82
		83	/* optionally saved, might be zero */
		84	AV *defav;
		85	SV *defsv;
		86	SV *errsv;
		87
		88	/* saved global state not related to stacks */
12	U8 dowarn;	89	U8 dowarn;
13	AV *defav;	90	I32 in_eval;
14		91
		92	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	93	PERL_SI *curstackinfo;
16	AV *curstack;	94	AV *curstack;
17	AV *mainstack;	95	AV *mainstack;
18	SV **stack_sp;	96	SV **stack_sp;
19	OP *op;	97	OP *op;
20	SV **curpad;	98	SV **curpad;
		99	AV *comppad;
21	SV **stack_base;	100	SV **stack_base;
22	SV **stack_max;	101	SV **stack_max;
23	SV **tmps_stack;	102	SV **tmps_stack;
24	I32 tmps_floor;	103	I32 tmps_floor;
25	I32 tmps_ix;	104	I32 tmps_ix;
35	I32 savestack_max;	114	I32 savestack_max;
36	OP **retstack;	115	OP **retstack;
37	I32 retstack_ix;	116	I32 retstack_ix;
38	I32 retstack_max;	117	I32 retstack_max;
39	COP *curcop;	118	COP *curcop;
		119	JMPENV *top_env;
40		120
		121	/* data associated with this coroutine (initial args) */
41	AV *args;	122	AV *args;
42	};	123	};
43		124
44	typedef struct coro *Coro__State;	125	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	126	typedef struct coro *Coro__State_or_hashref;
46		127
		128	static AV main_mainstack; / used to differentiate between $main and others */
		129	static HV *coro_state_stash;
		130	static SV *ucoro_state_sv;
		131	static U32 ucoro_state_hash;
47	static HV *padlist_cache;	132	static HV *padlist_cache;
		133	static SV coro_mortal; / will be freed after next transfer */
48		134
49	/* mostly copied from op.c:cv_clone2 */	135	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *	136	STATIC AV *
51	clone_padlist (AV *protopadlist)	137	clone_padlist (AV *protopadlist)
52	{	138	{
…		…
115	SvPADTMP_on (sv);	201	SvPADTMP_on (sv);
116	npad[ix] = sv;	202	npad[ix] = sv;
117	}	203	}
118	}	204	}
119		205
120	#if 0 /* NONOTUNDERSTOOD */	206	#if 0 /* return -ENOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */	207	/* Now that vars are all in place, clone nested closures. */
122		208
123	for (ix = fpad; ix > 0; ix--) {	209	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	210	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv	211	if (namesv
…		…
138	#endif	224	#endif
139		225
140	return newpadlist;	226	return newpadlist;
141	}	227	}
142		228
143	STATIC AV *	229	#ifdef MAY_FLUSH
		230	STATIC void
144	free_padlist (AV *padlist)	231	free_padlist (AV *padlist)
145	{	232	{
146	/* may be during global destruction */	233	/* may be during global destruction */
147	if (SvREFCNT(padlist))	234	if (SvREFCNT(padlist))
148	{	235	{
…		…
156	}	243	}
157		244
158	SvREFCNT_dec((SV*)padlist);	245	SvREFCNT_dec((SV*)padlist);
159	}	246	}
160	}	247	}
		248	#endif
161		249
162	/* the next tow functions merely cache the padlists */	250	/* the next two functions merely cache the padlists */
163	STATIC void	251	STATIC void
164	get_padlist (CV *cv)	252	get_padlist (CV *cv)
165	{	253	{
166	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);	254	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
167		255
…		…
183	}	271	}
184		272
185	av_push ((AV )he, (SV *)CvPADLIST (cv));	273	av_push ((AV )he, (SV *)CvPADLIST (cv));
186	}	274	}
187		275
		276	#ifdef MAY_FLUSH
		277	STATIC void
		278	flush_padlist_cache ()
		279	{
		280	HV *hv = padlist_cache;
		281	padlist_cache = newHV ();
		282
		283	if (hv_iterinit (hv))
		284	{
		285	HE *he;
		286	AV *padlist;
		287
		288	while (!!(he = hv_iternext (hv)))
		289	{
		290	AV av = (AV )HeVAL(he);
		291
		292	/* casting is fun. */
		293	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
		294	free_padlist (padlist);
		295	}
		296	}
		297
		298	SvREFCNT_dec (hv);
		299	}
		300	#endif
		301
		302	#define SB do {
		303	#define SE } while (0)
		304
		305	#define LOAD(state) load_state(aTHX_ (state));
		306	#define SAVE(state,flags) save_state(aTHX_ (state),(flags));
		307
		308	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); (val) = 0; SE
		309
188	static void	310	static void
189	SAVE(pTHX_ Coro__State c)	311	load_state(pTHX_ Coro__State c)
		312	{
		313	PL_dowarn = c->dowarn;
		314	PL_in_eval = c->in_eval;
		315
		316	PL_curstackinfo = c->curstackinfo;
		317	PL_curstack = c->curstack;
		318	PL_mainstack = c->mainstack;
		319	PL_stack_sp = c->stack_sp;
		320	PL_op = c->op;
		321	PL_curpad = c->curpad;
		322	PL_comppad = c->comppad;
		323	PL_stack_base = c->stack_base;
		324	PL_stack_max = c->stack_max;
		325	PL_tmps_stack = c->tmps_stack;
		326	PL_tmps_floor = c->tmps_floor;
		327	PL_tmps_ix = c->tmps_ix;
		328	PL_tmps_max = c->tmps_max;
		329	PL_markstack = c->markstack;
		330	PL_markstack_ptr = c->markstack_ptr;
		331	PL_markstack_max = c->markstack_max;
		332	PL_scopestack = c->scopestack;
		333	PL_scopestack_ix = c->scopestack_ix;
		334	PL_scopestack_max = c->scopestack_max;
		335	PL_savestack = c->savestack;
		336	PL_savestack_ix = c->savestack_ix;
		337	PL_savestack_max = c->savestack_max;
		338	PL_retstack = c->retstack;
		339	PL_retstack_ix = c->retstack_ix;
		340	PL_retstack_max = c->retstack_max;
		341	PL_curcop = c->curcop;
		342	PL_top_env = c->top_env;
		343
		344	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		345	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		346	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		347
		348	{
		349	dSP;
		350	CV *cv;
		351
		352	/* now do the ugly restore mess */
		353	while ((cv = (CV *)POPs))
		354	{
		355	AV padlist = (AV )POPs;
		356
		357	if (padlist)
		358	{
		359	put_padlist (cv); /* mark this padlist as available */
		360	CvPADLIST(cv) = padlist;
		361	#ifdef USE_THREADS
		362	/CvOWNER(cv) = (struct perl_thread )POPs;*/
		363	#endif
		364	}
		365
		366	++CvDEPTH(cv);
		367	}
		368
		369	PUTBACK;
		370	}
		371	}
		372
		373	static void
		374	save_state(pTHX_ Coro__State c, int flags)
190	{	375	{
191	{	376	{
192	dSP;	377	dSP;
193	I32 cxix = cxstack_ix;	378	I32 cxix = cxstack_ix;
		379	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	380	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		381
197	/*	382	/*
198	* the worst thing you can imagine happens first - we have to save	383	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	384	* (and reinitialize) all cv's in the whole callchain :(
200	*/	385	*/
…		…
211	{	396	{
212	CV *cv = cx->blk_sub.cv;	397	CV *cv = cx->blk_sub.cv;
213	if (CvDEPTH(cv))	398	if (CvDEPTH(cv))
214	{	399	{
215	#ifdef USE_THREADS	400	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));	401	/XPUSHs ((SV )CvOWNER(cv));*/
		402	/CvOWNER(cv) = 0;/
		403	/error must unlock this cv etc.. etc.../
217	#endif	404	#endif
218	EXTEND (SP, 3);	405	EXTEND (SP, CvDEPTH(cv)*2);
		406
		407	while (--CvDEPTH(cv))
		408	{
		409	/* this tells the restore code to increment CvDEPTH */
		410	PUSHs (Nullsv);
219	PUSHs ((SV *)CvDEPTH(cv));	411	PUSHs ((SV *)cv);
		412	}
		413
220	PUSHs ((SV *)CvPADLIST(cv));	414	PUSHs ((SV *)CvPADLIST(cv));
221	PUSHs ((SV *)cv);	415	PUSHs ((SV *)cv);
222		416
223	get_padlist (cv);	417	get_padlist (cv); /* this is a monster */
224
225	CvDEPTH(cv) = 0;
226	#ifdef USE_THREADS
227	CvOWNER(cv) = 0;
228	error must unlock this cv etc.. etc...
229	if you are here wondering about this error message then
230	the reason is that it will not work as advertised yet
231	#endif
232	}	418	}
233	}	419	}
		420	#ifdef CXt_FORMAT
234	else if (CxTYPE(cx) == CXt_FORMAT)	421	else if (CxTYPE(cx) == CXt_FORMAT)
235	{	422	{
236	/* I never used formats, so how should I know how these are implemented? */	423	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */	424	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	425	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}	426	}
		427	#endif
240	}	428	}
241		429
242	if (top_si->si_type == PERLSI_MAIN)	430	if (top_si->si_type == PERLSI_MAIN)
243	break;	431	break;
244		432
…		…
248	}	436	}
249		437
250	PUTBACK;	438	PUTBACK;
251	}	439	}
252		440
		441	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		442	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		443	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		444
253	c->dowarn = PL_dowarn;	445	c->dowarn = PL_dowarn;
254	c->defav = GvAV (PL_defgv);	446	c->in_eval = PL_in_eval;
		447
255	c->curstackinfo = PL_curstackinfo;	448	c->curstackinfo = PL_curstackinfo;
256	c->curstack = PL_curstack;	449	c->curstack = PL_curstack;
257	c->mainstack = PL_mainstack;	450	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;	451	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;	452	c->op = PL_op;
260	c->curpad = PL_curpad;	453	c->curpad = PL_curpad;
		454	c->comppad = PL_comppad;
261	c->stack_base = PL_stack_base;	455	c->stack_base = PL_stack_base;
262	c->stack_max = PL_stack_max;	456	c->stack_max = PL_stack_max;
263	c->tmps_stack = PL_tmps_stack;	457	c->tmps_stack = PL_tmps_stack;
264	c->tmps_floor = PL_tmps_floor;	458	c->tmps_floor = PL_tmps_floor;
265	c->tmps_ix = PL_tmps_ix;	459	c->tmps_ix = PL_tmps_ix;
…		…
275	c->savestack_max = PL_savestack_max;	469	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;	470	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;	471	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;	472	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;	473	c->curcop = PL_curcop;
		474	c->top_env = PL_top_env;
280	}	475	}
281		476
282	static void	477	/*
283	LOAD(pTHX_ Coro__State c)	478	* allocate various perl stacks. This is an exact copy
		479	* of perl.c:init_stacks, except that it uses less memory
		480	* on the assumption that coroutines do not usually need
		481	* a lot of stackspace.
		482	*/
		483	STATIC void
		484	coro_init_stacks (pTHX)
284	{	485	{
285	PL_dowarn = c->dowarn;	486	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
286	GvAV (PL_defgv) = c->defav;	487	PL_curstackinfo->si_type = PERLSI_MAIN;
287	PL_curstackinfo = c->curstackinfo;	488	PL_curstack = PL_curstackinfo->si_stack;
288	PL_curstack = c->curstack;	489	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
289	PL_mainstack = c->mainstack;	490
		491	PL_stack_base = AvARRAY(PL_curstack);
290	PL_stack_sp = c->stack_sp;	492	PL_stack_sp = PL_stack_base;
291	PL_op = c->op;	493	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
292	PL_curpad = c->curpad;	494
293	PL_stack_base = c->stack_base;	495	New(50,PL_tmps_stack,96,SV*);
294	PL_stack_max = c->stack_max;	496	PL_tmps_floor = -1;
295	PL_tmps_stack = c->tmps_stack;	497	PL_tmps_ix = -1;
296	PL_tmps_floor = c->tmps_floor;	498	PL_tmps_max = 96;
297	PL_tmps_ix = c->tmps_ix;	499
298	PL_tmps_max = c->tmps_max;	500	New(54,PL_markstack,16,I32);
299	PL_markstack = c->markstack;
300	PL_markstack_ptr = c->markstack_ptr;	501	PL_markstack_ptr = PL_markstack;
301	PL_markstack_max = c->markstack_max;	502	PL_markstack_max = PL_markstack + 16;
302	PL_scopestack = c->scopestack;
303	PL_scopestack_ix = c->scopestack_ix;
304	PL_scopestack_max = c->scopestack_max;
305	PL_savestack = c->savestack;
306	PL_savestack_ix = c->savestack_ix;
307	PL_savestack_max = c->savestack_max;
308	PL_retstack = c->retstack;
309	PL_retstack_ix = c->retstack_ix;
310	PL_retstack_max = c->retstack_max;
311	PL_curcop = c->curcop;
312		503
313	{	504	#ifdef SET_MARK_OFFSET
314	dSP;	505	SET_MARK_OFFSET;
315	CV *cv;
316
317	/* now do the ugly restore mess */
318	while ((cv = (CV *)POPs))
319	{
320	AV padlist = (AV )POPs;
321
322	put_padlist (cv);
323	CvPADLIST(cv) = padlist;
324	CvDEPTH(cv) = (I32)POPs;
325
326	#ifdef USE_THREADS
327	CvOWNER(cv) = (struct perl_thread *)POPs;
328	error does not work either
329	#endif	506	#endif
330	}
331		507
332	PUTBACK;	508	New(54,PL_scopestack,16,I32);
333	}	509	PL_scopestack_ix = 0;
334	}	510	PL_scopestack_max = 16;
335		511
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	512	New(54,PL_savestack,96,ANY);
		513	PL_savestack_ix = 0;
		514	PL_savestack_max = 96;
		515
		516	New(54,PL_retstack,8,OP*);
		517	PL_retstack_ix = 0;
		518	PL_retstack_max = 8;
		519	}
		520
		521	/*
		522	* destroy the stacks, the callchain etc...
		523	*/
337	STATIC void	524	STATIC void
338	destroy_stacks(pTHX)	525	destroy_stacks(pTHX)
339	{	526	{
340	dSP;	527	if (!IN_DESTRUCT)
341		528	{
342	/* die does this while calling POPSTACK, but I just don't see why. */
343	dounwind(-1);
344
345	/* is this ugly, I ask? */	529	/* is this ugly, I ask? */
346	while (PL_scopestack_ix)	530	while (PL_scopestack_ix)
347	LEAVE;	531	LEAVE;
		532
		533	/* sure it is, but more important: is it correct?? :/ */
		534	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		535	FREETMPS;
		536	}
348		537
349	while (PL_curstackinfo->si_next)	538	while (PL_curstackinfo->si_next)
350	PL_curstackinfo = PL_curstackinfo->si_next;	539	PL_curstackinfo = PL_curstackinfo->si_next;
351		540
352	while (PL_curstackinfo)	541	while (PL_curstackinfo)
353	{	542	{
354	PERL_SI *p = PL_curstackinfo->si_prev;	543	PERL_SI *p = PL_curstackinfo->si_prev;
355		544
		545	{
		546	dSP;
		547	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		548	PUTBACK; /* possibly superfluous */
		549	}
		550
		551	if (!IN_DESTRUCT)
		552	{
		553	dounwind(-1);
356	SvREFCNT_dec(PL_curstackinfo->si_stack);	554	SvREFCNT_dec(PL_curstackinfo->si_stack);
		555	}
		556
357	Safefree(PL_curstackinfo->si_cxstack);	557	Safefree(PL_curstackinfo->si_cxstack);
358	Safefree(PL_curstackinfo);	558	Safefree(PL_curstackinfo);
359	PL_curstackinfo = p;	559	PL_curstackinfo = p;
360	}	560	}
361		561
362	if (PL_scopestack_ix != 0)
363	Perl_warner(aTHX_ WARN_INTERNAL,
364	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
365	(long)PL_scopestack_ix);
366	if (PL_savestack_ix != 0)
367	Perl_warner(aTHX_ WARN_INTERNAL,
368	"Unbalanced saves: %ld more saves than restores\n",
369	(long)PL_savestack_ix);
370	if (PL_tmps_floor != -1)
371	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
372	(long)PL_tmps_floor + 1);
373	/*
374	*/
375	Safefree(PL_tmps_stack);	562	Safefree(PL_tmps_stack);
376	Safefree(PL_markstack);	563	Safefree(PL_markstack);
377	Safefree(PL_scopestack);	564	Safefree(PL_scopestack);
378	Safefree(PL_savestack);	565	Safefree(PL_savestack);
379	Safefree(PL_retstack);	566	Safefree(PL_retstack);
380	}	567	}
381		568
382	#define SUB_INIT "Coro::State::_newcoro"	569	static void
		570	allocate_stack (Coro__State ctx, int alloc)
		571	{
		572	coro_stack *stack;
		573
		574	New (0, stack, 1, coro_stack);
		575
		576	stack->refcnt = 1;
		577	stack->usecnt = 1;
		578	stack->gencnt = ctx->gencnt = 0;
		579	if (alloc)
		580	{
		581	#if HAVE_MMAP
		582	stack->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-write for us */
		583	stack->sptr = mmap (0, stack->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		584	if (stack->sptr == (void *)-1)
		585	#endif
		586	{
		587	/FIXME//D//* reasonable stack size! */
		588	stack->ssize = -4096 * sizeof (long);
		589	New (0, stack->sptr, 4096, long);
		590	}
		591	}
		592	else
		593	stack->sptr = 0;
		594
		595	ctx->stack = stack;
		596	}
		597
		598	static void
		599	deallocate_stack (Coro__State ctx)
		600	{
		601	coro_stack *stack = ctx->stack;
		602
		603	ctx->stack = 0;
		604
		605	if (stack)
		606	{
		607	if (!--stack->refcnt)
		608	{
		609	#ifdef HAVE_MMAP
		610	if (stack->ssize > 0 && stack->sptr)
		611	munmap (stack->sptr, stack->ssize);
		612	else
		613	#endif
		614	Safefree (stack->sptr);
		615
		616	Safefree (stack);
		617	}
		618	else if (ctx->gencnt == stack->gencnt)
		619	--stack->usecnt;
		620	}
		621	}
		622
		623	static void
		624	setup_coro (void *arg)
		625	{
		626	/*
		627	* emulate part of the perl startup here.
		628	*/
		629	dSP;
		630	Coro__State ctx = (Coro__State)arg;
		631	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
		632
		633	coro_init_stacks (aTHX);
		634	/PL_curcop = 0;/
		635	/PL_in_eval = PL_in_eval;/ /* inherit */
		636	SvREFCNT_dec (GvAV (PL_defgv));
		637	GvAV (PL_defgv) = ctx->args; ctx->args = 0;
		638
		639	SPAGAIN;
		640
		641	if (ctx->stack)
		642	{
		643	ctx->cursp = 0;
		644
		645	PUSHMARK(SP);
		646	PUTBACK;
		647	(void) call_sv (sub_init, G_VOID\|G_NOARGS\|G_EVAL);
		648
		649	if (SvTRUE (ERRSV))
		650	croak (NULL);
		651	else
		652	croak ("FATAL: CCTXT coroutine returned!");
		653	}
		654	else
		655	{
		656	UNOP myop;
		657
		658	PL_op = (OP *)&myop;
		659
		660	Zero(&myop, 1, UNOP);
		661	myop.op_next = Nullop;
		662	myop.op_flags = OPf_WANT_VOID;
		663
		664	PUSHMARK(SP);
		665	XPUSHs (sub_init);
		666	/*
		667	* the next line is slightly wrong, as PL_op->op_next
		668	* is actually being executed so we skip the first op.
		669	* that doesn't matter, though, since it is only
		670	* pp_nextstate and we never return...
		671	* ah yes, and I don't care anyways ;)
		672	*/
		673	PUTBACK;
		674	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		675	SPAGAIN;
		676
		677	ENTER; /* necessary e.g. for dounwind */
		678	}
		679	}
		680
		681	static void
		682	continue_coro (void *arg)
		683	{
		684	/*
		685	* this is a _very_ stripped down perl interpreter ;)
		686	*/
		687	Coro__State ctx = (Coro__State)arg;
		688	JMPENV coro_start_env;
		689
		690	PL_top_env = &ctx->start_env;
		691
		692	ctx->cursp = 0;
		693	PL_op = PL_op->op_next;
		694	CALLRUNOPS(aTHX);
		695
		696	abort ();
		697	}
		698
		699	STATIC void
		700	transfer(pTHX_ struct coro prev, struct coro next, int flags)
		701	{
		702	dSTACKLEVEL;
		703	static struct coro *xnext;
		704
		705	if (prev != next)
		706	{
		707	xnext = next;
		708
		709	if (next->mainstack)
		710	{
		711	SAVE (prev, flags);
		712	LOAD (next);
		713
		714	/* mark this state as in-use */
		715	next->mainstack = 0;
		716	next->tmps_ix = -2;
		717
		718	/* stacklevel changed? if yes, grab the stack for us! */
		719	if (flags & TRANSFER_SAVE_CCTXT)
		720	{
		721	if (!prev->stack)
		722	allocate_stack (prev, 0);
		723	else if (prev->cursp != stacklevel
		724	&& prev->stack->usecnt > 1)
		725	{
		726	prev->gencnt = ++prev->stack->gencnt;
		727	prev->stack->usecnt = 1;
		728	}
		729
		730	/* has our stack been invalidated? */
		731	if (next->stack && next->stack->gencnt != next->gencnt)
		732	{
		733	deallocate_stack (next);
		734	allocate_stack (next, 1);
		735	coro_create (&(next->stack->cctx),
		736	continue_coro, (void *)next,
		737	next->stack->sptr, labs (next->stack->ssize));
		738	}
		739
		740	coro_transfer (&(prev->stack->cctx), &(next->stack->cctx));
		741	/* don't add any code here */
		742	}
		743
		744	}
		745	else if (next->tmps_ix == -2)
		746	croak ("tried to transfer to running coroutine");
		747	else
		748	{
		749	SAVE (prev, -1); /* first get rid of the old state */
		750
		751	if (flags & TRANSFER_SAVE_CCTXT)
		752	{
		753	if (!prev->stack)
		754	allocate_stack (prev, 0);
		755
		756	if (prev->stack->sptr && flags & TRANSFER_LAZY_STACK)
		757	{
		758	PL_top_env = &next->start_env;
		759
		760	setup_coro (next);
		761
		762	prev->stack->refcnt++;
		763	prev->stack->usecnt++;
		764	next->stack = prev->stack;
		765	next->gencnt = prev->gencnt;
		766	}
		767	else
		768	{
		769	assert (!next->stack);
		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	}
383		922
384	MODULE = Coro::State PACKAGE = Coro::State	923	MODULE = Coro::State PACKAGE = Coro::State
385		924
386	PROTOTYPES: ENABLE	925	PROTOTYPES: ENABLE
387		926
388	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
389	if (!padlist_cache)	938	if (!padlist_cache)
390	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	}
391		946
392	Coro::State	947	Coro::State
393	_newprocess(args)	948	_newprocess(args)
394	SV * args	949	SV * args
395	PROTOTYPE: $	950	PROTOTYPE: $
396	CODE:	951	CODE:
397	Coro__State coro;	952	Coro__State coro;
398		953
399	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	954	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
400	croak ("Coro::State::newprocess expects an arrayref");	955	croak ("Coro::State::_newprocess expects an arrayref");
401		956
402	New (0, coro, 1, struct coro);	957	Newz (0, coro, 1, struct coro);
403		958
		959	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
404	coro->mainstack = 0; /* actual work is done inside transfer */	960	coro->mainstack = 0; /* actual work is done inside transfer */
405	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;
406		968
407	RETVAL = coro;	969	RETVAL = coro;
408	OUTPUT:	970	OUTPUT:
409	RETVAL	971	RETVAL
410		972
411	void	973	void
412	transfer(prev,next)	974	transfer(prev, next, flags)
413	Coro::State_or_hashref prev	975	SV *prev
414	Coro::State_or_hashref next	976	SV *next
		977	int flags
		978	PROTOTYPE: @
415	CODE:	979	CODE:
416
417	if (prev != next)
418	{
419	PUTBACK;	980	PUTBACK;
420	SAVE (aTHX_ prev);	981	SV_CORO (next, "Coro::transfer");
421		982	SV_CORO (prev, "Coro::transfer");
422	/*	983	transfer (aTHX_ SvSTATE (prev), SvSTATE (next), flags);
423	* this could be done in newprocess which would lead to
424	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425	* code here, but lazy allocation of stacks has also
426	* some virtues and the overhead of the if() is nil.
427	*/
428	if (next->mainstack)
429	{
430	LOAD (aTHX_ next);
431	next->mainstack = 0; /* unnecessary but much cleaner */
432	SPAGAIN;	984	SPAGAIN;
433	}
434	else
435	{
436	/*
437	* emulate part of the perl startup here.
438	*/
439	UNOP myop;
440
441	init_stacks (); /* from perl.c */
442	PL_op = (OP *)&myop;
443	/PL_curcop = 0;/
444	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445
446	SPAGAIN;
447	Zero(&myop, 1, UNOP);
448	myop.op_next = Nullop;
449	myop.op_flags = OPf_WANT_VOID;
450
451	PUSHMARK(SP);
452	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453	PUTBACK;
454	/*
455	* the next line is slightly wrong, as PL_op->op_next
456	* is actually being executed so we skip the first op.
457	* that doesn't matter, though, since it is only
458	* pp_nextstate and we never return...
459	*/
460	PL_op = Perl_pp_entersub(aTHX);
461	SPAGAIN;
462
463	ENTER;
464	}
465	}
466		985
467	void	986	void
468	DESTROY(coro)	987	DESTROY(coro)
469	Coro::State coro	988	Coro::State coro
470	CODE:	989	CODE:
471		990
472	if (coro->mainstack)	991	if (coro->mainstack && coro->mainstack != main_mainstack)
473	{	992	{
474	struct coro temp;	993	struct coro temp;
475		994
476	PUTBACK;	995	PUTBACK;
477	SAVE(aTHX_ (&temp));	996	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
478	LOAD(aTHX_ coro);	997	LOAD(aTHX_ coro);
479
480	destroy_stacks ();
481	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483	LOAD((&temp));
484	SPAGAIN;	998	SPAGAIN;
		999
		1000	destroy_stacks (aTHX);
		1001
		1002	LOAD((&temp)); /* this will get rid of defsv etc.. */
		1003	SPAGAIN;
		1004
		1005	coro->mainstack = 0;
485	}	1006	}
486		1007
		1008	deallocate_stack (coro);
487	SvREFCNT_dec (coro->args);	1009	SvREFCNT_dec (coro->args);
488	Safefree (coro);	1010	Safefree (coro);
489		1011
		1012	void
		1013	flush()
		1014	CODE:
		1015	#ifdef MAY_FLUSH
		1016	flush_padlist_cache ();
		1017	#endif
490		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.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.48 by pcg, Sat Nov 15 03:53:37 2003 UTC

Diff Legend

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