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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.256 by root, Sat Nov 8 13:32:18 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	void *stack_start;
		1103	size_t stack_size;
		1104
		1105	++cctx_count;
		1106	Newz (0, cctx, 1, coro_cctx);
		1107
		1108	cctx->gen = cctx_gen;
		1109
		1110	#if HAVE_MMAP
		1111	cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE;
		1112	/* mmap supposedly does allocate-on-write for us */
		1113	cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC\|PROT_READ\|PROT_WRITE, MAP_PRIVATE\|MAP_ANONYMOUS, 0, 0);
		1114
		1115	if (cctx->sptr != (void *)-1)
		1116	{
		1117	# if CORO_STACKGUARD
		1118	mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE);
		1119	# endif
		1120	stack_start = CORO_STACKGUARD * PAGESIZE + (char *)cctx->sptr;
		1121	stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE;
		1122	cctx->flags \|= CC_MAPPED;
		1123	}
		1124	else
		1125	#endif
		1126	{
		1127	cctx->ssize = cctx_stacksize * (long)sizeof (long);
		1128	New (0, cctx->sptr, cctx_stacksize, long);
		1129
		1130	if (!cctx->sptr)
		1131	{
		1132	perror ("FATAL: unable to allocate stack for coroutine");
		1133	_exit (EXIT_FAILURE);
		1134	}
		1135
		1136	stack_start = cctx->sptr;
		1137	stack_size = cctx->ssize;
		1138	}
		1139
		1140	REGISTER_STACK (cctx, (char )stack_start, (char )stack_start + stack_size);
		1141	coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size);
		1142
		1143	return cctx;
		1144	}
		1145
		1146	static void
		1147	cctx_destroy (coro_cctx *cctx)
		1148	{
		1149	if (!cctx)
		1150	return;
		1151
		1152	--cctx_count;
		1153	coro_destroy (&cctx->cctx);
		1154
		1155	/* coro_transfer creates new, empty cctx's */
		1156	if (cctx->sptr)
		1157	{
		1158	#if CORO_USE_VALGRIND
		1159	VALGRIND_STACK_DEREGISTER (cctx->valgrind_id);
		1160	#endif
		1161
		1162	#if HAVE_MMAP
		1163	if (cctx->flags & CC_MAPPED)
		1164	munmap (cctx->sptr, cctx->ssize);
		1165	else
		1166	#endif
		1167	Safefree (cctx->sptr);
		1168	}
		1169
		1170	Safefree (cctx);
		1171	}
		1172
		1173	/* wether this cctx should be destructed */
		1174	#define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen \|\| ((cctx)->flags & CC_NOREUSE))
		1175
		1176	static coro_cctx *
		1177	cctx_get (pTHX)
		1178	{
		1179	while (expect_true (cctx_first))
		1180	{
		1181	coro_cctx *cctx = cctx_first;
		1182	cctx_first = cctx->next;
		1183	--cctx_idle;
		1184
		1185	if (expect_true (!CCTX_EXPIRED (cctx)))
		1186	return cctx;
		1187
		1188	cctx_destroy (cctx);
		1189	}
		1190
		1191	return cctx_new ();
		1192	}
		1193
		1194	static void
		1195	cctx_put (coro_cctx *cctx)
		1196	{
		1197	assert (("cctx_put called on non-initialised cctx", cctx->sptr));
		1198
		1199	/* free another cctx if overlimit */
		1200	if (expect_false (cctx_idle >= cctx_max_idle))
		1201	{
		1202	coro_cctx *first = cctx_first;
		1203	cctx_first = first->next;
		1204	--cctx_idle;
		1205
		1206	cctx_destroy (first);
		1207	}
		1208
		1209	++cctx_idle;
		1210	cctx->next = cctx_first;
		1211	cctx_first = cctx;
		1212	}
		1213
		1214	/ coroutine switching ***************************************************/
		1215
		1216	static void
		1217	transfer_check (pTHX_ struct coro prev, struct coro next)
		1218	{
		1219	if (expect_true (prev != next))
		1220	{
		1221	if (expect_false (!(prev->flags & (CF_RUNNING \| CF_NEW))))
		1222	croak ("Coro::State::transfer called with non-running/new prev Coro::State, but can only transfer from running or new states");
		1223
		1224	if (expect_false (next->flags & CF_RUNNING))
		1225	croak ("Coro::State::transfer called with running next Coro::State, but can only transfer to inactive states");
		1226
		1227	if (expect_false (next->flags & CF_DESTROYED))
		1228	croak ("Coro::State::transfer called with destroyed next Coro::State, but can only transfer to inactive states");
		1229
		1230	#if !PERL_VERSION_ATLEAST (5,10,0)
		1231	if (expect_false (PL_lex_state != LEX_NOTPARSING))
		1232	croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version");
		1233	#endif
		1234	}
		1235	}
		1236
		1237	/* always use the TRANSFER macro */
		1238	static void NOINLINE
		1239	transfer (pTHX_ struct coro prev, struct coro next, int force_cctx)
		1240	{
		1241	dSTACKLEVEL;
		1242
		1243	/* sometimes transfer is only called to set idle_sp */
		1244	if (expect_false (!next))
		1245	{
		1246	((coro_cctx *)prev)->idle_sp = STACKLEVEL;
		1247	assert (((coro_cctx )prev)->idle_te = PL_top_env); / just for the side-effect when asserts are enabled */
		1248	}
		1249	else if (expect_true (prev != next))
		1250	{
		1251	static volatile int has_throw;
		1252	coro_cctx *prev__cctx;
		1253
		1254	if (expect_false (prev->flags & CF_NEW))
		1255	{
		1256	/* create a new empty/source context */
		1257	++cctx_count;
		1258	New (0, prev->cctx, 1, coro_cctx);
		1259	prev->cctx->sptr = 0;
		1260	coro_create (&prev->cctx->cctx, 0, 0, 0, 0);
		1261
		1262	prev->flags &= ~CF_NEW;
		1263	prev->flags \|= CF_RUNNING;
		1264	}
		1265
		1266	prev->flags &= ~CF_RUNNING;
		1267	next->flags \|= CF_RUNNING;
		1268
		1269	LOCK;
		1270
		1271	/* first get rid of the old state */
		1272	save_perl (aTHX_ prev);
		1273
		1274	if (expect_false (next->flags & CF_NEW))
		1275	{
		1276	/* need to start coroutine */
		1277	next->flags &= ~CF_NEW;
		1278	/* setup coroutine call */
		1279	coro_setup (aTHX_ next);
		1280	}
		1281	else
		1282	load_perl (aTHX_ next);
		1283
		1284	prev__cctx = prev->cctx;
		1285
		1286	/* possibly "free" the cctx */
		1287	if (expect_true (
		1288	prev__cctx->idle_sp == STACKLEVEL
		1289	&& !(prev__cctx->flags & CC_TRACE)
		1290	&& !force_cctx
		1291	))
		1292	{
		1293	/* I assume that STACKLEVEL is a stronger indicator than PL_top_env changes */
		1294	assert (("ERROR: current top_env must equal previous top_env", PL_top_env == prev__cctx->idle_te));
		1295
		1296	prev->cctx = 0;
		1297
		1298	/* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get */
		1299	/* without this the next cctx_get might destroy the prev__cctx while still in use */
		1300	if (expect_false (CCTX_EXPIRED (prev__cctx)))
		1301	if (!next->cctx)
		1302	next->cctx = cctx_get (aTHX);
		1303
		1304	cctx_put (prev__cctx);
		1305	}
		1306
		1307	++next->usecount;
		1308
		1309	if (expect_true (!next->cctx))
		1310	next->cctx = cctx_get (aTHX);
		1311
		1312	has_throw = !!next->throw;
		1313
		1314	if (expect_false (prev__cctx != next->cctx))
		1315	{
		1316	prev__cctx->top_env = PL_top_env;
		1317	PL_top_env = next->cctx->top_env;
		1318	coro_transfer (&prev__cctx->cctx, &next->cctx->cctx);
		1319	}
		1320
		1321	free_coro_mortal (aTHX);
		1322	UNLOCK;
		1323
		1324	if (expect_false (has_throw))
		1325	{
		1326	struct coro *coro = SvSTATE (coro_current);
		1327
		1328	if (coro->throw)
		1329	{
		1330	SV *exception = coro->throw;
		1331	coro->throw = 0;
		1332	sv_setsv (ERRSV, exception);
		1333	croak (0);
		1334	}
		1335	}
		1336	}
		1337	}
		1338
		1339	struct transfer_args
		1340	{
		1341	struct coro prev, next;
		1342	};
		1343
		1344	#define TRANSFER(ta, force_cctx) transfer (aTHX_ (ta).prev, (ta).next, (force_cctx))
		1345	#define TRANSFER_CHECK(ta) transfer_check (aTHX_ (ta).prev, (ta).next)
		1346
		1347	/ high level stuff ******************************************************/
		1348
		1349	static int
		1350	coro_state_destroy (pTHX_ struct coro *coro)
		1351	{
		1352	if (coro->flags & CF_DESTROYED)
		1353	return 0;
		1354
		1355	coro->flags \|= CF_DESTROYED;
		1356
		1357	if (coro->flags & CF_READY)
		1358	{
		1359	/* reduce nready, as destroying a ready coro effectively unreadies it */
		1360	/* alternative: look through all ready queues and remove the coro */
		1361	LOCK;
		1362	--coro_nready;
		1363	UNLOCK;
		1364	}
		1365	else
		1366	coro->flags \|= CF_READY; /* make sure it is NOT put into the readyqueue */
		1367
		1368	if (coro->mainstack && coro->mainstack != main_mainstack)
		1369	{
		1370	struct coro temp;
		1371
		1372	if (coro->flags & CF_RUNNING)
		1373	croak ("FATAL: tried to destroy currently running coroutine");
		1374
		1375	save_perl (aTHX_ &temp);
		1376	load_perl (aTHX_ coro);
		1377
		1378	coro_destruct (aTHX_ coro);
		1379
		1380	load_perl (aTHX_ &temp);
		1381
		1382	coro->slot = 0;
		1383	}
		1384
		1385	cctx_destroy (coro->cctx);
		1386	SvREFCNT_dec (coro->args);
		1387
		1388	if (coro->next) coro->next->prev = coro->prev;
		1389	if (coro->prev) coro->prev->next = coro->next;
		1390	if (coro == coro_first) coro_first = coro->next;
		1391
		1392	return 1;
		1393	}
		1394
		1395	static int
		1396	coro_state_free (pTHX_ SV sv, MAGIC mg)
		1397	{
		1398	struct coro coro = (struct coro )mg->mg_ptr;
		1399	mg->mg_ptr = 0;
		1400
		1401	coro->hv = 0;
		1402
		1403	if (--coro->refcnt < 0)
		1404	{
		1405	coro_state_destroy (aTHX_ coro);
		1406	Safefree (coro);
		1407	}
		1408
		1409	return 0;
		1410	}
		1411
		1412	static int
		1413	coro_state_dup (pTHX_ MAGIC mg, CLONE_PARAMS params)
		1414	{
		1415	struct coro coro = (struct coro )mg->mg_ptr;
		1416
		1417	++coro->refcnt;
		1418
		1419	return 0;
		1420	}
		1421
		1422	static MGVTBL coro_state_vtbl = {
		1423	0, 0, 0, 0,
		1424	coro_state_free,
		1425	0,
		1426	#ifdef MGf_DUP
		1427	coro_state_dup,
		1428	#else
		1429	# define MGf_DUP 0
		1430	#endif
		1431	};
		1432
		1433	static void
		1434	prepare_transfer (pTHX_ struct transfer_args ta, SV prev_sv, SV *next_sv)
		1435	{
		1436	ta->prev = SvSTATE (prev_sv);
		1437	ta->next = SvSTATE (next_sv);
		1438	TRANSFER_CHECK (*ta);
		1439	}
		1440
		1441	static void
		1442	api_transfer (SV prev_sv, SV next_sv)
		1443	{
		1444	dTHX;
		1445	struct transfer_args ta;
		1446
		1447	prepare_transfer (aTHX_ &ta, prev_sv, next_sv);
		1448	TRANSFER (ta, 1);
		1449	}
		1450
		1451	/ Coro ******************************************************************/
		1452
		1453	static void
		1454	coro_enq (pTHX_ SV *coro_sv)
		1455	{
		1456	av_push (coro_ready [SvSTATE (coro_sv)->prio - PRIO_MIN], coro_sv);
		1457	}
		1458
		1459	static SV *
		1460	coro_deq (pTHX)
		1461	{
		1462	int prio;
		1463
		1464	for (prio = PRIO_MAX - PRIO_MIN + 1; --prio >= 0; )
		1465	if (AvFILLp (coro_ready [prio]) >= 0)
		1466	return av_shift (coro_ready [prio]);
		1467
		1468	return 0;
		1469	}
		1470
		1471	static int
		1472	api_ready (SV *coro_sv)
		1473	{
		1474	dTHX;
		1475	struct coro *coro;
		1476	SV *sv_hook;
		1477	void (*xs_hook)(void);
		1478
		1479	if (SvROK (coro_sv))
		1480	coro_sv = SvRV (coro_sv);
		1481
		1482	coro = SvSTATE (coro_sv);
		1483
		1484	if (coro->flags & CF_READY)
		1485	return 0;
		1486
		1487	coro->flags \|= CF_READY;
		1488
		1489	LOCK;
		1490
		1491	sv_hook = coro_nready ? 0 : coro_readyhook;
		1492	xs_hook = coro_nready ? 0 : coroapi.readyhook;
		1493
		1494	coro_enq (aTHX_ SvREFCNT_inc_NN (coro_sv));
		1495	++coro_nready;
		1496
		1497	UNLOCK;
		1498
		1499	if (sv_hook)
		1500	{
		1501	dSP;
		1502
		1503	ENTER;
		1504	SAVETMPS;
		1505
		1506	PUSHMARK (SP);
		1507	PUTBACK;
		1508	call_sv (sv_hook, G_DISCARD);
		1509	SPAGAIN;
		1510
		1511	FREETMPS;
		1512	LEAVE;
		1513	}
		1514
		1515	if (xs_hook)
		1516	xs_hook ();
		1517
		1518	return 1;
		1519	}
		1520
		1521	static int
		1522	api_is_ready (SV *coro_sv)
		1523	{
		1524	dTHX;
		1525	return !!(SvSTATE (coro_sv)->flags & CF_READY);
		1526	}
		1527
		1528	static void
		1529	prepare_schedule (pTHX_ struct transfer_args *ta)
		1530	{
		1531	SV prev_sv, next_sv;
		1532
		1533	for (;;)
		1534	{
		1535	LOCK;
		1536	next_sv = coro_deq (aTHX);
		1537
		1538	/* nothing to schedule: call the idle handler */
		1539	if (expect_false (!next_sv))
		1540	{
		1541	dSP;
		1542	UNLOCK;
		1543
		1544	ENTER;
		1545	SAVETMPS;
		1546
		1547	PUSHMARK (SP);
		1548	PUTBACK;
		1549	call_sv (get_sv ("Coro::idle", FALSE), G_DISCARD);
		1550	SPAGAIN;
		1551
		1552	FREETMPS;
		1553	LEAVE;
		1554	continue;
		1555	}
		1556
		1557	ta->next = SvSTATE (next_sv);
		1558
		1559	/* cannot transfer to destroyed coros, skip and look for next */
		1560	if (expect_false (ta->next->flags & CF_DESTROYED))
		1561	{
		1562	UNLOCK;
		1563	SvREFCNT_dec (next_sv);
		1564	/* coro_nready is already taken care of by destroy */
		1565	continue;
		1566	}
		1567
		1568	--coro_nready;
		1569	UNLOCK;
		1570	break;
		1571	}
		1572
		1573	/* free this only after the transfer */
		1574	prev_sv = SvRV (coro_current);
		1575	ta->prev = SvSTATE (prev_sv);
		1576	TRANSFER_CHECK (*ta);
		1577	assert (ta->next->flags & CF_READY);
		1578	ta->next->flags &= ~CF_READY;
		1579	SvRV_set (coro_current, next_sv);
		1580
		1581	LOCK;
		1582	free_coro_mortal (aTHX);
		1583	coro_mortal = prev_sv;
		1584	UNLOCK;
		1585	}
		1586
		1587	static void
		1588	prepare_cede (pTHX_ struct transfer_args *ta)
		1589	{
		1590	api_ready (coro_current);
		1591	prepare_schedule (aTHX_ ta);
		1592	}
		1593
		1594	static int
		1595	prepare_cede_notself (pTHX_ struct transfer_args *ta)
		1596	{
		1597	if (coro_nready)
		1598	{
		1599	SV *prev = SvRV (coro_current);
		1600	prepare_schedule (aTHX_ ta);
		1601	api_ready (prev);
		1602	return 1;
		1603	}
		1604	else
		1605	return 0;
		1606	}
		1607
		1608	static void
		1609	api_schedule (void)
		1610	{
		1611	dTHX;
		1612	struct transfer_args ta;
		1613
		1614	prepare_schedule (aTHX_ &ta);
		1615	TRANSFER (ta, 1);
		1616	}
		1617
		1618	static int
		1619	api_cede (void)
		1620	{
		1621	dTHX;
		1622	struct transfer_args ta;
		1623
		1624	prepare_cede (aTHX_ &ta);
		1625
		1626	if (expect_true (ta.prev != ta.next))
		1627	{
		1628	TRANSFER (ta, 1);
		1629	return 1;
		1630	}
		1631	else
		1632	return 0;
		1633	}
		1634
		1635	static int
		1636	api_cede_notself (void)
		1637	{
		1638	dTHX;
		1639	struct transfer_args ta;
		1640
		1641	if (prepare_cede_notself (aTHX_ &ta))
		1642	{
		1643	TRANSFER (ta, 1);
		1644	return 1;
		1645	}
		1646	else
		1647	return 0;
		1648	}
		1649
		1650	static void
		1651	api_trace (SV *coro_sv, int flags)
		1652	{
		1653	dTHX;
		1654	struct coro *coro = SvSTATE (coro_sv);
		1655
		1656	if (flags & CC_TRACE)
		1657	{
		1658	if (!coro->cctx)
		1659	coro->cctx = cctx_new ();
		1660	else if (!(coro->cctx->flags & CC_TRACE))
		1661	croak ("cannot enable tracing on coroutine with custom stack");
		1662
		1663	coro->cctx->flags \|= CC_NOREUSE \| (flags & (CC_TRACE \| CC_TRACE_ALL));
		1664	}
		1665	else if (coro->cctx && coro->cctx->flags & CC_TRACE)
		1666	{
		1667	coro->cctx->flags &= ~(CC_TRACE \| CC_TRACE_ALL);
		1668
		1669	if (coro->flags & CF_RUNNING)
		1670	PL_runops = RUNOPS_DEFAULT;
		1671	else
		1672	coro->slot->runops = RUNOPS_DEFAULT;
		1673	}
		1674	}
		1675
		1676	#if 0
		1677	static int
		1678	coro_gensub_free (pTHX_ SV sv, MAGIC mg)
		1679	{
		1680	AV *padlist;
		1681	AV av = (AV )mg->mg_obj;
		1682
		1683	abort ();
		1684
		1685	return 0;
		1686	}
		1687
		1688	static MGVTBL coro_gensub_vtbl = {
		1689	0, 0, 0, 0,
		1690	coro_gensub_free
		1691	};
		1692	#endif
		1693
		1694	/*****************************************************************************/
		1695	/* PerlIO::cede */
		1696
		1697	typedef struct
		1698	{
		1699	PerlIOBuf base;
		1700	NV next, every;
		1701	} PerlIOCede;
		1702
		1703	static IV
		1704	PerlIOCede_pushed (pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
		1705	{
		1706	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1707
		1708	self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
		1709	self->next = nvtime () + self->every;
		1710
		1711	return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab);
		1712	}
		1713
		1714	static SV *
		1715	PerlIOCede_getarg (pTHX_ PerlIO f, CLONE_PARAMS param, int flags)
		1716	{
		1717	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1718
		1719	return newSVnv (self->every);
		1720	}
		1721
		1722	static IV
		1723	PerlIOCede_flush (pTHX_ PerlIO *f)
		1724	{
		1725	PerlIOCede *self = PerlIOSelf (f, PerlIOCede);
		1726	double now = nvtime ();
		1727
		1728	if (now >= self->next)
		1729	{
		1730	api_cede ();
		1731	self->next = now + self->every;
		1732	}
		1733
		1734	return PerlIOBuf_flush (aTHX_ f);
		1735	}
		1736
		1737	static PerlIO_funcs PerlIO_cede =
		1738	{
		1739	sizeof(PerlIO_funcs),
		1740	"cede",
		1741	sizeof(PerlIOCede),
		1742	PERLIO_K_DESTRUCT \| PERLIO_K_RAW,
		1743	PerlIOCede_pushed,
		1744	PerlIOBuf_popped,
		1745	PerlIOBuf_open,
		1746	PerlIOBase_binmode,
		1747	PerlIOCede_getarg,
		1748	PerlIOBase_fileno,
		1749	PerlIOBuf_dup,
		1750	PerlIOBuf_read,
		1751	PerlIOBuf_unread,
		1752	PerlIOBuf_write,
		1753	PerlIOBuf_seek,
		1754	PerlIOBuf_tell,
		1755	PerlIOBuf_close,
		1756	PerlIOCede_flush,
		1757	PerlIOBuf_fill,
		1758	PerlIOBase_eof,
		1759	PerlIOBase_error,
		1760	PerlIOBase_clearerr,
		1761	PerlIOBase_setlinebuf,
		1762	PerlIOBuf_get_base,
		1763	PerlIOBuf_bufsiz,
		1764	PerlIOBuf_get_ptr,
		1765	PerlIOBuf_get_cnt,
		1766	PerlIOBuf_set_ptrcnt,
		1767	};
		1768
		1769
		1770	MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_
		1771
		1772	PROTOTYPES: DISABLE
		1773
		1774	BOOT:
		1775	{
		1776	#ifdef USE_ITHREADS
		1777	MUTEX_INIT (&coro_lock);
		1778	# if CORO_PTHREAD
		1779	coro_thx = PERL_GET_CONTEXT;
		1780	# endif
		1781	#endif
		1782	BOOT_PAGESIZE;
		1783
		1784	irsgv = gv_fetchpv ("/" , GV_ADD\|GV_NOTQUAL, SVt_PV);
		1785	stdoutgv = gv_fetchpv ("STDOUT", GV_ADD\|GV_NOTQUAL, SVt_PVIO);
		1786
		1787	orig_sigelem_get = PL_vtbl_sigelem.svt_get; PL_vtbl_sigelem.svt_get = coro_sigelem_get;
		1788	orig_sigelem_set = PL_vtbl_sigelem.svt_set; PL_vtbl_sigelem.svt_set = coro_sigelem_set;
		1789	orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
		1790
		1791	hv_sig = coro_get_hv (aTHX_ "SIG", TRUE);
		1792	rv_diehook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
		1793	rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
		1794
		1795	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
		1796
		1797	newCONSTSUB (coro_state_stash, "CC_TRACE" , newSViv (CC_TRACE));
		1798	newCONSTSUB (coro_state_stash, "CC_TRACE_SUB" , newSViv (CC_TRACE_SUB));
		1799	newCONSTSUB (coro_state_stash, "CC_TRACE_LINE", newSViv (CC_TRACE_LINE));
		1800	newCONSTSUB (coro_state_stash, "CC_TRACE_ALL" , newSViv (CC_TRACE_ALL));
		1801
		1802	main_mainstack = PL_mainstack;
		1803	main_top_env = PL_top_env;
		1804
		1805	while (main_top_env->je_prev)
		1806	main_top_env = main_top_env->je_prev;
		1807
		1808	coroapi.ver = CORO_API_VERSION;
		1809	coroapi.rev = CORO_API_REVISION;
		1810	coroapi.transfer = api_transfer;
		1811
		1812	{
		1813	SV **svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0);
		1814
		1815	if (!svp) croak ("Time::HiRes is required");
		1816	if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer");
		1817
		1818	nvtime = INT2PTR (double ()(), SvIV (svp));
		1819	}
		1820
		1821	assert (("PRIO_NORMAL must be 0", !PRIO_NORMAL));
		1822	}
		1823
		1824	SV *
		1825	new (char *klass, ...)
		1826	CODE:
		1827	{
		1828	struct coro *coro;
		1829	MAGIC *mg;
		1830	HV *hv;
		1831	int i;
		1832
		1833	Newz (0, coro, 1, struct coro);
		1834	coro->args = newAV ();
		1835	coro->flags = CF_NEW;
		1836
		1837	if (coro_first) coro_first->prev = coro;
		1838	coro->next = coro_first;
		1839	coro_first = coro;
		1840
		1841	coro->hv = hv = newHV ();
		1842	mg = sv_magicext ((SV )hv, 0, CORO_MAGIC_type_state, &coro_state_vtbl, (char )coro, 0);
		1843	mg->mg_flags \|= MGf_DUP;
		1844	RETVAL = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
		1845
		1846	av_extend (coro->args, items - 1);
		1847	for (i = 1; i < items; i++)
		1848	av_push (coro->args, newSVsv (ST (i)));
		1849	}
		1850	OUTPUT:
		1851	RETVAL
		1852
		1853	# these not obviously related functions are all rolled into the same xs
		1854	# function to increase chances that they all will call transfer with the same
		1855	# stack offset
		1856	void
		1857	_set_stacklevel (...)
		1858	ALIAS:
		1859	Coro::State::transfer = 1
		1860	Coro::schedule = 2
		1861	Coro::cede = 3
		1862	Coro::cede_notself = 4
		1863	CODE:
		1864	{
		1865	struct transfer_args ta;
		1866
		1867	PUTBACK;
		1868	switch (ix)
		1869	{
		1870	case 0:
		1871	ta.prev = (struct coro )INT2PTR (coro_cctx , SvIV (ST (0)));
		1872	ta.next = 0;
		1873	break;
		1874
		1875	case 1:
		1876	if (items != 2)
		1877	croak ("Coro::State::transfer (prev, next) expects two arguments, not %d", items);
		1878
		1879	prepare_transfer (aTHX_ &ta, ST (0), ST (1));
		1880	break;
		1881
		1882	case 2:
		1883	prepare_schedule (aTHX_ &ta);
		1884	break;
		1885
		1886	case 3:
		1887	prepare_cede (aTHX_ &ta);
		1888	break;
		1889
		1890	case 4:
		1891	if (!prepare_cede_notself (aTHX_ &ta))
		1892	XSRETURN_EMPTY;
		1893
		1894	break;
		1895	}
		1896	SPAGAIN;
		1897
		1898	BARRIER;
		1899	PUTBACK;
		1900	TRANSFER (ta, 0);
		1901	SPAGAIN; /* might be the sp of a different coroutine now */
		1902	/* be extra careful not to ever do anything after TRANSFER */
		1903	}
		1904
		1905	bool
		1906	_destroy (SV *coro_sv)
		1907	CODE:
		1908	RETVAL = coro_state_destroy (aTHX_ SvSTATE (coro_sv));
		1909	OUTPUT:
		1910	RETVAL
		1911
		1912	void
		1913	_exit (int code)
		1914	PROTOTYPE: $
		1915	CODE:
		1916	_exit (code);
		1917
		1918	int
		1919	cctx_stacksize (int new_stacksize = 0)
		1920	CODE:
		1921	RETVAL = cctx_stacksize;
		1922	if (new_stacksize)
		1923	{
		1924	cctx_stacksize = new_stacksize;
		1925	++cctx_gen;
		1926	}
		1927	OUTPUT:
		1928	RETVAL
		1929
		1930	int
		1931	cctx_max_idle (int max_idle = 0)
		1932	CODE:
		1933	RETVAL = cctx_max_idle;
		1934	if (max_idle > 1)
		1935	cctx_max_idle = max_idle;
		1936	OUTPUT:
		1937	RETVAL
		1938
		1939	int
		1940	cctx_count ()
		1941	CODE:
		1942	RETVAL = cctx_count;
		1943	OUTPUT:
		1944	RETVAL
		1945
		1946	int
		1947	cctx_idle ()
		1948	CODE:
		1949	RETVAL = cctx_idle;
		1950	OUTPUT:
		1951	RETVAL
		1952
		1953	void
		1954	list ()
		1955	PPCODE:
		1956	{
		1957	struct coro *coro;
		1958	for (coro = coro_first; coro; coro = coro->next)
		1959	if (coro->hv)
		1960	XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv)));
		1961	}
		1962
		1963	void
		1964	call (Coro::State coro, SV *coderef)
		1965	ALIAS:
		1966	eval = 1
		1967	CODE:
		1968	{
		1969	if (coro->mainstack && ((coro->flags & CF_RUNNING) \|\| coro->slot))
		1970	{
		1971	struct coro temp;
		1972
		1973	if (!(coro->flags & CF_RUNNING))
235	{	1974	{
236	/* I never used formats, so how should I know how these are implemented? */	1975	PUTBACK;
237	/* my bold guess is as a simple, plain sub... */	1976	save_perl (aTHX_ &temp);
238	croak ("CXt_FORMAT not yet handled. Don't switch coroutines from within formats");	1977	load_perl (aTHX_ coro);
		1978	}
		1979
		1980	{
		1981	dSP;
		1982	ENTER;
		1983	SAVETMPS;
		1984	PUTBACK;
		1985	PUSHSTACK;
		1986	PUSHMARK (SP);
		1987
		1988	if (ix)
		1989	eval_sv (coderef, 0);
		1990	else
		1991	call_sv (coderef, G_KEEPERR \| G_EVAL \| G_VOID \| G_DISCARD);
		1992
		1993	POPSTACK;
		1994	SPAGAIN;
		1995	FREETMPS;
		1996	LEAVE;
		1997	PUTBACK;
		1998	}
		1999
		2000	if (!(coro->flags & CF_RUNNING))
		2001	{
		2002	save_perl (aTHX_ coro);
		2003	load_perl (aTHX_ &temp);
		2004	SPAGAIN;
239	}	2005	}
240	}	2006	}
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	}	2007	}
281		2008
282	static void	2009	SV *
283	LOAD(pTHX_ Coro__State c)	2010	is_ready (Coro::State coro)
284	{	2011	PROTOTYPE: $
285	PL_dowarn = c->dowarn;	2012	ALIAS:
286	GvAV (PL_defgv) = c->defav;	2013	is_ready = CF_READY
287	PL_curstackinfo = c->curstackinfo;	2014	is_running = CF_RUNNING
288	PL_curstack = c->curstack;	2015	is_new = CF_NEW
289	PL_mainstack = c->mainstack;	2016	is_destroyed = CF_DESTROYED
290	PL_stack_sp = c->stack_sp;	2017	CODE:
291	PL_op = c->op;	2018	RETVAL = boolSV (coro->flags & ix);
292	PL_curpad = c->curpad;	2019	OUTPUT:
293	PL_stack_base = c->stack_base;	2020	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		2021
		2022	void
		2023	api_trace (SV *coro, int flags = CC_TRACE \| CC_TRACE_SUB)
		2024
		2025	SV *
		2026	has_cctx (Coro::State coro)
		2027	PROTOTYPE: $
		2028	CODE:
		2029	RETVAL = boolSV (!!coro->cctx);
		2030	OUTPUT:
		2031	RETVAL
		2032
		2033	int
		2034	is_traced (Coro::State coro)
		2035	PROTOTYPE: $
		2036	CODE:
		2037	RETVAL = (coro->cctx ? coro->cctx->flags : 0) & CC_TRACE_ALL;
		2038	OUTPUT:
		2039	RETVAL
		2040
		2041	UV
		2042	rss (Coro::State coro)
		2043	PROTOTYPE: $
		2044	ALIAS:
		2045	usecount = 1
		2046	CODE:
		2047	switch (ix)
313	{	2048	{
314	dSP;	2049	case 0: RETVAL = coro_rss (aTHX_ coro); break;
315	CV *cv;	2050	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	}	2051	}
		2052	OUTPUT:
		2053	RETVAL
331		2054
332	PUTBACK;	2055	void
333	}	2056	force_cctx ()
334	}	2057	CODE:
		2058	struct coro *coro = SvSTATE (coro_current);
		2059	coro->cctx->idle_sp = 0;
