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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.233 by root, Fri May 9 22:04:37 2008 UTC

		1	#include "libcoro/coro.c"
		2
		3	#define PERL_NO_GET_CONTEXT
		4	#define PERL_EXT
		5
1	#include "EXTERN.h"	6	#include "EXTERN.h"
2	#include "perl.h"	7	#include "perl.h"
3	#include "XSUB.h"	8	#include "XSUB.h"
4		9
5	#if 0	10	#include "patchlevel.h"
6	# define CHK(x) (void *)0	11
		12	#include <stdio.h>
		13	#include <errno.h>
		14	#include <assert.h>
		15
		16	#ifdef WIN32
		17	# undef setjmp
		18	# undef longjmp
		19	# undef _exit
		20	# define setjmp _setjmp // deep magic, don't ask
7	#else	21	#else
8	# define CHK(x) if (!(x)) croak("FATAL, CHK: " #x)	22	# include <inttypes.h> /* most portable stdint.h */
		23	#endif
		24
		25	#ifdef HAVE_MMAP
		26	# include <unistd.h>
		27	# include <sys/mman.h>
		28	# ifndef MAP_ANONYMOUS
		29	# ifdef MAP_ANON
		30	# define MAP_ANONYMOUS MAP_ANON
		31	# else
		32	# undef HAVE_MMAP
		33	# endif
9	#endif	34	# endif
		35	# include <limits.h>
		36	# ifndef PAGESIZE
		37	# define PAGESIZE pagesize
		38	# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE)
		39	static long pagesize;
		40	# else
		41	# define BOOT_PAGESIZE (void)0
		42	# endif
		43	#else
		44	# define PAGESIZE 0
		45	# define BOOT_PAGESIZE (void)0
		46	#endif
