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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.241 by root, Mon Jul 21 02:39:15 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	#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);
312		807
313	{	808	{
314	dSP;	809	dSP;
315	CV *cv;	810	LOGOP myop;
316		811
317	/* now do the ugly restore mess */	812	Zero (&myop, 1, LOGOP);
318	while ((cv = (CV *)POPs))	813	myop.op_next = Nullop;
319	{	814	myop.op_flags = OPf_WANT_VOID;
320	AV padlist = (AV )POPs;
321		815
322	put_padlist (cv);	816	PUSHMARK (SP);
323	CvPADLIST(cv) = padlist;	817	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;	818	PUTBACK;
		819	PL_op = (OP *)&myop;
		820	PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
		821	SPAGAIN;
333	}	822	}
334	}
335		823
336	/* 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
337	STATIC void	825	* likely was suspended in set_stacklevel, called from entersub.
		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)
		834	{
		835	if (!IN_DESTRUCT)
		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 */
		849	dounwind (-1);
		850	}
		851
		852	SvREFCNT_dec (GvSV (PL_defgv));
		853	SvREFCNT_dec (GvAV (PL_defgv));
		854	SvREFCNT_dec (GvSV (PL_errgv));
		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);
		861
		862	SvREFCNT_dec (coro->saved_deffh);
		863	SvREFCNT_dec (coro->throw);
		864
338	destroy_stacks(pTHX)	865	coro_destroy_stacks (aTHX);
		866	}
		867
		868	static void
		869	free_coro_mortal (pTHX)
		870	{
		871	if (expect_true (coro_mortal))
		872	{
		873	SvREFCNT_dec (coro_mortal);
		874	coro_mortal = 0;
		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)
339	{	1007	{
340	dSP;	1008	dSP;
		1009	LOGOP myop;
341		1010
342	/* die does this while calling POPSTACK, but I just don't see why. */	1011	PL_top_env = &PL_start_env;
343	dounwind(-1);
344		1012
345	/* is this ugly, I ask? */	1013	if (cctx->flags & CC_TRACE)
346	while (PL_scopestack_ix)	1014	PL_runops = runops_trace;
347	LEAVE;
348		1015
349	while (PL_curstackinfo->si_next)	1016	Zero (&myop, 1, LOGOP);
350	PL_curstackinfo = PL_curstackinfo->si_next;	1017	myop.op_next = PL_op;
		1018	myop.op_flags = OPf_WANT_VOID \| OPf_STACKED;
351		1019
352	while (PL_curstackinfo)	1020	PUSHMARK (SP);
353	{	1021	EXTEND (SP, 2);
354	PERL_SI *p = PL_curstackinfo->si_prev;	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	}
355		1029
356	SvREFCNT_dec(PL_curstackinfo->si_stack);	1030	/*
357	Safefree(PL_curstackinfo->si_cxstack);	1031	* this is a _very_ stripped down perl interpreter ;)
358	Safefree(PL_curstackinfo);	1032	*/
359	PL_curstackinfo = p;	1033	static void
360	}	1034	cctx_run (void *arg)
		1035	{
		1036	dTHX;
361		1037
362	if (PL_scopestack_ix != 0)	1038	/* cctx_run is the alternative tail of transfer(), so unlock here. */
363	Perl_warner(aTHX_ WARN_INTERNAL,	1039	UNLOCK;
364	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",	1040
365	(long)PL_scopestack_ix);	1041	/* we now skip the entersub that lead to transfer() */
366	if (PL_savestack_ix != 0)	1042	PL_op = PL_op->op_next;
367	Perl_warner(aTHX_ WARN_INTERNAL,	1043
368	"Unbalanced saves: %ld more saves than restores\n",	1044	/* inject a fake subroutine call to cctx_init */
369	(long)PL_savestack_ix);	1045	cctx_prepare (aTHX_ (coro_cctx *)arg);
370	if (PL_tmps_floor != -1)	1046
371	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",	1047	/* somebody or something will hit me for both perl_run and PL_restartop */
372	(long)PL_tmps_floor + 1);	1048	PL_restartop = PL_op;
		1049	perl_run (PL_curinterp);
		1050
373	/*	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)
374	*/	1281	{
375	Safefree(PL_tmps_stack);	1282	SV *exception = coro->throw;
376	Safefree(PL_markstack);	1283	coro->throw = 0;
377	Safefree(PL_scopestack);	1284	sv_setsv (ERRSV, exception);
378	Safefree(PL_savestack);	1285	croak (0);
379	Safefree(PL_retstack);	1286	}
		1287	}
		1288	}
