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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.414 by root, Wed Jun 29 16:08:31 2011 UTC vs.
Revision 1.473 by root, Sun Sep 3 23:36:01 2017 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 "perl.h"
 #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 SvREFCNT_dec_NN
+  #define SvREFCNT_dec_NN(sv) SvREFCNT_dec (sv)
+#endif
+#ifndef SvREFCNT_inc_NN
+  #define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
+#endif
 #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
-#if 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 defined(DEBUGGING) && PERL_VERSION_ATLEAST(5,12,0)
 # define HAS_SCOPESTACK_NAME 1
-#endif
-#if !__i386 && !__x86_64 && !__powerpc && !__m68k && !__alpha && !__mips && !__sparc64
-# undef CORO_STACKGUARD
-#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
 # if CORO_PTHREAD
 static void *coro_thx;
 # endif
 #endif
-/* used in state.h */
-#define VAR(name,type) VARx(name, PL_ ## name, type)
 #ifdef __linux
 # include <time.h> /* for timespec */
 # include <syscall.h> /* for SYS_* */
 # ifdef SYS_clock_gettime
 #  define coro_clock_gettime(id, ts) syscall (SYS_clock_gettime, (id), (ts))
 #  define CORO_CLOCK_MONOTONIC         1
 #  define CORO_CLOCK_THREAD_CPUTIME_ID 3
 # endif
 #endif
+/* one off bugfix for perl 5.22 */
+#if PERL_VERSION_ATLEAST(5,22,0) && !PERL_VERSION_ATLEAST(5,24,0)
+# undef PadlistNAMES
+# define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY (pl))
+#endif
+#if PERL_VERSION_ATLEAST(5,24,0)
+# define SUB_ARGARRAY PL_curpad[0]
+#else
+# define SUB_ARGARRAY (SV *)cx->blk_sub.argarray
+#endif
+/* perl usually suppresses asserts. for debugging, we sometimes force it to be on */
+#if 0
+# undef NDEBUG
+# include <assert.h>
+#endif
 static double (*nvtime)(); /* so why doesn't it take void? */
 static void   (*u2time)(pTHX_ UV ret[2]);
 /* we hijack an hopefully unused CV flag for our purposes */
 #define CVf_SLF 0x4000
 static GV *irsgv;    /* $/ */
 static GV *stdoutgv; /* *STDOUT */
 static SV *rv_diehook;
 static SV *rv_warnhook;
-static HV *hv_sig;   /* %SIG */
 /* async_pool helper stuff */
 static SV *sv_pool_rss;
 static SV *sv_pool_size;
 static SV *sv_async_pool_idle; /* description string */
 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
 {
-#define VARx(name,expr,type) type name;
+  #define VARx(name,expr,type) type name;
-# include "state.h"
+  #include "state.h"
-#undef VARx
 } 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))
   SV *saved_deffh;
   SV *invoke_cb;
   AV *invoke_av;
   /* on_enter/on_leave */
-  AV *on_enter;
+  AV *on_enter; AV *on_enter_xs;
-  AV *on_leave;
+  AV *on_leave; AV *on_leave_xs;
   /* swap_sv */
   AV *swap_sv;
   /* times */
 #define coro_nready coroapi.nready
 /** JIT *********************************************************************/
 #if CORO_JIT
-  /* APPLE doesn't have HAVE_MMAP though */
+  /* 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
+    #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) || !HAVE_MMAP
+#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 *);
 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");
   return 0;
 }
 ecb_inline struct coro *
-SvSTATE_ (pTHX_ SV *coro)
+SvSTATE_ (pTHX_ SV *coro_sv)
 {
   MAGIC *mg;
-  if (SvROK (coro))
+  if (SvROK (coro_sv))
-    coro = SvRV (coro);
+    coro_sv = SvRV (coro_sv);
-  mg = SvSTATEhv_p (aTHX_ coro);
+  mg = SvSTATEhv_p (aTHX_ coro_sv);
   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 */
