[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.14 by root, Mon Jul 23 23:48:05 2001 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 "libcoro/coro.c"
6	# define CHK(x) (void *)0	6
7	#else	7	#ifdef HAVE_MMAP
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	8	# include <unistd.h>
		9	# include <sys/mman.h>
9	#endif	10	#endif
		11
		12	#define MAY_FLUSH /* increases codesize */
		13
		14	#define TRANSFER_SAVE_DEFAV 0x00000001
		15	#define TRANSFER_SAVE_DEFSV 0x00000002
		16	#define TRANSFER_SAVE_ERRSV 0x00000004
		17	#define TRANSFER_SAVE_CCTXT 0x00000008
		18
		19	#define TRANSFER_SAVE_ALL -1
		20
		21	#define SUB_INIT "Coro::State::initialize"
		22	#define UCORO_STATE "_coro_state"
10		23
11	struct coro {	24	struct coro {
		25	/* the optional C context */
		26	coro_context cctx;
		27	void *sptr;
		28	long ssize;
		29
		30	/* optionally saved, might be zero */
		31	AV *defav;
		32	SV *defsv;
		33	SV *errsv;
		34
		35	/* saved global state not related to stacks */
12	U8 dowarn;	36	U8 dowarn;
13	AV *defav;	37
14		38	/* the stacks and related info (callchain etc..) */
15	PERL_SI *curstackinfo;	39	PERL_SI *curstackinfo;
16	AV *curstack;	40	AV *curstack;
17	AV *mainstack;	41	AV *mainstack;
18	SV **stack_sp;	42	SV **stack_sp;
19	OP *op;	43	OP *op;
35	I32 savestack_max;	59	I32 savestack_max;
36	OP **retstack;	60	OP **retstack;
37	I32 retstack_ix;	61	I32 retstack_ix;
38	I32 retstack_max;	62	I32 retstack_max;
39	COP *curcop;	63	COP *curcop;
		64	JMPENV start_env;
		65	JMPENV *top_env;
40		66
		67	/* data associated with this coroutine (initial args) */
41	AV *args;	68	AV *args;
42	};	69	};
43		70
44	typedef struct coro *Coro__State;	71	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	72	typedef struct coro *Coro__State_or_hashref;
46		73
		74	static AV main_mainstack; / used to differentiate between $main and others */
		75	static HV *coro_state_stash;
		76	static SV *ucoro_state_sv;
		77	static U32 ucoro_state_hash;
47	static HV *padlist_cache;	78	static HV *padlist_cache;
48		79
49	/* mostly copied from op.c:cv_clone2 */	80	/* mostly copied from op.c:cv_clone2 */
50	STATIC AV *	81	STATIC AV *
51	clone_padlist (AV *protopadlist)	82	clone_padlist (AV *protopadlist)
…		…
115	SvPADTMP_on (sv);	146	SvPADTMP_on (sv);
116	npad[ix] = sv;	147	npad[ix] = sv;
117	}	148	}
118	}	149	}
119		150
120	#if 0 /* NONOTUNDERSTOOD */	151	#if 0 /* return -ENOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */	152	/* Now that vars are all in place, clone nested closures. */
122		153
123	for (ix = fpad; ix > 0; ix--) {	154	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;	155	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv	156	if (namesv
…		…
138	#endif	169	#endif
139		170
140	return newpadlist;	171	return newpadlist;
141	}	172	}
142		173
		174	#ifdef MAY_FLUSH
143	STATIC AV *	175	STATIC AV *
144	free_padlist (AV *padlist)	176	free_padlist (AV *padlist)
145	{	177	{
146	/* may be during global destruction */	178	/* may be during global destruction */
147	if (SvREFCNT(padlist))	179	if (SvREFCNT(padlist))
…		…
156	}	188	}
157		189
158	SvREFCNT_dec((SV*)padlist);	190	SvREFCNT_dec((SV*)padlist);
159	}	191	}
160	}	192	}
		193	#endif
161		194
162	STATIC AV *	195	/* the next two functions merely cache the padlists */
163	unuse_padlist (AV *padlist)	196	STATIC void
		197	get_padlist (CV *cv)