380	}	1289	}
381		1290
382	#define SUB_INIT "Coro::State::_newcoro"	1291	struct transfer_args
		1292	{
		1293	struct coro prev, next;
		1294	};
383		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
384	MODULE = Coro::State PACKAGE = Coro::State	1628	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
385		1629
386	PROTOTYPES: ENABLE	1630	PROTOTYPES: DISABLE
387		1631
388	BOOT:	1632	BOOT:
389	if (!padlist_cache)	1633	{
390	padlist_cache = newHV ();	1634	#ifdef USE_ITHREADS
		1635	MUTEX_INIT (&coro_mutex);
		1636	#endif
		1637	BOOT_PAGESIZE;
391		1638
392	Coro::State	1639	irsgv = gv_fetchpv ("/" , GV_ADD\|GV_NOTQUAL, SVt_PV);
393	_newprocess(args)	1640	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD\|GV_NOTQUAL, SVt_PVIO);
394	SV * args	1641
395	PROTOTYPE: $	1642	orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
		1643	orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
		1644	orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
		1645
		1646	hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
		1647	rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
		1648	rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
		1649
		1650	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		1651
		1652	newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
		1653	newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
		1654	newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
		1655	newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
		1656
		1657	main_mainstack = PL_mainstack;
		1658	main_top_env = PL_top_env;
		1659
		1660	while (main_top_env->je_prev)
		1661	main_top_env = main_top_env->je_prev;
		1662
		1663	coroapi.ver = CORO_API_VERSION;
		1664	coroapi.rev = CORO_API_REVISION;
		1665	coroapi.transfer = api_transfer;
		1666
		1667	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1668	}
		1669
		1670	SV *
		1671	new (char *klass, ...)
396	CODE:	1672	CODE:
397	Coro__State coro;	1673	{
		1674	struct coro *coro;
		1675	MAGIC *mg;
		1676	HV *hv;
		1677	int i;
398		1678
399	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
400	croak ("Coro::State::newprocess expects an arrayref");
401
402	New (0, coro, 1, struct coro);	1679	Newz (0, coro, 1, struct coro);
		1680	coro->args = newAV ();
		1681	coro->flags = CF_NEW;
403		1682
404	coro->mainstack = 0; /* actual work is done inside transfer */	1683	if (coro_first) coro_first->prev = coro;
405	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	1684	coro->next = coro_first;
		1685	coro_first = coro;
406		1686
407	RETVAL = coro;	1687	coro->hv = hv = newHV ();
		1688	mg = sv_magicext ((SV )hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char )coro, 0);
		1689	mg->mg_flags \|= MGf_DUP;
		1690	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		1691
		1692	av_extend (coro->args, items - 1);
		1693	for (i = 1; i < items; i++)
		1694	av_push (coro->args, newSVsv (ST (i)));
		1695	}
408	OUTPUT:	1696	OUTPUT:
409	RETVAL	1697	RETVAL
410		1698
		1699	# these not obviously related functions are all rolled into the same xs
		1700	# function to increase chances that they all will call transfer with the same
		1701	# stack offset
411	void	1702	void
412	transfer(prev,next)	1703	_set_stacklevel (...)
413	Coro::State_or_hashref prev	1704	ALIAS:
414	Coro::State_or_hashref next	1705	Coro::State::transfer = 1
		1706	Coro::schedule = 2
		1707	Coro::cede = 3
		1708	Coro::cede_notself = 4