-ecb_inline 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;
 }
 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 = {
 /* the next two functions merely cache the padlists */
 ecb_inline void
 get_padlist (pTHX_ CV *cv)
 {
   MAGIC *mg = CORO_MAGIC_cv (cv);
-  AV *av;
+  size_t *lenp;
-  if (ecb_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 */
 ecb_inline void
 put_padlist (pTHX_ CV *cv)
 {
   MAGIC *mg = CORO_MAGIC_cv (cv);
-  AV *av;
   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 (ecb_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.
+     */
+    U32 svany_in_head_set = (1 << SVt_NULL) | (1 << SVt_BIND) | (1 << SVt_IV) | (1 << SVt_RV);
+    #if NVSIZE <= IVSIZE && PERL_VERSION_ATLEAST(5,22,0)
+      svany_in_head_set |= 1 << SVt_NV;
+    #endif
+    #define svany_in_head(type) (svany_in_head_set & (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)
+swap_svs_enter (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
-    }
 }
+static void
+swap_svs_leave (pTHX_ Coro__State c)
+{
+  int i;
+  for (i = AvFILLp (c->swap_sv) - 1; i >= 0; i -= 2)
+    swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
+}
-#define SWAP_SVS(coro)				\
+#define SWAP_SVS_ENTER(coro)			\
   if (ecb_expect_false ((coro)->swap_sv))	\
-    swap_svs (aTHX_ (coro))
+    swap_svs_enter (aTHX_ (coro))
+#define SWAP_SVS_LEAVE(coro)			\
+  if (ecb_expect_false ((coro)->swap_sv))	\
+    swap_svs_leave (aTHX_ (coro))
 static void
 on_enterleave_call (pTHX_ SV *cb);
 static void
 #if CORO_JIT
   load_perl_slots (slot);
 #else
   #define VARx(name,expr,type) expr = slot->name;
-  # include "state.h"
+  #include "state.h"
-  #undef VARx
 #endif
   {
     dSP;
     /* now do the ugly restore mess */
     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;
   }
       for (i = 0; i <= AvFILLp (c->on_enter); ++i)
         on_enterleave_call (aTHX_ AvARRAY (c->on_enter)[i]);
     }
+  if (ecb_expect_false (c->on_enter_xs))
+    {
+      int i;
+      for (i = 0; i <= AvFILLp (c->on_enter_xs); i += 2)
+        ((coro_enterleave_hook)AvARRAY (c->on_enter_xs)[i]) (aTHX_ AvARRAY (c->on_enter_xs)[i + 1]);
+    }
-  SWAP_SVS (c);
+  SWAP_SVS_ENTER (c);
 }
 static void
 save_perl (pTHX_ Coro__State c)
 {
-  SWAP_SVS (c);
+  SWAP_SVS_LEAVE (c);
+  if (ecb_expect_false (c->on_leave_xs))
+    {
+      int i;
+      for (i = AvFILLp (c->on_leave_xs) - 1; i >= 0; i -= 2)
+        ((coro_enterleave_hook)AvARRAY (c->on_leave_xs)[i]) (aTHX_ AvARRAY (c->on_leave_xs)[i + 1]);
+    }
   if (ecb_expect_false (c->on_leave))
     {
       int i;
 #if CORO_JIT
     save_perl_slots (slot);
 #else
     #define VARx(name,expr,type) slot->name = expr;
-    # include "state.h"
+    #include "state.h"
-    #undef VARx
 #endif
   }
 }
 /*
 #endif
     New(54,PL_savestack,24,ANY);
     PL_savestack_ix = 0;
     PL_savestack_max = 24;
+#if PERL_VERSION_ATLEAST (5,24,0)
+    /* perl 5.24 moves SS_MAXPUSH optimisation from */
+    /* the header macros to PL_savestack_max */
+    PL_savestack_max -= SS_MAXPUSH;
+#endif
 #if !PERL_VERSION_ATLEAST (5,10,0)
     New(54,PL_retstack,4,OP*);
     PL_retstack_ix = 0;
     PL_retstack_max = 4;
     }
   return rss;
 }
