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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.400 by root, Thu May 12 23:55:39 2011 UTC vs.
Revision 1.449 by root, Sun Jun 21 17:02:49 2015 UTC

 /* 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"
 #define PERL_NO_GET_CONTEXT
 #define PERL_EXT
 #include "XSUB.h"
 #include "perliol.h"
 #include "schmorp.h"
+#define ECB_NO_THREADS 1
+#define ECB_NO_LIBM 1
+#include "ecb.h"
+#include <stddef.h>
 #include <stdio.h>
 #include <errno.h>
 #include <assert.h>
 #ifndef SVs_PADSTALE
 # define SVs_PADSTALE 0
+#endif
+#ifdef PadARRAY
+# define NEWPADAPI 1
+# 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
+#ifndef PadnamelistREFCNT
+# define PadnamelistREFCNT(pnl) SvREFCNT (pnl)
+#endif
+#ifndef PadnamelistREFCNT_dec
+# define PadnamelistREFCNT_dec(pnl) SvREFCNT_dec (pnl)
+#endif
+/* 5.19.something has replaced SVt_BIND by SVt_INVLIST */
+/* we just alias it to SVt_IV, as that is sufficient for swap_sv for now */
+#if PERL_VERSION_ATLEAST(5,19,0)
+# define SVt_BIND SVt_IV
 #endif
 #if defined(_WIN32)
 # undef HAS_GETTIMEOFDAY
 # undef setjmp
 # define setjmp _setjmp /* deep magic */
 #else
 # include <inttypes.h> /* most portable stdint.h */
 #endif
-#ifdef HAVE_MMAP
-# include <unistd.h>
-# include <sys/mman.h>
-# ifndef MAP_ANONYMOUS
-#  ifdef MAP_ANON
-#   define MAP_ANONYMOUS MAP_ANON
-#  else
-#   undef HAVE_MMAP
-#  endif
-# endif
-# include <limits.h>
-# 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 <valgrind/valgrind.h>
-#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
+#if defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)
-# undef CORO_STACKGUARD
+# define HAS_SCOPESTACK_NAME 1
-#endif
-#ifndef CORO_STACKGUARD
-# define CORO_STACKGUARD 0
 #endif
 /* prefer perl internal functions over our own? */
 #ifndef CORO_PREFER_PERL_FUNCTIONS
 # define CORO_PREFER_PERL_FUNCTIONS 0
 # define STACKLEVEL ((void *)&stacklevel)
 #endif
 #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 */
 #ifdef USE_ITHREADS
 # if CORO_PTHREAD
 typedef struct coro_cctx
 {
   struct coro_cctx *next;
   /* the stack */
-  void *sptr;
+  struct coro_stack stack;
-  size_t ssize;
   /* cpu state */
   void *idle_sp;   /* sp of top-level transfer/schedule/cede call */
+#ifndef NDEBUG
-  JMPENV *idle_te; /* same as idle_sp, but for top_env, TODO: remove once stable */
+  JMPENV *idle_te; /* same as idle_sp, but for top_env */
+#endif
   JMPENV *top_env;
   coro_context cctx;
   U32 gen;
 #if CORO_USE_VALGRIND
 };
 /* 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;
+  #define VARx(name,expr,type) type name;
-# include "state.h"
+  #include "state.h"
-#undef VAR
 } 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 */
 struct coro
 {
 static struct coro *coro_ready [CORO_PRIO_MAX - CORO_PRIO_MIN + 1][2]; /* head|tail */
 static CV *cv_coro_run;
 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 ECB_AMD64 && 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);
 static SV *coro_select_select;
 /** time stuff **************************************************************/
 #ifdef HAS_GETTIMEOFDAY
-static void
+ecb_inline void
 coro_u2time (pTHX_ UV ret[2])
 {
   struct timeval tv;
   gettimeofday (&tv, 0);
   ret [0] = tv.tv_sec;
   ret [1] = tv.tv_usec;
 }
-static double
+ecb_inline double
-coro_nvtime ()
+coro_nvtime (void)
 {
   struct timeval tv;
   gettimeofday (&tv, 0);
   return tv.tv_sec + tv.tv_usec * 1e-6;
 }
-static void
+ecb_inline void
 time_init (pTHX)
 {
   nvtime = coro_nvtime;
   u2time = coro_u2time;
 }
 #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");
   if (!SvIOK (*svp)) croak ("Time::NVtime isn't a function pointer. Caught");
 #endif
 /** lowlevel stuff **********************************************************/
