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