164	{	198	{
		199	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
		200
		201	if (he && AvFILLp ((AV )he) >= 0)
		202	CvPADLIST (cv) = (AV )av_pop ((AV )*he);
		203	else
		204	CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
		205	}
		206
		207	STATIC void
		208	put_padlist (CV *cv)
		209	{
		210	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 1);
		211
		212	if (SvTYPE (*he) != SVt_PVAV)
		213	{
		214	SvREFCNT_dec (*he);
		215	he = (SV )newAV ();
		216	}
		217
		218	av_push ((AV )he, (SV *)CvPADLIST (cv));
		219	}
		220
		221	#ifdef MAY_FLUSH
		222	STATIC void
		223	flush_padlist_cache ()
		224	{
		225	HV *hv = padlist_cache;
		226	padlist_cache = newHV ();
		227
		228	if (hv_iterinit (hv))
		229	{
		230	HE *he;
		231	AV *padlist;
		232
		233	while (!!(he = hv_iternext (hv)))
		234	{
		235	AV av = (AV )HeVAL(he);
		236
		237	/* casting is fun. */
		238	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
165	free_padlist (padlist);	239	free_padlist (padlist);
		240	}
		241	}
		242
		243	SvREFCNT_dec (hv);
166	}	244	}
		245	#endif
		246
		247	#define SB do {
		248	#define SE } while (0)
		249
		250	#define LOAD(state) SB load_state(aTHX_ (state)); SPAGAIN; SE
		251	#define SAVE(state,flags) SB PUTBACK; save_state(aTHX_ (state),(flags)); SE
		252
		253	#define REPLACE_SV(sv,val) SB SvREFCNT_dec(sv); (sv) = (val); SE
167		254
168	static void	255	static void
169	SAVE(pTHX_ Coro__State c)	256	load_state(pTHX_ Coro__State c)
		257	{
		258	PL_dowarn = c->dowarn;
		259
		260	PL_curstackinfo = c->curstackinfo;
		261	PL_curstack = c->curstack;
		262	PL_mainstack = c->mainstack;
		263	PL_stack_sp = c->stack_sp;
		264	PL_op = c->op;
		265	PL_curpad = c->curpad;
		266	PL_stack_base = c->stack_base;
		267	PL_stack_max = c->stack_max;
		268	PL_tmps_stack = c->tmps_stack;
		269	PL_tmps_floor = c->tmps_floor;
		270	PL_tmps_ix = c->tmps_ix;
		271	PL_tmps_max = c->tmps_max;
		272	PL_markstack = c->markstack;
		273	PL_markstack_ptr = c->markstack_ptr;
		274	PL_markstack_max = c->markstack_max;
		275	PL_scopestack = c->scopestack;
		276	PL_scopestack_ix = c->scopestack_ix;
		277	PL_scopestack_max = c->scopestack_max;
		278	PL_savestack = c->savestack;
		279	PL_savestack_ix = c->savestack_ix;
		280	PL_savestack_max = c->savestack_max;
		281	PL_retstack = c->retstack;
		282	PL_retstack_ix = c->retstack_ix;
		283	PL_retstack_max = c->retstack_max;
		284	PL_curcop = c->curcop;
		285	PL_start_env = c->start_env;
		286	PL_top_env = c->top_env;
		287
		288	if (c->defav) REPLACE_SV (GvAV (PL_defgv), c->defav);
		289	if (c->defsv) REPLACE_SV (DEFSV , c->defsv);
		290	if (c->errsv) REPLACE_SV (ERRSV , c->errsv);
		291
		292	{
		293	dSP;
		294	CV *cv;
		295
		296	/* now do the ugly restore mess */
		297	while ((cv = (CV *)POPs))
		298	{
		299	AV padlist = (AV )POPs;
		300
		301	if (padlist)
		302	{
		303	put_padlist (cv); /* mark this padlist as available */
		304	CvPADLIST(cv) = padlist;
		305	#ifdef USE_THREADS
		306	/CvOWNER(cv) = (struct perl_thread )POPs;*/
		307	#endif
		308	}
		309
		310	++CvDEPTH(cv);
		311	}
		312
		313	PUTBACK;
		314	}
		315	}
		316
		317	static void
		318	save_state(pTHX_ Coro__State c, int flags)