-/** coroutine stack handling ************************************************/
+/** provide custom get/set/clear methods for %SIG elements ******************/
-static int (*orig_sigelem_get) (pTHX_ SV *sv, MAGIC *mg);
-static int (*orig_sigelem_set) (pTHX_ SV *sv, MAGIC *mg);
-static int (*orig_sigelem_clr) (pTHX_ SV *sv, MAGIC *mg);
 /* apparently < 5.8.8 */
 #ifndef MgPV_nolen_const
 #define MgPV_nolen_const(mg)    (((((int)(mg)->mg_len)) == HEf_SVKEY) ?   \
                                  SvPV_nolen((SV*)((mg)->mg_ptr)) :  \
                                  (const char*)(mg)->mg_ptr)
 #endif
+/* this will be a patched copy of PL_vtbl_sigelem */
+static MGVTBL coro_sigelem_vtbl;
+static int ecb_cold
+coro_sig_copy (pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, I32 namlen)
+{
+  char *key = SvPV_nolen ((SV *)name);
+  /* do what mg_copy normally does */
+  sv_magic (nsv, mg->mg_obj, PERL_MAGIC_sigelem, name, namlen);
+  assert (mg_find (nsv, PERL_MAGIC_sigelem)->mg_virtual == &PL_vtbl_sigelem);
+  /* patch sigelem vtbl, but only for __WARN__ and __DIE__ */
+  if (*key == '_'
+      && (strEQ (key, "__DIE__")
+          || strEQ (key, "__WARN__")))
+    mg_find (nsv, PERL_MAGIC_sigelem)->mg_virtual = &coro_sigelem_vtbl;
+  return 1;
+}
+/* perl does not have a %SIG vtbl, we provide one so we can override */
+/* the magic vtbl for the __DIE__ and __WARN__ members */
+static const MGVTBL coro_sig_vtbl = {
+  0, 0, 0, 0, 0,
+  coro_sig_copy
+};
 /*
  * 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 (extremely slow),
  */
 static int ecb_cold
 coro_sigelem_get (pTHX_ SV *sv, MAGIC *mg)
 {
   const char *s = MgPV_nolen_const (mg);
+  /* the key must be either __DIE__ or __WARN__ here */
+  SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook;
-  if (*s == '_')
+  SV *ssv;
-    {
-      SV **svp = 0;
-      if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
-      if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
-      if (svp)
+  if (!*svp)
-        {
+    ssv = &PL_sv_undef;
-          sv_setsv (sv, *svp ? *svp : &PL_sv_undef);
+  else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
-          return 0;
+    ssv = sv_2mortal (newRV_inc (*svp));
-        }
+  else
-    }
+    ssv = *svp;
-  return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 0;
+  sv_setsv (sv, ssv);
+  return 0;
 }
 static int ecb_cold
 coro_sigelem_clr (pTHX_ SV *sv, MAGIC *mg)
 {
   const char *s = MgPV_nolen_const (mg);
+  /* the key must be either __DIE__ or __WARN__ here */
+  SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook;
-  if (*s == '_')
-    {
-      SV **svp = 0;
-      if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
-      if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
-      if (svp)
-        {
-          SV *old = *svp;
+  SV *old = *svp;
-          *svp = 0;
+  *svp = 0;
-          SvREFCNT_dec (old);
+  SvREFCNT_dec (old);
-          return 0;
+  return 0;
-        }
-    }
-  return orig_sigelem_clr ? orig_sigelem_clr (aTHX_ sv, mg) : 0;
 }
 static int ecb_cold
 coro_sigelem_set (pTHX_ SV *sv, MAGIC *mg)
 {
   const char *s = MgPV_nolen_const (mg);
+  /* the key must be either __DIE__ or __WARN__ here */
+  SV **svp = s[2] == 'D' ? &PL_diehook : &PL_warnhook;
-  if (*s == '_')
-    {
-      SV **svp = 0;
-      if (strEQ (s, "__DIE__" )) svp = &PL_diehook;
-      if (strEQ (s, "__WARN__")) svp = &PL_warnhook;
-      if (svp)
-        {
-          SV *old = *svp;
+  SV *old = *svp;
-          *svp = SvOK (sv) ? newSVsv (sv) : 0;
+  *svp = SvOK (sv) ? newSVsv (sv) : 0;
-          SvREFCNT_dec (old);
+  SvREFCNT_dec (old);
-          return 0;
+  return 0;
-        }
-    }
-  return orig_sigelem_set ? orig_sigelem_set (aTHX_ sv, mg) : 0;
 }
 static void
 prepare_nop (pTHX_ struct coro_transfer_args *ta)
 {
 static int
 slf_check_repeat (pTHX_ struct CoroSLF *frame)
 {
   return 1;
 }
+/** coroutine stack handling ************************************************/
 static UNOP init_perl_op;
 ecb_noinline static void /* noinline to keep it out of the transfer fast path */
 init_perl (pTHX_ struct coro *coro)
   PL_hints      = 0;
   /* 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);
   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;
     myop.op_next  = Nullop;
     myop.op_type  = OP_ENTERSUB;
     myop.op_flags = OPf_WANT_VOID;
     PUSHMARK (SP);
-    PUSHs ((SV *)coro->startcv);
+    XPUSHs ((SV *)coro->startcv);
     PUTBACK;
     PL_op = (OP *)&myop;
     PL_op = PL_ppaddr[OP_ENTERSUB](aTHX);
   }
   PL_op = (OP *)&init_perl_op;
   /* copy throw, in case it was set before init_perl */
   CORO_THROW = coro->except;
-  SWAP_SVS (coro);
+  SWAP_SVS_ENTER (coro);
   if (ecb_expect_false (enable_times))
     {
       coro_times_update ();
       coro_times_sub (coro);
     /* this will cause transfer_check to croak on block*/
     SvRV_set (coro_current, (SV *)coro->hv);
     load_perl (aTHX_ coro);
+    /* restore swapped sv's */
+    SWAP_SVS_LEAVE (coro);
     coro_unwind_stacks (aTHX);
-    /* restore swapped sv's */
-    SWAP_SVS (coro);
     coro_destruct_stacks (aTHX);
     /* now save some sv's to be free'd later */
     svf    [0] =       GvSV (PL_defgv);
     SvREFCNT_dec (coro->saved_deffh);
     SvREFCNT_dec (coro->rouse_cb);
     SvREFCNT_dec (coro->invoke_cb);
     SvREFCNT_dec (coro->invoke_av);
+    SvREFCNT_dec (coro->on_enter_xs);
+    SvREFCNT_dec (coro->on_leave_xs);
   }
 }
 ecb_inline void
 free_coro_mortal (pTHX)
                 av_push (av, SvREFCNT_inc_NN (*bot++));
               PL_runops = RUNOPS_DEFAULT;
               ENTER;
               SAVETMPS;
