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

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.263 by root, Wed Nov 12 04:49:06 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.263 by root, Wed Nov 12 04:49:06 2008 UTC