170	{	319	{
171	{	320	{
172	dSP;	321	dSP;
173	I32 cxix = cxstack_ix;	322	I32 cxix = cxstack_ix;
		323	PERL_CONTEXT *ccstk = cxstack;
174	PERL_SI *top_si = PL_curstackinfo;	324	PERL_SI *top_si = PL_curstackinfo;
175	PERL_CONTEXT *ccstk = cxstack;
176		325
177	/*	326	/*
178	* the worst thing you can imagine happens first - we have to save	327	* the worst thing you can imagine happens first - we have to save
179	* (and reinitialize) all cv's in the whole callchain :(	328	* (and reinitialize) all cv's in the whole callchain :(
180	*/	329	*/
181		330
182	PUSHs (Nullsv);	331	PUSHs (Nullsv);
183	/* this loop was inspired by pp_caller */	332	/* this loop was inspired by pp_caller */
184	for (;;)	333	for (;;)
185	{	334	{
186	while (cxix >= 0)	335	do
187	{	336	{
188	PERL_CONTEXT *cx = &ccstk[--cxix];	337	PERL_CONTEXT *cx = &ccstk[cxix--];
189		338
190	if (CxTYPE(cx) == CXt_SUB)	339	if (CxTYPE(cx) == CXt_SUB)
191	{	340	{
192	CV *cv = cx->blk_sub.cv;	341	CV *cv = cx->blk_sub.cv;
193	if (CvDEPTH(cv))	342	if (CvDEPTH(cv))
194	{	343	{
195	#ifdef USE_THREADS	344	#ifdef USE_THREADS
196	XPUSHs ((SV *)CvOWNER(cv));	345	/XPUSHs ((SV )CvOWNER(cv));*/
		346	/CvOWNER(cv) = 0;/
		347	/error must unlock this cv etc.. etc.../
197	#endif	348	#endif
198	EXTEND (SP, 3);	349	EXTEND (SP, CvDEPTH(cv)*2);
		350
		351	while (--CvDEPTH(cv))
		352	{
		353	/* this tells the restore code to increment CvDEPTH */
		354	PUSHs (Nullsv);
199	PUSHs ((SV *)CvDEPTH(cv));	355	PUSHs ((SV *)cv);
		356	}
		357
200	PUSHs ((SV *)CvPADLIST(cv));	358	PUSHs ((SV *)CvPADLIST(cv));
201	PUSHs ((SV *)cv);	359	PUSHs ((SV *)cv);
202		360
203	CvPADLIST(cv) = clone_padlist (CvPADLIST(cv));	361	get_padlist (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	}	362	}
213	}	363	}
214	else if (CxTYPE(cx) == CXt_FORMAT)	364	else if (CxTYPE(cx) == CXt_FORMAT)
215	{	365	{
216	/* I never used formats, so how should I know how these are implemented? */	366	/* I never used formats, so how should I know how these are implemented? */
217	/* my bold guess is as a simple, plain sub... */	367	/* my bold guess is as a simple, plain sub... */
218	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	368	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
219	}	369	}
220	}	370	}
		371	while (cxix >= 0);
221		372
222	if (top_si->si_type == PERLSI_MAIN)	373	if (top_si->si_type == PERLSI_MAIN)
223	break;	374	break;
224		375
225	top_si = top_si->si_prev;	376	top_si = top_si->si_prev;
…		…
228	}	379	}
229		380
230	PUTBACK;	381	PUTBACK;
231	}	382	}
232		383
		384	c->defav = flags & TRANSFER_SAVE_DEFAV ? (AV *)SvREFCNT_inc (GvAV (PL_defgv)) : 0;
		385	c->defsv = flags & TRANSFER_SAVE_DEFSV ? SvREFCNT_inc (DEFSV) : 0;
		386	c->errsv = flags & TRANSFER_SAVE_ERRSV ? SvREFCNT_inc (ERRSV) : 0;
		387
		388	/* I have not the slightest idea of why av_reify is necessary */
		389	/* but if it's missing the defav contents magically get replaced sometimes */
		390	if (c->defav)
		391	av_reify (c->defav);
		392
233	c->dowarn = PL_dowarn;	393	c->dowarn = PL_dowarn;
234	c->defav = GvAV (PL_defgv);	394
235	c->curstackinfo = PL_curstackinfo;	395	c->curstackinfo = PL_curstackinfo;
236	c->curstack = PL_curstack;	396	c->curstack = PL_curstack;
237	c->mainstack = PL_mainstack;	397	c->mainstack = PL_mainstack;
238	c->stack_sp = PL_stack_sp;	398	c->stack_sp = PL_stack_sp;
239	c->op = PL_op;	399	c->op = PL_op;
…		…
255	c->savestack_max = PL_savestack_max;	415	c->savestack_max = PL_savestack_max;
256	c->retstack = PL_retstack;	416	c->retstack = PL_retstack;
257	c->retstack_ix = PL_retstack_ix;	417	c->retstack_ix = PL_retstack_ix;
258	c->retstack_max = PL_retstack_max;	418	c->retstack_max = PL_retstack_max;
259	c->curcop = PL_curcop;	419	c->curcop = PL_curcop;
		420	c->start_env = PL_start_env;
		421	c->top_env = PL_top_env;
		422	}
		423
		424	/*
		425	* allocate various perl stacks. This is an exact copy
		426	* of perl.c:init_stacks, except that it uses less memory
		427	* on the assumption that coroutines do not usually need
		428	* a lot of stackspace.
		429	*/
		430	STATIC void
		431	coro_init_stacks (pTHX)
		432	{
		433	PL_curstackinfo = new_stackinfo(96, 1024/sizeof(PERL_CONTEXT) - 1);
		434	PL_curstackinfo->si_type = PERLSI_MAIN;
		435	PL_curstack = PL_curstackinfo->si_stack;
		436	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		437
		438	PL_stack_base = AvARRAY(PL_curstack);
		439	PL_stack_sp = PL_stack_base;
		440	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
		441
		442	New(50,PL_tmps_stack,64,SV*);
		443	PL_tmps_floor = -1;
		444	PL_tmps_ix = -1;
		445	PL_tmps_max = 64;
		446
		447	New(54,PL_markstack,12,I32);
		448	PL_markstack_ptr = PL_markstack;
		449	PL_markstack_max = PL_markstack + 12;
		450
		451	SET_MARK_OFFSET;
		452
		453	New(54,PL_scopestack,12,I32);
		454	PL_scopestack_ix = 0;
		455	PL_scopestack_max = 12;
		456
		457	New(54,PL_savestack,64,ANY);
		458	PL_savestack_ix = 0;
		459	PL_savestack_max = 64;
		460
		461	New(54,PL_retstack,8,OP*);
		462	PL_retstack_ix = 0;
		463	PL_retstack_max = 8;
		464	}
		465
		466	/*
		467	* destroy the stacks, the callchain etc...
		468	* still there is a memleak of 128 bytes...
		469	*/
		470	STATIC void
		471	destroy_stacks(pTHX)
		472	{
		473	/* is this ugly, I ask? */
		474	while (PL_scopestack_ix)
		475	LEAVE;
		476
		477	/* sure it is, but more important: is it correct?? :/ */
		478	while (PL_tmps_ix > PL_tmps_floor) /* should only ever be one iteration */
		479	FREETMPS;
		480
		481	while (PL_curstackinfo->si_next)
		482	PL_curstackinfo = PL_curstackinfo->si_next;
		483
		484	while (PL_curstackinfo)
		485	{
		486	PERL_SI *p = PL_curstackinfo->si_prev;
		487
		488	{
		489	dSP;
		490	SWITCHSTACK (PL_curstack, PL_curstackinfo->si_stack);
		491	PUTBACK; /* possibly superfluous */
		492	}
		493
		494	dounwind(-1);
		495
		496	SvREFCNT_dec(PL_curstackinfo->si_stack);
		497	Safefree(PL_curstackinfo->si_cxstack);
		498	Safefree(PL_curstackinfo);
		499	PL_curstackinfo = p;
		500	}
		501
		502	Safefree(PL_tmps_stack);
		503	Safefree(PL_markstack);
		504	Safefree(PL_scopestack);
		505	Safefree(PL_savestack);
		506	Safefree(PL_retstack);
260	}	507	}
261		508
262	static void	509	static void
263	LOAD(pTHX_ Coro__State c)	510	allocate_stack (Coro__State ctx)
264	{	511	{
265	PL_dowarn = c->dowarn;	512	#ifdef HAVE_MMAP
266	GvAV (PL_defgv) = c->defav;	513	ctx->ssize = 128 * 1024 * sizeof (long); /* mmap should do allocate-on-use */
267	PL_curstackinfo = c->curstackinfo;	514	ctx->sptr = mmap (0, ctx->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANON, 0, 0);
268	PL_curstack = c->curstack;	515	if (ctx->sptr == (void *)-1)
269	PL_mainstack = c->mainstack;	516	#endif
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
293	{	517	{
		518	/FIXME//D//* reasonable stack size! */
		519	ctx->ssize = 4096 * sizeof (long);
		520	New (0, ctx->sptr, 4096, long);
		521	}
		522	}
		523
		524	static void
		525	deallocate_stack (Coro__State ctx)
		526	{
		527	#ifdef HAVE_MMAP
		528	munmap (ctx->sptr, ctx->ssize);
		529	#else
		530	Safefree (ctx->sptr);
		531	#endif
		532	}
		533
		534	/* might go away together with optional SAVE_CCTXT */
		535	static void
		536	setup_coro (void *arg)
		537	{
		538	/*
		539	* emulate part of the perl startup here.
		540	*/
294	dSP;	541	dSP;
295	CV *cv;	542	Coro__State ctx = (Coro__State)arg;
		543	SV sub_init = (SV)get_cv(SUB_INIT, FALSE);
296		544
297	/* now do the ugly restore mess */	545	coro_init_stacks (aTHX);
298	while ((cv = (CV *)POPs))	546	JMPENV_BOOTSTRAP;
		547	SPAGAIN;
		548
		549	/PL_curcop = 0;/
		550	SvREFCNT_dec (GvAV (PL_defgv));
		551	GvAV (PL_defgv) = ctx->args;
		552
		553	if (ctx->sptr)
299	{	554	{
300	AV padlist = (AV )POPs;	555	PUSHMARK(SP);
301
302	unuse_padlist (CvPADLIST(cv));
303	CvPADLIST(cv) = padlist;
304	CvDEPTH(cv) = (I32)POPs;
305
306	#ifdef USE_THREADS
307	CvOWNER(cv) = (struct perl_thread *)POPs;
308	error does not work either
309	#endif
310	}
311
312	PUTBACK;	556	PUTBACK;
		557	(void) call_sv (sub_init, G_VOID\|G_NOARGS);
		558	croak ("FATAL: CCTXT coroutine returned!");
313	}	559	}
314	}	560	else
		561	{
		562	UNOP myop;
315		563
316	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	564	PL_op = (OP *)&myop;
		565
		566	Zero(&myop, 1, UNOP);
		567	myop.op_next = Nullop;
		568	myop.op_flags = OPf_WANT_VOID;
		569
		570	PUSHMARK(SP);
		571	XPUSHs (sub_init);
		572	/*
		573	* the next line is slightly wrong, as PL_op->op_next
		574	* is actually being executed so we skip the first op.
		575	* that doesn't matter, though, since it is only
		576	* pp_nextstate and we never return...
		577	* ah yes, and I don't care anyways ;)
		578	*/
		579	PUTBACK;
		580	PL_op = pp_entersub();
		581	SPAGAIN;
		582
		583	ENTER; /* necessary e.g. for dounwind */
		584	}
		585	}
		586
317	STATIC void	587	STATIC void
318	S_nuke_stacks(pTHX)	588	transfer(pTHX_ struct coro prev, struct coro next, int flags)
319	{	589	{
320	while (PL_curstackinfo->si_next)	590	dSP;
321	PL_curstackinfo = PL_curstackinfo->si_next;	591
322	while (PL_curstackinfo) {	592	if (prev != next)
323	PERL_SI *p = PL_curstackinfo->si_prev;	593	{
324	/* curstackinfo->si_stack got nuked by sv_free_arenas() */	594	/*
325	Safefree(PL_curstackinfo->si_cxstack);	595	* this could be done in newprocess which would lead to
326	Safefree(PL_curstackinfo);	596	* extremely elegant and fast (basically just SAVE/LOAD)
327	PL_curstackinfo = p;	597	* code here, but lazy allocation of stacks has also
		598	* some virtues and the overhead of the if() is nil.
		599	*/
		600	if (next->mainstack)
		601	{
		602	SAVE (prev, flags);
		603	LOAD (next);
		604
		605	/* mark this state as in-use */
		606	next->mainstack = 0;
		607	next->tmps_ix = -2;
		608
		609	if (flags & TRANSFER_SAVE_CCTXT)
		610	{
		611	if (!next->ssize)
		612	croak ("destination coroutine has no CCTXT (%p, %d)", next->sptr, next->ssize);
		613
		614	if (!prev->ssize)
		615	prev->ssize = 1; /* mark cctx as valid ;) */
		616
		617	coro_transfer (&(prev->cctx), &(next->cctx));
		618	}
		619
		620	}
		621	else if (next->tmps_ix == -2)
		622	croak ("tried to transfer to running coroutine");
		623	else
		624	{
		625	SAVE (prev, -1); /* first get rid of the old state */
		626
		627	if (flags & TRANSFER_SAVE_CCTXT)
		628	{
		629	if (!next->ssize)
		630	{
		631	allocate_stack (next);
		632	coro_create (&(next->cctx),
		633	setup_coro, (void *)next,
		634	next->sptr, next->ssize);
		635	}
		636
		637	if (!prev->ssize)
		638	prev->ssize = 1; /* mark cctx as valid ;) */
		639
		640	coro_transfer (&(prev->cctx), &(next->cctx));
		641	}
		642	else
		643	setup_coro (next);
		644	}
328	}	645	}
329	Safefree(PL_tmps_stack);
330	Safefree(PL_markstack);
331	Safefree(PL_scopestack);
332	Safefree(PL_savestack);
333	Safefree(PL_retstack);
334	}	646	}
335
336	#define SUB_INIT "Coro::State::_newcoro"
337		647
338	MODULE = Coro::State PACKAGE = Coro::State	648	MODULE = Coro::State PACKAGE = Coro::State
339		649
340	PROTOTYPES: ENABLE	650	PROTOTYPES: ENABLE
341		651
342	BOOT:	652	BOOT:
		653	{ /* {} necessary for stoopid perl-5.6.x */
		654	ucoro_state_sv = newSVpv (UCORO_STATE, sizeof(UCORO_STATE) - 1);
		655	PERL_HASH(ucoro_state_hash, UCORO_STATE, sizeof(UCORO_STATE) - 1);
		656	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		657
		658	newCONSTSUB (coro_state_stash, "SAVE_DEFAV", newSViv (TRANSFER_SAVE_DEFAV));
		659	newCONSTSUB (coro_state_stash, "SAVE_DEFSV", newSViv (TRANSFER_SAVE_DEFSV));
		660	newCONSTSUB (coro_state_stash, "SAVE_ERRSV", newSViv (TRANSFER_SAVE_ERRSV));
		661	newCONSTSUB (coro_state_stash, "SAVE_CCTXT", newSViv (TRANSFER_SAVE_CCTXT));
		662
343	if (!padlist_cache)	663	if (!padlist_cache)
344	padlist_cache = newHV ();	664	padlist_cache = newHV ();
		665
		666	main_mainstack = PL_mainstack;
		667	}
345		668
346	Coro::State	669	Coro::State
347	_newprocess(args)	670	_newprocess(args)
348	SV * args	671	SV * args
349	PROTOTYPE: $	672	PROTOTYPE: $
350	CODE:	673	CODE:
351	Coro__State coro;	674	Coro__State coro;
352		675
353	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)	676	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
354	croak ("Coro::State::newprocess expects an arrayref");	677	croak ("Coro::State::_newprocess expects an arrayref");
355		678
356	New (0, coro, 1, struct coro);	679	New (0, coro, 1, struct coro);
357		680
		681	coro->args = (AV *)SvREFCNT_inc (SvRV (args));