335		2060
336	/* this is an EXACT copy of S_nuke_stacks in perl.c, which is unfortunately static */	2061	void
337	STATIC void	2062	swap_defsv (Coro::State self)
338	destroy_stacks(pTHX)	2063	PROTOTYPE: $
339	{	2064	ALIAS:
340	/* die does this while calling POPSTACK, but I just don't see why. */	2065	swap_defav = 1
341	dounwind(-1);	2066	CODE:
		2067	if (!self->slot)
		2068	croak ("cannot swap state with coroutine that has no saved state");
		2069	else
		2070	{
		2071	SV src = ix ? (SV )&GvAV (PL_defgv) : &GvSV (PL_defgv);
		2072	SV dst = ix ? (SV )&self->slot->defav : (SV **)&self->slot->defsv;
342		2073
343	/* is this ugly, I ask? */	2074	SV tmp = src; src = dst; *dst = tmp;
344	while (PL_scopestack_ix)	2075	}
345	LEAVE;
346		2076
347	while (PL_curstackinfo->si_next)
348	PL_curstackinfo = PL_curstackinfo->si_next;
349
350	while (PL_curstackinfo)
351	{
352	PERL_SI *p = PL_curstackinfo->si_prev;
353
354	SvREFCNT_dec(PL_curstackinfo->si_stack);
355	Safefree(PL_curstackinfo->si_cxstack);
356	Safefree(PL_curstackinfo);
357	PL_curstackinfo = p;
358	}
359
360	if (PL_scopestack_ix != 0)
361	Perl_warner(aTHX_ WARN_INTERNAL,
362	"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
363	(long)PL_scopestack_ix);
364	if (PL_savestack_ix != 0)
365	Perl_warner(aTHX_ WARN_INTERNAL,
366	"Unbalanced saves: %ld more saves than restores\n",
367	(long)PL_savestack_ix);
368	if (PL_tmps_floor != -1)
369	Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
370	(long)PL_tmps_floor + 1);
371	/*
372	*/
373	Safefree(PL_tmps_stack);
374	Safefree(PL_markstack);
375	Safefree(PL_scopestack);
376	Safefree(PL_savestack);
377	Safefree(PL_retstack);
378	}
379
380	#define SUB_INIT "Coro::State::_newcoro"
381
382	MODULE = Coro::State PACKAGE = Coro::State	2077	MODULE = Coro::State PACKAGE = Coro
383
384	PROTOTYPES: ENABLE
385		2078
386	BOOT:	2079	BOOT:
387	if (!padlist_cache)	2080	{
388	padlist_cache = newHV ();	2081	int i;
389		2082
390	Coro::State	2083	av_async_pool = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
391	_newprocess(args)	2084	sv_pool_rss = coro_get_sv (aTHX_ "Coro::POOL_RSS" , TRUE);
392	SV * args	2085	sv_pool_size = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
		2086
		2087	coro_current = coro_get_sv (aTHX_ "Coro::current", FALSE);
		2088	SvREADONLY_on (coro_current);
		2089
		2090	coro_stash = gv_stashpv ("Coro", TRUE);
		2091
		2092	newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (PRIO_MAX));
		2093	newCONSTSUB (coro_stash, "PRIO_HIGH", newSViv (PRIO_HIGH));
		2094	newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (PRIO_NORMAL));
		2095	newCONSTSUB (coro_stash, "PRIO_LOW", newSViv (PRIO_LOW));
		2096	newCONSTSUB (coro_stash, "PRIO_IDLE", newSViv (PRIO_IDLE));
		2097	newCONSTSUB (coro_stash, "PRIO_MIN", newSViv (PRIO_MIN));
		2098
		2099	for (i = PRIO_MAX - PRIO_MIN + 1; i--; )
		2100	coro_ready[i] = newAV ();
		2101
		2102	{
		2103	SV *sv = perl_get_sv ("Coro::API", TRUE);
		2104	perl_get_sv ("Coro::API", TRUE); /* silence 5.10 warning */
		2105
		2106	coroapi.schedule = api_schedule;
		2107	coroapi.cede = api_cede;
		2108	coroapi.cede_notself = api_cede_notself;
		2109	coroapi.ready = api_ready;
		2110	coroapi.is_ready = api_is_ready;
		2111	coroapi.nready = &coro_nready;
		2112	coroapi.current = coro_current;
		2113
		2114	GCoroAPI = &coroapi;
		2115	sv_setiv (sv, (IV)&coroapi);
		2116	SvREADONLY_on (sv);
		2117	}
		2118	}
		2119
		2120	void
		2121	_set_current (SV *current)