-static SV *
+static SV * ecb_noinline
 coro_get_sv (pTHX_ const char *name, int create)
 {
 #if PERL_VERSION_ATLEAST (5,10,0)
          /* silence stupid and wrong 5.10 warning that I am unable to switch off */
          get_sv (name, create);
 #endif
   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)
          /* silence stupid and wrong 5.10 warning that I am unable to switch off */
          get_av (name, create);
 #endif
   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)
          /* silence stupid and wrong 5.10 warning that I am unable to switch off */
          get_hv (name, create);
 #endif
   return get_hv (name, create);
 }
-INLINE void
+ecb_inline void
-coro_times_update ()
+coro_times_update (void)
 {
 #ifdef coro_clock_gettime
   struct timespec ts;
   ts.tv_sec  = ts.tv_nsec = 0;
   time_real [0] = tv [0];
   time_real [1] = tv [1] * 1000;
 #endif
 }
-INLINE void
+ecb_inline void
 coro_times_add (struct coro *c)
 {
   c->t_real [1] += time_real [1];
   if (c->t_real [1] > 1000000000) { c->t_real [1] -= 1000000000; ++c->t_real [0]; }
   c->t_real [0] += time_real [0];
   c->t_cpu  [1] += time_cpu  [1];
   if (c->t_cpu  [1] > 1000000000) { c->t_cpu  [1] -= 1000000000; ++c->t_cpu  [0]; }
   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]; }
   c->t_real [1] -= time_real [1];
   c->t_real [0] -= time_real [0];
 /* magic glue */
 #define CORO_MAGIC_type_cv    26
 #define CORO_MAGIC_type_state PERL_MAGIC_ext
-#define CORO_MAGIC_NN(sv, type)			\
+#define CORO_MAGIC_NN(sv, type)				\
-  (expect_true (SvMAGIC (sv)->mg_type == type)	\
+  (ecb_expect_true (SvMAGIC (sv)->mg_type == type)	\
-    ? SvMAGIC (sv)				\
+    ? SvMAGIC (sv)					\
     : mg_find (sv, type))
-#define CORO_MAGIC(sv, type)			\
+#define CORO_MAGIC(sv, type)				\
-  (expect_true (SvMAGIC (sv))			\
+  (ecb_expect_true (SvMAGIC (sv))			\
-    ? CORO_MAGIC_NN (sv, type)			\
+    ? 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
      ))
     return mg;
   return 0;
 }
-INLINE struct coro *
+ecb_inline struct coro *
 SvSTATE_ (pTHX_ SV *coro)
 {
   MAGIC *mg;
   if (SvROK (coro))
     coro = SvRV (coro);
-  mg = SvSTATEhv_p (coro);
+  mg = SvSTATEhv_p (aTHX_ coro);
   if (!mg)
     croak ("Coro::State object required");
   return (struct coro *)mg->mg_ptr;
 }
 #define SvSTATE_current SvSTATE_hv (SvRV (coro_current))
 /*****************************************************************************/
 /* padlist management and caching */
-static AV *
+ecb_inline PADLIST *
 coro_derive_padlist (pTHX_ CV *cv)
 {
-  AV *padlist = CvPADLIST (cv);
+  PADLIST *padlist = CvPADLIST (cv);
-  AV *newpadlist, *newpad;
+  PADLIST *newpadlist;
+  PADNAMELIST *padnames;
+  PAD *newpad;
+  PADOFFSET off = PadlistMAX (padlist) + 1;
-  newpadlist = newAV ();
+#if NEWPADAPI
+  /* if we had the original CvDEPTH, we might be able to steal the CvDEPTH+1 entry instead */
+  /* 20131102194744.GA6705@schmorp.de, 20131102195825.2013.qmail@lists-nntp.develooper.com */
+  while (!PadlistARRAY (padlist)[off - 1])
+    --off;
+  Perl_pad_push (aTHX_ padlist, off);
+  newpad = PadlistARRAY (padlist)[off];
+  PadlistARRAY (padlist)[off] = 0;
+#else
+#if PERL_VERSION_ATLEAST (5,10,0)
+  Perl_pad_push (aTHX_ padlist, off);
+#else
+  Perl_pad_push (aTHX_ padlist, off, 1);
+#endif
+  newpad = PadlistARRAY (padlist)[off];
+  PadlistMAX (padlist) = off - 1;
+#endif
+  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);
-#if PERL_VERSION_ATLEAST (5,10,0)
-  Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1);
-#else
-  Perl_pad_push (aTHX_ padlist, AvFILLp (padlist) + 1, 1);
 #endif
