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

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

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs. Revision 1.240 by root, Sun Jun 29 00:28:17 2008 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.240 by root, Sun Jun 29 00:28:17 2008 UTC