393	PROTOTYPE: $	2122	PROTOTYPE: $
		2123	CODE:
		2124	SvREFCNT_dec (SvRV (coro_current));
		2125	SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
		2126
		2127	void
		2128	_set_readyhook (SV *hook)
		2129	PROTOTYPE: $
394	CODE:	2130	CODE:
395	Coro__State coro;
396
397	if (!SvROK (args) \|\| SvTYPE (SvRV (args)) != SVt_PVAV)
398	croak ("Coro::State::newprocess expects an arrayref");
399		2131	LOCK;
400	New (0, coro, 1, struct coro);	2132	SvREFCNT_dec (coro_readyhook);
		2133	coro_readyhook = SvOK (hook) ? newSVsv (hook) : 0;
		2134	UNLOCK;
401		2135
402	coro->mainstack = 0; /* actual work is done inside transfer */	2136	int
403	coro->args = (AV *)SvREFCNT_inc (SvRV (args));	2137	prio (Coro::State coro, int newprio = 0)
404		2138	ALIAS:
		2139	nice = 1
		2140	CODE:
		2141	{
405	RETVAL = coro;	2142	RETVAL = coro->prio;
406	OUTPUT:	2143
		2144	if (items > 1)
		2145	{
		2146	if (ix)
		2147	newprio = coro->prio - newprio;
		2148
		2149	if (newprio < PRIO_MIN) newprio = PRIO_MIN;
		2150	if (newprio > PRIO_MAX) newprio = PRIO_MAX;
		2151
		2152	coro->prio = newprio;
		2153	}
		2154	}
		2155	OUTPUT:
