[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.243 by root, Sat Aug 30 03:07:46 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	static int (orig_sigelem_clr) (pTHX_ SV sv, MAGIC *mg);
		689
		690	/* apparently < 5.8.8 */
		691	#ifndef MgPV_nolen_const
		692	#define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \
		693	SvPV_nolen((SV*)((mg)->mg_ptr)) : \
		694	(const char*)(mg)->mg_ptr)
		695	#endif
		696
		697	/*
		698	* This overrides the default magic get method of %SIG elements.
		699	* The original one doesn't provide for reading back of PL_diehook/PL_warnhook
		700	* and instead of tryign to save and restore the hash elements, we just provide
		701	* readback here.
		702	* We only do this when the hook is != 0, as they are often set to 0 temporarily,
		703	* not expecting this to actually change the hook. This is a potential problem
		704	* when a schedule happens then, but we ignore this.
		705	*/
		706	static int
		707	coro_sigelem_get (pTHX_ SV sv, MAGIC mg)
		708	{
		709	const char *s = MgPV_nolen_const (mg);
		710
		711	if (*s == '_')
		712	{
		713	SV **svp = 0;
		714
		715	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		716	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		717
		718	if (svp)
		719	{
		720	sv_setsv (sv, svp ? svp : &PL_sv_undef);
		721	return 0;
		722	}
		723	}
		724
		725	return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
		726	}
		727
		728	static int
		729	coro_sigelem_clr (pTHX_ SV sv, MAGIC mg)
		730	{
		731	const char *s = MgPV_nolen_const (mg);
		732
		733	if (*s == '_')
		734	{
		735	SV **svp = 0;
		736
		737	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		738	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		739
		740	if (svp)
		741	{
		742	SV old = svp;
		743	*svp = 0;
		744	SvREFCNT_dec (old);
		745	return 0;
		746	}
		747	}
		748
		749	return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
		750	}
		751
		752	static int
		753	coro_sigelem_set (pTHX_ SV sv, MAGIC mg)
		754	{
		755	const char *s = MgPV_nolen_const (mg);
		756
		757	if (*s == '_')
		758	{
		759	SV **svp = 0;
		760
		761	if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
		762	if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
		763
		764	if (svp)
		765	{
		766	SV old = svp;
		767	*svp = newSVsv (sv);
		768	SvREFCNT_dec (old);
		769	return 0;
		770	}
		771	}
		772
		773	return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
		774	}
		775
		776	static void
		777	coro_setup (pTHX_ struct coro *coro)
		778	{
		779	/*
		780	* emulate part of the perl startup here.
		781	*/
		782	coro_init_stacks (aTHX);
		783
		784	PL_runops = RUNOPS_DEFAULT;
		785	PL_curcop = &PL_compiling;
		786	PL_in_eval = EVAL_NULL;
		787	PL_comppad = 0;
		788	PL_curpm = 0;
		789	PL_curpad = 0;
		790	PL_localizing = 0;
		791	PL_dirty = 0;
		792	PL_restartop = 0;
		793	#if PERL_VERSION_ATLEAST (5,10,0)
		794	PL_parser = 0;
		795	#endif
		796
		797	/* recreate the die/warn hooks */
		798	PL_diehook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
		799	PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
		800
		801	GvSV (PL_defgv) = newSV (0);
		802	GvAV (PL_defgv) = coro->args; coro->args = 0;
		803	GvSV (PL_errgv) = newSV (0);
		804	GvSV (irsgv) = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
		805	PL_rs = newSVsv (GvSV (irsgv));
		806	PL_defoutgv = (GV *)SvREFCNT_inc (stdoutgv);
315		807
316	{	808	{
317	dSP;	809	dSP;
318	CV *cv;	810	LOGOP myop;
319		811
320	/* now do the ugly restore mess */	812	Zero (&myop, 1, LOGOP);
321	while ((cv = (CV *)POPs))	813	myop.op_next = Nullop;
322	{	814	myop.op_flags = OPf_WANT_VOID;
323	AV padlist = (AV )POPs;
324		815
325	put_padlist (cv);	816	PUSHMARK (SP);
326	CvPADLIST(cv) = padlist;	817	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;	818	PUTBACK;
		819	PL_op = (OP *)&myop;
		820	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		821	SPAGAIN;
336	}	822	}
337	}
338		823
339	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	824	/* this newly created coroutine might be run on an existing cctx which most
340	STATIC void	825	* likely was suspended in set_stacklevel, called from entersub.
341	destroy_stacks(pTHX)	826	* set_stacklevl doesn't do anything on return, but entersub does LEAVE,
		827	* so we ENTER here for symmetry
		828	*/
		829	ENTER;
		830	}
		831
		832	static void
		833	coro_destroy (pTHX_ struct coro *coro)