+              PUSHMARK (SP);
               EXTEND (SP, 3);
-              PUSHMARK (SP);
               PUSHs (&PL_sv_no);
               PUSHs (fullname);
               PUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
               PUTBACK;
               cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 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)
                         {
                             gv_efullname3 (fullname, gv, 0);
                           PL_runops = RUNOPS_DEFAULT;
                           ENTER;
                           SAVETMPS;
+                          PUSHMARK (SP);
                           EXTEND (SP, 3);
-                          PUSHMARK (SP);
                           PUSHs (&PL_sv_yes);
                           PUSHs (fullname);
-                          PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc ((SV *)cx->blk_sub.argarray)) : &PL_sv_undef);
+                          PUSHs (CxHASARGS (cx) ? sv_2mortal (newRV_inc (SUB_ARGARRAY)) : &PL_sv_undef);
                           PUTBACK;
                           cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_sub_cb", sizeof ("_trace_sub_cb") - 1, 0);
                           if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
                           SPAGAIN;
                           FREETMPS;
                       dSP;
                       PL_runops = RUNOPS_DEFAULT;
                       ENTER;
                       SAVETMPS;
-                      EXTEND (SP, 3);
-                      PL_runops = RUNOPS_DEFAULT;
                       PUSHMARK (SP);
+                      EXTEND (SP, 2);
                       PUSHs (sv_2mortal (newSVpv (OutCopFILE (oldcop), 0)));
                       PUSHs (sv_2mortal (newSViv (CopLINE (oldcop))));
                       PUTBACK;
                       cb = hv_fetch ((HV *)SvRV (coro_current), "_trace_line_cb", sizeof ("_trace_line_cb") - 1, 0);
                       if (cb) call_sv (*cb, G_KEEPERR | G_EVAL | G_VOID | G_DISCARD);
 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 ;)
  */
 static void
 cctx_run (void *arg)
      * coro body here, as perl_run destroys these. Likewise, we cannot catch
      * runtime errors here, as this is just a random interpreter, not a thread.
      */
     /*
+     * pp_entersub in 5.24 no longer ENTERs, but perl_destruct
+     * requires PL_scopestack_ix, so do it here if required.
+     */
+    if (!PL_scopestack_ix)
+      ENTER;
+    /*
      * 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 (void)
 static coro_cctx *
 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 (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_READ | PROT_WRITE | PROT_EXEC, 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 */
 }
 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 (ecb_expect_false (cctx_idle >= cctx_max_idle))
     {
       coro_cctx *first = cctx_first;
     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;
           /* 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;
             }
   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));
       /* coro hv's (and only hv's at the moment) are supported as well */
 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 (ecb_expect_false (coro->flags & CF_NOCANCEL))
     {
       /* coro currently busy cancelling something, so just notify it */
       coro->slf_frame.data = (void *)coro;
       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.
 safe_cancel (pTHX_ struct coro *coro, SV **arg, int items)
 {
   if (coro->cctx)
     croak ("coro inside C callback, unable to cancel at this time, caught");
-  if (coro->flags & CF_NEW)
+  if (coro->flags & (CF_NEW | CF_ZOMBIE))
     {
       coro_set_status (aTHX_ coro, arg, items);
       coro_state_destroy (aTHX_ coro);
     }
   else
       else
         {
           av_clear (GvAV (PL_defgv));
           hv_store (hv, "desc", sizeof ("desc") - 1, SvREFCNT_inc_NN (sv_async_pool_idle), 0);
+          if (ecb_expect_false (coro->swap_sv))
+            {
+              SWAP_SVS_LEAVE (coro);
+              SvREFCNT_dec_NN (coro->swap_sv);
+              coro->swap_sv = 0;
+            }
           coro->prio = 0;
-          if (coro->cctx && (coro->cctx->flags & CC_TRACE))
+          if (ecb_expect_false (coro->cctx) && ecb_expect_false (coro->cctx->flags & CC_TRACE))
             api_trace (aTHX_ coro_current, 0);
           frame->prepare = prepare_schedule;
           av_push (av_async_pool, SvREFCNT_inc (hv));
         }
 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
 static void
 coro_pop_on_leave (pTHX_ void *coro)
 {
   SV *cb = coro_avp_pop_and_free (aTHX_ &((struct coro *)coro)->on_leave);
   on_enterleave_call (aTHX_ sv_2mortal (cb));
+}
+static void
+enterleave_hook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, void *arg)
+{
+  if (!hook)
+    return;
+  if (!*avp)
+    {
+      *avp = newAV ();
+      AvREAL_off (*avp);
+    }
+  av_push (*avp, (SV *)hook);
+  av_push (*avp, (SV *)arg);
+}
+static void
+enterleave_unhook_xs (pTHX_ struct coro *coro, AV **avp, coro_enterleave_hook hook, int execute)
+{
+  AV *av = *avp;
+  int i;
+  if (!av)
+    return;
+  for (i = AvFILLp (av) - 1; i >= 0; i -= 2)
+    if (AvARRAY (av)[i] == (SV *)hook)
+      {
+        if (execute)
+          hook (aTHX_ (void *)AvARRAY (av)[i + 1]);
+        memmove (AvARRAY (av) + i, AvARRAY (av) + i + 2, AvFILLp (av) - i - 1);
+        av_pop (av);
+        av_pop (av);
+        break;
+      }
+  if (AvFILLp (av) >= 0)
+    {
+      *avp = 0;
+      SvREFCNT_dec_NN (av);
+    }
+}
+static void
+api_enterleave_hook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
+{
+  struct coro *coro = SvSTATE (coro_sv);
+  if (SvSTATE_current == coro)
+    if (enter)
+      enter (aTHX_ enter_arg);
+  enterleave_hook_xs (aTHX_ coro, &coro->on_enter_xs, enter, enter_arg);
+  enterleave_hook_xs (aTHX_ coro, &coro->on_leave_xs, leave, leave_arg);
+}
+static void
+api_enterleave_unhook (pTHX_ SV *coro_sv, coro_enterleave_hook enter, coro_enterleave_hook leave)
+{
+  struct coro *coro = SvSTATE (coro_sv);
+  enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
+  enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, SvSTATE_current == coro);
+}
+static void
+savedestructor_unhook_enter (pTHX_ coro_enterleave_hook enter)
+{
+  struct coro *coro = SvSTATE_current;
+  enterleave_unhook_xs (aTHX_ coro, &coro->on_enter_xs, enter, 0);
+}
+static void
+savedestructor_unhook_leave (pTHX_ coro_enterleave_hook leave)
+{
+  struct coro *coro = SvSTATE_current;
+  enterleave_unhook_xs (aTHX_ coro, &coro->on_leave_xs, leave, 1);
+}
+static void
+api_enterleave_scope_hook (pTHX_ coro_enterleave_hook enter, void *enter_arg, coro_enterleave_hook leave, void *leave_arg)
+{
+  api_enterleave_hook (aTHX_ coro_current, enter, enter_arg, leave, leave_arg);
+  /* this ought to be much cheaper than malloc + a single destructor call */
+  if (enter) SAVEDESTRUCTOR_X (savedestructor_unhook_enter, enter);
+  if (leave) SAVEDESTRUCTOR_X (savedestructor_unhook_leave, leave);
 }
 /*****************************************************************************/
 /* PerlIO::cede */
           XPUSHs (sv_2mortal (newRV_inc ((SV *)av)));
           PUTBACK;
           call_sv (cb, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
         }
-      SvREFCNT_dec (cb);
+      SvREFCNT_dec_NN (cb);
     }
 }
 static void
 coro_semaphore_destroy (pTHX_ struct CoroSLF *frame)
 {
   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);
         {
           api_ready (aTHX_ cb);
           sv_setiv (cb, 0); /* signal waiter */
         }