415	CODE:	1709	CODE:
		1710	{
		1711	struct transfer_args ta;
416		1712
417	if (prev != next)	1713	PUTBACK;
		1714	switch (ix)
418	{	1715	{
419	PUTBACK;
420	SAVE (aTHX_ prev);
421
422	/*
423	* this could be done in newprocess which would lead to
424	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
425	* code here, but lazy allocation of stacks has also
426	* some virtues and the overhead of the if() is nil.
427	*/
428	if (next->mainstack)
429	{
430	LOAD (aTHX_ next);
431	next->mainstack = 0; /* unnecessary but much cleaner */
432	SPAGAIN;
433	}
434	else	1716	case 0:
		1717	ta.prev = (struct coro )INT2PTR (coro_cctx , SvIV (ST (0)));
		1718	ta.next = 0;
435	{	1719	break;
436	/*
437	* emulate part of the perl startup here.
438	*/
439	UNOP myop;
440		1720
441	init_stacks (); /* from perl.c */	1721	case 1:
442	PL_op = (OP *)&myop;	1722	if (items != 2)
443	/PL_curcop = 0;/	1723	croak ("Coro::State::transfer (prev,next) expects two arguments, not %d", items);
444	GvAV (PL_defgv) = (SV *)SvREFCNT_inc (next->args);
445		1724
446	SPAGAIN;	1725	prepare_transfer (aTHX_ &ta, ST (0), ST (1));
447	Zero(&myop, 1, UNOP);
448	myop.op_next = Nullop;
449	myop.op_flags = OPf_WANT_VOID;
450
451	PUSHMARK(SP);
452	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
453	PUTBACK;
454	/*
455	* the next line is slightly wrong, as PL_op->op_next
456	* is actually being executed so we skip the first op.
457	* that doesn't matter, though, since it is only
458	* pp_nextstate and we never return...
459	*/
460	PL_op = Perl_pp_entersub(aTHX);
461	SPAGAIN;
462
463	ENTER;
464	}	1726	break;
		1727
		1728	case 2:
		1729	prepare_schedule (aTHX_ &ta);
		1730	break;
		1731
		1732	case 3:
		1733	prepare_cede (aTHX_ &ta);
		1734	break;
		1735
		1736	case 4:
		1737	if (!prepare_cede_notself (aTHX_ &ta))
		1738	XSRETURN_EMPTY;
		1739
		1740	break;
465	}	1741	}
		1742	SPAGAIN;
		1743
		1744	BARRIER;
		1745	PUTBACK;
		1746	TRANSFER (ta, 0);
		1747	SPAGAIN; /* might be the sp of a different coroutine now */
		1748	/* be extra careful not to ever do anything after TRANSFER */
		1749	}
		1750
		1751	bool
		1752	_destroy (SV *coro_sv)
		1753	CODE:
		1754	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		1755	OUTPUT:
		1756	RETVAL
466		1757
467	void	1758	void
468	DESTROY(coro)	1759	_exit (int code)
469	Coro::State coro	1760	PROTOTYPE: $
470	CODE:	1761	CODE:
		1762	_exit (code);
