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

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.258 by root, Sun Nov 9 23:08:49 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.258 by root, Sun Nov 9 23:08:49 2008 UTC