10		47
		48	#if CORO_USE_VALGRIND
		49	# include <valgrind/valgrind.h>
		50	# define REGISTER_STACK(cctx,start,end) (cctx)->valgrind_id = VALGRIND_STACK_REGISTER ((start), (end))
		51	#else
		52	# define REGISTER_STACK(cctx,start,end)
		53	#endif
		54
		55	/* the maximum number of idle cctx that will be pooled */
		56	#define MAX_IDLE_CCTX 8
		57
		58	#define PERL_VERSION_ATLEAST(a,b,c) \
		59	(PERL_REVISION > (a) \
		60	\|\| (PERL_REVISION == (a) \
		61	&& (PERL_VERSION > (b) \
		62	\|\| (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))
		63
		64	#if !PERL_VERSION_ATLEAST (5,6,0)
		65	# ifndef PL_ppaddr
		66	# define PL_ppaddr ppaddr
		67	# endif
		68	# ifndef call_sv
		69	# define call_sv perl_call_sv
		70	# endif
		71	# ifndef get_sv
		72	# define get_sv perl_get_sv
		73	# endif
		74	# ifndef get_cv
		75	# define get_cv perl_get_cv
		76	# endif
		77	# ifndef IS_PADGV
		78	# define IS_PADGV(v) 0
		79	# endif
		80	# ifndef IS_PADCONST
		81	# define IS_PADCONST(v) 0
		82	# endif
		83	#endif
		84
		85	/* 5.8.8 */
		86	#ifndef GV_NOTQUAL
		87	# define GV_NOTQUAL 0
		88	#endif
		89	#ifndef newSV
		90	# define newSV(l) NEWSV(0,l)
		91	#endif
		92
		93	/* 5.11 */
		94	#ifndef CxHASARGS
		95	# define CxHASARGS(cx) (cx)->blk_sub.hasargs
		96	#endif
		97
		98	/* 5.8.7 */
		99	#ifndef SvRV_set
		100	# define SvRV_set(s,v) SvRV(s) = (v)
		101	#endif
		102
		103	#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
		104	# undef CORO_STACKGUARD
		105	#endif
		106
		107	#ifndef CORO_STACKGUARD
		108	# define CORO_STACKGUARD 0
		109	#endif
		110
		111	/* prefer perl internal functions over our own? */
		112	#ifndef CORO_PREFER_PERL_FUNCTIONS
		113	# define CORO_PREFER_PERL_FUNCTIONS 0
		114	#endif
		115
		116	/* The next macros try to return the current stack pointer, in an as
		117	* portable way as possible. */
		118	#define dSTACKLEVEL volatile char stacklevel
		119	#define STACKLEVEL ((void *)&stacklevel)
		120
		121	#define IN_DESTRUCT (PL_main_cv == Nullcv)
		122
		123	#if __GNUC__ >= 3
		124	# define attribute(x) __attribute__(x)
		125	# define BARRIER __asm__ __volatile__ ("" : : : "memory")
		126	# define expect(expr,value) __builtin_expect ((expr),(value))
		127	#else
		128	# define attribute(x)
		129	# define BARRIER
		130	# define expect(expr,value) (expr)
		131	#endif
		132
		133	#define expect_false(expr) expect ((expr) != 0, 0)
		134	#define expect_true(expr) expect ((expr) != 0, 1)
		135
		136	#define NOINLINE attribute ((noinline))
		137
		138	#include "CoroAPI.h"
		139
		140	#ifdef USE_ITHREADS
		141	static perl_mutex coro_mutex;
		142	# define LOCK do { MUTEX_LOCK (&coro_mutex); } while (0)
		143	# define UNLOCK do { MUTEX_UNLOCK (&coro_mutex); } while (0)
		144	#else
		145	# define LOCK (void)0
		146	# define UNLOCK (void)0
		147	#endif
		148
		149	/* helper storage struct for Coro::AIO */
		150	struct io_state
		151	{
		152	int errorno;
		153	I32 laststype;
		154	int laststatval;
		155	Stat_t statcache;
		156	};
		157
		158	static size_t coro_stacksize = CORO_STACKSIZE;
		159	static struct CoroAPI coroapi;
		160	static AV main_mainstack; / used to differentiate between $main and others */
		161	static JMPENV *main_top_env;
		162	static HV coro_state_stash, coro_stash;
		163	static volatile SV coro_mortal; / will be freed after next transfer */
		164
		165	static GV irsgv; / $/ */
		166	static GV stdoutgv; / STDOUT /
		167	static SV *rv_diehook;
		168	static SV *rv_warnhook;
		169	static HV hv_sig; / %SIG */
		170
		171	/* async_pool helper stuff */
		172	static SV *sv_pool_rss;
		173	static SV *sv_pool_size;
		174	static AV *av_async_pool;
		175
		176	/* Coro::AnyEvent */
		177	static SV *sv_activity;
		178
		179	static struct coro_cctx *cctx_first;
		180	static int cctx_count, cctx_idle;
		181
		182	enum {
		183	CC_MAPPED = 0x01,
		184	CC_NOREUSE = 0x02, /* throw this away after tracing */
		185	CC_TRACE = 0x04,
		186	CC_TRACE_SUB = 0x08, /* trace sub calls */
		187	CC_TRACE_LINE = 0x10, /* trace each statement */
		188	CC_TRACE_ALL = CC_TRACE_SUB \| CC_TRACE_LINE,
		189	};
		190
		191	/* this is a structure representing a c-level coroutine */
		192	typedef struct coro_cctx {
		193	struct coro_cctx *next;
		194
		195	/* the stack */
		196	void *sptr;
		197	size_t ssize;
		198
		199	/* cpu state */
		200	void idle_sp; / sp of top-level transfer/schedule/cede call */
		201	JMPENV idle_te; / same as idle_sp, but for top_env, TODO: remove once stable */
		202	JMPENV *top_env;
		203	coro_context cctx;
		204
		205	#if CORO_USE_VALGRIND
		206	int valgrind_id;
		207	#endif
		208	unsigned char flags;
		209	} coro_cctx;
		210
		211	enum {
		212	CF_RUNNING = 0x0001, /* coroutine is running */
		213	CF_READY = 0x0002, /* coroutine is ready */
		214	CF_NEW = 0x0004, /* has never been switched to */
		215	CF_DESTROYED = 0x0008, /* coroutine data has been freed */
		216	};
		217
		218	/* the structure where most of the perl state is stored, overlaid on the cxstack */
		219	typedef struct {
		220	SV *defsv;
		221	AV *defav;
		222	SV *errsv;
		223	SV *irsgv;
		224	#define VAR(name,type) type name;
		225	# include "state.h"
		226	#undef VAR
		227	} perl_slots;
		228
		229	#define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT))
		230
		231	/* this is a structure representing a perl-level coroutine */
11	struct coro {	232	struct coro {
12	U8 dowarn;	233	/* the c coroutine allocated to this perl coroutine, if any */
13	AV *defav;	234	coro_cctx *cctx;
14		235
15	PERL_SI *curstackinfo;	236	/* process data */
16	AV *curstack;
17	AV *mainstack;	237	AV *mainstack;
18	SV **stack_sp;	238	perl_slots slot; / basically the saved sp */
19	OP *op;
20	SV **curpad;
21	SV **stack_base;
22	SV **stack_max;
23	SV **tmps_stack;
24	I32 tmps_floor;
25	I32 tmps_ix;
26	I32 tmps_max;
27	I32 *markstack;
28	I32 *markstack_ptr;
29	I32 *markstack_max;
30	I32 *scopestack;
31	I32 scopestack_ix;
32	I32 scopestack_max;
33	ANY *savestack;
34	I32 savestack_ix;
35	I32 savestack_max;
36	OP **retstack;
37	I32 retstack_ix;
38	I32 retstack_max;
39	COP *curcop;
40		239
41	AV *args;	240	AV args; / data associated with this coroutine (initial args) */
		241	int refcnt; /* coroutines are refcounted, yes */
		242	int flags; /* CF_ flags */
		243	HV hv; / the perl hash associated with this coro, if any */
		244
		245	/* statistics */
		246	int usecount; /* number of transfers to this coro */
		247
		248	/* coro process data */
		249	int prio;
		250	SV throw; / exception to be thrown */
		251
		252	/* async_pool */
		253	SV *saved_deffh;
		254
		255	/* linked list */
		256	struct coro next, prev;
42	};	257	};
43		258
44	typedef struct coro *Coro__State;	259	typedef struct coro *Coro__State;
45	typedef struct coro *Coro__State_or_hashref;	260	typedef struct coro *Coro__State_or_hashref;
46		261
47	static HV *padlist_cache;	262	/ Coro ******************************************************************/
48		263
49	/* mostly copied from op.c:cv_clone2 */	264	#define PRIO_MAX 3
50	STATIC AV *	265	#define PRIO_HIGH 1
51	clone_padlist (AV *protopadlist)	266	#define PRIO_NORMAL 0
		267	#define PRIO_LOW -1
		268	#define PRIO_IDLE -3
		269	#define PRIO_MIN -4
		270
		271	/* for Coro.pm */
		272	static SV *coro_current;
		273	static SV *coro_readyhook;
		274	static AV *coro_ready [PRIO_MAX-PRIO_MIN+1];
		275	static int coro_nready;
		276	static struct coro *coro_first;
		277
		278	/ lowlevel stuff ********************************************************/
		279
		280	static SV *
		281	coro_get_sv (pTHX_ const char *name, int create)
52	{	282	{
53	AV *av;	283	#if PERL_VERSION_ATLEAST (5,10,0)
54	I32 ix;	284	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
55	AV protopad_name = (AV ) * av_fetch (protopadlist, 0, FALSE);	285	get_sv (name, create);
56	AV protopad = (AV ) * av_fetch (protopadlist, 1, FALSE);	286	#endif
57	SV **pname = AvARRAY (protopad_name);	287	return get_sv (name, create);
58	SV **ppad = AvARRAY (protopad);	288	}
59	I32 fname = AvFILLp (protopad_name);	289
60	I32 fpad = AvFILLp (protopad);	290	static AV *
		291	coro_get_av (pTHX_ const char *name, int create)
		292	{
		293	#if PERL_VERSION_ATLEAST (5,10,0)
		294	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
		295	get_av (name, create);
		296	#endif
		297	return get_av (name, create);
		298	}
		299
		300	static HV *
		301	coro_get_hv (pTHX_ const char *name, int create)
		302	{
		303	#if PERL_VERSION_ATLEAST (5,10,0)
		304	/* silence stupid and wrong 5.10 warning that I am unable to switch off */
		305	get_hv (name, create);
		306	#endif
		307	return get_hv (name, create);
		308	}
		309
		310	static AV *
		311	coro_clone_padlist (pTHX_ CV *cv)
		312	{
		313	AV *padlist = CvPADLIST (cv);
61	AV newpadlist, newpad_name, *newpad;	314	AV newpadlist, newpad;
62	SV **npad;
63
64	newpad_name = newAV ();
65	for (ix = fname; ix >= 0; ix--)
66	av_store (newpad_name, ix, SvREFCNT_inc (pname[ix]));
67
68	newpad = newAV ();
69	av_fill (newpad, AvFILLp (protopad));
70	npad = AvARRAY (newpad);
71		315
72	newpadlist = newAV ();	316	newpadlist = newAV ();
73	AvREAL_off (newpadlist);	317	AvREAL_off (newpadlist);
74	av_store (newpadlist, 0, (SV *) newpad_name);	318	#if PERL_VERSION_ATLEAST (5,10,0)
		319	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
		320	#else
		321	Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
		322	#endif
		323	newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
		324	--AvFILLp (padlist);
		325
		326	av_store (newpadlist, 0, SvREFCNT_inc (*av_fetch (padlist, 0, FALSE)));
75	av_store (newpadlist, 1, (SV *) newpad);	327	av_store (newpadlist, 1, (SV *)newpad);
76		328
77	av = newAV (); /* will be @_ */	329	return newpadlist;
78	av_extend (av, 0);	330	}
79	av_store (newpad, 0, (SV *) av);
80	AvFLAGS (av) = AVf_REIFY;
81		331
82	for (ix = fpad; ix > 0; ix--)	332	static void
		333	free_padlist (pTHX_ AV *padlist)
		334	{
		335	/* may be during global destruction */
		336	if (SvREFCNT (padlist))
83	{	337	{
84	SV *namesv = (ix <= fname) ? pname[ix] : Nullsv;	338	I32 i = AvFILLp (padlist);
85	if (namesv && namesv != &PL_sv_undef)	339	while (i >= 0)
86	{	340	{
87	char name = SvPVX (namesv); / XXX */	341	SV **svp = av_fetch (padlist, i--, FALSE);
88	if (SvFLAGS (namesv) & SVf_FAKE \|\| *name == '&')	342	if (svp)
89	{ /* lexical from outside? */
90	npad[ix] = SvREFCNT_inc (ppad[ix]);
91	}	343	{
92	else
93	{ /* our own lexical */
94	SV *sv;	344	SV *sv;
95	if (*name == '&')	345	while (&PL_sv_undef != (sv = av_pop ((AV )svp)))
96	sv = SvREFCNT_inc (ppad[ix]);	346	SvREFCNT_dec (sv);
97	else if (*name == '@')	347
98	sv = (SV *) newAV ();	348	SvREFCNT_dec (*svp);
99	else if (*name == '%')
100	sv = (SV *) newHV ();
101	else
102	sv = NEWSV (0, 0);
103	if (!SvPADBUSY (sv))
104	SvPADMY_on (sv);
105	npad[ix] = sv;
106	}	349	}
107	}	350	}
108	else if (IS_PADGV (ppad[ix]) \|\| IS_PADCONST (ppad[ix]))
109	{
110	npad[ix] = SvREFCNT_inc (ppad[ix]);
111	}
112	else
113	{
114	SV *sv = NEWSV (0, 0);
115	SvPADTMP_on (sv);
116	npad[ix] = sv;
117	}
118	}
119		351
120	#if 0 /* NONOTUNDERSTOOD */
121	/* Now that vars are all in place, clone nested closures. */
122
123	for (ix = fpad; ix > 0; ix--) {
124	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
125	if (namesv
126	&& namesv != &PL_sv_undef
127	&& !(SvFLAGS(namesv) & SVf_FAKE)
128	&& *SvPVX(namesv) == '&'
129	&& CvCLONE(ppad[ix]))
130	{
131	CV kid = cv_clone((CV)ppad[ix]);
132	SvREFCNT_dec(ppad[ix]);
133	CvCLONE_on(kid);
134	SvPADMY_on(kid);
135	npad[ix] = (SV*)kid;
136	}
137	}
138	#endif
139
140	return newpadlist;
141	}
142
143	STATIC AV *
144	free_padlist (AV *padlist)
145	{
146	/* may be during global destruction */
147	if (SvREFCNT(padlist))
148	{
149	I32 i = AvFILLp(padlist);
150	while (i >= 0)
151	{
152	SV **svp = av_fetch(padlist, i--, FALSE);
153	SV sv = svp ? svp : Nullsv;
154	if (sv)
155	SvREFCNT_dec(sv);
156	}
157
158	SvREFCNT_dec((SV*)padlist);	352	SvREFCNT_dec ((SV*)padlist);
		353	}
		354	}
		355
		356	static int
		357	coro_cv_free (pTHX_ SV sv, MAGIC mg)
		358	{
		359	AV *padlist;
		360	AV av = (AV )mg->mg_obj;
		361
		362	/* casting is fun. */
		363	while (&PL_sv_undef != (SV )(padlist = (AV )av_pop (av)))
		364	free_padlist (aTHX_ padlist);
		365
		366	return 0;
		367	}
		368
		369	#define CORO_MAGIC_type_cv PERL_MAGIC_ext
		370	#define CORO_MAGIC_type_state PERL_MAGIC_ext
		371
		372	static MGVTBL coro_cv_vtbl = {
		373	0, 0, 0, 0,
		374	coro_cv_free
		375	};
		376
		377	#define CORO_MAGIC(sv,type) \
		378	SvMAGIC (sv) \
		379	? SvMAGIC (sv)->mg_type == type \
		380	? SvMAGIC (sv) \
		381	: mg_find (sv, type) \
		382	: 0
		383
		384	#define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv)
		385	#define CORO_MAGIC_state(sv) CORO_MAGIC (((SV *)(sv)), CORO_MAGIC_type_state)
		386
		387	static struct coro *
		388	SvSTATE_ (pTHX_ SV *coro)
		389	{
		390	HV *stash;
		391	MAGIC *mg;
		392
		393	if (SvROK (coro))
		394	coro = SvRV (coro);
		395
		396	if (expect_false (SvTYPE (coro) != SVt_PVHV))
		397	croak ("Coro::State object required");
		398
		399	stash = SvSTASH (coro);
		400	if (expect_false (stash != coro_stash && stash != coro_state_stash))
		401	{
		402	/* very slow, but rare, check */
		403	if (!sv_derived_from (sv_2mortal (newRV_inc (coro)), "Coro::State"))
		404	croak ("Coro::State object required");
		405	}
		406
		407	mg = CORO_MAGIC_state (coro);
		408	return (struct coro *)mg->mg_ptr;
		409	}
		410
		411	#define SvSTATE(sv) SvSTATE_ (aTHX_ (sv))
		412
		413	/* the next two functions merely cache the padlists */
		414	static void
		415	get_padlist (pTHX_ CV *cv)
		416	{
		417	MAGIC *mg = CORO_MAGIC_cv (cv);
		418	AV *av;
		419
		420	if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0))
		421	CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
		422	else
		423	{
		424	#if CORO_PREFER_PERL_FUNCTIONS
		425	/* this is probably cleaner, but also slower? */
		426	CV *cp = Perl_cv_clone (cv);
		427	CvPADLIST (cv) = CvPADLIST (cp);
		428	CvPADLIST (cp) = 0;
		429	SvREFCNT_dec (cp);
		430	#else
		431	CvPADLIST (cv) = coro_clone_padlist (aTHX_ cv);
		432	#endif
		433	}
		434	}
		435
		436	static void
		437	put_padlist (pTHX_ CV *cv)
		438	{
		439	MAGIC *mg = CORO_MAGIC_cv (cv);
		440	AV *av;
		441
		442	if (expect_false (!mg))
		443	mg = sv_magicext ((SV )cv, (SV )newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
		444
		445	av = (AV *)mg->mg_obj;
		446
		447	if (expect_false (AvFILLp (av) >= AvMAX (av)))
		448	av_extend (av, AvMAX (av) + 1);
		449
		450	AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
		451	}
		452
		453	/ load & save, init *****************************************************/
		454
		455	static void
		456	load_perl (pTHX_ Coro__State c)
		457	{
		458	perl_slots *slot = c->slot;
		459	c->slot = 0;
		460
		461	PL_mainstack = c->mainstack;
		462
		463	GvSV (PL_defgv) = slot->defsv;
		464	GvAV (PL_defgv) = slot->defav;
		465	GvSV (PL_errgv) = slot->errsv;
		466	GvSV (irsgv) = slot->irsgv;
		467
		468	#define VAR(name,type) PL_ ## name = slot->name;
		469	# include "state.h"
		470	#undef VAR
		471
		472	{
		473	dSP;
		474
		475	CV *cv;
		476
		477	/* now do the ugly restore mess */
		478	while (expect_true (cv = (CV *)POPs))
		479	{
		480	put_padlist (aTHX_ cv); /* mark this padlist as available */
		481	CvDEPTH (cv) = PTR2IV (POPs);
		482	CvPADLIST (cv) = (AV *)POPs;
		483	}
		484
		485	PUTBACK;
159	}	486	}
160	}	487	}
161		488
162	/* the next tow functions merely cache the padlists */
163	STATIC void
164	get_padlist (CV *cv)
165	{
166	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 0);
167
168	if (he && AvFILLp ((AV )he) >= 0)
169	CvPADLIST (cv) = (AV )av_pop ((AV )*he);
170	else
171	CvPADLIST (cv) = clone_padlist (CvPADLIST (cv));
172	}
173
174	STATIC void
175	put_padlist (CV *cv)
176	{
177	SV *he = hv_fetch (padlist_cache, (void )&cv, sizeof (CV *), 1);
178
179	if (SvTYPE (*he) != SVt_PVAV)
180	{
181	SvREFCNT_dec (*he);
182	he = (SV )newAV ();
183	}
184
185	av_push ((AV )he, (SV *)CvPADLIST (cv));
186	}
187
188	static void	489	static void
189	save_state(pTHX_ Coro__State c)	490	save_perl (pTHX_ Coro__State c)
190	{	491	{
191	{	492	{
192	dSP;	493	dSP;
193	I32 cxix = cxstack_ix;	494	I32 cxix = cxstack_ix;
		495	PERL_CONTEXT *ccstk = cxstack;
194	PERL_SI *top_si = PL_curstackinfo;	496	PERL_SI *top_si = PL_curstackinfo;
195	PERL_CONTEXT *ccstk = cxstack;
196		497
197	/*	498	/*
198	* the worst thing you can imagine happens first - we have to save	499	* the worst thing you can imagine happens first - we have to save
199	* (and reinitialize) all cv's in the whole callchain :(	500	* (and reinitialize) all cv's in the whole callchain :(
200	*/	501	*/
201		502
202	PUSHs (Nullsv);	503	XPUSHs (Nullsv);
203	/* this loop was inspired by pp_caller */	504	/* this loop was inspired by pp_caller */
204	for (;;)	505	for (;;)
205	{	506	{
206	while (cxix >= 0)	507	while (expect_true (cxix >= 0))
207	{	508	{
208	PERL_CONTEXT *cx = &ccstk[cxix--];	509	PERL_CONTEXT *cx = &ccstk[cxix--];
209		510
210	if (CxTYPE(cx) == CXt_SUB)	511	if (expect_true (CxTYPE (cx) == CXt_SUB \|\| CxTYPE (cx) == CXt_FORMAT))
211	{	512	{
212	CV *cv = cx->blk_sub.cv;	513	CV *cv = cx->blk_sub.cv;
		514
213	if (CvDEPTH(cv))	515	if (expect_true (CvDEPTH (cv)))
214	{	516	{
215	#ifdef USE_THREADS
216	XPUSHs ((SV *)CvOWNER(cv));
217	#endif
218	EXTEND (SP, 3);	517	EXTEND (SP, 3);
219	PUSHs ((SV *)CvDEPTH(cv));
220	PUSHs ((SV *)CvPADLIST(cv));	518	PUSHs ((SV *)CvPADLIST (cv));
		519	PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
221	PUSHs ((SV *)cv);	520	PUSHs ((SV *)cv);
222		521
223	get_padlist (cv);
224
225	CvDEPTH(cv) = 0;	522	CvDEPTH (cv) = 0;
226	#ifdef USE_THREADS	523	get_padlist (aTHX_ cv);
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	}	524	}
233	}	525	}
234	else if (CxTYPE(cx) == CXt_FORMAT)
235	{
236	/* I never used formats, so how should I know how these are implemented? */
237	/* my bold guess is as a simple, plain sub... */
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");
239	}
240	}	526	}
241		527
242	if (top_si->si_type == PERLSI_MAIN)	528	if (expect_true (top_si->si_type == PERLSI_MAIN))
243	break;	529	break;
244		530
245	top_si = top_si->si_prev;	531	top_si = top_si->si_prev;
246	ccstk = top_si->si_cxstack;	532	ccstk = top_si->si_cxstack;
247	cxix = top_si->si_cxix;	533	cxix = top_si->si_cxix;
248	}	534	}
249		535
250	PUTBACK;	536	PUTBACK;
251	}	537	}
252		538
253	c->dowarn = PL_dowarn;	539	/* allocate some space on the context stack for our purposes */
254	c->defav = GvAV (PL_defgv);	540	/* we manually unroll here, as usually 2 slots is enough */
255	c->curstackinfo = PL_curstackinfo;	541	if (SLOT_COUNT >= 1) CXINC;
256	c->curstack = PL_curstack;	542	if (SLOT_COUNT >= 2) CXINC;
		543	if (SLOT_COUNT >= 3) CXINC;
		544	{
		545	int i;
		546	for (i = 3; i < SLOT_COUNT; ++i)
		547	CXINC;
		548	}
		549	cxstack_ix -= SLOT_COUNT; /* undo allocation */
		550
257	c->mainstack = PL_mainstack;	551	c->mainstack = PL_mainstack;
258	c->stack_sp = PL_stack_sp;
259	c->op = PL_op;
260	c->curpad = PL_curpad;
261	c->stack_base = PL_stack_base;
262	c->stack_max = PL_stack_max;
263	c->tmps_stack = PL_tmps_stack;
264	c->tmps_floor = PL_tmps_floor;
265	c->tmps_ix = PL_tmps_ix;
266	c->tmps_max = PL_tmps_max;
267	c->markstack = PL_markstack;
268	c->markstack_ptr = PL_markstack_ptr;
269	c->markstack_max = PL_markstack_max;
270	c->scopestack = PL_scopestack;
271	c->scopestack_ix = PL_scopestack_ix;
272	c->scopestack_max = PL_scopestack_max;
273	c->savestack = PL_savestack;
274	c->savestack_ix = PL_savestack_ix;
275	c->savestack_max = PL_savestack_max;
276	c->retstack = PL_retstack;
277	c->retstack_ix = PL_retstack_ix;
278	c->retstack_max = PL_retstack_max;
279	c->curcop = PL_curcop;
280	}
281		552
282	#define LOAD(state) do { load_state(aTHX_ state); SPAGAIN; } while (0)	553	{
283	#define SAVE(state) do { PUTBACK; save_state(aTHX_ state); } while (0)	554	perl_slots slot = c->slot = (perl_slots )(cxstack + cxstack_ix + 1);
284		555
		556	slot->defav = GvAV (PL_defgv);
		557	slot->defsv = DEFSV;
		558	slot->errsv = ERRSV;
		559	slot->irsgv = GvSV (irsgv);
		560
		561	#define VAR(name,type) slot->name = PL_ ## name;
		562	# include "state.h"
		563	#undef VAR
		564	}
		565	}
		566
		567	/*
		568	* allocate various perl stacks. This is an exact copy
		569	* of perl.c:init_stacks, except that it uses less memory
		570	* on the (sometimes correct) assumption that coroutines do
		571	* not usually need a lot of stackspace.
		572	*/
		573	#if CORO_PREFER_PERL_FUNCTIONS
		574	# define coro_init_stacks init_stacks
		575	#else