-  newpad = (AV *)AvARRAY (padlist)[AvFILLp (padlist)];
-  --AvFILLp (padlist);
-  av_store (newpadlist, 0, SvREFCNT_inc_NN (AvARRAY (padlist)[0]));
+  /* Already extended to 2 elements by newPADLIST. */
-  av_store (newpadlist, 1, (SV *)newpad);
+  PadlistMAX (newpadlist) = 1;
+  padnames = PadlistNAMES (padlist);
+  ++PadnamelistREFCNT (padnames);
+  PadlistNAMES (newpadlist) = padnames;
+  PadlistARRAY (newpadlist)[1] = newpad;
   return newpadlist;
 }
-static void
+ecb_inline void
-free_padlist (pTHX_ AV *padlist)
+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--];
+          PAD *pad = PadlistARRAY (padlist)[i--];
-          I32 j = AvFILLp (av);
+          if (pad)
+            {
+              I32 j = PadMAX (pad);
-          while (j >= 0)
+              while (j >= 0)
-            SvREFCNT_dec (AvARRAY (av)[j--]);
+                SvREFCNT_dec (PadARRAY (pad)[j--]);
-          AvFILLp (av) = -1;
+              PadMAX (pad) = -1;
-          SvREFCNT_dec (av);
+              SvREFCNT_dec (pad);
+            }
         }
-      SvREFCNT_dec (AvARRAY (padlist)[0]);
+      PadnamelistREFCNT_dec (PadlistNAMES (padlist));
+#if 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;
+  PADLIST *padlist;
-  AV *av = (AV *)mg->mg_obj;
+  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 (len--)
-  while (&PL_sv_undef != (SV *)(padlist = (AV *)av_pop (av)))
-    free_padlist (aTHX_ padlist);
+    free_padlist (aTHX_ padlists[len]);
-  SvREFCNT_dec (av); /* sv_magicext increased the refcount */
   return 0;
 }
 static MGVTBL coro_cv_vtbl = {
   0, 0, 0, 0,
   coro_cv_free
 };
 /* 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))
+  if (ecb_expect_true (mg && *(lenp = (size_t *)mg->mg_ptr)))
-    CvPADLIST (cv) = (AV *)AvARRAY (av)[AvFILLp (av)--];
+    CvPADLIST (cv) = ((PADLIST **)(mg->mg_ptr + sizeof(size_t)))[--*lenp];
   else
    {
 #if CORO_PREFER_PERL_FUNCTIONS
      /* this is probably cleaner? but also slower! */
      /* in practise, it seems to be less stable */
      CvPADLIST (cv) = coro_derive_padlist (aTHX_ cv);
 #endif
    }
 }
-static void
+ecb_inline void
 put_padlist (pTHX_ CV *cv)
 {
   MAGIC *mg = CORO_MAGIC_cv (cv);
-  AV *av;
-  if (expect_false (!mg))
+  if (ecb_expect_false (!mg))
+    {
-    mg = sv_magicext ((SV *)cv, (SV *)newAV (), CORO_MAGIC_type_cv, &coro_cv_vtbl, 0, 0);
+      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);
-  av = (AV *)mg->mg_obj;
+  ((PADLIST **)(mg->mg_ptr + sizeof (size_t))) [(*(size_t *)mg->mg_ptr)++] = CvPADLIST (cv);
-  if (expect_false (AvFILLp (av) >= AvMAX (av)))
-    av_extend (av, AvFILLp (av) + 1);
-  AvARRAY (av)[++AvFILLp (av)] = (SV *)CvPADLIST (cv);
 }
 /** load & save, init *******************************************************/