-      SvREFCNT_dec (cb);
+      SvREFCNT_dec_NN (cb);
       --count;
     }
 }
   }
   av_push (state, data_sv);
   api_ready (aTHX_ coro);
-  SvREFCNT_dec (coro);
+  SvREFCNT_dec_NN (coro);
-  SvREFCNT_dec ((AV *)state);
+  SvREFCNT_dec_NN ((AV *)state);
 }
 static int
 slf_check_aio_req (pTHX_ struct CoroSLF *frame)
 {
   /* 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);
     errno          = data->errorno;
     PL_laststype   = data->laststype;
     PL_laststatval = data->laststatval;
     PL_statcache   = data->statcache;
-    SvREFCNT_dec (data_sv);
+    SvREFCNT_dec_NN (data_sv);
   }
   /* push result values */
   {
     dSP;
   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));
+  #define VARx(name,expr,type) pushav_4uv (aTHX_ (UV)&(expr), sizeof (expr), offsetof (perl_slots, name), sizeof (type));
-# include "state.h"
+  #include "state.h"
-#undef VARx
   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);
+  if (map_base == (char *)MAP_FAILED)
+    map_base = mmap (0, map_len, PROT_READ | PROT_WRITE, 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);
 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;
         cctx_current = cctx_new_empty ();
         irsgv    = gv_fetchpv ("/"     , GV_ADD|GV_NOTQUAL, SVt_PV);
         stdoutgv = gv_fetchpv ("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
-        orig_sigelem_get = PL_vtbl_sigelem.svt_get;   PL_vtbl_sigelem.svt_get   = coro_sigelem_get;
+	{
-        orig_sigelem_set = PL_vtbl_sigelem.svt_set;   PL_vtbl_sigelem.svt_set   = coro_sigelem_set;
+	  /*
-        orig_sigelem_clr = PL_vtbl_sigelem.svt_clear; PL_vtbl_sigelem.svt_clear = coro_sigelem_clr;
+	   * we provide a vtbvl for %SIG magic that replaces PL_vtbl_sig
+	   * by coro_sig_vtbl in hash values.
+	   */
+	  MAGIC *mg = mg_find ((SV *)GvHV (gv_fetchpv ("SIG", GV_ADD | GV_NOTQUAL, SVt_PVHV)), PERL_MAGIC_sig);
+	  /* this only works if perl doesn't have a vtbl for %SIG */
+	  assert (!mg->mg_virtual);
+	  /*
+	   * The irony is that the perl API itself asserts that mg_virtual
+	   * must be non-const, yet perl5porters insisted on marking their
+	   * vtbls as read-only, just to thwart perl modules from patching
+	   * them.
+	   */
+	  mg->mg_virtual = (MGVTBL *)&coro_sig_vtbl;
+	  mg->mg_flags |= MGf_COPY;
+	  coro_sigelem_vtbl = PL_vtbl_sigelem;
+	  coro_sigelem_vtbl.svt_get   = coro_sigelem_get;
+	  coro_sigelem_vtbl.svt_set   = coro_sigelem_set;
+	  coro_sigelem_vtbl.svt_clear = coro_sigelem_clr;
+	}
-        hv_sig      = coro_get_hv (aTHX_ "SIG", TRUE);
         rv_diehook  = newRV_inc ((SV *)gv_fetchpv ("Coro::State::diehook" , 0, SVt_PVCV));
         rv_warnhook = newRV_inc ((SV *)gv_fetchpv ("Coro::State::warnhook", 0, SVt_PVCV));
 	coro_state_stash = gv_stashpv ("Coro::State", TRUE);
 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 (ecb_expect_false (current == self))
           {
             coro_times_update ();
             coro_times_add (SvSTATE (coro_current));
         if (ecb_expect_false (current == self))
           coro_times_sub (SvSTATE (coro_current));
 }
 void
-swap_sv (Coro::State coro, SV *sv, SV *swapsv)
+swap_sv (Coro::State coro, SV *sva, SV *svb)
 	CODE:
 {
         struct coro *current = SvSTATE_current;
+        AV *swap_sv;
+        int i;
+        sva = SvRV (sva);
+        svb = SvRV (svb);
         if (current == coro)
-          SWAP_SVS (current);
+          SWAP_SVS_LEAVE (current);
         if (!coro->swap_sv)
           coro->swap_sv = newAV ();
+        swap_sv = coro->swap_sv;
+        for (i = AvFILLp (swap_sv) - 1; i >= 0; i -= 2)
+          {
+            SV *a = AvARRAY (swap_sv)[i    ];
+            SV *b = AvARRAY (swap_sv)[i + 1];
+            if (a == sva && b == svb)
+              {
+                SvREFCNT_dec_NN (a);
+                SvREFCNT_dec_NN (b);
+                for (; i <= AvFILLp (swap_sv) - 2; i++)
+                  AvARRAY (swap_sv)[i] = AvARRAY (swap_sv)[i + 2];
+                AvFILLp (swap_sv) -= 2;
+                goto removed;
+              }
+          }
-        av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (sv    )));
+        av_push (swap_sv, SvREFCNT_inc_NN (sva));
-        av_push (coro->swap_sv, SvREFCNT_inc_NN (SvRV (swapsv)));
+        av_push (swap_sv, SvREFCNT_inc_NN (svb));
+	removed:
         if (current == coro)