285	static void	576	static void
286	load_state(pTHX_ Coro__State c)	577	coro_init_stacks (pTHX)
287	{	578	{
288	PL_dowarn = c->dowarn;
289	GvAV (PL_defgv) = c->defav;
290	PL_curstackinfo = c->curstackinfo;	579	PL_curstackinfo = new_stackinfo(32, 8);
291	PL_curstack = c->curstack;	580	PL_curstackinfo->si_type = PERLSI_MAIN;
292	PL_mainstack = c->mainstack;	581	PL_curstack = PL_curstackinfo->si_stack;
		582	PL_mainstack = PL_curstack; /* remember in case we switch stacks */
		583
		584	PL_stack_base = AvARRAY(PL_curstack);
293	PL_stack_sp = c->stack_sp;	585	PL_stack_sp = PL_stack_base;
294	PL_op = c->op;	586	PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
295	PL_curpad = c->curpad;	587
296	PL_stack_base = c->stack_base;	588	New(50,PL_tmps_stack,32,SV*);
297	PL_stack_max = c->stack_max;	589	PL_tmps_floor = -1;
298	PL_tmps_stack = c->tmps_stack;	590	PL_tmps_ix = -1;
299	PL_tmps_floor = c->tmps_floor;	591	PL_tmps_max = 32;
300	PL_tmps_ix = c->tmps_ix;	592
301	PL_tmps_max = c->tmps_max;	593	New(54,PL_markstack,16,I32);
302	PL_markstack = c->markstack;
303	PL_markstack_ptr = c->markstack_ptr;	594	PL_markstack_ptr = PL_markstack;
304	PL_markstack_max = c->markstack_max;	595	PL_markstack_max = PL_markstack + 16;
305	PL_scopestack = c->scopestack;	596
306	PL_scopestack_ix = c->scopestack_ix;	597	#ifdef SET_MARK_OFFSET
307	PL_scopestack_max = c->scopestack_max;	598	SET_MARK_OFFSET;
308	PL_savestack = c->savestack;	599	#endif
309	PL_savestack_ix = c->savestack_ix;	600
310	PL_savestack_max = c->savestack_max;	601	New(54,PL_scopestack,8,I32);
311	PL_retstack = c->retstack;	602	PL_scopestack_ix = 0;
312	PL_retstack_ix = c->retstack_ix;	603	PL_scopestack_max = 8;
313	PL_retstack_max = c->retstack_max;	604
314	PL_curcop = c->curcop;	605	New(54,PL_savestack,24,ANY);
		606	PL_savestack_ix = 0;
		607	PL_savestack_max = 24;
		608
		609	#if !PERL_VERSION_ATLEAST (5,10,0)
		610	New(54,PL_retstack,4,OP*);
		611	PL_retstack_ix = 0;
		612	PL_retstack_max = 4;
		613	#endif
		614	}
		615	#endif
		616
		617	/*
		618	* destroy the stacks, the callchain etc...
		619	*/
		620	static void
		621	coro_destroy_stacks (pTHX)
		622	{
		623	while (PL_curstackinfo->si_next)
		624	PL_curstackinfo = PL_curstackinfo->si_next;
		625
		626	while (PL_curstackinfo)
		627	{
		628	PERL_SI *p = PL_curstackinfo->si_prev;
		629
		630	if (!IN_DESTRUCT)
		631	SvREFCNT_dec (PL_curstackinfo->si_stack);
		632
		633	Safefree (PL_curstackinfo->si_cxstack);
		634	Safefree (PL_curstackinfo);
		635	PL_curstackinfo = p;
		636	}
		637
		638	Safefree (PL_tmps_stack);
		639	Safefree (PL_markstack);
		640	Safefree (PL_scopestack);
		641	Safefree (PL_savestack);
		642	#if !PERL_VERSION_ATLEAST (5,10,0)
		643	Safefree (PL_retstack);
		644	#endif
		645	}
		646
		647	static size_t
		648	coro_rss (pTHX_ struct coro *coro)
		649	{
		650	size_t rss = sizeof (*coro);
		651
		652	if (coro->mainstack)
		653	{
		654	perl_slots tmp_slot;
		655	perl_slots *slot;
		656
		657	if (coro->flags & CF_RUNNING)
		658	{
		659	slot = &tmp_slot;
		660
		661	#define VAR(name,type) slot->name = PL_ ## name;
		662	# include "state.h"
		663	#undef VAR
		664	}
		665	else
		666	slot = coro->slot;
		667
		668	rss += sizeof (slot->curstackinfo);
		669	rss += (slot->curstackinfo->si_cxmax + 1) * sizeof (PERL_CONTEXT);
		670	rss += sizeof (SV) + sizeof (struct xpvav) + (1 + AvMAX (slot->curstack)) * sizeof (SV *);
		671	rss += slot->tmps_max * sizeof (SV *);
		672	rss += (slot->markstack_max - slot->markstack_ptr) * sizeof (I32);
		673	rss += slot->scopestack_max * sizeof (I32);
		674	rss += slot->savestack_max * sizeof (ANY);
		675
		676	#if !PERL_VERSION_ATLEAST (5,10,0)
		677	rss += slot->retstack_max * sizeof (OP *);
		678	#endif
		679	}
		680
		681	return rss;
		682	}
		683
		684	/ coroutine stack handling **********************************************/
		685
		686	static int (orig_sigelem_get) (pTHX_ SV sv, MAGIC *mg);
		687	static int (orig_sigelem_set) (pTHX_ SV sv, MAGIC *mg);
		688
		689	/*
		690	* This overrides the default magic get method of %SIG elements.
		691	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook
		692	* and instead of tryign to save and restore the hash elements, we just provide
		693	* readback here.
		694	* We only do this when the hook is != 0, as they are often set to 0 temporarily,
		695	* not expecting this to actually change the hook. This is a potential problem
		696	* when a schedule happens then, but we ignore this.
		697	*/
		698	static int
		699	coro_sigelem_get (pTHX_ SV sv, MAGIC mg)
		700	{
		701	const char *s = MgPV_nolen_const (mg);
		702
		703	if (*s == '_')
		704	{
		705	if (strEQ (s, "__DIE__" ) && PL_diehook ) return sv_setsv (sv, PL_diehook ), 0;
		706	if (strEQ (s, "__WARN__") && PL_warnhook) return sv_setsv (sv, PL_warnhook), 0;
		707	}
		708
		709	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
		710	}
		711
		712	static int
		713	coro_sigelem_set (pTHX_ SV sv, MAGIC mg)
		714	{
		715	const char *s = MgPV_nolen_const (mg);
		716
		717	if (*s == '_')
		718	{
		719	SV **svp = 0;
		720
		721	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		722	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		723
		724	if (svp)
		725	{
		726	SV old = svp;
		727	*svp = newSVsv (sv);
		728	SvREFCNT_dec (old);
		729	return 0;
		730	}
		731	}
		732
		733	return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
		734	}
		735
		736	static void
		737	coro_setup (pTHX_ struct coro *coro)
		738	{
		739	/*
		740	* emulate part of the perl startup here.
		741	*/
		742	coro_init_stacks (aTHX);
		743
		744	PL_runops = RUNOPS_DEFAULT;
		745	PL_curcop = &PL_compiling;
		746	PL_in_eval = EVAL_NULL;
		747	PL_comppad = 0;
		748	PL_curpm = 0;
		749	PL_curpad = 0;
		750	PL_localizing = 0;
		751	PL_dirty = 0;
		752	PL_restartop = 0;
		753	#if PERL_VERSION_ATLEAST (5,10,0)
		754	PL_parser = 0;
		755	#endif
		756
		757	/* recreate the die/warn hooks */
		758	PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
		759	PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
		760
		761	GvSV (PL_defgv) = newSV (0);
		762	GvAV (PL_defgv) = coro->args; coro->args = 0;
		763	GvSV (PL_errgv) = newSV (0);
		764	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
		765	PL_rs = newSVsv (GvSV (irsgv));
		766	PL_defoutgv = (GV *)SvREFCNT_inc (stdoutgv);
315		767
316	{	768	{
317	dSP;	769	dSP;
318	CV *cv;	770	LOGOP myop;
319		771
320	/* now do the ugly restore mess */	772	Zero (&myop, 1, LOGOP);
321	while ((cv = (CV *)POPs))	773	myop.op_next = Nullop;
322	{	774	myop.op_flags = OPf_WANT_VOID;
323	AV padlist = (AV )POPs;
324		775
325	put_padlist (cv);	776	PUSHMARK (SP);
326	CvPADLIST(cv) = padlist;	777	XPUSHs (sv_2mortal (av_shift (GvAV (PL_defgv))));
327	CvDEPTH(cv) = (I32)POPs;
328
329	#ifdef USE_THREADS
330	CvOWNER(cv) = (struct perl_thread *)POPs;
331	error does not work either
332	#endif
333	}
334
335	PUTBACK;	778	PUTBACK;
		779	PL_op = (OP *)&myop;
		780	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		781	SPAGAIN;
336	}	782	}
337	}
338		783
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	784	/* this newly created coroutine might be run on an existing cctx which most
340	STATIC void	785	* likely was suspended in set_stacklevel, called from entersub.
341	destroy_stacks(pTHX)	786	* set_stacklevl doesn't do anything on return, but entersub does LEAVE,
		787	* so we ENTER here for symmetry
		788	*/
		789	ENTER;
		790	}
		791
		792	static void
		793	coro_destroy (pTHX_ struct coro *coro)
