ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/Coro/Coro/State.xs

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

Diff Legend

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