358	coro->mainstack = 0; /* actual work is done inside transfer */	682	coro->mainstack = 0; /* actual work is done inside transfer */
359	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	683	coro->sptr = 0;
		684	coro->ssize = 0;
360		685
361	RETVAL = coro;	686	RETVAL = coro;
362	OUTPUT:	687	OUTPUT:
363	RETVAL	688	RETVAL
364		689
365	void	690	void
366	transfer(prev,next)	691	transfer(prev, next, flags = TRANSFER_SAVE_ALL)
367	Coro::State_or_hashref prev	692	Coro::State_or_hashref prev
368	Coro::State_or_hashref next	693	Coro::State_or_hashref next
		694	int flags
		695	PROTOTYPE: @
369	CODE:	696	CODE:
370		697	transfer (aTHX_ prev, next, flags);
371	if (prev != next)
372	{
373	PUTBACK;
374	SAVE (aTHX_ prev);
375
376	/*
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;
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		698
421	void	699	void
422	DESTROY(coro)	700	DESTROY(coro)
423	Coro::State coro	701	Coro::State coro
424	CODE:	702	CODE:
425		703
426	if (coro->mainstack)	704	if (coro->mainstack && coro->mainstack != main_mainstack)
427	{	705	{
428	struct coro temp;	706	struct coro temp;
429		707
430	PUTBACK;
431	SAVE(aTHX_ (&temp));	708	SAVE(aTHX_ (&temp), TRANSFER_SAVE_ALL);
432	LOAD(aTHX_ coro);	709	LOAD(aTHX_ coro);
433		710
434	S_nuke_stacks ();	711	destroy_stacks (aTHX);
435	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
436		712
437	LOAD((&temp));	713	LOAD((&temp)); /* this will get rid of defsv etc.. */
438	SPAGAIN;	714
		715	coro->mainstack = 0;
439	}	716	}
440		717
441	SvREFCNT_dec (coro->args);	718	if (coro->sptr)
		719	{
		720	deallocate_stack (coro);
		721	coro->sptr = 0;
		722	}
		723