342	{	794	{
343	/* die does this while calling POPSTACK, but I just don't see why. */	795	if (!IN_DESTRUCT)
344	/* OTOH, die does not have a memleak, but we do... */	796	{
		797	/* restore all saved variables and stuff */
		798	LEAVE_SCOPE (0);
		799	assert (PL_tmps_floor == -1);
		800
		801	/* free all temporaries */
		802	FREETMPS;
		803	assert (PL_tmps_ix == -1);
		804
		805	/* unwind all extra stacks */
		806	POPSTACK_TO (PL_mainstack);
		807
		808	/* unwind main stack */
345	dounwind(-1);	809	dounwind (-1);
346
347	/* is this ugly, I ask? */
348	while (PL_scopestack_ix)
349	LEAVE;
350
351	while (PL_curstackinfo->si_next)
352	PL_curstackinfo = PL_curstackinfo->si_next;
353
354	while (PL_curstackinfo)
355	{	810	}
356	PERL_SI *p = PL_curstackinfo->si_prev;
357		811
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	812	SvREFCNT_dec (GvSV (PL_defgv));
359	Safefree(PL_curstackinfo->si_cxstack);	813	SvREFCNT_dec (GvAV (PL_defgv));
360	Safefree(PL_curstackinfo);	814	SvREFCNT_dec (GvSV (PL_errgv));
361	PL_curstackinfo = p;	815	SvREFCNT_dec (PL_defoutgv);
		816	SvREFCNT_dec (PL_rs);
		817	SvREFCNT_dec (GvSV (irsgv));
		818
		819	SvREFCNT_dec (PL_diehook);
		820	SvREFCNT_dec (PL_warnhook);
362	}	821
		822	SvREFCNT_dec (coro->saved_deffh);
		823	SvREFCNT_dec (coro->throw);
363		824
364	if (PL_scopestack_ix != 0)	825	coro_destroy_stacks (aTHX);
365	Perl_warner(aTHX_ WARN_INTERNAL,	826	}
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	827
367	(long)PL_scopestack_ix);	828	static void
368	if (PL_savestack_ix != 0)	829	free_coro_mortal (pTHX)
369	Perl_warner(aTHX_ WARN_INTERNAL,	830	{
370	"Unbalanced saves: %ld more saves than restores\n",	831	if (expect_true (coro_mortal))
371	(long)PL_savestack_ix);	832	{
372	if (PL_tmps_floor != -1)	833	SvREFCNT_dec (coro_mortal);
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	834	coro_mortal = 0;
374	(long)PL_tmps_floor + 1);	835	}
		836	}
		837
		838	static int
		839	runops_trace (pTHX)
		840	{
		841	COP *oldcop = 0;
		842	int oldcxix = -2;
		843	struct coro coro = SvSTATE (coro_current); / trace cctx is tied to specific coro */
		844	coro_cctx *cctx = coro->cctx;
		845
		846	while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
		847	{
		848	PERL_ASYNC_CHECK ();
		849
		850	if (cctx->flags & CC_TRACE_ALL)
		851	{
		852	if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
		853	{
		854	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		855	SV bot, top;
		856	AV av = newAV (); / return values */
		857	SV **cb;
		858	dSP;
		859
		860	GV *gv = CvGV (cx->blk_sub.cv);
		861	SV *fullname = sv_2mortal (newSV (0));
		862	if (isGV (gv))
		863	gv_efullname3 (fullname, gv, 0);
		864
		865	bot = PL_stack_base + cx->blk_oldsp + 1;
		866	top = cx->blk_gimme == G_ARRAY ? SP + 1
		867	: cx->blk_gimme == G_SCALAR ? bot + 1
		868	: bot;
		869
		870	av_extend (av, top - bot);
		871	while (bot < top)
		872	av_push (av, SvREFCNT_inc (*bot++));
		873
		874	PL_runops = RUNOPS_DEFAULT;
		875	ENTER;
		876	SAVETMPS;
		877	EXTEND (SP, 3);
		878	PUSHMARK (SP);
		879	PUSHs (&PL_sv_no);
		880	PUSHs (fullname);
		881	PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		882	PUTBACK;
		883	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		884	if (cb) call_sv (*cb, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		885	SPAGAIN;
		886	FREETMPS;
		887	LEAVE;
		888	PL_runops = runops_trace;
		889	}
		890
		891	if (oldcop != PL_curcop)
		892	{
		893	oldcop = PL_curcop;
		894
		895	if (PL_curcop != &PL_compiling)
		896	{
		897	SV **cb;
		898
		899	if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
		900	{
		901	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		902
		903	if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
		904	{
		905	runops_proc_t old_runops = PL_runops;
		906	dSP;
		907	GV *gv = CvGV (cx->blk_sub.cv);
		908	SV *fullname = sv_2mortal (newSV (0));
		909
		910	if (isGV (gv))
		911	gv_efullname3 (fullname, gv, 0);
		912
		913	PL_runops = RUNOPS_DEFAULT;
		914	ENTER;
		915	SAVETMPS;
		916	EXTEND (SP, 3);
		917	PUSHMARK (SP);
		918	PUSHs (&PL_sv_yes);
		919	PUSHs (fullname);
		920	PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
		921	PUTBACK;
		922	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		923	if (cb) call_sv (*cb, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		924	SPAGAIN;
		925	FREETMPS;
		926	LEAVE;
		927	PL_runops = runops_trace;
		928	}
		929
		930	oldcxix = cxstack_ix;
		931	}
		932
		933	if (cctx->flags & CC_TRACE_LINE)
		934	{
		935	dSP;
		936
		937	PL_runops = RUNOPS_DEFAULT;
		938	ENTER;
		939	SAVETMPS;
		940	EXTEND (SP, 3);
		941	PL_runops = RUNOPS_DEFAULT;
		942	PUSHMARK (SP);
		943	PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
		944	PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
		945	PUTBACK;
		946	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
		947	if (cb) call_sv (*cb, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		948	SPAGAIN;
		949	FREETMPS;
		950	LEAVE;
		951	PL_runops = runops_trace;
		952	}
		953	}
		954	}
		955	}
		956	}
		957
		958	TAINT_NOT;
		959	return 0;
		960	}
		961
		962	/* inject a fake call to Coro::State::_cctx_init into the execution */
		963	/* _cctx_init should be careful, as it could be called at almost any time */
		964	/* during execution of a perl program */
		965	static void NOINLINE
		966	cctx_prepare (pTHX_ coro_cctx *cctx)
		967	{
		968	dSP;
		969	LOGOP myop;
		970
		971	PL_top_env = &PL_start_env;
		972
		973	if (cctx->flags & CC_TRACE)
		974	PL_runops = runops_trace;
		975
		976	Zero (&myop, 1, LOGOP);
		977	myop.op_next = PL_op;
		978	myop.op_flags = OPf_WANT_VOID \| OPf_STACKED;
		979
		980	PUSHMARK (SP);
		981	EXTEND (SP, 2);
		982	PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
		983	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
		984	PUTBACK;
		985	PL_op = (OP *)&myop;
		986	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		987	SPAGAIN;
		988	}
		989
		990	/*
		991	* this is a _very_ stripped down perl interpreter ;)
		992	*/
		993	static void
		994	cctx_run (void *arg)
		995	{
		996	dTHX;
		997
		998	/* cctx_run is the alternative tail of transfer(), so unlock here. */
		999	UNLOCK;
		1000
		1001	/* we now skip the entersub that lead to transfer() */
		1002	PL_op = PL_op->op_next;
		1003
		1004	/* inject a fake subroutine call to cctx_init */
		1005	cctx_prepare (aTHX_ (coro_cctx *)arg);
		1006
		1007	/* somebody or something will hit me for both perl_run and PL_restartop */
		1008	PL_restartop = PL_op;
		1009	perl_run (PL_curinterp);
		1010
375	/*	1011	/*
		1012	* If perl-run returns we assume exit() was being called or the coro
		1013	* fell off the end, which seems to be the only valid (non-bug)
		1014	* reason for perl_run to return. We try to exit by jumping to the
		1015	* bootstrap-time "top" top_env, as we cannot restore the "main"
		1016	* coroutine as Coro has no such concept
		1017	*/
		1018	PL_top_env = main_top_env;
		1019	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
		1020	}
		1021
		1022	static coro_cctx *
		1023	cctx_new ()
		1024	{
		1025	coro_cctx *cctx;
		1026	void *stack_start;
		1027	size_t stack_size;
		1028
		1029	++cctx_count;
		1030
		1031	Newz (0, cctx, 1, coro_cctx);
		1032
		1033	#if HAVE_MMAP
		1034	cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
		1035	/* mmap supposedly does allocate-on-write for us */
		1036	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		1037
		1038	if (cctx->sptr != (void *)-1)
		1039	{
		1040	# if CORO_STACKGUARD
		1041	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
		1042	# endif
		1043	stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
		1044	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
		1045	cctx->flags \|= CC_MAPPED;
		1046	}
		1047	else
		1048	#endif
		1049	{
		1050	cctx->ssize = coro_stacksize * (long)sizeof (long);
		1051	New (0, cctx->sptr, coro_stacksize, long);
		1052
		1053	if (!cctx->sptr)
		1054	{
		1055	perror ("FATAL: unable to allocate stack for coroutine");
		1056	_exit (EXIT_FAILURE);
		1057	}
		1058
		1059	stack_start = cctx->sptr;
		1060	stack_size = cctx->ssize;
		1061	}
		1062
		1063	REGISTER_STACK (cctx, (char )stack_start, (char )stack_start + stack_size);
		1064	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
		1065
		1066	return cctx;
		1067	}
		1068
		1069	static void
		1070	cctx_destroy (coro_cctx *cctx)
		1071	{
		1072	if (!cctx)
		1073	return;
		1074
		1075	--cctx_count;
		1076
		1077	#if CORO_USE_VALGRIND
		1078	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		1079	#endif
		1080
		1081	#if HAVE_MMAP
		1082	if (cctx->flags & CC_MAPPED)
		1083	munmap (cctx->sptr, cctx->ssize);
		1084	else
		1085	#endif
		1086	Safefree (cctx->sptr);
		1087
		1088	Safefree (cctx);
		1089	}
		1090
		1091	/* wether this cctx should be destructed */
		1092	#define CCTX_EXPIRED(cctx) ((cctx)->ssize < coro_stacksize \|\| ((cctx)->flags & CC_NOREUSE))
		1093
		1094	static coro_cctx *
		1095	cctx_get (pTHX)
		1096	{
		1097	while (expect_true (cctx_first))
		1098	{
		1099	coro_cctx *cctx = cctx_first;
		1100	cctx_first = cctx->next;
		1101	--cctx_idle;
		1102
		1103	if (expect_true (!CCTX_EXPIRED (cctx)))
		1104	return cctx;
		1105
		1106	cctx_destroy (cctx);
		1107	}
		1108
		1109	return cctx_new ();
		1110	}
		1111
		1112	static void
		1113	cctx_put (coro_cctx *cctx)
		1114	{
		1115	/* free another cctx if overlimit */
		1116	if (expect_false (cctx_idle >= MAX_IDLE_CCTX))
		1117	{
		1118	coro_cctx *first = cctx_first;
		1119	cctx_first = first->next;
		1120	--cctx_idle;
		1121
		1122	cctx_destroy (first);
		1123	}
		1124
		1125	++cctx_idle;
		1126	cctx->next = cctx_first;
		1127	cctx_first = cctx;
		1128	}
		1129
		1130	/ coroutine switching ***************************************************/
		1131
		1132	static void
		1133	transfer_check (pTHX_ struct coro prev, struct coro next)
		1134	{
		1135	if (expect_true (prev != next))
		1136	{
		1137	if (expect_false (!(prev->flags & (CF_RUNNING \| CF_NEW))))
		1138	croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
		1139
		1140	if (expect_false (next->flags & CF_RUNNING))
		1141	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		1142
		1143	if (expect_false (next->flags & CF_DESTROYED))
		1144	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		1145
		1146	#if !PERL_VERSION_ATLEAST (5,10,0)
		1147	if (expect_false (PL_lex_state != LEX_NOTPARSING))
		1148	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version");
		1149	#endif
		1150	}
		1151	}
		1152
		1153	/* always use the TRANSFER macro */
		1154	static void NOINLINE
		1155	transfer (pTHX_ struct coro prev, struct coro next, int force_cctx)
		1156	{
		1157	dSTACKLEVEL;
		1158	static volatile int has_throw;
		1159
		1160	/* sometimes transfer is only called to set idle_sp */
		1161	if (expect_false (!next))
		1162	{
		1163	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		1164	assert (((coro_cctx )prev)->idle_te = PL_top_env); / just for the side-effect when asserts are enabled */
		1165	}
		1166	else if (expect_true (prev != next))
		1167	{
		1168	coro_cctx *prev__cctx;
		1169
		1170	if (expect_false (prev->flags & CF_NEW))
		1171	{
		1172	/* create a new empty context */
		1173	Newz (0, prev->cctx, 1, coro_cctx);
		1174	prev->flags &= ~CF_NEW;
		1175	prev->flags \|= CF_RUNNING;
		1176	}
		1177
		1178	prev->flags &= ~CF_RUNNING;
		1179	next->flags \|= CF_RUNNING;
		1180
		1181	LOCK;
		1182
		1183	/* first get rid of the old state */
		1184	save_perl (aTHX_ prev);
		1185
		1186	if (expect_false (next->flags & CF_NEW))
		1187	{
		1188	/* need to start coroutine */
		1189	next->flags &= ~CF_NEW;
		1190	/* setup coroutine call */
		1191	coro_setup (aTHX_ next);
		1192	}
		1193	else
		1194	load_perl (aTHX_ next);
		1195
		1196	prev__cctx = prev->cctx;
		1197
		1198	/* possibly "free" the cctx */
		1199	if (expect_true (
		1200	prev__cctx->idle_sp == STACKLEVEL
		1201	&& !(prev__cctx->flags & CC_TRACE)
		1202	&& !force_cctx
		1203	))
		1204	{
		1205	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		1206	assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
		1207
		1208	prev->cctx = 0;
		1209
		1210	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
		1211	/* without this the next cctx_get might destroy the prev__cctx while still in use */
		1212	if (expect_false (CCTX_EXPIRED (prev__cctx)))
		1213	if (!next->cctx)
		1214	next->cctx = cctx_get (aTHX);
		1215
		1216	cctx_put (prev__cctx);
		1217	}
		1218
		1219	++next->usecount;
		1220
		1221	if (expect_true (!next->cctx))
		1222	next->cctx = cctx_get (aTHX);
		1223
		1224	has_throw = !!next->throw;
		1225
		1226	if (expect_false (prev__cctx != next->cctx))
		1227	{
		1228	prev__cctx->top_env = PL_top_env;
		1229	PL_top_env = next->cctx->top_env;
		1230	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		1231	}
		1232
		1233	free_coro_mortal (aTHX);
		1234	UNLOCK;
		1235
		1236	if (expect_false (has_throw))
		1237	{
		1238	struct coro *coro = SvSTATE (coro_current);
		1239
		1240	if (coro->throw)
376	*/	1241	{
377	Safefree(PL_tmps_stack);	1242	SV *exception = coro->throw;
378	Safefree(PL_markstack);	1243	coro->throw = 0;
379	Safefree(PL_scopestack);	1244	sv_setsv (ERRSV, exception);
380	Safefree(PL_savestack);	1245	croak (0);
381	Safefree(PL_retstack);	1246	}
		1247	}
		1248	}
382	}	1249	}
383		1250
384	#define SUB_INIT "Coro::State::_newcoro"	1251	struct transfer_args
		1252	{
		1253	struct coro prev, next;
		1254	};
385		1255
		1256	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
		1257	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
		1258
		1259	/ high level stuff ******************************************************/
		1260
		1261	static int
		1262	coro_state_destroy (pTHX_ struct coro *coro)
		1263	{
		1264	if (coro->flags & CF_DESTROYED)
		1265	return 0;
		1266
		1267	coro->flags \|= CF_DESTROYED;
		1268
		1269	if (coro->flags & CF_READY)
		1270	{
		1271	/* reduce nready, as destroying a ready coro effectively unreadies it */
		1272	/* alternative: look through all ready queues and remove the coro */
		1273	LOCK;
		1274	--coro_nready;
		1275	UNLOCK;
		1276	}
		1277	else
		1278	coro->flags \|= CF_READY; /* make sure it is NOT put into the readyqueue */
		1279
		1280	if (coro->mainstack && coro->mainstack != main_mainstack)
		1281	{
		1282	struct coro temp;
		1283
		1284	if (coro->flags & CF_RUNNING)
		1285	croak ("FATAL: tried to destroy currently running coroutine");
		1286
		1287	save_perl (aTHX_ &temp);
		1288	load_perl (aTHX_ coro);
		1289
		1290	coro_destroy (aTHX_ coro);
		1291
		1292	load_perl (aTHX_ &temp);
		1293
		1294	coro->slot = 0;
		1295	}
		1296
		1297	cctx_destroy (coro->cctx);
		1298	SvREFCNT_dec (coro->args);
		1299
		1300	if (coro->next) coro->next->prev = coro->prev;
		1301	if (coro->prev) coro->prev->next = coro->next;
		1302	if (coro == coro_first) coro_first = coro->next;
		1303
		1304	return 1;
		1305	}
		1306
		1307	static int
		1308	coro_state_free (pTHX_ SV sv, MAGIC mg)
		1309	{
		1310	struct coro coro = (struct coro )mg->mg_ptr;
		1311	mg->mg_ptr = 0;
		1312
		1313	coro->hv = 0;
		1314
		1315	if (--coro->refcnt < 0)
		1316	{
		1317	coro_state_destroy (aTHX_ coro);
		1318	Safefree (coro);
		1319	}
		1320
		1321	return 0;
		1322	}
		1323
		1324	static int
		1325	coro_state_dup (pTHX_ MAGIC mg, CLONE_PARAMS params)
		1326	{
		1327	struct coro coro = (struct coro )mg->mg_ptr;
		1328
		1329	++coro->refcnt;
		1330
		1331	return 0;
		1332	}
		1333
		1334	static MGVTBL coro_state_vtbl = {
		1335	0, 0, 0, 0,
		1336	coro_state_free,
		1337	0,
		1338	#ifdef MGf_DUP
		1339	coro_state_dup,
		1340	#else
		1341	# define MGf_DUP 0
		1342	#endif
		1343	};
		1344
		1345	static void
		1346	prepare_transfer (pTHX_ struct transfer_args ta, SV prev_sv, SV *next_sv)
		1347	{
		1348	ta->prev = SvSTATE (prev_sv);
		1349	ta->next = SvSTATE (next_sv);
		1350	TRANSFER_CHECK (*ta);
		1351	}
		1352
		1353	static void
		1354	api_transfer (SV prev_sv, SV next_sv)
		1355	{
		1356	dTHX;
		1357	struct transfer_args ta;
		1358
		1359	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
		1360	TRANSFER (ta, 1);
		1361	}
		1362
		1363	/ Coro ******************************************************************/
		1364
		1365	static void
		1366	coro_enq (pTHX_ SV *coro_sv)
		1367	{
		1368	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		1369	}
		1370
		1371	static SV *
		1372	coro_deq (pTHX)
		1373	{
		1374	int prio;
		1375
		1376	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
		1377	if (AvFILLp (coro_ready [prio]) >= 0)
		1378	return av_shift (coro_ready [prio]);
		1379
		1380	return 0;
		1381	}
		1382
		1383	static int
		1384	api_ready (SV *coro_sv)
		1385	{
		1386	dTHX;
		1387	struct coro *coro;
		1388	SV *hook;
		1389
		1390	if (SvROK (coro_sv))
		1391	coro_sv = SvRV (coro_sv);
		1392
		1393	coro = SvSTATE (coro_sv);
		1394
		1395	if (coro->flags & CF_READY)
		1396	return 0;
		1397
		1398	coro->flags \|= CF_READY;
		1399
		1400	LOCK;
		1401
		1402	hook = coro_nready ? 0 : coro_readyhook;
		1403
		1404	coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
		1405	++coro_nready;
		1406
		1407	UNLOCK;
		1408
		1409	if (hook)
		1410	{
		1411	dSP;
		1412
		1413	ENTER;
		1414	SAVETMPS;
		1415
		1416	PUSHMARK (SP);
		1417	PUTBACK;
		1418	call_sv (hook, G_DISCARD);
		1419	SPAGAIN;
		1420
		1421	FREETMPS;
		1422	LEAVE;
		1423	}
		1424
		1425	return 1;
		1426	}
		1427
		1428	static int
		1429	api_is_ready (SV *coro_sv)
		1430	{
		1431	dTHX;
		1432	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		1433	}
		1434
		1435	static void
		1436	prepare_schedule (pTHX_ struct transfer_args *ta)
		1437	{
		1438	SV prev_sv, next_sv;
		1439
		1440	for (;;)
		1441	{
		1442	LOCK;
		1443	next_sv = coro_deq (aTHX);
		1444
		1445	/* nothing to schedule: call the idle handler */
		1446	if (expect_false (!next_sv))
		1447	{
		1448	dSP;
		1449	UNLOCK;
		1450
		1451	ENTER;
		1452	SAVETMPS;
		1453
		1454	PUSHMARK (SP);
		1455	PUTBACK;
		1456	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1457	SPAGAIN;
		1458
		1459	FREETMPS;
		1460	LEAVE;
		1461	continue;
		1462	}
		1463
		1464	ta->next = SvSTATE (next_sv);
		1465
		1466	/* cannot transfer to destroyed coros, skip and look for next */
		1467	if (expect_false (ta->next->flags & CF_DESTROYED))
		1468	{
		1469	UNLOCK;
		1470	SvREFCNT_dec (next_sv);
		1471	/* coro_nready is already taken care of by destroy */
		1472	continue;
		1473	}
		1474
		1475	--coro_nready;
		1476	UNLOCK;
		1477	break;
		1478	}
		1479
		1480	/* free this only after the transfer */
		1481	prev_sv = SvRV (coro_current);
		1482	ta->prev = SvSTATE (prev_sv);
		1483	TRANSFER_CHECK (*ta);
		1484	assert (ta->next->flags & CF_READY);
		1485	ta->next->flags &= ~CF_READY;
		1486	SvRV_set (coro_current, next_sv);
		1487
		1488	LOCK;
		1489	free_coro_mortal (aTHX);
		1490	coro_mortal = prev_sv;
		1491	UNLOCK;
		1492	}
		1493
		1494	static void
		1495	prepare_cede (pTHX_ struct transfer_args *ta)
		1496	{
		1497	api_ready (coro_current);
		1498	prepare_schedule (aTHX_ ta);
		1499	}
		1500
		1501	static int
		1502	prepare_cede_notself (pTHX_ struct transfer_args *ta)
		1503	{
		1504	if (coro_nready)
		1505	{
		1506	SV *prev = SvRV (coro_current);
		1507	prepare_schedule (aTHX_ ta);
		1508	api_ready (prev);
		1509	return 1;
		1510	}
		1511	else
		1512	return 0;
		1513	}
		1514
		1515	static void
		1516	api_schedule (void)
		1517	{
		1518	dTHX;
		1519	struct transfer_args ta;
		1520
		1521	prepare_schedule (aTHX_ &ta);
		1522	TRANSFER (ta, 1);
		1523	}
		1524
		1525	static int
		1526	api_cede (void)
		1527	{
		1528	dTHX;
		1529	struct transfer_args ta;
		1530
		1531	prepare_cede (aTHX_ &ta);
		1532
		1533	if (expect_true (ta.prev != ta.next))
		1534	{
		1535	TRANSFER (ta, 1);
		1536	return 1;
		1537	}
		1538	else
		1539	return 0;
		1540	}
		1541
		1542	static int
		1543	api_cede_notself (void)
		1544	{
		1545	dTHX;
		1546	struct transfer_args ta;
		1547
		1548	if (prepare_cede_notself (aTHX_ &ta))
		1549	{
		1550	TRANSFER (ta, 1);
		1551	return 1;
		1552	}
		1553	else
		1554	return 0;
		1555	}
		1556
		1557	static void
		1558	api_trace (SV *coro_sv, int flags)
		1559	{
		1560	dTHX;
		1561	struct coro *coro = SvSTATE (coro_sv);
		1562
		1563	if (flags & CC_TRACE)
		1564	{
		1565	if (!coro->cctx)
		1566	coro->cctx = cctx_new ();
		1567	else if (!(coro->cctx->flags & CC_TRACE))
		1568	croak ("cannot enable tracing on coroutine with custom stack");
		1569
		1570	coro->cctx->flags \|= CC_NOREUSE \| (flags & (CC_TRACE \| CC_TRACE_ALL));
		1571	}
		1572	else if (coro->cctx && coro->cctx->flags & CC_TRACE)
		1573	{
		1574	coro->cctx->flags &= ~(CC_TRACE \| CC_TRACE_ALL);
		1575
		1576	if (coro->flags & CF_RUNNING)
		1577	PL_runops = RUNOPS_DEFAULT;
		1578	else
		1579	coro->slot->runops = RUNOPS_DEFAULT;
		1580	}
		1581	}
		1582
386	MODULE = Coro::State PACKAGE = Coro::State	1583	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
387		1584
388	PROTOTYPES: ENABLE	1585	PROTOTYPES: DISABLE
389		1586
390	BOOT:	1587	BOOT:
391	if (!padlist_cache)	1588	{
392	padlist_cache = newHV ();	1589	#ifdef USE_ITHREADS
		1590	MUTEX_INIT (&coro_mutex);
		1591	#endif
		1592	BOOT_PAGESIZE;
393		1593
394	Coro::State	1594	irsgv = gv_fetchpv ("/" , GV_ADD\|GV_NOTQUAL, SVt_PV);
395	_newprocess(args)	1595	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD\|GV_NOTQUAL, SVt_PVIO);
396	SV * args	1596
397	PROTOTYPE: $	1597	orig_sigelem_get = PL_vtbl_sigelem.svt_get;
		1598	PL_vtbl_sigelem.svt_get = coro_sigelem_get;
		1599	orig_sigelem_set = PL_vtbl_sigelem.svt_set;
		1600	PL_vtbl_sigelem.svt_set = coro_sigelem_set;
		1601
		1602	hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
		1603	rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
		1604	rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
		1605
		1606	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		1607
		1608	newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
		1609	newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
		1610	newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
		1611	newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
		1612
		1613	main_mainstack = PL_mainstack;
		1614	main_top_env = PL_top_env;
		1615
		1616	while (main_top_env->je_prev)
		1617	main_top_env = main_top_env->je_prev;
		1618
		1619	coroapi.ver = CORO_API_VERSION;
		1620	coroapi.rev = CORO_API_REVISION;
		1621	coroapi.transfer = api_transfer;
		1622
		1623	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1624	}
		1625
		1626	SV *
		1627	new (char *klass, ...)
398	CODE:	1628	CODE:
399	Coro__State coro;	1629	{
		1630	struct coro *coro;
		1631	MAGIC *mg;
		1632	HV *hv;
		1633	int i;
400		1634
401	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
402	croak ("Coro::State::newprocess expects an arrayref");
403
404	New (0, coro, 1, struct coro);	1635	Newz (0, coro, 1, struct coro);
		1636	coro->args = newAV ();
		1637	coro->flags = CF_NEW;
405		1638
406	coro->mainstack = 0; /* actual work is done inside transfer */	1639	if (coro_first) coro_first->prev = coro;
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1640	coro->next = coro_first;
		1641	coro_first = coro;
408		1642
409	RETVAL = coro;	1643	coro->hv = hv = newHV ();
		1644	mg = sv_magicext ((SV )hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char )coro, 0);
		1645	mg->mg_flags \|= MGf_DUP;
		1646	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		1647
		1648	av_extend (coro->args, items - 1);
		1649	for (i = 1; i < items; i++)
		1650	av_push (coro->args, newSVsv (ST (i)));
		1651	}