-          SWAP_SVS (current);
+          SWAP_SVS_ENTER (current);
 }
 MODULE = Coro::State                PACKAGE = Coro
 BOOT:
 {
+	if (SVt_LAST > 32)
+          croak ("Coro internal error: SVt_LAST > 32, swap_sv might need adjustment");
         sv_pool_rss        = coro_get_sv (aTHX_ "Coro::POOL_RSS"  , TRUE);
         sv_pool_size       = coro_get_sv (aTHX_ "Coro::POOL_SIZE" , TRUE);
         cv_coro_run        =      get_cv (      "Coro::_coro_run" , GV_ADD);
         coro_current       = coro_get_sv (aTHX_ "Coro::current"   , FALSE); SvREADONLY_on (coro_current);
         av_async_pool      = coro_get_av (aTHX_ "Coro::async_pool", TRUE);
         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));
           coroapi.ready        = api_ready;
           coroapi.is_ready     = api_is_ready;
           coroapi.nready       = coro_nready;
           coroapi.current      = coro_current;
+          coroapi.enterleave_hook       = api_enterleave_hook;
+          coroapi.enterleave_unhook     = api_enterleave_unhook;
+          coroapi.enterleave_scope_hook = api_enterleave_scope_hook;
           /*GCoroAPI = &coroapi;*/