407	RETVAL	2156	RETVAL
408		2157
		2158	SV *
		2159	ready (SV *self)
		2160	PROTOTYPE: $
		2161	CODE:
		2162	RETVAL = boolSV (api_ready (self));
		2163	OUTPUT:
		2164	RETVAL
		2165
		2166	int
		2167	nready (...)
		2168	PROTOTYPE:
		2169	CODE:
		2170	RETVAL = coro_nready;
		2171	OUTPUT:
		2172	RETVAL
		2173
409	void	2174	void
410	transfer(prev,next)	2175	throw (Coro::State self, SV *throw = &PL_sv_undef)
411	Coro::State_or_hashref prev	2176	PROTOTYPE: $;$
412	Coro::State_or_hashref next
413	CODE:	2177	CODE:
		2178	SvREFCNT_dec (self->throw);
		2179	self->throw = SvOK (throw) ? newSVsv (throw) : 0;
414		2180
415	if (prev != next)	2181	# for async_pool speedup
		2182	void
		2183	_pool_1 (SV *cb)
		2184	CODE:
		2185	{
		2186	struct coro *coro = SvSTATE (coro_current);
		2187	HV hv = (HV )SvRV (coro_current);
		2188	AV *defav = GvAV (PL_defgv);
		2189	SV *invoke = hv_delete (hv, "_invoke", sizeof ("_invoke") - 1, 0);
		2190	AV *invoke_av;
		2191	int i, len;
		2192
		2193	if (!invoke)
416	{	2194	{
		2195	SV *old = PL_diehook;
		2196	PL_diehook = 0;
		2197	SvREFCNT_dec (old);
		2198	croak ("\3async_pool terminate\2\n");
		2199	}
		2200
		2201	SvREFCNT_dec (coro->saved_deffh);
		2202	coro->saved_deffh = SvREFCNT_inc_NN ((SV *)PL_defoutgv);
		2203
		2204	hv_store (hv, "desc", sizeof ("desc") - 1,
		2205	newSVpvn ("[async_pool]", sizeof ("[async_pool]") - 1), 0);
		2206
		2207	invoke_av = (AV *)SvRV (invoke);
		2208	len = av_len (invoke_av);
		2209
		2210	sv_setsv (cb, AvARRAY (invoke_av)[0]);
		2211
		2212	if (len > 0)
		2213	{
		2214	av_fill (defav, len - 1);
		2215	for (i = 0; i < len; ++i)
		2216	av_store (defav, i, SvREFCNT_inc_NN (AvARRAY (invoke_av)[i + 1]));
		2217	}
		2218
		2219	SvREFCNT_dec (invoke);
		2220	}
		2221
		2222	void
		2223	_pool_2 (SV *cb)
		2224	CODE:
		2225	{
		2226	struct coro *coro = SvSTATE (coro_current);
		2227
		2228	sv_setsv (cb, &PL_sv_undef);
		2229
		2230	SvREFCNT_dec ((SV )PL_defoutgv); PL_defoutgv = (GV )coro->saved_deffh;
		2231	coro->saved_deffh = 0;
		2232
		2233	if (coro_rss (aTHX_ coro) > SvUV (sv_pool_rss)
		2234	\|\| av_len (av_async_pool) + 1 >= SvIV (sv_pool_size))
		2235	{
		2236	SV *old = PL_diehook;
		2237	PL_diehook = 0;
		2238	SvREFCNT_dec (old);
		2239	croak ("\3async_pool terminate\2\n");
		2240	}
		2241
		2242	av_clear (GvAV (PL_defgv));
		2243	hv_store ((HV *)SvRV (coro_current), "desc", sizeof ("desc") - 1,
		2244	newSVpvn ("[async_pool idle]", sizeof ("[async_pool idle]") - 1), 0);
		2245
		2246	coro->prio = 0;
		2247
		2248	if (coro->cctx && (coro->cctx->flags & CC_TRACE))
		2249	api_trace (coro_current, 0);
		2250
		2251	av_push (av_async_pool, newSVsv (coro_current));
		2252	}
		2253
		2254	#if 0
		2255
		2256	void
		2257	_generator_call (...)
		2258	PROTOTYPE: @
		2259	PPCODE:
		2260	fprintf (stderr, "call %p\n", CvXSUBANY(cv).any_ptr);
		2261	xxxx
		2262	abort ();
		2263
		2264	SV *
		2265	gensub (SV *sub, ...)
		2266	PROTOTYPE: &;@
		2267	CODE:
		2268	{
		2269	struct coro *coro;
		2270	MAGIC *mg;
		2271	CV *xcv;
		2272	CV ncv = (CV )newSV_type (SVt_PVCV);
		2273	int i;
		2274
		2275	CvGV (ncv) = CvGV (cv);
		2276	CvFILE (ncv) = CvFILE (cv);
		2277
		2278	Newz (0, coro, 1, struct coro);
		2279	coro->args = newAV ();
		2280	coro->flags = CF_NEW;
		2281
		2282	av_extend (coro->args, items - 1);
		2283	for (i = 1; i < items; i++)
		2284	av_push (coro->args, newSVsv (ST (i)));
		2285
		2286	CvISXSUB_on (ncv);
		2287	CvXSUBANY (ncv).any_ptr = (void *)coro;
		2288
		2289	xcv = GvCV (gv_fetchpv ("Coro::_generator_call", 0, SVt_PVCV));
		2290
		2291	CvXSUB (ncv) = CvXSUB (xcv);
		2292	CvANON_on (ncv);
		2293
		2294	mg = sv_magicext ((SV )ncv, 0, CORO_MAGIC_type_state, &coro_gensub_vtbl, (char )coro, 0);
		2295	RETVAL = newRV_noinc ((SV *)ncv);
		2296	}
		2297	OUTPUT:
		2298	RETVAL
		2299
		2300	#endif
		2301
		2302
		2303	MODULE = Coro::State PACKAGE = Coro::AIO
		2304
		2305	void
		2306	_get_state (SV *self)
		2307	PPCODE:
		2308	{
		2309	AV *defav = GvAV (PL_defgv);
		2310	AV *av = newAV ();
		2311	int i;
		2312	SV *data_sv = newSV (sizeof (struct io_state));
		2313	struct io_state data = (struct io_state )SvPVX (data_sv);
		2314	SvCUR_set (data_sv, sizeof (struct io_state));
		2315	SvPOK_only (data_sv);
		2316
		2317	data->errorno = errno;
		2318	data->laststype = PL_laststype;
		2319	data->laststatval = PL_laststatval;
		2320	data->statcache = PL_statcache;
		2321
		2322	av_extend (av, AvFILLp (defav) + 1 + 1);
		2323
		2324	for (i = 0; i <= AvFILLp (defav); ++i)
		2325	av_push (av, SvREFCNT_inc_NN (AvARRAY (defav)[i]));
		2326
		2327	av_push (av, data_sv);
		2328
		2329	XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
		2330
		2331	api_ready (self);
		2332	}
		2333
		2334	void
		2335	_set_state (SV *state)
		2336	PROTOTYPE: $
		2337	PPCODE:
		2338	{
		2339	AV av = (AV )SvRV (state);
		2340	struct io_state data = (struct io_state )SvPVX (AvARRAY (av)[AvFILLp (av)]);
		2341	int i;
		2342
		2343	errno = data->errorno;
		2344	PL_laststype = data->laststype;
		2345	PL_laststatval = data->laststatval;
		2346	PL_statcache = data->statcache;
		2347
		2348	EXTEND (SP, AvFILLp (av));
		2349	for (i = 0; i < AvFILLp (av); ++i)
		2350	PUSHs (sv_2mortal (SvREFCNT_inc_NN (AvARRAY (av)[i])));
		2351	}
		2352
		2353
		2354	MODULE = Coro::State PACKAGE = Coro::AnyEvent
		2355
		2356	BOOT:
		2357	sv_activity = coro_get_sv (aTHX_ "Coro::AnyEvent::ACTIVITY", TRUE);
		2358
		2359	SV *
		2360	_schedule (...)
		2361	PROTOTYPE: @
		2362	CODE:
		2363	{
		2364	static int incede;
		2365
		2366	api_cede_notself ();
		2367
		2368	++incede;
		2369	while (coro_nready >= incede && api_cede ())
		2370	;
		2371
		2372	sv_setsv (sv_activity, &PL_sv_undef);
		2373	if (coro_nready >= incede)
		2374	{
		2375	PUSHMARK (SP);
417	PUTBACK;	2376	PUTBACK;
418	SAVE (aTHX_ prev);	2377	call_pv ("Coro::AnyEvent::_activity", G_DISCARD \| G_EVAL);
419
420	/*
421	* this could be done in newprocess which would lead to
422	* extremely elegant and fast (just PUTBACK/SAVE/LOAD/SPAGAIN)
423	* code here, but lazy allocation of stacks has also
424	* some virtues and the overhead of the if() is nil.
425	*/
426	if (next->mainstack)
427	{
428	LOAD (aTHX_ next);
429	next->mainstack = 0; /* unnecessary but much cleaner */
430	SPAGAIN;
431	}
432	else
433	{
434	/*
435	* emulate part of the perl startup here.
436	*/
437	UNOP myop;
438
439	init_stacks (); /* from perl.c */
440	PL_op = (OP *)&myop;
441	/PL_curcop = 0;/
442	GvAV (PL_defgv) = (AV )SvREFCNT_inc ((SV )next->args);
443
444	SPAGAIN;
445	Zero(&myop, 1, UNOP);
446	myop.op_next = Nullop;
447	myop.op_flags = OPf_WANT_VOID;
448
449	PUSHMARK(SP);
450	XPUSHs ((SV*)get_cv(SUB_INIT, TRUE));
451	PUTBACK;
452	/*
453	* the next line is slightly wrong, as PL_op->op_next
454	* is actually being executed so we skip the first op.
455	* that doesn't matter, though, since it is only
456	* pp_nextstate and we never return...
457	*/
458	PL_op = Perl_pp_entersub(aTHX);
459	SPAGAIN;
460
461	ENTER;
462	}
463	}
464
465	void
466	DESTROY(coro)
467	Coro::State coro
468	CODE:
469
470	if (coro->mainstack)
471	{
472	struct coro temp;
473
474	PUTBACK;
475	SAVE(aTHX_ (&temp));
476	LOAD(aTHX_ coro);
477
478	destroy_stacks ();
479	SvREFCNT_dec ((SV *)GvAV (PL_defgv));
480
481	LOAD((&temp));
482	SPAGAIN;	2378	SPAGAIN;
483	}	2379	}
484		2380
485	SvREFCNT_dec (coro->args);	2381	--incede;
486	Safefree (coro);	2382	}
487		2383
488		2384
		2385	MODULE = Coro::State PACKAGE = PerlIO::cede
		2386
		2387	BOOT:
		2388	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.5 by root, Tue Jul 17 02:55:29 2001 UTC vs. Revision 1.256 by root, Sat Nov 8 13:32:18 2008 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.5 by root, Tue Jul 17 02:55:29 2001 UTC vs.
Revision 1.256 by root, Sat Nov 8 13:32:18 2008 UTC