410	OUTPUT:	1652	OUTPUT:
411	RETVAL	1653	RETVAL
412		1654
		1655	# these not obviously related functions are all rolled into the same xs
		1656	# function to increase chances that they all will call transfer with the same
		1657	# stack offset
413	void	1658	void
414	transfer(prev,next)	1659	_set_stacklevel (...)
415	Coro::State_or_hashref prev	1660	ALIAS:
416	Coro::State_or_hashref next	1661	Coro::State::transfer = 1
		1662	Coro::schedule = 2
		1663	Coro::cede = 3
		1664	Coro::cede_notself = 4
417	CODE:	1665	CODE:
		1666	{
		1667	struct transfer_args ta;
418		1668
419	if (prev != next)	1669	PUTBACK;
		1670	switch (ix)
420	{	1671	{
421	/*
422	* this could be done in newprocess which would lead to
423	* extremely elegant and fast (just SAVE/LOAD)
424	* code here, but lazy allocation of stacks has also
425	* some virtues and the overhead of the if() is nil.
426	*/
427	if (next->mainstack)
428	{
429	SAVE (prev);
430	LOAD (next);
431	/* mark this state as in-use */
432	next->mainstack = 0;
433	next->tmps_ix = -2;
434	}
435	else if (next->tmps_ix == -2)
436	{
437	croak ("tried to transfer to running coroutine");
438	}
439	else	1672	case 0:
		1673	ta.prev = (struct coro )INT2PTR (coro_cctx , SvIV (ST (0)));
		1674	ta.next = 0;
440	{	1675	break;
441	SAVE (prev);
442		1676
443	/*	1677	case 1:
444	* emulate part of the perl startup here.	1678	if (items != 2)
445	*/	1679	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446	UNOP myop;
447		1680
448	init_stacks (); /* from perl.c */	1681	prepare_transfer (aTHX_ &ta, ST (0), ST (1));
449	PL_op = (OP *)&myop;
450	/PL_curcop = 0;/
451	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
452
453	SPAGAIN;
454	Zero(&myop, 1, UNOP);
455	myop.op_next = Nullop;
456	myop.op_flags = OPf_WANT_VOID;
457
458	PUSHMARK(SP);
459	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
460	PUTBACK;
461	/*
462	* the next line is slightly wrong, as PL_op->op_next
463	* is actually being executed so we skip the first op.
464	* that doesn't matter, though, since it is only
465	* pp_nextstate and we never return...
466	*/
467	PL_op = Perl_pp_entersub(aTHX);
468	SPAGAIN;
469
470	ENTER;
471	}	1682	break;
		1683
		1684	case 2:
		1685	prepare_schedule (aTHX_ &ta);
		1686	break;
		1687
		1688	case 3:
		1689	prepare_cede (aTHX_ &ta);
		1690	break;
		1691
		1692	case 4:
		1693	if (!prepare_cede_notself (aTHX_ &ta))
		1694	XSRETURN_EMPTY;
		1695
		1696	break;
472	}	1697	}
		1698	SPAGAIN;
		1699
		1700	BARRIER;
		1701	PUTBACK;
		1702	TRANSFER (ta, 0);
		1703	SPAGAIN; /* might be the sp of a different coroutine now */
		1704	/* be extra careful not to ever do anything after TRANSFER */
		1705	}
		1706
		1707	bool
		1708	_destroy (SV *coro_sv)
		1709	CODE:
		1710	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		1711	OUTPUT:
		1712	RETVAL