471		1763
		1764	int
		1765	cctx_stacksize (int new_stacksize = 0)
		1766	CODE:
		1767	RETVAL = coro_stacksize;
		1768	if (new_stacksize)
		1769	coro_stacksize = new_stacksize;
		1770	OUTPUT:
		1771	RETVAL
		1772
		1773	int
		1774	cctx_count ()
		1775	CODE:
		1776	RETVAL = cctx_count;
		1777	OUTPUT:
		1778	RETVAL
		1779
		1780	int
		1781	cctx_idle ()
		1782	CODE:
		1783	RETVAL = cctx_idle;
		1784	OUTPUT:
		1785	RETVAL
		1786
		1787	void
		1788	list ()
		1789	PPCODE:
		1790	{
		1791	struct coro *coro;
		1792	for (coro = coro_first; coro; coro = coro->next)
		1793	if (coro->hv)
		1794	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
		1795	}
		1796
		1797	void
		1798	call (Coro::State coro, SV *coderef)
		1799	ALIAS:
		1800	eval = 1
		1801	CODE:
		1802	{
472	if (coro->mainstack)	1803	if (coro->mainstack)
473	{	1804	{
474	struct coro temp;	1805	struct coro temp;
475		1806
		1807	if (!(coro->flags & CF_RUNNING))
		1808	{
		1809	PUTBACK;
		1810	save_perl (aTHX_ &temp);
		1811	load_perl (aTHX_ coro);
		1812	}
		1813
		1814	{
		1815	dSP;
		1816	ENTER;
		1817	SAVETMPS;
		1818	PUTBACK;
		1819	PUSHSTACK;
		1820	PUSHMARK (SP);
		1821
		1822	if (ix)
		1823	eval_sv (coderef, 0);
		1824	else
		1825	call_sv (coderef, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		1826
		1827	POPSTACK;
		1828	SPAGAIN;
		1829	FREETMPS;
		1830	LEAVE;
		1831	PUTBACK;
		1832	}
		1833
		1834	if (!(coro->flags & CF_RUNNING))
		1835	{
		1836	save_perl (aTHX_ coro);
		1837	load_perl (aTHX_ &temp);
		1838	SPAGAIN;
		1839	}
		1840	}
		1841	}
		1842
		1843	SV *
		1844	is_ready (Coro::State coro)
		1845	PROTOTYPE: $
		1846	ALIAS:
		1847	is_ready = CF_READY
		1848	is_running = CF_RUNNING
		1849	is_new = CF_NEW
		1850	is_destroyed = CF_DESTROYED
		1851	CODE:
		1852	RETVAL = boolSV (coro->flags & ix);
		1853	OUTPUT:
		1854	RETVAL
		1855
		1856	void
		1857	api_trace (SV *coro, int flags = CC_TRACE \| CC_TRACE_SUB)
		1858
		1859	SV *
		1860	has_cctx (Coro::State coro)
		1861	PROTOTYPE: $
		1862	CODE:
		1863	RETVAL = boolSV (!!coro->cctx);
		1864	OUTPUT:
		1865	RETVAL
		1866
		1867	int
		1868	is_traced (Coro::State coro)
		1869	PROTOTYPE: $
		1870	CODE:
		1871	RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
		1872	OUTPUT:
		1873	RETVAL
		1874
		1875	IV
		1876	rss (Coro::State coro)
		1877	PROTOTYPE: $
		1878	ALIAS:
		1879	usecount = 1
		1880	CODE:
		1881	switch (ix)
		1882	{
		1883	case 0: RETVAL = coro_rss (aTHX_ coro); break;
		1884	case 1: RETVAL = coro->usecount; break;
		1885	}
		1886	OUTPUT:
		1887	RETVAL
		1888
		1889	void
		1890	force_cctx ()
		1891	CODE:
		1892	struct coro *coro = SvSTATE (coro_current);
		1893	coro->cctx->idle_sp = 0;
		1894
		1895	MODULE = Coro::State PACKAGE = Coro
		1896
		1897	BOOT:
		1898	{
		1899	int i;
		1900
		1901	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
		1902	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
		1903	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
		1904
		1905	coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
		1906	SvREADONLY_on (coro_current);
		1907
		1908	coro_stash = gv_stashpv ("Coro", TRUE);
		1909
		1910	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		1911	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		1912	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		1913	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		1914	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		1915	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		1916
		1917	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		1918	coro_ready[i] = newAV ();
		1919
		1920	{
		1921	SV *sv = perl_get_sv ("Coro::API", TRUE);
		1922	perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
		1923
		1924	coroapi.schedule = api_schedule;
		1925	coroapi.cede = api_cede;
		1926	coroapi.cede_notself = api_cede_notself;
		1927	coroapi.ready = api_ready;
		1928	coroapi.is_ready = api_is_ready;
		1929	coroapi.nready = &coro_nready;
		1930	coroapi.current = coro_current;
		1931
		1932	GCoroAPI = &coroapi;
		1933	sv_setiv (sv, (IV)&coroapi);
		1934	SvREADONLY_on (sv);
		1935	}
		1936	}
		1937
		1938	void
		1939	_set_current (SV *current)
		1940	PROTOTYPE: $
		1941	CODE:
		1942	SvREFCNT_dec (SvRV (coro_current));
		1943	SvRV_set (coro_current, SvREFCNT_inc (SvRV (current)));
		1944
		1945	void
		1946	_set_readyhook (SV *hook)
		1947	PROTOTYPE: $
		1948	CODE:
		1949	LOCK;
		1950	SvREFCNT_dec (coro_readyhook);
		1951	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
		1952	UNLOCK;
		1953
		1954	int
		1955	prio (Coro::State coro, int newprio = 0)
		1956	ALIAS:
		1957	nice = 1
		1958	CODE:
		1959	{
		1960	RETVAL = coro->prio;
		1961
		1962	if (items > 1)
		1963	{
		1964	if (ix)
		1965	newprio = coro->prio - newprio;
		1966
		1967	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
		1968	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
		1969
		1970	coro->prio = newprio;
		1971	}
		1972	}
		1973	OUTPUT:
		1974	RETVAL
		1975
		1976	SV *
		1977	ready (SV *self)
		1978	PROTOTYPE: $
		1979	CODE:
		1980	RETVAL = boolSV (api_ready (self));
		1981	OUTPUT:
		1982	RETVAL
		1983
		1984	int
		1985	nready (...)
		1986	PROTOTYPE:
		1987	CODE:
		1988	RETVAL = coro_nready;
		1989	OUTPUT:
		1990	RETVAL
		1991
		1992	void
		1993	throw (Coro::State self, SV *throw = &PL_sv_undef)
		1994	PROTOTYPE: $;$
		1995	CODE:
		1996	SvREFCNT_dec (self->throw);
		1997	self->throw = SvOK (throw) ? newSVsv (throw) : 0;
		1998
		1999	void
		2000	swap_defsv (Coro::State self)
		2001	PROTOTYPE: $
		2002	ALIAS:
		2003	swap_defav = 1
		2004	CODE:
		2005	if (!self->slot)
		2006	croak ("cannot swap state with coroutine that has no saved state");
		2007	else
		2008	{
		2009	SV src = ix ? (SV )&GvAV (PL_defgv) : &GvSV (PL_defgv);
		2010	SV dst = ix ? (SV )&self->slot->defav : (SV **)&self->slot->defsv;
		2011
		2012	SV tmp = src; src = dst; *dst = tmp;
		2013	}
		2014
		2015	# for async_pool speedup
		2016	void
		2017	_pool_1 (SV *cb)
		2018	CODE:
		2019	{
		2020	struct coro *coro = SvSTATE (coro_current);
		2021	HV hv = (HV )SvRV (coro_current);
		2022	AV *defav = GvAV (PL_defgv);
		2023	SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
		2024	AV *invoke_av;
		2025	int i, len;
		2026
		2027	if (!invoke)
		2028	{
		2029	SV *old = PL_diehook;
		2030	PL_diehook = 0;
		2031	SvREFCNT_dec (old);
		2032	croak ("\3async_pool terminate\2\n");
		2033	}
		2034
		2035	SvREFCNT_dec (coro->saved_deffh);
		2036	coro->saved_deffh = SvREFCNT_inc ((SV *)PL_defoutgv);
		2037
		2038	hv_store (hv, "desc", sizeof ("desc") - 1,
		2039	newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
		2040
		2041	invoke_av = (AV *)SvRV (invoke);
		2042	len = av_len (invoke_av);
		2043
		2044	sv_setsv (cb, AvARRAY (invoke_av)[0]);
		2045
		2046	if (len > 0)
		2047	{
		2048	av_fill (defav, len - 1);
		2049	for (i = 0; i < len; ++i)
		2050	av_store (defav, i, SvREFCNT_inc (AvARRAY (invoke_av)[i + 1]));
		2051	}
		2052
		2053	SvREFCNT_dec (invoke);
		2054	}
		2055
		2056	void
		2057	_pool_2 (SV *cb)
		2058	CODE:
		2059	{
		2060	struct coro *coro = SvSTATE (coro_current);
		2061
		2062	sv_setsv (cb, &PL_sv_undef);
		2063
		2064	SvREFCNT_dec ((SV )PL_defoutgv); PL_defoutgv = (GV )coro->saved_deffh;
		2065	coro->saved_deffh = 0;
		2066
		2067	if (coro_rss (aTHX_ coro) > SvIV (sv_pool_rss)
		2068	\|\| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
		2069	{
		2070	SV *old = PL_diehook;
		2071	PL_diehook = 0;
		2072	SvREFCNT_dec (old);
		2073	croak ("\3async_pool terminate\2\n");
		2074	}
		2075
		2076	av_clear (GvAV (PL_defgv));
		2077	hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
		2078	newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
		2079
		2080	coro->prio = 0;
		2081
		2082	if (coro->cctx && (coro->cctx->flags & CC_TRACE))
		2083	api_trace (coro_current, 0);
		2084
		2085	av_push (av_async_pool, newSVsv (coro_current));
		2086	}
		2087
		2088
		2089	MODULE = Coro::State PACKAGE = Coro::AIO
		2090
		2091	SV *
		2092	_get_state ()
		2093	CODE:
		2094	{
		2095	struct io_state *data;
		2096
		2097	RETVAL = newSV (sizeof (struct io_state));
		2098	data = (struct io_state *)SvPVX (RETVAL);
		2099	SvCUR_set (RETVAL, sizeof (struct io_state));
		2100	SvPOK_only (RETVAL);
		2101
		2102	data->errorno = errno;
		2103	data->laststype = PL_laststype;
		2104	data->laststatval = PL_laststatval;
		2105	data->statcache = PL_statcache;
		2106	}
		2107	OUTPUT:
		2108	RETVAL
		2109
		2110	void
		2111	_set_state (char *data_)
		2112	PROTOTYPE: $
		2113	CODE:
		2114	{
		2115	struct io_state data = (void )data_;
		2116
		2117	errno = data->errorno;
		2118	PL_laststype = data->laststype;
		2119	PL_laststatval = data->laststatval;
		2120	PL_statcache = data->statcache;
		2121	}
		2122
		2123
		2124	MODULE = Coro::State PACKAGE = Coro::AnyEvent
		2125
		2126	BOOT:
		2127	sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
		2128
		2129	SV *
		2130	_schedule (...)
		2131	PROTOTYPE: @
		2132	CODE:
		2133	{
		2134	static int incede;
		2135
		2136	api_cede_notself ();
		2137
		2138	++incede;
		2139	while (coro_nready >= incede && api_cede ())
		2140	;
		2141
		2142	sv_setsv (sv_activity, &PL_sv_undef);
		2143	if (coro_nready >= incede)
		2144	{
		2145	PUSHMARK (SP);
476	PUTBACK;	2146	PUTBACK;
477	SAVE(aTHX_ (&temp));	2147	call_pv ("Coro::AnyEvent::_activity", G_DISCARD \| G_EVAL);
478	LOAD(aTHX_ coro);
479
480	destroy_stacks ();
481	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
482
483	LOAD((&temp));
484	SPAGAIN;	2148	SPAGAIN;
485	}	2149	}
486		2150
487	SvREFCNT_dec (coro->args);	2151	--incede;
488	Safefree (coro);	2152	}
489		2153
490

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs. Revision 1.241 by root, Mon Jul 21 02:39:15 2008 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.4 by root, Tue Jul 17 02:21:56 2001 UTC vs.
Revision 1.241 by root, Mon Jul 21 02:39:15 2008 UTC