+ecb_inline void
+swap_sv (SV *a, SV *b)
+{
+  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_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 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_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);
+  }
+#endif
+}
 /* swap sv heads, at least logically */
 static void
 swap_svs (pTHX_ Coro__State c)
 {
   int i;
-  for (i = 0; i <= AvFILLp (c->swap_sv); )
+  for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
-    {
+    swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
-      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;
-      /* 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);
-#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;
-        /* 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 (b)))
-          SvANY (b) = (void *)((PTRV)SvANY (b) - (PTRV)a + (PTRV)b);
-      }
-#endif
-    }
 }
-#define SWAP_SVS(coro)		\
+#define SWAP_SVS(coro)				\
-  if (expect_false ((coro)->swap_sv))	\
+  if (ecb_expect_false ((coro)->swap_sv))	\
     swap_svs (aTHX_ (coro))
 static void
 on_enterleave_call (pTHX_ SV *cb);
   perl_slots *slot = c->slot;
   c->slot = 0;
   PL_mainstack = c->mainstack;
-  GvSV (PL_defgv)  = slot->defsv;
+#if CORO_JIT
-  GvAV (PL_defgv)  = slot->defav;
+  load_perl_slots (slot);
-  GvSV (PL_errgv)  = slot->errsv;
+#else
-  GvSV (irsgv)     = slot->irsgv;
-  GvHV (PL_hintgv) = slot->hinthv;
-  #define VAR(name,type) PL_ ## name = slot->name;
+  #define VARx(name,expr,type) expr = slot->name;
-  # include "state.h"
+  #include "state.h"
-  #undef VAR
+#endif
   {
     dSP;
     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;
   }
   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;
       for (i = 0; i <= AvFILLp (c->on_enter); ++i)
         on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);
 static void
 save_perl (pTHX_ Coro__State c)
 {
   SWAP_SVS (c);
-  if (expect_false (c->on_leave))
+  if (ecb_expect_false (c->on_leave))
     {
       int i;
       for (i = AvFILLp (c->on_leave); i >= 0; --i)
         on_enterleave_call (aTHX_ AvARRAY (c->on_leave)[i]);
     }
   times_valid = 0;
-  if (expect_false (enable_times))
+  if (ecb_expect_false (enable_times))
     {
       coro_times_update (); times_valid = 1;
       coro_times_add (c);
     }
     XPUSHs (Nullsv);
     /* 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));
                     PUSHs (INT2PTR (SV *, (IV)CvDEPTH (cv)));
                     PUSHs ((SV *)cv);
                     get_padlist (aTHX_ cv);
                   }
               }
           }
-        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;
         ccstk  = top_si->si_cxstack;
         cxix   = top_si->si_cxix;
     PUTBACK;
   }
   /* 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;
       for (i = 0; i < SLOT_COUNT; ++i)
         CXINC;
   c->mainstack = PL_mainstack;
   {
     perl_slots *slot = c->slot = (perl_slots *)(cxstack + cxstack_ix + 1);
-    slot->defav  = GvAV (PL_defgv);
+#if CORO_JIT
-    slot->defsv  = DEFSV;
+    save_perl_slots (slot);
-    slot->errsv  = ERRSV;
+#else
-    slot->irsgv  = GvSV (irsgv);
-    slot->hinthv = GvHV (PL_hintgv);
-    #define VAR(name,type) slot->name = PL_ ## name;
+    #define VARx(name,expr,type) slot->name = expr;
-    # include "state.h"
+    #include "state.h"
-    #undef VAR
+#endif
   }
 }
 /*
  * allocate various perl stacks. This is almost an exact copy
 #endif
     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;
     PL_savestack_max = 24;
   }
   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);
 #endif
 }
 #endif
 /*
  * This overrides the default magic get method of %SIG elements.
  * The original one doesn't provide for reading back of PL_diehook/PL_warnhook
- * and instead of trying to save and restore the hash elements, we just provide
+ * and instead of trying to save and restore the hash elements (extremely slow),
- * readback here.
+ * 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);
   if (*s == '_')
     {
       SV **svp = 0;
       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;
         }
     }
   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);
   if (*s == '_')
     }
   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);
   if (*s == '_')
   return 1;
 }
 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)
 {
   /*
    * emulate part of the perl startup here.
    */
   PL_parser     = 0;
 #endif
   PL_hints      = 0;
   /* recreate the die/warn hooks */
-  PL_diehook  = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__DIE__" , sizeof ("__DIE__" ) - 1, 1), rv_diehook );
+  PL_diehook  = SvREFCNT_inc (rv_diehook);
-  PL_warnhook = 0; SvSetMagicSV (*hv_fetch (hv_sig, "__WARN__", sizeof ("__WARN__") - 1, 1), rv_warnhook);
+  PL_warnhook = SvREFCNT_inc (rv_warnhook);
   GvSV (PL_defgv)    = newSV (0);
   GvAV (PL_defgv)    = coro->args; coro->args = 0;
   GvSV (PL_errgv)    = newSV (0);
   GvSV (irsgv)       = newSVpvn ("\n", 1); sv_magic (GvSV (irsgv), (SV *)irsgv, PERL_MAGIC_sv, "/", 0);
-  GvHV (PL_hintgv)   = 0;
+  GvHV (PL_hintgv)   = newHV ();
+#if PERL_VERSION_ATLEAST (5,10,0)
+  hv_magic (GvHV (PL_hintgv), 0, PERL_MAGIC_hints);
+#endif
   PL_rs              = newSVsv (GvSV (irsgv));
   PL_defoutgv        = (GV *)SvREFCNT_inc_NN (stdoutgv);
   {
     dSP;
   /* copy throw, in case it was set before init_perl */
   CORO_THROW = coro->except;
   SWAP_SVS (coro);
-  if (expect_false (enable_times))
+  if (ecb_expect_false (enable_times))
     {
       coro_times_update ();
       coro_times_sub (coro);
     }
 }
     /* restore swapped sv's */
     SWAP_SVS (coro);
     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);
     svf    [3] = (SV *)PL_defoutgv;
     svf    [4] =       PL_rs;
     SvREFCNT_dec (coro->invoke_cb);
     SvREFCNT_dec (coro->invoke_av);
   }
 }