473		1713
474	void	1714	void
475	DESTROY(coro)	1715	_exit (int code)
476	Coro::State coro	1716	PROTOTYPE: $
477	CODE:	1717	CODE:
		1718	_exit (code);
478		1719
		1720	int
		1721	cctx_stacksize (int new_stacksize = 0)
		1722	CODE:
		1723	RETVAL = coro_stacksize;
		1724	if (new_stacksize)
		1725	coro_stacksize = new_stacksize;
		1726	OUTPUT:
		1727	RETVAL
		1728
		1729	int
		1730	cctx_count ()
		1731	CODE:
		1732	RETVAL = cctx_count;
		1733	OUTPUT:
		1734	RETVAL
		1735
		1736	int
		1737	cctx_idle ()
		1738	CODE:
		1739	RETVAL = cctx_idle;
		1740	OUTPUT:
		1741	RETVAL
		1742
		1743	void
		1744	list ()
		1745	PPCODE:
		1746	{
		1747	struct coro *coro;
		1748	for (coro = coro_first; coro; coro = coro->next)
		1749	if (coro->hv)
		1750	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
		1751	}
		1752
		1753	void
		1754	call (Coro::State coro, SV *coderef)
		1755	ALIAS:
		1756	eval = 1
		1757	CODE:
		1758	{
479	if (coro->mainstack)	1759	if (coro->mainstack)
480	{	1760	{
481	struct coro temp;	1761	struct coro temp;
482		1762
483	SAVE(aTHX_ (&temp));	1763	if (!(coro->flags & CF_RUNNING))
484	LOAD(aTHX_ coro);	1764	{
		1765	PUTBACK;
		1766	save_perl (aTHX_ &temp);
		1767	load_perl (aTHX_ coro);
		1768	}
485		1769
486	destroy_stacks ();	1770	{
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));	1771	dSP;
		1772	ENTER;
		1773	SAVETMPS;
		1774	PUTBACK;
		1775	PUSHSTACK;
		1776	PUSHMARK (SP);
488		1777
489	LOAD((&temp));	1778	if (ix)
		1779	eval_sv (coderef, 0);
		1780	else
		1781	call_sv (coderef, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		1782
		1783	POPSTACK;
		1784	SPAGAIN;
		1785	FREETMPS;
		1786	LEAVE;
		1787	PUTBACK;
		1788	}
		1789
		1790	if (!(coro->flags & CF_RUNNING))
		1791	{
		1792	save_perl (aTHX_ coro);
		1793	load_perl (aTHX_ &temp);
		1794	SPAGAIN;
		1795	}
490	}	1796	}
		1797	}