-          sv_setiv (sv, (IV)&coroapi);
+          sv_setiv (sv, PTR2IV (&coroapi));
           SvREADONLY_on (sv);
         }
 }
 SV *
 void
 _set_current (SV *current)
         PROTOTYPE: $
 	CODE:
-        SvREFCNT_dec (SvRV (coro_current));
+        SvREFCNT_dec_NN (SvRV (coro_current));
         SvRV_set (coro_current, SvREFCNT_inc_NN (SvRV (current)));
 void
 _set_readyhook (SV *hook)
 	PROTOTYPE: $
         if ((SV *)hv == &PL_sv_undef)
           {
             SV *sv = coro_new (aTHX_ coro_stash, (SV **)&cv_pool_handler, 1, 1);
             hv = (HV *)SvREFCNT_inc_NN (SvRV (sv));
-            SvREFCNT_dec (sv);
+            SvREFCNT_dec_NN (sv);
           }
         {
           struct coro *coro = SvSTATE_hv (hv);
         api_ready (aTHX_ (SV *)hv);
         if (GIMME_V != G_VOID)
           XPUSHs (sv_2mortal (newRV_noinc ((SV *)hv)));
         else
-          SvREFCNT_dec (hv);
+          SvREFCNT_dec_NN (hv);
 }
 SV *
 rouse_cb ()
         PROTOTYPE:
         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);
         RETVAL = newSVsv (AvARRAY ((AV *)SvRV (self))[0]);
 	OUTPUT:
         RETVAL
 void
-up (SV *self, int adjust = 1)
+up (SV *self)
-	ALIAS:
-        adjust = 1
         CODE:
+        coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), 1);
+void
+adjust (SV *self, int adjust)
+        CODE:
-        coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), ix ? adjust : 1);
+        coro_semaphore_adjust (aTHX_ (AV *)SvRV (self), adjust);
 void
 down (...)
         CODE:
         CORO_EXECUTE_SLF_XS (slf_init_semaphore_down);
           XSRETURN_NO;
 }
 void
 waiters (SV *self)
-    	PPCODE:
+	PPCODE:
 {
         AV *av = (AV *)SvRV (self);
         int wcount = AvFILLp (av) + 1 - 1;
         if (GIMME_V == G_SCALAR)
 void
 _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.414 by root, Wed Jun 29 16:08:31 2011 UTC vs. Revision 1.473 by root, Sun Sep 3 23:36:01 2017 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.414 by root, Wed Jun 29 16:08:31 2011 UTC vs.
Revision 1.473 by root, Sun Sep 3 23:36:01 2017 UTC