-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;
     }
 }
               if (PL_curcop != &PL_compiling)
                 {
                   SV **cb;
-                  if (oldcxix != cxstack_ix && cctx_current->flags & CC_TRACE_SUB)
+                  if (oldcxix != cxstack_ix && cctx_current->flags & CC_TRACE_SUB && cxstack_ix >= 0)
                     {
                       PERL_CONTEXT *cx = &cxstack[cxstack_ix];
                       if (CxTYPE (cx) == CXt_SUB && oldcxix < cxstack_ix)
                         {
   return frame->check (aTHX_ frame); /* execute the restored frame - there must be one */
 }
 /* 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;
   if (cctx_current->flags & CC_TRACE)
   slf_frame.prepare = slf_prepare_set_stacklevel;
   slf_frame.check   = slf_check_set_stacklevel;
 }
 /* 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 ;)
  */
      */
     /*
      * 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
+     * reason for perl_run to return. We try to mimic whatever perl is normally
-     * bootstrap-time "top" top_env, as we cannot restore the "main"
+     * doing in that case. YMMV.
-     * 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.
      */
-    PL_top_env = main_top_env;
+    perlish_exit (aTHX);
-    JMPENV_JUMP (2); /* I do not feel well about the hardcoded 2 at all */
   }
 }
 static coro_cctx *
-cctx_new ()
+cctx_new (void)
 {
   coro_cctx *cctx;
   ++cctx_count;
   New (0, cctx, 1, coro_cctx);
   return cctx;
 }
 /* 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;
 }
 /* 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
+  if (!coro_stack_alloc (&cctx->stack, cctx_stacksize))
-  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
-    {
-      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.");
+      perror ("FATAL: unable to allocate stack for coroutine, exiting.");
-          _exit (EXIT_FAILURE);
+      _exit (EXIT_FAILURE);
-        }
-      stack_start = cctx->sptr;
-      stack_size  = cctx->ssize;
     }
-  #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;
 }
 static void
   assert (("FATAL: tried to destroy current cctx", cctx != cctx_current));
   --cctx_count;
   coro_destroy (&cctx->cctx);
-  /* coro_transfer creates new, empty cctx's */
+  coro_stack_free (&cctx->stack);
-  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);
-    }
   Safefree (cctx);
 }
 /* wether this cctx should be destructed */
 #define CCTX_EXPIRED(cctx) ((cctx)->gen != cctx_gen || ((cctx)->flags & CC_NOREUSE))
 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);
     }
 }
 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;
       --cctx_idle;
 static void
 transfer_check (pTHX_ struct coro *prev, struct coro *next)
 {
   /* 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;
           prev->flags |=  CF_RUNNING;
         }
       next->flags |=  CF_RUNNING;
       /* 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;
           /* setup coroutine call */
           init_perl (aTHX_ next);
         }
       else
         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
          ))
         {
           /* I assume that stacklevel is a stronger indicator than PL_top_env changes */
           assert (("FATAL: current top_env must equal previous top_env in Coro (please report)", PL_top_env == cctx_current->idle_te));
           /* 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 (ecb_expect_false (CCTX_EXPIRED (cctx_current)))
-            if (expect_true (!next->cctx))
+            if (ecb_expect_true (!next->cctx))
               next->cctx = cctx_get (aTHX);
           cctx_put (cctx_current);
         }
       else
         prev->cctx = cctx_current;
       ++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;
           coro_transfer (&cctx_prev->cctx, &cctx_current->cctx);
         }
     return;
   slf_destroy (aTHX_ coro);
   coro->flags |= CF_ZOMBIE;
   if (coro->flags & CF_READY)
     {
       /* reduce nready, as destroying a ready coro effectively unreadies it */
       /* alternative: look through all ready queues and remove the coro */
       --coro_nready;
   SvREFCNT_dec (coro->startcv);
   SvREFCNT_dec (coro->args);
   SvREFCNT_dec (coro->swap_sv);
   SvREFCNT_dec (CORO_THROW);
-  coro_call_on_destroy (coro);
+  coro_call_on_destroy (aTHX_ coro);
   /* more destruction mayhem in coro_state_free */
 }
 static int
 coro_state_free (pTHX_ SV *sv, MAGIC *mg)
 {
   struct coro *coro = (struct coro *)mg->mg_ptr;
   mg->mg_ptr = 0;
-  coro_state_destroy (coro);
+  coro_state_destroy (aTHX_ coro);
   SvREFCNT_dec (coro->on_destroy);
   SvREFCNT_dec (coro->status);
   Safefree (coro);
   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) */
   /* WE SIMply nuke the pointers in the copy, causing perl to croak */
   mg->mg_ptr     = 0;
   TRANSFER (ta, 1);
 }
 /** Coro ********************************************************************/