342	{	834	{
343	/* die does this while calling POPSTACK, but I just don't see why. */	835	if (!IN_DESTRUCT)
344	/* OTOH, die does not have a memleak, but we do... */	836	{
		837	/* restore all saved variables and stuff */
		838	LEAVE_SCOPE (0);
		839	assert (PL_tmps_floor == -1);
		840
		841	/* free all temporaries */
		842	FREETMPS;
		843	assert (PL_tmps_ix == -1);
		844
		845	/* unwind all extra stacks */
		846	POPSTACK_TO (PL_mainstack);
		847
		848	/* unwind main stack */
345	dounwind(-1);	849	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	{	850	}
356	PERL_SI *p = PL_curstackinfo->si_prev;
357		851
358	SvREFCNT_dec(PL_curstackinfo->si_stack);	852	SvREFCNT_dec (GvSV (PL_defgv));
359	Safefree(PL_curstackinfo->si_cxstack);	853	SvREFCNT_dec (GvAV (PL_defgv));
360	Safefree(PL_curstackinfo);	854	SvREFCNT_dec (GvSV (PL_errgv));
361	PL_curstackinfo = p;	855	SvREFCNT_dec (PL_defoutgv);
		856	SvREFCNT_dec (PL_rs);
		857	SvREFCNT_dec (GvSV (irsgv));
		858
		859	SvREFCNT_dec (PL_diehook);
		860	SvREFCNT_dec (PL_warnhook);
362	}	861
		862	SvREFCNT_dec (coro->saved_deffh);
		863	SvREFCNT_dec (coro->throw);
363		864
364	if (PL_scopestack_ix != 0)	865	coro_destroy_stacks (aTHX);
365	Perl_warner(aTHX_ WARN_INTERNAL,	866	}
366	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	867
367	(long)PL_scopestack_ix);	868	static void
368	if (PL_savestack_ix != 0)	869	free_coro_mortal (pTHX)
369	Perl_warner(aTHX_ WARN_INTERNAL,	870	{
370	"Unbalanced saves: %ld more saves than restores\n",	871	if (expect_true (coro_mortal))
371	(long)PL_savestack_ix);	872	{
372	if (PL_tmps_floor != -1)	873	SvREFCNT_dec (coro_mortal);
373	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	874	coro_mortal = 0;
374	(long)PL_tmps_floor + 1);	875	}
		876	}
		877
		878	static int
		879	runops_trace (pTHX)
		880	{
		881	COP *oldcop = 0;
		882	int oldcxix = -2;
		883	struct coro coro = SvSTATE (coro_current); / trace cctx is tied to specific coro */
		884	coro_cctx *cctx = coro->cctx;
		885
		886	while ((PL_op = CALL_FPTR (PL_op->op_ppaddr) (aTHX)))
		887	{
		888	PERL_ASYNC_CHECK ();
		889
		890	if (cctx->flags & CC_TRACE_ALL)
		891	{
		892	if (PL_op->op_type == OP_LEAVESUB && cctx->flags & CC_TRACE_SUB)
		893	{
		894	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		895	SV bot, top;
		896	AV av = newAV (); / return values */
		897	SV **cb;
		898	dSP;
		899
		900	GV *gv = CvGV (cx->blk_sub.cv);
		901	SV *fullname = sv_2mortal (newSV (0));
		902	if (isGV (gv))
		903	gv_efullname3 (fullname, gv, 0);
		904
		905	bot = PL_stack_base + cx->blk_oldsp + 1;
		906	top = cx->blk_gimme == G_ARRAY ? SP + 1
		907	: cx->blk_gimme == G_SCALAR ? bot + 1
		908	: bot;
		909
		910	av_extend (av, top - bot);
		911	while (bot < top)
		912	av_push (av, SvREFCNT_inc (*bot++));
		913
		914	PL_runops = RUNOPS_DEFAULT;
		915	ENTER;
		916	SAVETMPS;
		917	EXTEND (SP, 3);
		918	PUSHMARK (SP);
		919	PUSHs (&PL_sv_no);
		920	PUSHs (fullname);
		921	PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		922	PUTBACK;
		923	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		924	if (cb) call_sv (*cb, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		925	SPAGAIN;
		926	FREETMPS;
		927	LEAVE;
		928	PL_runops = runops_trace;
		929	}
		930
		931	if (oldcop != PL_curcop)
		932	{
		933	oldcop = PL_curcop;
		934
		935	if (PL_curcop != &PL_compiling)
		936	{
		937	SV **cb;
		938
		939	if (oldcxix != cxstack_ix && cctx->flags & CC_TRACE_SUB)
		940	{
		941	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
		942
		943	if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
		944	{
		945	runops_proc_t old_runops = PL_runops;
		946	dSP;
		947	GV *gv = CvGV (cx->blk_sub.cv);
		948	SV *fullname = sv_2mortal (newSV (0));
		949
		950	if (isGV (gv))
		951	gv_efullname3 (fullname, gv, 0);
		952
		953	PL_runops = RUNOPS_DEFAULT;
		954	ENTER;
		955	SAVETMPS;
		956	EXTEND (SP, 3);
		957	PUSHMARK (SP);
		958	PUSHs (&PL_sv_yes);
		959	PUSHs (fullname);
		960	PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
		961	PUTBACK;
		962	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
		963	if (cb) call_sv (*cb, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		964	SPAGAIN;
		965	FREETMPS;
		966	LEAVE;
		967	PL_runops = runops_trace;
		968	}
		969
		970	oldcxix = cxstack_ix;
		971	}
		972
		973	if (cctx->flags & CC_TRACE_LINE)
		974	{
		975	dSP;
		976
		977	PL_runops = RUNOPS_DEFAULT;
		978	ENTER;
		979	SAVETMPS;
		980	EXTEND (SP, 3);
		981	PL_runops = RUNOPS_DEFAULT;
		982	PUSHMARK (SP);
		983	PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
		984	PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
		985	PUTBACK;
		986	cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
		987	if (cb) call_sv (*cb, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		988	SPAGAIN;
		989	FREETMPS;
		990	LEAVE;
		991	PL_runops = runops_trace;
		992	}
		993	}
		994	}
		995	}
		996	}
		997
		998	TAINT_NOT;
		999	return 0;
		1000	}
		1001
		1002	/* inject a fake call to Coro::State::_cctx_init into the execution */
		1003	/* _cctx_init should be careful, as it could be called at almost any time */
		1004	/* during execution of a perl program */
		1005	static void NOINLINE
		1006	cctx_prepare (pTHX_ coro_cctx *cctx)
		1007	{
		1008	dSP;
		1009	LOGOP myop;
		1010
		1011	PL_top_env = &PL_start_env;
		1012
		1013	if (cctx->flags & CC_TRACE)
		1014	PL_runops = runops_trace;
		1015
		1016	Zero (&myop, 1, LOGOP);
		1017	myop.op_next = PL_op;
		1018	myop.op_flags = OPf_WANT_VOID \| OPf_STACKED;
		1019
		1020	PUSHMARK (SP);
		1021	EXTEND (SP, 2);
		1022	PUSHs (sv_2mortal (newSViv (PTR2IV (cctx))));
		1023	PUSHs ((SV *)get_cv ("Coro::State::_cctx_init", FALSE));
		1024	PUTBACK;
		1025	PL_op = (OP *)&myop;
		1026	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		1027	SPAGAIN;
		1028	}
		1029
		1030	/*
		1031	* this is a _very_ stripped down perl interpreter ;)
		1032	*/
		1033	static void
		1034	cctx_run (void *arg)
		1035	{
		1036	dTHX;
		1037
		1038	/* cctx_run is the alternative tail of transfer(), so unlock here. */
		1039	UNLOCK;
		1040
		1041	/* we now skip the entersub that lead to transfer() */
		1042	PL_op = PL_op->op_next;
		1043
		1044	/* inject a fake subroutine call to cctx_init */
		1045	cctx_prepare (aTHX_ (coro_cctx *)arg);
		1046
		1047	/* somebody or something will hit me for both perl_run and PL_restartop */
		1048	PL_restartop = PL_op;
		1049	perl_run (PL_curinterp);
		1050
375	/*	1051	/*
		1052	* If perl-run returns we assume exit() was being called or the coro
		1053	* fell off the end, which seems to be the only valid (non-bug)
		1054	* reason for perl_run to return. We try to exit by jumping to the
		1055	* bootstrap-time "top" top_env, as we cannot restore the "main"
		1056	* coroutine as Coro has no such concept
		1057	*/
		1058	PL_top_env = main_top_env;
		1059	JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
		1060	}
		1061
		1062	static coro_cctx *
		1063	cctx_new ()
		1064	{
		1065	coro_cctx *cctx;
		1066	void *stack_start;
		1067	size_t stack_size;
		1068
		1069	++cctx_count;
		1070
		1071	Newz (0, cctx, 1, coro_cctx);
		1072
		1073	#if HAVE_MMAP
		1074	cctx->ssize = ((coro_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
		1075	/* mmap supposedly does allocate-on-write for us */
		1076	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		1077
		1078	if (cctx->sptr != (void *)-1)
		1079	{
		1080	# if CORO_STACKGUARD
		1081	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
		1082	# endif
		1083	stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
		1084	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
		1085	cctx->flags \|= CC_MAPPED;
		1086	}
		1087	else
		1088	#endif
		1089	{
		1090	cctx->ssize = coro_stacksize * (long)sizeof (long);
		1091	New (0, cctx->sptr, coro_stacksize, long);
		1092
		1093	if (!cctx->sptr)
		1094	{
		1095	perror ("FATAL: unable to allocate stack for coroutine");
		1096	_exit (EXIT_FAILURE);
		1097	}
		1098
		1099	stack_start = cctx->sptr;
		1100	stack_size = cctx->ssize;
		1101	}
		1102
		1103	REGISTER_STACK (cctx, (char )stack_start, (char )stack_start + stack_size);
		1104	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
		1105
		1106	return cctx;
		1107	}
		1108
		1109	static void
		1110	cctx_destroy (coro_cctx *cctx)
		1111	{
		1112	if (!cctx)
		1113	return;
		1114
		1115	--cctx_count;
		1116
		1117	#if CORO_USE_VALGRIND
		1118	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		1119	#endif
		1120
		1121	#if HAVE_MMAP
		1122	if (cctx->flags & CC_MAPPED)
		1123	munmap (cctx->sptr, cctx->ssize);
		1124	else
		1125	#endif
		1126	Safefree (cctx->sptr);
		1127
		1128	Safefree (cctx);
		1129	}
		1130
		1131	/* wether this cctx should be destructed */
		1132	#define CCTX_EXPIRED(cctx) ((cctx)->ssize < coro_stacksize \|\| ((cctx)->flags & CC_NOREUSE))
		1133
		1134	static coro_cctx *
		1135	cctx_get (pTHX)
		1136	{
		1137	while (expect_true (cctx_first))
		1138	{
		1139	coro_cctx *cctx = cctx_first;
		1140	cctx_first = cctx->next;
		1141	--cctx_idle;
		1142
		1143	if (expect_true (!CCTX_EXPIRED (cctx)))
		1144	return cctx;
		1145
		1146	cctx_destroy (cctx);
		1147	}
		1148
		1149	return cctx_new ();
		1150	}
		1151
		1152	static void
		1153	cctx_put (coro_cctx *cctx)
		1154	{
		1155	/* free another cctx if overlimit */
		1156	if (expect_false (cctx_idle >= MAX_IDLE_CCTX))
		1157	{
		1158	coro_cctx *first = cctx_first;
		1159	cctx_first = first->next;
		1160	--cctx_idle;
		1161
		1162	cctx_destroy (first);
		1163	}
		1164
		1165	++cctx_idle;
		1166	cctx->next = cctx_first;
		1167	cctx_first = cctx;
		1168	}
		1169
		1170	/ coroutine switching ***************************************************/
		1171
		1172	static void
		1173	transfer_check (pTHX_ struct coro prev, struct coro next)
		1174	{
		1175	if (expect_true (prev != next))
		1176	{
		1177	if (expect_false (!(prev->flags & (CF_RUNNING \| CF_NEW))))
		1178	croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
		1179
		1180	if (expect_false (next->flags & CF_RUNNING))
		1181	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		1182
		1183	if (expect_false (next->flags & CF_DESTROYED))
		1184	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		1185
		1186	#if !PERL_VERSION_ATLEAST (5,10,0)
		1187	if (expect_false (PL_lex_state != LEX_NOTPARSING))
		1188	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version");
		1189	#endif
		1190	}
		1191	}
		1192
		1193	/* always use the TRANSFER macro */
		1194	static void NOINLINE
		1195	transfer (pTHX_ struct coro prev, struct coro next, int force_cctx)
		1196	{
		1197	dSTACKLEVEL;
		1198	static volatile int has_throw;
		1199
		1200	/* sometimes transfer is only called to set idle_sp */
		1201	if (expect_false (!next))
		1202	{
		1203	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		1204	assert (((coro_cctx )prev)->idle_te = PL_top_env); / just for the side-effect when asserts are enabled */
		1205	}
		1206	else if (expect_true (prev != next))
		1207	{
		1208	coro_cctx *prev__cctx;
		1209
		1210	if (expect_false (prev->flags & CF_NEW))
		1211	{
		1212	/* create a new empty context */
		1213	Newz (0, prev->cctx, 1, coro_cctx);
		1214	prev->flags &= ~CF_NEW;
		1215	prev->flags \|= CF_RUNNING;
		1216	}
		1217
		1218	prev->flags &= ~CF_RUNNING;
		1219	next->flags \|= CF_RUNNING;
		1220
		1221	LOCK;
		1222
		1223	/* first get rid of the old state */
		1224	save_perl (aTHX_ prev);
		1225
		1226	if (expect_false (next->flags & CF_NEW))
		1227	{
		1228	/* need to start coroutine */
		1229	next->flags &= ~CF_NEW;
		1230	/* setup coroutine call */
		1231	coro_setup (aTHX_ next);
		1232	}
		1233	else
		1234	load_perl (aTHX_ next);
		1235
		1236	prev__cctx = prev->cctx;
		1237
		1238	/* possibly "free" the cctx */
		1239	if (expect_true (
		1240	prev__cctx->idle_sp == STACKLEVEL
		1241	&& !(prev__cctx->flags & CC_TRACE)
		1242	&& !force_cctx
		1243	))
		1244	{
		1245	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		1246	assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
		1247
		1248	prev->cctx = 0;
		1249
		1250	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
		1251	/* without this the next cctx_get might destroy the prev__cctx while still in use */
		1252	if (expect_false (CCTX_EXPIRED (prev__cctx)))
		1253	if (!next->cctx)
		1254	next->cctx = cctx_get (aTHX);
		1255
		1256	cctx_put (prev__cctx);
		1257	}
		1258
		1259	++next->usecount;
		1260
		1261	if (expect_true (!next->cctx))
		1262	next->cctx = cctx_get (aTHX);
		1263
		1264	has_throw = !!next->throw;
		1265
		1266	if (expect_false (prev__cctx != next->cctx))
		1267	{
		1268	prev__cctx->top_env = PL_top_env;
		1269	PL_top_env = next->cctx->top_env;
		1270	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		1271	}
		1272
		1273	free_coro_mortal (aTHX);
		1274	UNLOCK;
		1275
		1276	if (expect_false (has_throw))
		1277	{
		1278	struct coro *coro = SvSTATE (coro_current);
		1279
		1280	if (coro->throw)
376	*/	1281	{
377	Safefree(PL_tmps_stack);	1282	SV *exception = coro->throw;
378	Safefree(PL_markstack);	1283	coro->throw = 0;
379	Safefree(PL_scopestack);	1284	sv_setsv (ERRSV, exception);
380	Safefree(PL_savestack);	1285	croak (0);
381	Safefree(PL_retstack);	1286	}
		1287	}
		1288	}
382	}	1289	}
383		1290
384	#define SUB_INIT "Coro::State::_newcoro"	1291	struct transfer_args
		1292	{
		1293	struct coro prev, next;
		1294	};
385		1295
		1296	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
		1297	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
		1298
		1299	/ high level stuff ******************************************************/
		1300
		1301	static int
		1302	coro_state_destroy (pTHX_ struct coro *coro)
		1303	{
		1304	if (coro->flags & CF_DESTROYED)
		1305	return 0;
		1306
		1307	coro->flags \|= CF_DESTROYED;
		1308
		1309	if (coro->flags & CF_READY)
		1310	{
		1311	/* reduce nready, as destroying a ready coro effectively unreadies it */
		1312	/* alternative: look through all ready queues and remove the coro */
		1313	LOCK;
		1314	--coro_nready;
		1315	UNLOCK;
		1316	}
		1317	else
		1318	coro->flags \|= CF_READY; /* make sure it is NOT put into the readyqueue */
		1319
		1320	if (coro->mainstack && coro->mainstack != main_mainstack)
		1321	{
		1322	struct coro temp;
		1323
		1324	if (coro->flags & CF_RUNNING)
		1325	croak ("FATAL: tried to destroy currently running coroutine");
		1326
		1327	save_perl (aTHX_ &temp);
		1328	load_perl (aTHX_ coro);
		1329
		1330	coro_destroy (aTHX_ coro);
		1331
		1332	load_perl (aTHX_ &temp);
		1333
		1334	coro->slot = 0;
		1335	}
		1336
		1337	cctx_destroy (coro->cctx);
		1338	SvREFCNT_dec (coro->args);
		1339
		1340	if (coro->next) coro->next->prev = coro->prev;
		1341	if (coro->prev) coro->prev->next = coro->next;
		1342	if (coro == coro_first) coro_first = coro->next;
		1343
		1344	return 1;
		1345	}
		1346
		1347	static int
		1348	coro_state_free (pTHX_ SV sv, MAGIC mg)
		1349	{
		1350	struct coro coro = (struct coro )mg->mg_ptr;
		1351	mg->mg_ptr = 0;
		1352
		1353	coro->hv = 0;
		1354
		1355	if (--coro->refcnt < 0)
		1356	{
		1357	coro_state_destroy (aTHX_ coro);
		1358	Safefree (coro);
		1359	}
		1360
		1361	return 0;
		1362	}
		1363
		1364	static int
		1365	coro_state_dup (pTHX_ MAGIC mg, CLONE_PARAMS params)
		1366	{
		1367	struct coro coro = (struct coro )mg->mg_ptr;
		1368
		1369	++coro->refcnt;
		1370
		1371	return 0;
		1372	}
		1373
		1374	static MGVTBL coro_state_vtbl = {
		1375	0, 0, 0, 0,
		1376	coro_state_free,
		1377	0,
		1378	#ifdef MGf_DUP
		1379	coro_state_dup,
		1380	#else
		1381	# define MGf_DUP 0
		1382	#endif
		1383	};
		1384
		1385	static void
		1386	prepare_transfer (pTHX_ struct transfer_args ta, SV prev_sv, SV *next_sv)
		1387	{
		1388	ta->prev = SvSTATE (prev_sv);
		1389	ta->next = SvSTATE (next_sv);
		1390	TRANSFER_CHECK (*ta);
		1391	}
		1392
		1393	static void
		1394	api_transfer (SV prev_sv, SV next_sv)
		1395	{
		1396	dTHX;
		1397	struct transfer_args ta;
		1398
		1399	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
		1400	TRANSFER (ta, 1);
		1401	}
		1402
		1403	/ Coro ******************************************************************/
		1404
		1405	static void
		1406	coro_enq (pTHX_ SV *coro_sv)
		1407	{
		1408	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		1409	}
		1410
		1411	static SV *
		1412	coro_deq (pTHX)
		1413	{
		1414	int prio;
		1415
		1416	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
		1417	if (AvFILLp (coro_ready [prio]) >= 0)
		1418	return av_shift (coro_ready [prio]);
		1419
		1420	return 0;
		1421	}
		1422
		1423	static int
		1424	api_ready (SV *coro_sv)
		1425	{
		1426	dTHX;
		1427	struct coro *coro;
		1428	SV *sv_hook;
		1429	void (*xs_hook)(void);
		1430
		1431	if (SvROK (coro_sv))
		1432	coro_sv = SvRV (coro_sv);
		1433
		1434	coro = SvSTATE (coro_sv);
		1435
		1436	if (coro->flags & CF_READY)
		1437	return 0;
		1438
		1439	coro->flags \|= CF_READY;
		1440
		1441	LOCK;
		1442
		1443	sv_hook = coro_nready ? 0 : coro_readyhook;
		1444	xs_hook = coro_nready ? 0 : coroapi.readyhook;
		1445
		1446	coro_enq (aTHX_ SvREFCNT_inc (coro_sv));
		1447	++coro_nready;
		1448
		1449	UNLOCK;
		1450
		1451	if (sv_hook)
		1452	{
		1453	dSP;
		1454
		1455	ENTER;
		1456	SAVETMPS;
		1457
		1458	PUSHMARK (SP);
		1459	PUTBACK;
		1460	call_sv (sv_hook, G_DISCARD);
		1461	SPAGAIN;
		1462
		1463	FREETMPS;
		1464	LEAVE;
		1465	}
		1466
		1467	if (xs_hook)
		1468	xs_hook ();
		1469
		1470	return 1;
		1471	}
		1472
		1473	static int
		1474	api_is_ready (SV *coro_sv)
		1475	{
		1476	dTHX;
		1477	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		1478	}
		1479
		1480	static void
		1481	prepare_schedule (pTHX_ struct transfer_args *ta)
		1482	{
		1483	SV prev_sv, next_sv;
		1484
		1485	for (;;)
		1486	{
		1487	LOCK;
		1488	next_sv = coro_deq (aTHX);
		1489
		1490	/* nothing to schedule: call the idle handler */
		1491	if (expect_false (!next_sv))
		1492	{
		1493	dSP;
		1494	UNLOCK;
		1495
		1496	ENTER;
		1497	SAVETMPS;
		1498
		1499	PUSHMARK (SP);
		1500	PUTBACK;
		1501	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1502	SPAGAIN;
		1503
		1504	FREETMPS;
		1505	LEAVE;
		1506	continue;
		1507	}
		1508
		1509	ta->next = SvSTATE (next_sv);
		1510
		1511	/* cannot transfer to destroyed coros, skip and look for next */
		1512	if (expect_false (ta->next->flags & CF_DESTROYED))
		1513	{
		1514	UNLOCK;
		1515	SvREFCNT_dec (next_sv);
		1516	/* coro_nready is already taken care of by destroy */
		1517	continue;
		1518	}
		1519
		1520	--coro_nready;
		1521	UNLOCK;
		1522	break;
		1523	}
		1524
		1525	/* free this only after the transfer */
		1526	prev_sv = SvRV (coro_current);
		1527	ta->prev = SvSTATE (prev_sv);
		1528	TRANSFER_CHECK (*ta);
		1529	assert (ta->next->flags & CF_READY);
		1530	ta->next->flags &= ~CF_READY;
		1531	SvRV_set (coro_current, next_sv);
		1532
		1533	LOCK;
		1534	free_coro_mortal (aTHX);
		1535	coro_mortal = prev_sv;
		1536	UNLOCK;
		1537	}
		1538
		1539	static void
		1540	prepare_cede (pTHX_ struct transfer_args *ta)
		1541	{
		1542	api_ready (coro_current);
		1543	prepare_schedule (aTHX_ ta);
		1544	}
		1545
		1546	static int
		1547	prepare_cede_notself (pTHX_ struct transfer_args *ta)
		1548	{
		1549	if (coro_nready)
		1550	{
		1551	SV *prev = SvRV (coro_current);
		1552	prepare_schedule (aTHX_ ta);
		1553	api_ready (prev);
		1554	return 1;
		1555	}
		1556	else
		1557	return 0;
		1558	}
		1559
		1560	static void
		1561	api_schedule (void)
		1562	{
		1563	dTHX;
		1564	struct transfer_args ta;
		1565
		1566	prepare_schedule (aTHX_ &ta);
		1567	TRANSFER (ta, 1);
		1568	}
		1569
		1570	static int
		1571	api_cede (void)
		1572	{
		1573	dTHX;
		1574	struct transfer_args ta;
		1575
		1576	prepare_cede (aTHX_ &ta);
		1577
		1578	if (expect_true (ta.prev != ta.next))
		1579	{
		1580	TRANSFER (ta, 1);
		1581	return 1;
		1582	}
		1583	else
		1584	return 0;
		1585	}
		1586
		1587	static int
		1588	api_cede_notself (void)
		1589	{
		1590	dTHX;
		1591	struct transfer_args ta;
		1592
		1593	if (prepare_cede_notself (aTHX_ &ta))
		1594	{
		1595	TRANSFER (ta, 1);
		1596	return 1;
		1597	}
		1598	else
		1599	return 0;
		1600	}
		1601
		1602	static void
		1603	api_trace (SV *coro_sv, int flags)
		1604	{
		1605	dTHX;
		1606	struct coro *coro = SvSTATE (coro_sv);
		1607
		1608	if (flags & CC_TRACE)
		1609	{
		1610	if (!coro->cctx)
		1611	coro->cctx = cctx_new ();
		1612	else if (!(coro->cctx->flags & CC_TRACE))
		1613	croak ("cannot enable tracing on coroutine with custom stack");
		1614
		1615	coro->cctx->flags \|= CC_NOREUSE \| (flags & (CC_TRACE \| CC_TRACE_ALL));
		1616	}
		1617	else if (coro->cctx && coro->cctx->flags & CC_TRACE)
		1618	{
		1619	coro->cctx->flags &= ~(CC_TRACE \| CC_TRACE_ALL);
		1620
		1621	if (coro->flags & CF_RUNNING)
		1622	PL_runops = RUNOPS_DEFAULT;
		1623	else
		1624	coro->slot->runops = RUNOPS_DEFAULT;
		1625	}
		1626	}
		1627
		1628	static int
		1629	coro_gensub_free (pTHX_ SV sv, MAGIC mg)
		1630	{
		1631	AV *padlist;
		1632	AV av = (AV )mg->mg_obj;
		1633
		1634	abort ();
		1635
		1636	return 0;
		1637	}
		1638
		1639	static MGVTBL coro_gensub_vtbl = {
		1640	0, 0, 0, 0,
		1641	coro_gensub_free
		1642	};
		1643
386	MODULE = Coro::State PACKAGE = Coro::State	1644	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
387		1645
388	PROTOTYPES: ENABLE	1646	PROTOTYPES: DISABLE
389		1647
390	BOOT:	1648	BOOT:
391	if (!padlist_cache)	1649	{
392	padlist_cache = newHV ();	1650	#ifdef USE_ITHREADS
		1651	MUTEX_INIT (&coro_mutex);
		1652	#endif
		1653	BOOT_PAGESIZE;
393		1654
394	Coro::State	1655	irsgv = gv_fetchpv ("/" , GV_ADD\|GV_NOTQUAL, SVt_PV);
395	_newprocess(args)	1656	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD\|GV_NOTQUAL, SVt_PVIO);
396	SV * args	1657
397	PROTOTYPE: $	1658	orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
		1659	orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
		1660	orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
		1661
		1662	hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
		1663	rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
		1664	rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
		1665
		1666	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		1667
		1668	newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
		1669	newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
		1670	newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
		1671	newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
		1672
		1673	main_mainstack = PL_mainstack;
		1674	main_top_env = PL_top_env;
		1675
		1676	while (main_top_env->je_prev)
		1677	main_top_env = main_top_env->je_prev;
		1678
		1679	coroapi.ver = CORO_API_VERSION;
		1680	coroapi.rev = CORO_API_REVISION;
		1681	coroapi.transfer = api_transfer;
		1682
		1683	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1684	}
		1685
		1686	SV *
		1687	new (char *klass, ...)
398	CODE:	1688	CODE:
399	Coro__State coro;	1689	{
		1690	struct coro *coro;
		1691	MAGIC *mg;
		1692	HV *hv;
		1693	int i;
400		1694
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);	1695	Newz (0, coro, 1, struct coro);
		1696	coro->args = newAV ();
		1697	coro->flags = CF_NEW;
405		1698
406	coro->mainstack = 0; /* actual work is done inside transfer */	1699	if (coro_first) coro_first->prev = coro;
407	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1700	coro->next = coro_first;
		1701	coro_first = coro;
408		1702
409	RETVAL = coro;	1703	coro->hv = hv = newHV ();
		1704	mg = sv_magicext ((SV )hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char )coro, 0);
		1705	mg->mg_flags \|= MGf_DUP;
		1706	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		1707
		1708	av_extend (coro->args, items - 1);
		1709	for (i = 1; i < items; i++)
		1710	av_push (coro->args, newSVsv (ST (i)));
		1711	}
410	OUTPUT:	1712	OUTPUT:
411	RETVAL	1713	RETVAL
412		1714
		1715	# these not obviously related functions are all rolled into the same xs
		1716	# function to increase chances that they all will call transfer with the same
		1717	# stack offset
413	void	1718	void
414	transfer(prev,next)	1719	_set_stacklevel (...)
415	Coro::State_or_hashref prev	1720	ALIAS:
416	Coro::State_or_hashref next	1721	Coro::State::transfer = 1
		1722	Coro::schedule = 2
		1723	Coro::cede = 3
		1724	Coro::cede_notself = 4
417	CODE:	1725	CODE:
		1726	{
		1727	struct transfer_args ta;
418		1728
419	if (prev != next)	1729	PUTBACK;
		1730	switch (ix)
420	{	1731	{
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	1732	case 0:
		1733	ta.prev = (struct coro )INT2PTR (coro_cctx , SvIV (ST (0)));
		1734	ta.next = 0;
440	{	1735	break;
441	SAVE (prev);
442		1736
443	/*	1737	case 1:
444	* emulate part of the perl startup here.	1738	if (items != 2)
445	*/	1739	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
446	UNOP myop;
447		1740
448	init_stacks (); /* from perl.c */	1741	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	}	1742	break;
		1743
		1744	case 2:
		1745	prepare_schedule (aTHX_ &ta);
		1746	break;
		1747
		1748	case 3:
		1749	prepare_cede (aTHX_ &ta);
		1750	break;
		1751
		1752	case 4:
		1753	if (!prepare_cede_notself (aTHX_ &ta))
		1754	XSRETURN_EMPTY;
		1755
		1756	break;
472	}	1757	}
		1758	SPAGAIN;
		1759
		1760	BARRIER;
		1761	PUTBACK;
		1762	TRANSFER (ta, 0);
		1763	SPAGAIN; /* might be the sp of a different coroutine now */
		1764	/* be extra careful not to ever do anything after TRANSFER */
		1765	}
		1766
		1767	bool
		1768	_destroy (SV *coro_sv)
		1769	CODE:
		1770	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		1771	OUTPUT:
		1772	RETVAL
473		1773
474	void	1774	void
475	DESTROY(coro)	1775	_exit (int code)
476	Coro::State coro	1776	PROTOTYPE: $
477	CODE:	1777	CODE:
		1778	_exit (code);
478		1779
		1780	int
		1781	cctx_stacksize (int new_stacksize = 0)
		1782	CODE:
		1783	RETVAL = coro_stacksize;
		1784	if (new_stacksize)
		1785	coro_stacksize = new_stacksize;
		1786	OUTPUT:
		1787	RETVAL
		1788
		1789	int
		1790	cctx_count ()
		1791	CODE:
		1792	RETVAL = cctx_count;
		1793	OUTPUT:
		1794	RETVAL
		1795
		1796	int
		1797	cctx_idle ()
		1798	CODE:
		1799	RETVAL = cctx_idle;
		1800	OUTPUT:
		1801	RETVAL
		1802
		1803	void
		1804	list ()
		1805	PPCODE:
		1806	{
		1807	struct coro *coro;
		1808	for (coro = coro_first; coro; coro = coro->next)
		1809	if (coro->hv)
		1810	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
		1811	}
		1812
		1813	void
		1814	call (Coro::State coro, SV *coderef)
		1815	ALIAS:
		1816	eval = 1
		1817	CODE:
		1818	{
479	if (coro->mainstack)	1819	if (coro->mainstack)
480	{	1820	{
481	struct coro temp;	1821	struct coro temp;
482		1822
483	SAVE(aTHX_ (&temp));	1823	if (!(coro->flags & CF_RUNNING))
484	LOAD(aTHX_ coro);	1824	{
		1825	PUTBACK;
		1826	save_perl (aTHX_ &temp);
		1827	load_perl (aTHX_ coro);
		1828	}
485		1829
486	destroy_stacks ();	1830	{
487	SvREFCNT_dec ((SV *)GvAV (PL_defgv));	1831	dSP;
		1832	ENTER;
		1833	SAVETMPS;
		1834	PUTBACK;
		1835	PUSHSTACK;
		1836	PUSHMARK (SP);
488		1837
489	LOAD((&temp));	1838	if (ix)
		1839	eval_sv (coderef, 0);
		1840	else
		1841	call_sv (coderef, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		1842
		1843	POPSTACK;
		1844	SPAGAIN;
		1845	FREETMPS;
		1846	LEAVE;
		1847	PUTBACK;
		1848	}
		1849
		1850	if (!(coro->flags & CF_RUNNING))
		1851	{
		1852	save_perl (aTHX_ coro);
		1853	load_perl (aTHX_ &temp);
		1854	SPAGAIN;
		1855	}
490	}	1856	}
		1857	}
491		1858
		1859	SV *
		1860	is_ready (Coro::State coro)
		1861	PROTOTYPE: $
		1862	ALIAS:
		1863	is_ready = CF_READY
		1864	is_running = CF_RUNNING
		1865	is_new = CF_NEW
		1866	is_destroyed = CF_DESTROYED
		1867	CODE:
		1868	RETVAL = boolSV (coro->flags & ix);
		1869	OUTPUT:
		1870	RETVAL
		1871
		1872	void
		1873	api_trace (SV *coro, int flags = CC_TRACE \| CC_TRACE_SUB)
		1874
		1875	SV *
		1876	has_cctx (Coro::State coro)
		1877	PROTOTYPE: $
		1878	CODE:
		1879	RETVAL = boolSV (!!coro->cctx);
		1880	OUTPUT:
		1881	RETVAL
		1882
		1883	int
		1884	is_traced (Coro::State coro)
		1885	PROTOTYPE: $
		1886	CODE:
		1887	RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
		1888	OUTPUT:
		1889	RETVAL
		1890
		1891	IV
		1892	rss (Coro::State coro)
		1893	PROTOTYPE: $
		1894	ALIAS:
		1895	usecount = 1
		1896	CODE:
		1897	switch (ix)
		1898	{
		1899	case 0: RETVAL = coro_rss (aTHX_ coro); break;
		1900	case 1: RETVAL = coro->usecount; break;
		1901	}
		1902	OUTPUT:
		1903	RETVAL
		1904
		1905	void
		1906	force_cctx ()
		1907	CODE:
		1908	struct coro *coro = SvSTATE (coro_current);
		1909	coro->cctx->idle_sp = 0;
		1910
		1911	void
		1912	throw (Coro::State self, SV *throw = &PL_sv_undef)
		1913	PROTOTYPE: $;$
		1914	CODE:
		1915	SvREFCNT_dec (self->throw);
		1916	self->throw = SvOK (throw) ? newSVsv (throw) : 0;
		1917
		1918	void
		1919	swap_defsv (Coro::State self)
		1920	PROTOTYPE: $
		1921	ALIAS:
		1922	swap_defav = 1
		1923	CODE:
		1924	if (!self->slot)
		1925	croak ("cannot swap state with coroutine that has no saved state");
		1926	else
		1927	{
		1928	SV src = ix ? (SV )&GvAV (PL_defgv) : &GvSV (PL_defgv);
		1929	SV dst = ix ? (SV )&self->slot->defav : (SV **)&self->slot->defsv;
		1930
		1931	SV tmp = src; src = dst; *dst = tmp;
		1932	}
		1933
		1934	MODULE = Coro::State PACKAGE = Coro
		1935
		1936	BOOT:
		1937	{
		1938	int i;
		1939
		1940	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
		1941	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
		1942	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
		1943
		1944	coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
		1945	SvREADONLY_on (coro_current);
		1946
		1947	coro_stash = gv_stashpv ("Coro", TRUE);
		1948
		1949	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1950	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1951	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1952	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1953	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1954	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1955
		1956	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1957	coro_ready[i] = newAV ();
		1958
		1959	{
		1960	SV *sv = perl_get_sv ("Coro::API", TRUE);
		1961	perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
		1962
		1963	coroapi.schedule = api_schedule;
		1964	coroapi.cede = api_cede;
		1965	coroapi.cede_notself = api_cede_notself;
		1966	coroapi.ready = api_ready;
		1967	coroapi.is_ready = api_is_ready;
		1968	coroapi.nready = &coro_nready;
		1969	coroapi.current = coro_current;
		1970
		1971	GCoroAPI = &coroapi;
		1972	sv_setiv (sv, (IV)&coroapi);
		1973	SvREADONLY_on (sv);
		1974	}
		1975	}
		1976
		1977	void
		1978	_set_current (SV *current)
		1979	PROTOTYPE: $
		1980	CODE:
		1981	SvREFCNT_dec (SvRV (coro_current));
		1982	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1983
		1984	void
		1985	_set_readyhook (SV *hook)
		1986	PROTOTYPE: $
		1987	CODE:
		1988	LOCK;
		1989	SvREFCNT_dec (coro_readyhook);
		1990	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
		1991	UNLOCK;
		1992
		1993	int
		1994	prio (Coro::State coro, int newprio = 0)
		1995	ALIAS:
		1996	nice = 1
		1997	CODE:
		1998	{
		1999	RETVAL = coro->prio;
		2000
		2001	if (items > 1)
		2002	{
		2003	if (ix)
		2004	newprio = coro->prio - newprio;
		2005
		2006	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
		2007	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
		2008
		2009	coro->prio = newprio;
		2010	}
		2011	}
		2012	OUTPUT:
		2013	RETVAL
		2014
		2015	SV *
		2016	ready (SV *self)
		2017	PROTOTYPE: $
		2018	CODE:
		2019	RETVAL = boolSV (api_ready (self));
		2020	OUTPUT:
		2021	RETVAL
		2022
		2023	int
		2024	nready (...)
		2025	PROTOTYPE:
		2026	CODE:
		2027	RETVAL = coro_nready;
		2028	OUTPUT:
		2029	RETVAL
		2030
		2031	# for async_pool speedup
		2032	void
		2033	_pool_1 (SV *cb)
		2034	CODE:
		2035	{
		2036	struct coro *coro = SvSTATE (coro_current);
		2037	HV hv = (HV )SvRV (coro_current);
		2038	AV *defav = GvAV (PL_defgv);
		2039	SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
		2040	AV *invoke_av;
		2041	int i, len;
		2042
		2043	if (!invoke)
		2044	{
		2045	SV *old = PL_diehook;
		2046	PL_diehook = 0;
		2047	SvREFCNT_dec (old);
		2048	croak ("\3async_pool terminate\2\n");
		2049	}
		2050
492	SvREFCNT_dec (coro->args);	2051	SvREFCNT_dec (coro->saved_deffh);
493	Safefree (coro);	2052	coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
494		2053
		2054	hv_store (hv, "desc", sizeof ("desc") - 1,
		2055	newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
495		2056
		2057	invoke_av = (AV *)SvRV (invoke);
		2058	len = av_len (invoke_av);
		2059
		2060	sv_setsv (cb, AvARRAY (invoke_av)[0]);
		2061
		2062	if (len > 0)
		2063	{
		2064	av_fill (defav, len - 1);
		2065	for (i = 0; i < len; ++i)
		2066	av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
		2067	}
		2068
		2069	SvREFCNT_dec (invoke);
		2070	}
		2071
		2072	void
		2073	_pool_2 (SV *cb)
		2074	CODE:
		2075	{
		2076	struct coro *coro = SvSTATE (coro_current);
		2077
		2078	sv_setsv (cb, &PL_sv_undef);
		2079
		2080	SvREFCNT_dec ((SV )PL_defoutgv); PL_defoutgv = (GV )coro->saved_deffh;
		2081	coro->saved_deffh = 0;
		2082
		2083	if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
		2084	\|\| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
		2085	{
		2086	SV *old = PL_diehook;
		2087	PL_diehook = 0;
		2088	SvREFCNT_dec (old);
		2089	croak ("\3async_pool terminate\2\n");
		2090	}
		2091
		2092	av_clear (GvAV (PL_defgv));
		2093	hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
		2094	newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
		2095
		2096	coro->prio = 0;
		2097
		2098	if (coro->cctx && (coro->cctx->flags & CC_TRACE))
		2099	api_trace (coro_current, 0);
		2100
		2101	av_push (av_async_pool, newSVsv (coro_current));
		2102	}
		2103
		2104	#if 0
		2105
		2106	void
		2107	_generator_call (...)
		2108	PROTOTYPE: @
		2109	PPCODE:
		2110	fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
		2111	xxxx
		2112	abort ();
		2113
		2114	SV *
		2115	gensub (SV *sub, ...)
		2116	PROTOTYPE: &;@
		2117	CODE:
		2118	{
		2119	struct coro *coro;
		2120	MAGIC *mg;
		2121	CV *xcv;
		2122	CV ncv = (CV )newSV_type (SVt_PVCV);
		2123	int i;
		2124
		2125	CvGV (ncv) = CvGV (cv);
		2126	CvFILE (ncv) = CvFILE (cv);
		2127
		2128	Newz (0, coro, 1, struct coro);
		2129	coro->args = newAV ();
		2130	coro->flags = CF_NEW;
		2131
		2132	av_extend (coro->args, items - 1);
		2133	for (i = 1; i < items; i++)
		2134	av_push (coro->args, newSVsv (ST (i)));
		2135
		2136	CvISXSUB_on (ncv);
		2137	CvXSUBANY (ncv).any_ptr = (void *)coro;
		2138
		2139	xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
		2140
		2141	CvXSUB (ncv) = CvXSUB (xcv);
		2142	CvANON_on (ncv);
		2143
		2144	mg = sv_magicext ((SV )ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char )coro, 0);
		2145	RETVAL = newRV_noinc ((SV *)ncv);
		2146	}
		2147	OUTPUT:
		2148	RETVAL
		2149
		2150	#endif
		2151
		2152
		2153	MODULE = Coro::State PACKAGE = Coro::AIO
		2154
		2155	SV *
		2156	_get_state ()
		2157	CODE:
		2158	{
		2159	struct io_state *data;
		2160
		2161	RETVAL = newSV (sizeof (struct io_state));
		2162	data = (struct io_state *)SvPVX (RETVAL);
		2163	SvCUR_set (RETVAL, sizeof (struct io_state));
		2164	SvPOK_only (RETVAL);
		2165
		2166	data->errorno = errno;
		2167	data->laststype = PL_laststype;
		2168	data->laststatval = PL_laststatval;
		2169	data->statcache = PL_statcache;
		2170	}
		2171	OUTPUT:
		2172	RETVAL
		2173
		2174	void
		2175	_set_state (char *data_)
		2176	PROTOTYPE: $
		2177	CODE:
		2178	{
		2179	struct io_state data = (void )data_;
		2180
		2181	errno = data->errorno;
		2182	PL_laststype = data->laststype;
		2183	PL_laststatval = data->laststatval;
		2184	PL_statcache = data->statcache;
		2185	}
		2186
		2187
		2188	MODULE = Coro::State PACKAGE = Coro::AnyEvent
		2189
		2190	BOOT:
		2191	sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
		2192
		2193	SV *
		2194	_schedule (...)
		2195	PROTOTYPE: @
		2196	CODE:
		2197	{
		2198	static int incede;
		2199
		2200	api_cede_notself ();
		2201
		2202	++incede;
		2203	while (coro_nready >= incede && api_cede ())
		2204	;
		2205
		2206	sv_setsv (sv_activity, &PL_sv_undef);
		2207	if (coro_nready >= incede)
		2208	{
		2209	PUSHMARK (SP);
		2210	PUTBACK;
		2211	call_pv ("Coro::AnyEvent::_activity", G_DISCARD \| G_EVAL);
		2212	SPAGAIN;
		2213	}
		2214
		2215	--incede;
		2216	}
		2217

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.243 by root, Sat Aug 30 03:07:46 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.243 by root, Sat Aug 30 03:07:46 2008 UTC