491		1798
		1799	SV *
		1800	is_ready (Coro::State coro)
		1801	PROTOTYPE: $
		1802	ALIAS:
		1803	is_ready = CF_READY
		1804	is_running = CF_RUNNING
		1805	is_new = CF_NEW
		1806	is_destroyed = CF_DESTROYED
		1807	CODE:
		1808	RETVAL = boolSV (coro->flags & ix);
		1809	OUTPUT:
		1810	RETVAL
		1811
		1812	void
		1813	api_trace (SV *coro, int flags = CC_TRACE \| CC_TRACE_SUB)
		1814
		1815	SV *
		1816	has_stack (Coro::State coro)
		1817	PROTOTYPE: $
		1818	CODE:
		1819	RETVAL = boolSV (!!coro->cctx);
		1820	OUTPUT:
		1821	RETVAL
		1822
		1823	int
		1824	is_traced (Coro::State coro)
		1825	PROTOTYPE: $
		1826	CODE:
		1827	RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
		1828	OUTPUT:
		1829	RETVAL
		1830
		1831	IV
		1832	rss (Coro::State coro)
		1833	PROTOTYPE: $
		1834	ALIAS:
		1835	usecount = 1
		1836	CODE:
		1837	switch (ix)
		1838	{
		1839	case 0: RETVAL = coro_rss (aTHX_ coro); break;
		1840	case 1: RETVAL = coro->usecount; break;
		1841	}
		1842	OUTPUT:
		1843	RETVAL
		1844
		1845	void
		1846	force_cctx ()
		1847	CODE:
		1848	struct coro *coro = SvSTATE (coro_current);
		1849	coro->cctx->idle_sp = 0;
		1850
		1851	MODULE = Coro::State PACKAGE = Coro
		1852
		1853	BOOT:
		1854	{
		1855	int i;
		1856
		1857	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
		1858	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
		1859	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
		1860
		1861	coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
		1862	SvREADONLY_on (coro_current);
		1863
		1864	coro_stash = gv_stashpv ("Coro", TRUE);
		1865
		1866	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1867	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1868	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1869	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1870	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1871	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1872
		1873	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1874	coro_ready[i] = newAV ();
		1875
		1876	{
		1877	SV *sv = perl_get_sv ("Coro::API", TRUE);
		1878	perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
		1879
		1880	coroapi.schedule = api_schedule;
		1881	coroapi.cede = api_cede;
		1882	coroapi.cede_notself = api_cede_notself;
		1883	coroapi.ready = api_ready;
		1884	coroapi.is_ready = api_is_ready;
		1885	coroapi.nready = &coro_nready;
		1886	coroapi.current = coro_current;
		1887
		1888	GCoroAPI = &coroapi;
		1889	sv_setiv (sv, (IV)&coroapi);
		1890	SvREADONLY_on (sv);
		1891	}
		1892	}
		1893
		1894	void
		1895	_set_current (SV *current)
		1896	PROTOTYPE: $
		1897	CODE:
		1898	SvREFCNT_dec (SvRV (coro_current));
		1899	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1900
		1901	void
		1902	_set_readyhook (SV *hook)
		1903	PROTOTYPE: $
		1904	CODE:
		1905	LOCK;
		1906	if (coro_readyhook)
		1907	SvREFCNT_dec (coro_readyhook);
		1908	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
		1909	UNLOCK;
		1910
		1911	int
		1912	prio (Coro::State coro, int newprio = 0)
		1913	ALIAS:
		1914	nice = 1
		1915	CODE:
		1916	{
		1917	RETVAL = coro->prio;
		1918
		1919	if (items > 1)
		1920	{
		1921	if (ix)
		1922	newprio = coro->prio - newprio;
		1923
		1924	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
		1925	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
		1926
		1927	coro->prio = newprio;
		1928	}
		1929	}
		1930	OUTPUT:
		1931	RETVAL
		1932
		1933	SV *
		1934	ready (SV *self)
		1935	PROTOTYPE: $
		1936	CODE:
		1937	RETVAL = boolSV (api_ready (self));
		1938	OUTPUT:
		1939	RETVAL
		1940
		1941	int
		1942	nready (...)
		1943	PROTOTYPE:
		1944	CODE:
		1945	RETVAL = coro_nready;
		1946	OUTPUT:
		1947	RETVAL
		1948
		1949	void
		1950	throw (Coro::State self, SV *throw = &PL_sv_undef)
		1951	PROTOTYPE: $;$
		1952	CODE:
		1953	SvREFCNT_dec (self->throw);
		1954	self->throw = SvOK (throw) ? newSVsv (throw) : 0;
		1955
		1956	void
		1957	swap_defsv (Coro::State self)
		1958	PROTOTYPE: $
		1959	ALIAS:
		1960	swap_defav = 1
		1961	CODE:
		1962	if (!self->slot)
		1963	croak ("cannot swap state with coroutine that has no saved state");
		1964	else
		1965	{
		1966	SV src = ix ? (SV )&GvAV (PL_defgv) : &GvSV (PL_defgv);
		1967	SV dst = ix ? (SV )&self->slot->defav : (SV **)&self->slot->defsv;
		1968
		1969	SV tmp = src; src = dst; *dst = tmp;
		1970	}
		1971
		1972	# for async_pool speedup
		1973	void
		1974	_pool_1 (SV *cb)
		1975	CODE:
		1976	{
		1977	struct coro *coro = SvSTATE (coro_current);
		1978	HV hv = (HV )SvRV (coro_current);
		1979	AV *defav = GvAV (PL_defgv);
		1980	SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
		1981	AV *invoke_av;
		1982	int i, len;
		1983
		1984	if (!invoke)
		1985	{
		1986	SvREFCNT_dec (PL_diehook); PL_diehook = 0;
		1987	croak ("\3async_pool terminate\2\n");
		1988	}
		1989
492	SvREFCNT_dec (coro->args);	1990	SvREFCNT_dec (coro->saved_deffh);
493	Safefree (coro);	1991	coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
494		1992
		1993	hv_store (hv, "desc", sizeof ("desc") - 1,
		1994	newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
495		1995
		1996	invoke_av = (AV *)SvRV (invoke);
		1997	len = av_len (invoke_av);
		1998
		1999	sv_setsv (cb, AvARRAY (invoke_av)[0]);
		2000
		2001	if (len > 0)
		2002	{
		2003	av_fill (defav, len - 1);
		2004	for (i = 0; i < len; ++i)
		2005	av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
		2006	}
		2007
		2008	SvREFCNT_dec (invoke);
		2009	}
		2010
		2011	void
		2012	_pool_2 (SV *cb)
		2013	CODE:
		2014	{
		2015	struct coro *coro = SvSTATE (coro_current);
		2016
		2017	sv_setsv (cb, &PL_sv_undef);
		2018
		2019	SvREFCNT_dec ((SV )PL_defoutgv); PL_defoutgv = (GV )coro->saved_deffh;
		2020	coro->saved_deffh = 0;
		2021
		2022	if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
		2023	\|\| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
		2024	{
		2025	SvREFCNT_dec (PL_diehook); PL_diehook = 0;
		2026	croak ("\3async_pool terminate\2\n");
		2027	}
		2028
		2029	av_clear (GvAV (PL_defgv));
		2030	hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
		2031	newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
		2032
		2033	coro->prio = 0;
		2034
		2035	if (coro->cctx && (coro->cctx->flags & CC_TRACE))
		2036	api_trace (coro_current, 0);
		2037
		2038	av_push (av_async_pool, newSVsv (coro_current));
		2039	}
		2040
		2041
		2042	MODULE = Coro::State PACKAGE = Coro::AIO
		2043
		2044	SV *
		2045	_get_state ()
		2046	CODE:
		2047	{
		2048	struct io_state *data;
		2049
		2050	RETVAL = newSV (sizeof (struct io_state));
		2051	data = (struct io_state *)SvPVX (RETVAL);
		2052	SvCUR_set (RETVAL, sizeof (struct io_state));
		2053	SvPOK_only (RETVAL);
		2054
		2055	data->errorno = errno;
		2056	data->laststype = PL_laststype;
		2057	data->laststatval = PL_laststatval;
		2058	data->statcache = PL_statcache;
		2059	}
		2060	OUTPUT:
		2061	RETVAL
		2062
		2063	void
		2064	_set_state (char *data_)
		2065	PROTOTYPE: $
		2066	CODE:
		2067	{
		2068	struct io_state data = (void )data_;
		2069
		2070	errno = data->errorno;
		2071	PL_laststype = data->laststype;
		2072	PL_laststatval = data->laststatval;
		2073	PL_statcache = data->statcache;
		2074	}
		2075
		2076
		2077	MODULE = Coro::State PACKAGE = Coro::AnyEvent
		2078
		2079	BOOT:
		2080	sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
		2081
		2082	SV *
		2083	_schedule ()
		2084	PROTOTYPE: @
		2085	CODE:
		2086	{
		2087	static int incede;
		2088	fprintf (stderr, "_schedule\n");//D
		2089
		2090	api_cede_notself ();
		2091
		2092	++incede;
		2093	while (coro_nready >= incede && api_cede ())
		2094	;
		2095
		2096	sv_setsv (sv_activity, &PL_sv_undef);
		2097	if (coro_nready >= incede)
		2098	{
		2099	PUSHMARK (SP);
		2100	PUTBACK;
		2101	fprintf (stderr, "call act %d >= %d\n", coro_nready, incede);//D
		2102	call_pv ("Coro::AnyEvent::_activity", G_DISCARD \| G_EVAL);
		2103	SPAGAIN;
		2104	}
		2105
		2106	--incede;
		2107	}
		2108

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs. Revision 1.233 by root, Fri May 9 22:04:37 2008 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.6 by root, Tue Jul 17 15:42:28 2001 UTC vs.
Revision 1.233 by root, Fri May 9 22:04:37 2008 UTC