-INLINE void
+ecb_inline void
 coro_enq (pTHX_ struct coro *coro)
 {
   struct coro **ready = coro_ready [coro->prio - CORO_PRIO_MIN];
   SvREFCNT_inc_NN (coro->hv);
   coro->next_ready = 0;
   *(ready [0] ? &ready [1]->next_ready : &ready [0]) = coro;
   ready [1] = coro;
 }
-INLINE struct coro *
+ecb_inline struct coro *
 coro_deq (pTHX)
 {
   int prio;
   for (prio = CORO_PRIO_MAX - CORO_PRIO_MIN + 1; --prio >= 0; )
 {
   return !!(SvSTATE (coro_sv)->flags & CF_READY);
 }
 /* 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);
   ta->prev = SvSTATE_hv (prev_sv);
 {
   for (;;)
     {
       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
             {
               next->flags &= ~CF_READY;
               --coro_nready;
           /* nothing to schedule: call the idle handler */
           if (SvROK (sv_idle)
               && SvOBJECT (SvRV (sv_idle)))
             {
               if (SvRV (sv_idle) == SvRV (coro_current))
+                {
+                  require_pv ("Carp");
+                  {
+                    dSP;
+                    ENTER;
+                    SAVETMPS;
+                    PUSHMARK (SP);
-                croak ("FATAL: $Coro::IDLE blocked itself - did you try to block inside an event loop callback? Caught");
+                    XPUSHs (sv_2mortal (newSVpv ("FATAL: $Coro::idle blocked itself - did you try to block inside an event loop callback? Caught", 0)));
+                    PUTBACK;
+                    call_pv ("Carp::confess", G_VOID | G_DISCARD);
+                    FREETMPS;
+                    LEAVE;
+                  }
+                }
               ++coro_nready; /* hack so that api_ready doesn't invoke ready hook */
               api_ready (aTHX_ SvRV (sv_idle));
               --coro_nready;
             }
             }
         }
     }
 }
-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);
   if (coro_nready)
 {
   struct coro_transfer_args ta;
   prepare_cede (aTHX_ &ta);
-  if (expect_true (ta.prev != ta.next))
+  if (ecb_expect_true (ta.prev != ta.next))
     {
       TRANSFER (ta, 1);
       return 1;
     }
   else
       PUTBACK;
     }
 }
 static void