442	Safefree (coro);	724	Safefree (coro);
443		725
		726	void
		727	flush()
		728	CODE:
		729	#ifdef MAY_FLUSH
		730	flush_padlist_cache ();
		731	#endif
444		732
		733	MODULE = Coro::State PACKAGE = Coro::Cont
		734
		735	# this is slightly dirty
		736
		737	void
		738	yield(...)
		739	PROTOTYPE: @
		740	CODE:
		741	static SV *returnstk;
		742	SV *sv;
		743	AV *defav = GvAV (PL_defgv);
		744	struct coro prev, next;
		745
		746	if (!returnstk)
		747	returnstk = SvRV (get_sv ("Coro::Cont::return", FALSE));
		748
		749	/* set up @_ -- ugly */
		750	av_clear (defav);
		751	av_fill (defav, items - 1);
		752	while (items--)
		753	av_store (defav, items, SvREFCNT_inc (ST(items)));
		754
		755	mg_get (returnstk); /* isn't documentation wrong for mg_get? */
		756	sv = av_pop ((AV *)SvRV (returnstk));
		757	prev = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 0, 0)));
		758	next = (struct coro )SvIV ((SV)SvRV (av_fetch ((AV )SvRV (sv), 1, 0)));
		759	SvREFCNT_dec (sv);
		760
		761	transfer(aTHX_ prev, next, 0);
		762

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.14 by root, Mon Jul 23 23:48:05 2001 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.14 by root, Mon Jul 23 23:48:05 2001 UTC