--- Coro/Coro/State.xs 2011/05/22 20:13:33 1.403 +++ Coro/Coro/State.xs 2012/12/07 14:21:09 1.429 @@ -1,7 +1,7 @@ /* this works around a bug in mingw32 providing a non-working setjmp */ #define USE_NO_MINGW_SETJMP_TWO_ARGS -#define NDEBUG 1 +#define NDEBUG 1 /* perl usually disables NDEBUG later */ #include "libcoro/coro.c" @@ -15,6 +15,9 @@ #include "schmorp.h" +#define ECB_NO_THREADS 1 +#include "ecb.h" + #include #include #include @@ -24,6 +27,23 @@ # define SVs_PADSTALE 0 #endif +#ifdef PadARRAY +# define NEWPADAPI +# define newPADLIST(var) (Newz (0, var, 1, PADLIST), Newx (PadlistARRAY (var), 2, PAD *)) +#else +typedef AV PADNAMELIST; +# if !PERL_VERSION_ATLEAST(5,8,0) +typedef AV PADLIST; +typedef AV PAD; +# endif +# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl)) +# define PadlistMAX(pl) AvFILLp (pl) +# define PadlistNAMES(pl) (*PadlistARRAY (pl)) +# define PadARRAY AvARRAY +# define PadMAX AvFILLp +# define newPADLIST(var) ((var) = newAV (), av_extend (var, 1)) +#endif + #if defined(_WIN32) # undef HAS_GETTIMEOFDAY # undef setjmp @@ -34,42 +54,11 @@ # include /* most portable stdint.h */ #endif -#ifdef HAVE_MMAP -# include -# include -# ifndef MAP_ANONYMOUS -# ifdef MAP_ANON -# define MAP_ANONYMOUS MAP_ANON -# else -# undef HAVE_MMAP -# endif -# endif -# include -# ifndef PAGESIZE -# define PAGESIZE pagesize -# define BOOT_PAGESIZE pagesize = sysconf (_SC_PAGESIZE) -static long pagesize; -# else -# define BOOT_PAGESIZE (void)0 -# endif -#else -# define PAGESIZE 0 -# define BOOT_PAGESIZE (void)0 -#endif - -#if CORO_USE_VALGRIND -# include -#endif - /* the maximum number of idle cctx that will be pooled */ static int cctx_max_idle = 4; -#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64 -# undef CORO_STACKGUARD -#endif - -#ifndef CORO_STACKGUARD -# define CORO_STACKGUARD 0 +#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0) +# define HAS_SCOPESTACK_NAME 1 #endif /* prefer perl internal functions over our own? */ @@ -89,21 +78,6 @@ #define IN_DESTRUCT PL_dirty -#if __GNUC__ >= 3 -# define attribute(x) __attribute__(x) -# define expect(expr,value) __builtin_expect ((expr), (value)) -# define INLINE static inline -#else -# define attribute(x) -# define expect(expr,value) (expr) -# define INLINE static -#endif - -#define expect_false(expr) expect ((expr) != 0, 0) -#define expect_true(expr) expect ((expr) != 0, 1) - -#define NOINLINE attribute ((noinline)) - #include "CoroAPI.h" #define GCoroAPI (&coroapi) /* very sneaky */ @@ -185,12 +159,13 @@ struct coro_cctx *next; /* the stack */ - void *sptr; - size_t ssize; + struct coro_stack stack; /* cpu state */ void *idle_sp; /* sp of top-level transfer/schedule/cede call */ - JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */ +#ifndef NDEBUG + JMPENV *idle_te; /* same as idle_sp, but for top_env */ +#endif JMPENV *top_env; coro_context cctx; @@ -220,17 +195,11 @@ /* the structure where most of the perl state is stored, overlaid on the cxstack */ typedef struct { - SV *defsv; - AV *defav; - SV *errsv; - SV *irsgv; - HV *hinthv; -#define VAR(name,type) type name; -# include "state.h" -#undef VAR + #define VARx(name,expr,type) type name; + #include "state.h" } perl_slots; -// how many context stack entries do we need for perl_slots +/* how many context stack entries do we need for perl_slots */ #define SLOT_COUNT ((sizeof (perl_slots) + sizeof (PERL_CONTEXT) - 1) / sizeof (PERL_CONTEXT)) /* this is a structure representing a perl-level coroutine */ @@ -306,6 +275,29 @@ static struct coro *coro_first; #define coro_nready coroapi.nready +/** JIT *********************************************************************/ + +#if CORO_JIT + /* APPLE doesn't have mmap though */ + #define CORO_JIT_UNIXY (__linux || __FreeBSD__ || __OpenBSD__ || __NetBSD__ || __solaris || __APPLE__) + #ifndef CORO_JIT_TYPE + #if __x86_64 && CORO_JIT_UNIXY + #define CORO_JIT_TYPE "amd64-unix" + #elif __i386 && CORO_JIT_UNIXY + #define CORO_JIT_TYPE "x86-unix" + #endif + #endif +#endif + +#if !defined(CORO_JIT_TYPE) || _POSIX_MEMORY_PROTECTION <= 0 + #undef CORO_JIT +#endif + +#if CORO_JIT + typedef void (*load_save_perl_slots_type)(perl_slots *); + static load_save_perl_slots_type load_perl_slots, save_perl_slots; +#endif + /** Coro::Select ************************************************************/ static OP *(*coro_old_pp_sselect) (pTHX); @@ -330,7 +322,7 @@ #ifdef HAS_GETTIMEOFDAY -static void +ecb_inline void coro_u2time (pTHX_ UV ret[2]) { struct timeval tv; @@ -340,8 +332,8 @@ ret [1] = tv.tv_usec; } -static double -coro_nvtime () +ecb_inline double +coro_nvtime (void) { struct timeval tv; gettimeofday (&tv, 0); @@ -349,7 +341,7 @@ return tv.tv_sec + tv.tv_usec * 1e-6; } -static void +ecb_inline void time_init (pTHX) { nvtime = coro_nvtime; @@ -358,13 +350,13 @@ #else -static void +ecb_inline void time_init (pTHX) { SV **svp; require_pv ("Time/HiRes.pm"); - + svp = hv_fetch (PL_modglobal, "Time::NVtime", 12, 0); if (!svp) croak ("Time::HiRes is required, but missing. Caught"); @@ -380,7 +372,7 @@ /** lowlevel stuff **********************************************************/ -static SV * +static SV * ecb_noinline coro_get_sv (pTHX_ const char *name, int create) { #if PERL_VERSION_ATLEAST (5,10,0) @@ -390,7 +382,7 @@ return get_sv (name, create); } -static AV * +static AV * ecb_noinline coro_get_av (pTHX_ const char *name, int create) { #if PERL_VERSION_ATLEAST (5,10,0) @@ -400,7 +392,7 @@ return get_av (name, create); } -static HV * +static HV * ecb_noinline coro_get_hv (pTHX_ const char *name, int create) { #if PERL_VERSION_ATLEAST (5,10,0) @@ -410,8 +402,8 @@ return get_hv (name, create); } -INLINE void -coro_times_update () +ecb_inline void +coro_times_update (void) { #ifdef coro_clock_gettime struct timespec ts; @@ -433,7 +425,7 @@ #endif } -INLINE void +ecb_inline void coro_times_add (struct coro *c) { c->t_real [1] += time_real [1]; @@ -445,7 +437,7 @@ c->t_cpu [0] += time_cpu [0]; } -INLINE void +ecb_inline void coro_times_sub (struct coro *c) { if (c->t_real [1] < time_real [1]) { c->t_real [1] += 1000000000; --c->t_real [0]; } @@ -463,25 +455,25 @@ #define CORO_MAGIC_type_cv 26 #define CORO_MAGIC_type_state PERL_MAGIC_ext -#define CORO_MAGIC_NN(sv, type) \ - (expect_true (SvMAGIC (sv)->mg_type == type) \ - ? SvMAGIC (sv) \ +#define CORO_MAGIC_NN(sv, type) \ + (ecb_expect_true (SvMAGIC (sv)->mg_type == type) \ + ? SvMAGIC (sv) \ : mg_find (sv, type)) -#define CORO_MAGIC(sv, type) \ - (expect_true (SvMAGIC (sv)) \ - ? CORO_MAGIC_NN (sv, type) \ +#define CORO_MAGIC(sv, type) \ + (ecb_expect_true (SvMAGIC (sv)) \ + ? CORO_MAGIC_NN (sv, type) \ : 0) #define CORO_MAGIC_cv(cv) CORO_MAGIC (((SV *)(cv)), CORO_MAGIC_type_cv) #define CORO_MAGIC_state(sv) CORO_MAGIC_NN (((SV *)(sv)), CORO_MAGIC_type_state) -INLINE MAGIC * +ecb_inline MAGIC * SvSTATEhv_p (pTHX_ SV *coro) { MAGIC *mg; - if (expect_true ( + if (ecb_expect_true ( SvTYPE (coro) == SVt_PVHV && (mg = CORO_MAGIC_state (coro)) && mg->mg_virtual == &coro_state_vtbl @@ -491,7 +483,7 @@ return 0; } -INLINE struct coro * +ecb_inline struct coro * SvSTATE_ (pTHX_ SV *coro) { MAGIC *mg; @@ -515,71 +507,82 @@ /*****************************************************************************/ /* padlist management and caching */ -static AV * +ecb_inline PADLIST * coro_derive_padlist (pTHX_ CV *cv) { - AV *padlist = CvPADLIST (cv); - AV *newpadlist, *newpad; - - newpadlist = newAV (); + PADLIST *padlist = CvPADLIST (cv); + PADLIST *newpadlist; + PAD *newpad; + PADOFFSET const off = PadlistMAX (padlist) + 1; + + newPADLIST(newpadlist); +#if !PERL_VERSION_ATLEAST(5,15,3) + /* Padlists are AvREAL as of 5.15.3. See perl bug #98092 and perl commit 7d953ba. */ AvREAL_off (newpadlist); +#endif #if PERL_VERSION_ATLEAST (5,10,0) - Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1); + Perl_pad_push (aTHX_ padlist, off); #else - Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1); + Perl_pad_push (aTHX_ padlist, off, 1); #endif - newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)]; - --AvFILLp (padlist); + newpad = PadlistARRAY (padlist)[off]; + PadlistMAX (padlist) = off - 1; - av_store (newpadlist, 0, SvREFCNT_inc_NN (AvARRAY (padlist)[0])); - av_store (newpadlist, 1, (SV *)newpad); + /* Already extended to 2 elements by newPADLIST. */ + PadlistMAX (newpadlist) = 1; + PadlistNAMES (newpadlist) = (PADNAMELIST *)SvREFCNT_inc_NN (PadlistNAMES (padlist)); + PadlistARRAY (newpadlist)[1] = newpad; return newpadlist; } -static void -free_padlist (pTHX_ AV *padlist) +ecb_inline void +free_padlist (pTHX_ PADLIST *padlist) { /* may be during global destruction */ if (!IN_DESTRUCT) { - I32 i = AvFILLp (padlist); + I32 i = PadlistMAX (padlist); while (i > 0) /* special-case index 0 */ { /* we try to be extra-careful here */ - AV *av = (AV *)AvARRAY (padlist)[i--]; - I32 j = AvFILLp (av); + PAD *pad = PadlistARRAY (padlist)[i--]; + I32 j = PadMAX (pad); while (j >= 0) - SvREFCNT_dec (AvARRAY (av)[j--]); + SvREFCNT_dec (PadARRAY (pad)[j--]); - AvFILLp (av) = -1; - SvREFCNT_dec (av); + PadMAX (pad) = -1; + SvREFCNT_dec (pad); } - SvREFCNT_dec (AvARRAY (padlist)[0]); + SvREFCNT_dec (PadlistNAMES (padlist)); +#ifdef NEWPADAPI + Safefree (PadlistARRAY (padlist)); + Safefree (padlist); +#else AvFILLp (padlist) = -1; + AvREAL_off (padlist); SvREFCNT_dec ((SV*)padlist); +#endif } } static int coro_cv_free (pTHX_ SV *sv, MAGIC *mg) { - AV *padlist; - AV *av = (AV *)mg->mg_obj; + PADLIST *padlist; + PADLIST **padlists = (PADLIST **)(mg->mg_ptr + sizeof(size_t)); + size_t len = *(size_t *)mg->mg_ptr; /* perl manages to free our internal AV and _then_ call us */ if (IN_DESTRUCT) return 0; - /* casting is fun. */ - while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av))) - free_padlist (aTHX_ padlist); - - SvREFCNT_dec (av); /* sv_magicext increased the refcount */ + while (len--) + free_padlist (aTHX_ padlists[len]); return 0; } @@ -590,14 +593,14 @@ }; /* the next two functions merely cache the padlists */ -static void +ecb_inline void get_padlist (pTHX_ CV *cv) { MAGIC *mg = CORO_MAGIC_cv (cv); - AV *av; + size_t *lenp; - if (expect_true (mg && AvFILLp ((av = (AV *)mg->mg_obj)) >= 0)) - CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--]; + if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr))) + CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp]; else { #if CORO_PREFER_PERL_FUNCTIONS @@ -613,74 +616,77 @@ } } -static void +ecb_inline void put_padlist (pTHX_ CV *cv) { MAGIC *mg = CORO_MAGIC_cv (cv); - AV *av; - - if (expect_false (!mg)) - mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0); - av = (AV *)mg->mg_obj; - - if (expect_false (AvFILLp (av) >= AvMAX (av))) - av_extend (av, AvFILLp (av) + 1); + if (ecb_expect_false (!mg)) + { + mg = sv_magicext ((SV *)cv, 0, CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0); + Newz (0, mg->mg_ptr ,sizeof (size_t) + sizeof (PADLIST *), char); + mg->mg_len = 1; /* so mg_free frees mg_ptr */ + } + else + Renew (mg->mg_ptr, + sizeof(size_t) + (*(size_t *)mg->mg_ptr + 1) * sizeof(PADLIST *), + char); - AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv); + ((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv); } /** load & save, init *******************************************************/ -/* swap sv heads, at least logically */ -static void -swap_svs (pTHX_ Coro__State c) +ecb_inline void +swap_sv (SV *a, SV *b) { - int i; - - for (i = 0; i <= AvFILLp (c->swap_sv); ) - { - SV *a = AvARRAY (c->swap_sv)[i++]; - SV *b = AvARRAY (c->swap_sv)[i++]; - - const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */ - SV tmp; + const U32 keep = SVs_PADSTALE | SVs_PADTMP | SVs_PADMY; /* keep these flags */ + SV tmp; - /* swap sv_any */ - SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp); + /* swap sv_any */ + SvANY (&tmp) = SvANY (a); SvANY (a) = SvANY (b); SvANY (b) = SvANY (&tmp); - /* swap sv_flags */ - SvFLAGS (&tmp) = SvFLAGS (a); - SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep); - SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep); + /* swap sv_flags */ + SvFLAGS (&tmp) = SvFLAGS (a); + SvFLAGS (a) = (SvFLAGS (a) & keep) | (SvFLAGS (b ) & ~keep); + SvFLAGS (b) = (SvFLAGS (b) & keep) | (SvFLAGS (&tmp) & ~keep); #if PERL_VERSION_ATLEAST (5,10,0) - /* perl 5.10 complicates this _quite_ a bit, but it also is - * much faster, so no quarrels here. alternatively, we could - * sv_upgrade to avoid this. - */ - { - /* swap sv_u */ - tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u; + /* perl 5.10 and later complicates this _quite_ a bit, but it also + * is much faster, so no quarrels here. alternatively, we could + * sv_upgrade to avoid this. + */ + { + /* swap sv_u */ + tmp.sv_u = a->sv_u; a->sv_u = b->sv_u; b->sv_u = tmp.sv_u; - /* if SvANY points to the head, we need to adjust the pointers, - * as the pointer for a still points to b, and maybe vice versa. - */ - #define svany_in_head(type) \ - (((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type))) + /* if SvANY points to the head, we need to adjust the pointers, + * as the pointer for a still points to b, and maybe vice versa. + */ + #define svany_in_head(type) \ + (((1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV)) & (1 << (type))) - if (svany_in_head (SvTYPE (a))) - SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a); + if (svany_in_head (SvTYPE (a))) + SvANY (a) = (void *)((PTRV)SvANY (a) - (PTRV)b + (PTRV)a); - if (svany_in_head (SvTYPE (b))) - SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b); - } + if (svany_in_head (SvTYPE (b))) + SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b); + } #endif - } } -#define SWAP_SVS(coro) \ - if (expect_false ((coro)->swap_sv)) \ +/* swap sv heads, at least logically */ +static void +swap_svs (pTHX_ Coro__State c) +{ + int i; + + for (i = 0; i <= AvFILLp (c->swap_sv); i += 2) + swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]); +} + +#define SWAP_SVS(coro) \ + if (ecb_expect_false ((coro)->swap_sv)) \ swap_svs (aTHX_ (coro)) static void @@ -694,15 +700,12 @@ PL_mainstack = c->mainstack; - GvSV (PL_defgv) = slot->defsv; - GvAV (PL_defgv) = slot->defav; - GvSV (PL_errgv) = slot->errsv; - GvSV (irsgv) = slot->irsgv; - GvHV (PL_hintgv) = slot->hinthv; - - #define VAR(name,type) PL_ ## name = slot->name; - # include "state.h" - #undef VAR +#if CORO_JIT + load_perl_slots (slot); +#else + #define VARx(name,expr,type) expr = slot->name; + #include "state.h" +#endif { dSP; @@ -710,11 +713,11 @@ CV *cv; /* now do the ugly restore mess */ - while (expect_true (cv = (CV *)POPs)) + while (ecb_expect_true (cv = (CV *)POPs)) { put_padlist (aTHX_ cv); /* mark this padlist as available */ CvDEPTH (cv) = PTR2IV (POPs); - CvPADLIST (cv) = (AV *)POPs; + CvPADLIST (cv) = (PADLIST *)POPs; } PUTBACK; @@ -723,15 +726,15 @@ slf_frame = c->slf_frame; CORO_THROW = c->except; - if (expect_false (enable_times)) + if (ecb_expect_false (enable_times)) { - if (expect_false (!times_valid)) + if (ecb_expect_false (!times_valid)) coro_times_update (); coro_times_sub (c); } - if (expect_false (c->on_enter)) + if (ecb_expect_false (c->on_enter)) { int i; @@ -747,7 +750,7 @@ { SWAP_SVS (c); - if (expect_false (c->on_leave)) + if (ecb_expect_false (c->on_leave)) { int i; @@ -757,7 +760,7 @@ times_valid = 0; - if (expect_false (enable_times)) + if (ecb_expect_false (enable_times)) { coro_times_update (); times_valid = 1; coro_times_add (c); @@ -781,15 +784,15 @@ /* this loop was inspired by pp_caller */ for (;;) { - while (expect_true (cxix >= 0)) + while (ecb_expect_true (cxix >= 0)) { PERL_CONTEXT *cx = &ccstk[cxix--]; - if (expect_true (CxTYPE (cx) == CXt_SUB) || expect_false (CxTYPE (cx) == CXt_FORMAT)) + if (ecb_expect_true (CxTYPE (cx) == CXt_SUB) || ecb_expect_false (CxTYPE (cx) == CXt_FORMAT)) { CV *cv = cx->blk_sub.cv; - if (expect_true (CvDEPTH (cv))) + if (ecb_expect_true (CvDEPTH (cv))) { EXTEND (SP, 3); PUSHs ((SV *)CvPADLIST (cv)); @@ -802,7 +805,7 @@ } } - if (expect_true (top_si->si_type == PERLSI_MAIN)) + if (ecb_expect_true (top_si->si_type == PERLSI_MAIN)) break; top_si = top_si->si_prev; @@ -814,7 +817,7 @@ } /* allocate some space on the context stack for our purposes */ - if (expect_false (cxstack_ix + SLOT_COUNT >= cxstack_max)) + if (ecb_expect_false (cxstack_ix + (int)SLOT_COUNT >= cxstack_max)) { unsigned int i; @@ -829,15 +832,12 @@ { perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1); - slot->defav = GvAV (PL_defgv); - slot->defsv = DEFSV; - slot->errsv = ERRSV; - slot->irsgv = GvSV (irsgv); - slot->hinthv = GvHV (PL_hintgv); - - #define VAR(name,type) slot->name = PL_ ## name; - # include "state.h" - #undef VAR +#if CORO_JIT + save_perl_slots (slot); +#else + #define VARx(name,expr,type) slot->name = expr; + #include "state.h" +#endif } } @@ -878,6 +878,9 @@ New(54,PL_scopestack,8,I32); PL_scopestack_ix = 0; PL_scopestack_max = 8; +#if HAS_SCOPESTACK_NAME + New(54,PL_scopestack_name,8,const char*); +#endif New(54,PL_savestack,24,ANY); PL_savestack_ix = 0; @@ -915,6 +918,9 @@ Safefree (PL_tmps_stack); Safefree (PL_markstack); Safefree (PL_scopestack); +#if HAS_SCOPESTACK_NAME + Safefree (PL_scopestack_name); +#endif Safefree (PL_savestack); #if !PERL_VERSION_ATLEAST (5,10,0) Safefree (PL_retstack); @@ -973,7 +979,7 @@ * and instead of trying to save and restore the hash elements (extremely slow), * we just provide our own readback here. */ -static int +static int ecb_cold coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg) { const char *s = MgPV_nolen_const (mg); @@ -984,10 +990,19 @@ if (strEQ (s, "__DIE__" )) svp = &PL_diehook; if (strEQ (s, "__WARN__")) svp = &PL_warnhook; - + if (svp) { - sv_setsv (sv, *svp ? *svp : &PL_sv_undef); + SV *ssv; + + if (!*svp) + ssv = &PL_sv_undef; + else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */ + ssv = sv_2mortal (newRV_inc (*svp)); + else + ssv = *svp; + + sv_setsv (sv, ssv); return 0; } } @@ -995,7 +1010,7 @@ return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0; } -static int +static int ecb_cold coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg) { const char *s = MgPV_nolen_const (mg); @@ -1019,7 +1034,7 @@ return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0; } -static int +static int ecb_cold coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg) { const char *s = MgPV_nolen_const (mg); @@ -1064,7 +1079,7 @@ static UNOP init_perl_op; -static void NOINLINE /* noinline to keep it out of the transfer fast path */ +ecb_noinline static void /* noinline to keep it out of the transfer fast path */ init_perl (pTHX_ struct coro *coro) { /* @@ -1091,7 +1106,7 @@ /* recreate the die/warn hooks */ PL_diehook = SvREFCNT_inc (rv_diehook); PL_warnhook = SvREFCNT_inc (rv_warnhook); - + GvSV (PL_defgv) = newSV (0); GvAV (PL_defgv) = coro->args; coro->args = 0; GvSV (PL_errgv) = newSV (0); @@ -1136,7 +1151,7 @@ SWAP_SVS (coro); - if (expect_false (enable_times)) + if (ecb_expect_false (enable_times)) { coro_times_update (); coro_times_sub (coro); @@ -1189,7 +1204,7 @@ coro_destruct_stacks (aTHX); - // now save some sv's to be free'd later + /* now save some sv's to be free'd later */ svf [0] = GvSV (PL_defgv); svf [1] = (SV *)GvAV (PL_defgv); svf [2] = GvSV (PL_errgv); @@ -1219,10 +1234,10 @@ } } -INLINE void +ecb_inline void free_coro_mortal (pTHX) { - if (expect_true (coro_mortal)) + if (ecb_expect_true (coro_mortal)) { SvREFCNT_dec ((SV *)coro_mortal); coro_mortal = 0; @@ -1367,7 +1382,7 @@ } /* initialises PL_top_env and injects a pseudo-slf-call to set the stacklevel */ -static void NOINLINE +static void ecb_noinline cctx_prepare (pTHX) { PL_top_env = &PL_start_env; @@ -1388,12 +1403,24 @@ } /* the tail of transfer: execute stuff we can only do after a transfer */ -INLINE void +ecb_inline void transfer_tail (pTHX) { free_coro_mortal (aTHX); } +/* try to exit the same way perl's main function would do */ +/* we do not bother resetting the environment or other things *7 +/* that are not, uhm, essential */ +/* this obviously also doesn't work when perl is embedded */ +static void ecb_noinline ecb_cold +perlish_exit (pTHX) +{ + int exitstatus = perl_destruct (PL_curinterp); + perl_free (PL_curinterp); + exit (exitstatus); +} + /* * this is a _very_ stripped down perl interpreter ;) */ @@ -1430,19 +1457,15 @@ /* * If perl-run returns we assume exit() was being called or the coro * fell off the end, which seems to be the only valid (non-bug) - * reason for perl_run to return. We try to exit by jumping to the - * bootstrap-time "top" top_env, as we cannot restore the "main" - * coroutine as Coro has no such concept. - * This actually isn't valid with the pthread backend, but OSes requiring - * that backend are too broken to do it in a standards-compliant way. + * reason for perl_run to return. We try to mimic whatever perl is normally + * doing in that case. YMMV. */ - PL_top_env = main_top_env; - JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */ + perlish_exit (aTHX); } } static coro_cctx * -cctx_new () +cctx_new (void) { coro_cctx *cctx; @@ -1458,11 +1481,11 @@ /* create a new cctx only suitable as source */ static coro_cctx * -cctx_new_empty () +cctx_new_empty (void) { coro_cctx *cctx = cctx_new (); - cctx->sptr = 0; + cctx->stack.sptr = 0; coro_create (&cctx->cctx, 0, 0, 0, 0); return cctx; @@ -1470,47 +1493,17 @@ /* create a new cctx suitable as destination/running a perl interpreter */ static coro_cctx * -cctx_new_run () +cctx_new_run (void) { coro_cctx *cctx = cctx_new (); - void *stack_start; - size_t stack_size; -#if HAVE_MMAP - cctx->ssize = ((cctx_stacksize * sizeof (long) + PAGESIZE - 1) / PAGESIZE + CORO_STACKGUARD) * PAGESIZE; - /* mmap supposedly does allocate-on-write for us */ - cctx->sptr = mmap (0, cctx->ssize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, 0, 0); - - if (cctx->sptr != (void *)-1) - { - #if CORO_STACKGUARD - mprotect (cctx->sptr, CORO_STACKGUARD * PAGESIZE, PROT_NONE); - #endif - stack_start = (char *)cctx->sptr + CORO_STACKGUARD * PAGESIZE; - stack_size = cctx->ssize - CORO_STACKGUARD * PAGESIZE; - cctx->flags |= CC_MAPPED; - } - else -#endif + if (!coro_stack_alloc (&cctx->stack, cctx_stacksize)) { - cctx->ssize = cctx_stacksize * (long)sizeof (long); - New (0, cctx->sptr, cctx_stacksize, long); - - if (!cctx->sptr) - { - perror ("FATAL: unable to allocate stack for coroutine, exiting."); - _exit (EXIT_FAILURE); - } - - stack_start = cctx->sptr; - stack_size = cctx->ssize; + perror ("FATAL: unable to allocate stack for coroutine, exiting."); + _exit (EXIT_FAILURE); } - #if CORO_USE_VALGRIND - cctx->valgrind_id = VALGRIND_STACK_REGISTER ((char *)stack_start, (char *)stack_start + stack_size); - #endif - - coro_create (&cctx->cctx, cctx_run, (void *)cctx, stack_start, stack_size); + coro_create (&cctx->cctx, cctx_run, (void *)cctx, cctx->stack.sptr, cctx->stack.ssze); return cctx; } @@ -1526,20 +1519,7 @@ --cctx_count; coro_destroy (&cctx->cctx); - /* coro_transfer creates new, empty cctx's */ - if (cctx->sptr) - { - #if CORO_USE_VALGRIND - VALGRIND_STACK_DEREGISTER (cctx->valgrind_id); - #endif - -#if HAVE_MMAP - if (cctx->flags & CC_MAPPED) - munmap (cctx->sptr, cctx->ssize); - else -#endif - Safefree (cctx->sptr); - } + coro_stack_free (&cctx->stack); Safefree (cctx); } @@ -1550,13 +1530,13 @@ static coro_cctx * cctx_get (pTHX) { - while (expect_true (cctx_first)) + while (ecb_expect_true (cctx_first)) { coro_cctx *cctx = cctx_first; cctx_first = cctx->next; --cctx_idle; - if (expect_true (!CCTX_EXPIRED (cctx))) + if (ecb_expect_true (!CCTX_EXPIRED (cctx))) return cctx; cctx_destroy (cctx); @@ -1568,10 +1548,10 @@ static void cctx_put (coro_cctx *cctx) { - assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->sptr)); + assert (("FATAL: cctx_put called on non-initialised cctx in Coro (please report)", cctx->stack.sptr)); /* free another cctx if overlimit */ - if (expect_false (cctx_idle >= cctx_max_idle)) + if (ecb_expect_false (cctx_idle >= cctx_max_idle)) { coro_cctx *first = cctx_first; cctx_first = first->next; @@ -1592,38 +1572,38 @@ { /* TODO: throwing up here is considered harmful */ - if (expect_true (prev != next)) + if (ecb_expect_true (prev != next)) { - if (expect_false (!(prev->flags & (CF_RUNNING | CF_NEW)))) + if (ecb_expect_false (!(prev->flags & (CF_RUNNING | CF_NEW)))) croak ("Coro::State::transfer called with a blocked prev Coro::State, but can only transfer from running or new states,"); - if (expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED))) + if (ecb_expect_false (next->flags & (CF_RUNNING | CF_ZOMBIE | CF_SUSPENDED))) croak ("Coro::State::transfer called with running, destroyed or suspended next Coro::State, but can only transfer to inactive states,"); #if !PERL_VERSION_ATLEAST (5,10,0) - if (expect_false (PL_lex_state != LEX_NOTPARSING)) + if (ecb_expect_false (PL_lex_state != LEX_NOTPARSING)) croak ("Coro::State::transfer called while parsing, but this is not supported in your perl version,"); #endif } } /* always use the TRANSFER macro */ -static void NOINLINE /* noinline so we have a fixed stackframe */ +static void ecb_noinline /* noinline so we have a fixed stackframe */ transfer (pTHX_ struct coro *prev, struct coro *next, int force_cctx) { dSTACKLEVEL; /* sometimes transfer is only called to set idle_sp */ - if (expect_false (!prev)) + if (ecb_expect_false (!prev)) { cctx_current->idle_sp = STACKLEVEL; assert (cctx_current->idle_te = PL_top_env); /* just for the side-effect when asserts are enabled */ } - else if (expect_true (prev != next)) + else if (ecb_expect_true (prev != next)) { coro_cctx *cctx_prev; - if (expect_false (prev->flags & CF_NEW)) + if (ecb_expect_false (prev->flags & CF_NEW)) { /* create a new empty/source context */ prev->flags &= ~CF_NEW; @@ -1636,7 +1616,7 @@ /* first get rid of the old state */ save_perl (aTHX_ prev); - if (expect_false (next->flags & CF_NEW)) + if (ecb_expect_false (next->flags & CF_NEW)) { /* need to start coroutine */ next->flags &= ~CF_NEW; @@ -1647,7 +1627,7 @@ load_perl (aTHX_ next); /* possibly untie and reuse the cctx */ - if (expect_true ( + if (ecb_expect_true ( cctx_current->idle_sp == STACKLEVEL && !(cctx_current->flags & CC_TRACE) && !force_cctx @@ -1658,8 +1638,8 @@ /* if the cctx is about to be destroyed we need to make sure we won't see it in cctx_get. */ /* without this the next cctx_get might destroy the running cctx while still in use */ - if (expect_false (CCTX_EXPIRED (cctx_current))) - if (expect_true (!next->cctx)) + if (ecb_expect_false (CCTX_EXPIRED (cctx_current))) + if (ecb_expect_true (!next->cctx)) next->cctx = cctx_get (aTHX); cctx_put (cctx_current); @@ -1670,11 +1650,11 @@ ++next->usecount; cctx_prev = cctx_current; - cctx_current = expect_false (next->cctx) ? next->cctx : cctx_get (aTHX); + cctx_current = ecb_expect_false (next->cctx) ? next->cctx : cctx_get (aTHX); next->cctx = 0; - if (expect_false (cctx_prev != cctx_current)) + if (ecb_expect_false (cctx_prev != cctx_current)) { cctx_prev->top_env = PL_top_env; PL_top_env = cctx_current->top_env; @@ -1704,7 +1684,7 @@ slf_destroy (aTHX_ coro); coro->flags |= CF_ZOMBIE; - + if (coro->flags & CF_READY) { /* reduce nready, as destroying a ready coro effectively unreadies it */ @@ -1750,7 +1730,7 @@ return 0; } -static int +static int ecb_cold coro_state_dup (pTHX_ MAGIC *mg, CLONE_PARAMS *params) { /* called when perl clones the current process the slow way (windows process emulation) */ @@ -1791,7 +1771,7 @@ /** Coro ********************************************************************/ -INLINE void +ecb_inline void coro_enq (pTHX_ struct coro *coro) { struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN]; @@ -1803,7 +1783,7 @@ ready [1] = coro; } -INLINE struct coro * +ecb_inline struct coro * coro_deq (pTHX) { int prio; @@ -1866,7 +1846,7 @@ } /* expects to own a reference to next->hv */ -INLINE void +ecb_inline void prepare_schedule_to (pTHX_ struct coro_transfer_args *ta, struct coro *next) { SV *prev_sv = SvRV (coro_current); @@ -1889,10 +1869,10 @@ { struct coro *next = coro_deq (aTHX); - if (expect_true (next)) + if (ecb_expect_true (next)) { /* cannot transfer to destroyed coros, skip and look for next */ - if (expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED))) + if (ecb_expect_false (next->flags & (CF_ZOMBIE | CF_SUSPENDED))) SvREFCNT_dec (next->hv); /* coro_nready has already been taken care of by destroy */ else { @@ -1935,14 +1915,14 @@ } } -INLINE void +ecb_inline void prepare_cede (pTHX_ struct coro_transfer_args *ta) { api_ready (aTHX_ coro_current); prepare_schedule (aTHX_ ta); } -INLINE void +ecb_inline void prepare_cede_notself (pTHX_ struct coro_transfer_args *ta) { SV *prev = SvRV (coro_current); @@ -1982,7 +1962,7 @@ prepare_cede (aTHX_ &ta); - if (expect_true (ta.prev != ta.next)) + if (ecb_expect_true (ta.prev != ta.next)) { TRANSFER (ta, 1); return 1; @@ -2147,7 +2127,7 @@ coro_set_status (pTHX_ struct coro *coro, SV **arg, int items) { AV *av; - + if (coro->status) { av = coro->status; @@ -2204,8 +2184,8 @@ coro_hv = coro->hv; coro_set_status (aTHX_ coro, arg + 1, items - 1); - - if (expect_false (coro->flags & CF_NOCANCEL)) + + if (ecb_expect_false (coro->flags & CF_NOCANCEL)) { /* coro currently busy cancelling something, so just notify it */ coro->slf_frame.data = (void *)coro; @@ -2323,7 +2303,7 @@ HV *hv = (HV *)SvRV (coro_current); struct coro *coro = SvSTATE_hv ((SV *)hv); - if (expect_true (coro->saved_deffh)) + if (ecb_expect_true (coro->saved_deffh)) { /* subsequent iteration */ SvREFCNT_dec ((SV *)PL_defoutgv); PL_defoutgv = (GV *)coro->saved_deffh; @@ -2393,7 +2373,7 @@ slf_check_rouse_wait (pTHX_ struct CoroSLF *frame) { SV *data = (SV *)frame->data; - + if (CORO_THROW) return 0; @@ -2439,7 +2419,7 @@ } if (!SvROK (cb) - || SvTYPE (SvRV (cb)) != SVt_PVCV + || SvTYPE (SvRV (cb)) != SVt_PVCV || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback) croak ("Coro::rouse_wait called with illegal callback argument,"); @@ -2599,7 +2579,7 @@ /* set up the slf frame, unless it has already been set-up */ /* the latter happens when a new coro has been started */ /* or when a new cctx was attached to an existing coroutine */ - if (expect_true (!slf_frame.prepare)) + if (ecb_expect_true (!slf_frame.prepare)) { /* first iteration */ dSP; @@ -2650,7 +2630,7 @@ slf_frame.prepare = 0; /* invalidate the frame, we are done processing it */ /* exception handling */ - if (expect_false (CORO_THROW)) + if (ecb_expect_false (CORO_THROW)) { SV *exception = sv_2mortal (CORO_THROW); @@ -2662,7 +2642,7 @@ /* return value handling - mostly like entersub */ /* make sure we put something on the stack in scalar context */ if (GIMME_V == G_SCALAR - && expect_false (PL_stack_sp != PL_stack_base + checkmark + 1)) + && ecb_expect_false (PL_stack_sp != PL_stack_base + checkmark + 1)) { dSP; SV **bot = PL_stack_base + checkmark; @@ -2786,7 +2766,7 @@ NV next, every; } PerlIOCede; -static IV +static IV ecb_cold PerlIOCede_pushed (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { PerlIOCede *self = PerlIOSelf (f, PerlIOCede); @@ -2797,7 +2777,7 @@ return PerlIOBuf_pushed (aTHX_ f, mode, Nullsv, tab); } -static SV * +static SV * ecb_cold PerlIOCede_getarg (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { PerlIOCede *self = PerlIOSelf (f, PerlIOCede); @@ -2952,7 +2932,7 @@ /* if we were woken up but can't down, we look through the whole */ /* waiters list and only add us if we aren't in there already */ /* this avoids some degenerate memory usage cases */ - for (i = AvFILLp (av); i > 0; --i) // i > 0 is not an off-by-one bug + for (i = AvFILLp (av); i > 0; --i) /* i > 0 is not an off-by-one bug */ if (AvARRAY (av)[i] == coro_hv) return 1; @@ -3219,7 +3199,7 @@ static SV *prio_cv; static SV *prio_sv; - if (expect_false (!prio_cv)) + if (ecb_expect_false (!prio_cv)) { prio_cv = (SV *)get_cv ("IO::AIO::aioreq_pri", 0); prio_sv = newSViv (0); @@ -3335,6 +3315,73 @@ return coro_sv; } +#ifndef __cplusplus +ecb_cold XS(boot_Coro__State); +#endif + +#if CORO_JIT + +static void ecb_noinline ecb_cold +pushav_4uv (pTHX_ UV a, UV b, UV c, UV d) +{ + dSP; + AV *av = newAV (); + + av_store (av, 3, newSVuv (d)); + av_store (av, 2, newSVuv (c)); + av_store (av, 1, newSVuv (b)); + av_store (av, 0, newSVuv (a)); + + XPUSHs (sv_2mortal (newRV_noinc ((SV *)av))); + + PUTBACK; +} + +static void ecb_noinline ecb_cold +jit_init (pTHX) +{ + dSP; + SV *load, *save; + char *map_base; + char *load_ptr, *save_ptr; + STRLEN load_len, save_len, map_len; + int count; + + eval_pv ("require 'Coro/jit-" CORO_JIT_TYPE ".pl'", 1); + + PUSHMARK (SP); + #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type)); + #include "state.h" + count = call_pv ("Coro::State::_jit", G_ARRAY); + SPAGAIN; + + save = POPs; save_ptr = SvPVbyte (save, save_len); + load = POPs; load_ptr = SvPVbyte (load, load_len); + + map_len = load_len + save_len + 16; + + map_base = mmap (0, map_len, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + + assert (("Coro: unable to mmap jit code page, cannot continue.", map_base != (char *)MAP_FAILED)); + + load_perl_slots = (load_save_perl_slots_type)map_base; + memcpy (map_base, load_ptr, load_len); + + map_base += (load_len + 15) & ~15; + + save_perl_slots = (load_save_perl_slots_type)map_base; + memcpy (map_base, save_ptr, save_len); + + /* we are good citizens and try to make the page read-only, so the evil evil */ + /* hackers might have it a bit more difficult */ + mprotect (map_base, map_len, PROT_READ | PROT_EXEC); + + PUTBACK; + eval_pv ("undef &Coro::State::_jit", 1); +} + +#endif + MODULE = Coro::State PACKAGE = Coro::State PREFIX = api_ PROTOTYPES: DISABLE @@ -3346,7 +3393,12 @@ coro_thx = PERL_GET_CONTEXT; # endif #endif - BOOT_PAGESIZE; + /* perl defines these to check for existance first, but why it doesn't */ + /* just create them one at init time is not clear to me, except for */ + /* programs trying to delete them, but... */ + /* anyway, we declare this as invalid and make sure they are initialised here */ + DEFSV; + ERRSV; cctx_current = cctx_new_empty (); @@ -3399,6 +3451,11 @@ time_init (aTHX); assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL)); +#if CORO_JIT + PUTBACK; + jit_init (aTHX); + SPAGAIN; +#endif } SV * @@ -3485,7 +3542,7 @@ PROTOTYPE: PPCODE: { - struct coro *coro; + struct coro *coro; for (coro = coro_first; coro; coro = coro->next) if (coro->hv) XPUSHs (sv_2mortal (newRV_inc ((SV *)coro->hv))); @@ -3559,15 +3616,18 @@ RETVAL void -throw (Coro::State self, SV *exception = &PL_sv_undef) +throw (SV *self, SV *exception = &PL_sv_undef) PROTOTYPE: $;$ CODE: { + struct coro *coro = SvSTATE (self); struct coro *current = SvSTATE_current; - SV **exceptionp = self == current ? &CORO_THROW : &self->except; + SV **exceptionp = coro == current ? &CORO_THROW : &coro->except; SvREFCNT_dec (*exceptionp); SvGETMAGIC (exception); *exceptionp = SvOK (exception) ? newSVsv (exception) : 0; + + api_ready (aTHX_ self); } void @@ -3654,9 +3714,9 @@ times (Coro::State self) PPCODE: { - struct coro *current = SvSTATE (coro_current); + struct coro *current = SvSTATE (coro_current); - if (expect_false (current == self)) + if (ecb_expect_false (current == self)) { coro_times_update (); coro_times_add (SvSTATE (coro_current)); @@ -3666,7 +3726,7 @@ PUSHs (sv_2mortal (newSVnv (self->t_real [0] + self->t_real [1] * 1e-9))); PUSHs (sv_2mortal (newSVnv (self->t_cpu [0] + self->t_cpu [1] * 1e-9))); - if (expect_false (current == self)) + if (ecb_expect_false (current == self)) coro_times_sub (SvSTATE (coro_current)); } @@ -3707,7 +3767,7 @@ sv_Coro = newSVpv ("Coro", 0); SvREADONLY_on (sv_Coro); cv_pool_handler = get_cv ("Coro::pool_handler", GV_ADD); SvREADONLY_on (cv_pool_handler); CvNODEBUG_on (get_cv ("Coro::_pool_handler", 0)); /* work around a debugger bug */ - + coro_stash = gv_stashpv ("Coro", TRUE); newCONSTSUB (coro_stash, "PRIO_MAX", newSViv (CORO_PRIO_MAX)); @@ -3939,7 +3999,7 @@ CODE: { struct coro *coro = SvSTATE_current; - AV **avp = ix ? &coro->on_leave : &coro->on_enter; + AV **avp = ix ? &coro->on_leave : &coro->on_enter; block = s_get_cv_croak (block); @@ -3969,7 +4029,7 @@ new (SV *klass, SV *count = 0) CODE: { - int semcnt = 1; + int semcnt = 1; if (count) { @@ -4039,7 +4099,7 @@ void waiters (SV *self) - PPCODE: + PPCODE: { AV *av = (AV *)SvRV (self); int wcount = AvFILLp (av) + 1 - 1; @@ -4058,10 +4118,10 @@ MODULE = Coro::State PACKAGE = Coro::SemaphoreSet void -_may_delete (SV *sem, int count, int extra_refs) +_may_delete (SV *sem, int count, unsigned int extra_refs) PPCODE: { - AV *av = (AV *)SvRV (sem); + AV *av = (AV *)SvRV (sem); if (SvREFCNT ((SV *)av) == 1 + extra_refs && AvFILLp (av) == 0 /* no waiters, just count */ @@ -4092,7 +4152,7 @@ broadcast (SV *self) CODE: { - AV *av = (AV *)SvRV (self); + AV *av = (AV *)SvRV (self); coro_signal_wake (aTHX_ av, AvFILLp (av)); } @@ -4110,7 +4170,7 @@ IV awaited (SV *self) - CODE: + CODE: RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1; OUTPUT: RETVAL @@ -4125,7 +4185,7 @@ _schedule (...) CODE: { - static int incede; + static int incede; api_cede_notself (aTHX);