-coro_push_on_destroy (aTHX_ struct coro *coro, SV *cb)
+coro_push_on_destroy (pTHX_ struct coro *coro, SV *cb)
 {
   if (!coro->on_destroy)
     coro->on_destroy = newAV ();
   av_push (coro->on_destroy, cb);
   if (!coro->status)
     return 1;
   frame->destroy = 0;
-  coro_push_av (coro->status, GIMME_V);
+  coro_push_av (aTHX_ coro->status, GIMME_V);
   SvREFCNT_dec ((SV *)coro->hv);
   return 0;
 }
 {
   AV *od = coro->on_destroy;
   if (!od)
     return;
+  coro->on_destroy = 0;
+  sv_2mortal ((SV *)od);
   while (AvFILLp (od) >= 0)
     {
       SV *cb = sv_2mortal (av_pop (od));
 static void
 coro_set_status (pTHX_ struct coro *coro, SV **arg, int items)
 {
   AV *av;
   if (coro->status)
     {
       av = coro->status;
       av_clear (av);
     }
   coro = SvSTATE (arg [0]);
   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;
       frame->prepare = prepare_nop;
       slf_init_terminate_cancel_common (aTHX_ frame, coro_hv);
     }
   else
     {
       struct coro *self = SvSTATE_current;
+      if (!self)
+        croak ("Coro::cancel called outside of thread content,");
       /* otherwise we cancel directly, purely for speed reasons
        * unfortunately, this requires some magic trickery, as
        * somebody else could cancel us, so we have to fight the cancellation.
        * this is ugly, and hopefully fully worth the extra speed.
 slf_init_pool_handler (pTHX_ struct CoroSLF *frame, CV *cv, SV **arg, int items)
 {
   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;
       coro->saved_deffh = 0;
 static int
 slf_check_rouse_wait (pTHX_ struct CoroSLF *frame)
 {
   SV *data = (SV *)frame->data;
   if (CORO_THROW)
     return 0;
   if (SvTYPE (SvRV (data)) != SVt_PVAV)
     return 1;
       cb = sv_2mortal (coro->rouse_cb);
       coro->rouse_cb = 0;
     }
   if (!SvROK (cb)
       || SvTYPE (SvRV (cb)) != SVt_PVCV
       || CvXSUB ((CV *)SvRV (cb)) != coro_rouse_callback)
     croak ("Coro::rouse_wait called with illegal callback argument,");
   {
     CV *cv = (CV *)SvRV (cb); /* for S_GENSUB_ARG */
 /* "undo"/cancel a running slf call - used when cancelling a coro, mainly */
 static void
 slf_destroy (pTHX_ struct coro *coro)
 {
-  /* this callback is reserved for slf functions needing to do cleanup */
+  struct CoroSLF frame = coro->slf_frame;
-  if (coro->slf_frame.destroy && coro->slf_frame.prepare && !PL_dirty)
-    coro->slf_frame.destroy (aTHX_ &coro->slf_frame);
   /*
-   * The on_destroy above most likely is from an SLF call.
+   * The on_destroy below most likely is from an SLF call.
    * Since by definition the SLF call will not finish when we destroy
    * the coro, we will have to force-finish it here, otherwise
    * cleanup functions cannot call SLF functions.
    */
   coro->slf_frame.prepare = 0;
+  /* this callback is reserved for slf functions needing to do cleanup */
+  if (frame.destroy && frame.prepare && !PL_dirty)
+    frame.destroy (aTHX_ &frame);
 }
 /*
  * these not obviously related functions are all rolled into one
  * function to increase chances that they all will call transfer with the same
   I32 checkmark; /* mark SP to see how many elements check has pushed */
   /* 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;
       SV **arg = PL_stack_base + TOPMARK + 1;
       int items = SP - arg; /* args without function object */
   while (slf_frame.check (aTHX_ &slf_frame));
   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);
       CORO_THROW = 0;
       sv_setsv (ERRSV, exception);
     }
   /* 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;
       if (sp == bot) /* too few, push undef */
 {
   PerlIOBuf base;
   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);
   self->every = SvCUR (arg) ? SvNV (arg) : 0.01;
   self->next  = nvtime () + self->every;
   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);
   return newSVnv (self->every);
 {
   AV *av = (AV *)frame->data;
   SV *count_sv = AvARRAY (av)[0];
   SV *coro_hv = SvRV (coro_current);
+  frame->destroy = 0;
   /* if we are about to throw, don't actually acquire the lock, just throw */
-  if (CORO_THROW)
+  if (ecb_expect_false (CORO_THROW))
+    {
+      /* we still might be responsible for the semaphore, so wake up others */
+      coro_semaphore_adjust (aTHX_ av, 0);
-    return 0;
+      return 0;
+    }
   else if (SvIVX (count_sv) > 0)
     {
-      frame->destroy = 0;
       if (acquire)
         SvIVX (count_sv) = SvIVX (count_sv) - 1;
       else
         coro_semaphore_adjust (aTHX_ av, 0);
     {
       int i;
       /* 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;
       av_push (av, SvREFCNT_inc (coro_hv));
       return 1;
   /* it quickly returns */
   if (CORO_THROW)
     return 0;
   /* one element that is an RV? repeat! */
-  if (AvFILLp (state) == 0 && SvROK (AvARRAY (state)[0]))
+  if (AvFILLp (state) == 0 && SvTYPE (AvARRAY (state)[0]) != SVt_PV)
     return 1;
   /* restore status */
   {
     SV *data_sv = av_pop (state);
       dSP;
       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);
         }
     }
   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
 BOOT:
 {
+#define VARx(name,expr,type) if (sizeof (type) < sizeof (expr)) croak ("FATAL: Coro thread context slot '" # name "' too small for this version of perl.");
+#include "state.h"
 #ifdef USE_ITHREADS
 # if CORO_PTHREAD
         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 ();
         irsgv    = gv_fetchpv ("/"     , GV_ADD|GV_NOTQUAL, SVt_PV);
         stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
         coroapi.prepare_cede_notself = prepare_cede_notself;
         time_init (aTHX);
         assert (("PRIO_NORMAL must be 0", !CORO_PRIO_NORMAL));
+#if CORO_JIT
+	PUTBACK;
+	jit_init (aTHX);
+        SPAGAIN;
+#endif
 }
 SV *
 new (SV *klass, ...)
 	ALIAS:
 void
 transfer (...)
         PROTOTYPE: $$
 	CODE:
         CORO_EXECUTE_SLF_XS (slf_init_transfer);
-void
-_exit (int code)
-        PROTOTYPE: $
-	CODE:
-	_exit (code);
 SV *
 clone (Coro::State coro)
 	CODE:
 {
 void
 list ()
 	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)));
 }
         RETVAL = boolSV (coro->flags & ix);
 	OUTPUT:
         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
 api_trace (SV *coro, int flags = CC_TRACE | CC_TRACE_SUB)
 	PROTOTYPE: $;$
 void
 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));
           }
         EXTEND (SP, 2);
         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));
 }
 void
 swap_sv (Coro::State coro, SV *sv, SV *swapsv)
         sv_async_pool_idle = newSVpv ("[async pool idle]", 0); SvREADONLY_on (sv_async_pool_idle);
         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));
         newCONSTSUB (coro_stash, "PRIO_HIGH",   newSViv (CORO_PRIO_HIGH));
         newCONSTSUB (coro_stash, "PRIO_NORMAL", newSViv (CORO_PRIO_NORMAL));
         on_leave = 1
 	PROTOTYPE: &
 	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);
         if (!*avp)
           *avp = newAV ();
 SV *
 new (SV *klass, SV *count = 0)
 	CODE:
 {
-  	int semcnt = 1;
+	int semcnt = 1;
         if (count)
           {
             SvGETMAGIC (count);
           XSRETURN_NO;
 }
 void
 waiters (SV *self)
-    	PPCODE:
+	PPCODE:
 {
         AV *av = (AV *)SvRV (self);
         int wcount = AvFILLp (av) + 1 - 1;
         if (GIMME_V == G_SCALAR)
 }
 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 */
             && SvIV (AvARRAY (av)[0]) == count)
           XSRETURN_YES;
 void
 broadcast (SV *self)
         CODE:
 {
-  	AV *av = (AV *)SvRV (self);
+	AV *av = (AV *)SvRV (self);
         coro_signal_wake (aTHX_ av, AvFILLp (av));
 }
 void
 send (SV *self)
           SvIVX (AvARRAY (av)[0]) = 1; /* remember the signal */
 }
 IV
 awaited (SV *self)
-    	CODE:
+	CODE:
         RETVAL = AvFILLp ((AV *)SvRV (self)) + 1 - 1;
 	OUTPUT:
         RETVAL
 void
 _schedule (...)
 	CODE:
 {
-  	static int incede;
+	static int incede;
         api_cede_notself (aTHX);
         ++incede;
         while (coro_nready >= incede && api_cede (aTHX))
           {
             PL_ppaddr [OP_SSELECT] = coro_old_pp_sselect;
             coro_old_pp_sselect = 0;
           }
+MODULE = Coro::State                PACKAGE = Coro::Util
+void
+_exit (int code)
+	CODE:
+	_exit (code);
+NV
+time ()
+	CODE:
+        RETVAL = nvtime (aTHX);
+	OUTPUT:
+        RETVAL
+NV
+gettimeofday ()
+	PPCODE:
+{
+        UV tv [2];
+        u2time (aTHX_ tv);
+        EXTEND (SP, 2);
+        PUSHs (sv_2mortal (newSVuv (tv [0])));
+        PUSHs (sv_2mortal (newSVuv (tv [1])));
+}

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.400 by root, Thu May 12 23:55:39 2011 UTC vs. Revision 1.449 by root, Sun Jun 21 17:02:49 2015 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.400 by root, Thu May 12 23:55:39 2011 UTC vs.
Revision 1.449 by root, Sun Jun 21 17:02:49 2015 UTC