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

Comparing Coro/Coro/State.xs (file contents):
Revision 1.457 by root, Fri Jun 17 04:49:22 2016 UTC vs.
Revision 1.472 by root, Thu Aug 31 16:24:19 2017 UTC

 #  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 void
 swap_svs_enter (pTHX_ Coro__State c)
 {
   int i;
+  for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
+    swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
+}
+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]);
-}
-static void
-swap_svs_leave (pTHX_ Coro__State c)
-{
-  int i;
-  for (i = 0; i <= AvFILLp (c->swap_sv); i += 2)
     swap_sv (AvARRAY (c->swap_sv)[i], AvARRAY (c->swap_sv)[i + 1]);
 }
 #define SWAP_SVS_ENTER(coro)			\
   if (ecb_expect_false ((coro)->swap_sv))	\
 #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)
-        {
-          SV *ssv;
-          if (!*svp)
-            ssv = &PL_sv_undef;
+    ssv = &PL_sv_undef;
-          else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
+  else if (SvTYPE (*svp) == SVt_PVCV) /* perlio directly stores a CV in warnhook. ugh. */
-            ssv = sv_2mortal (newRV_inc (*svp));
+    ssv = sv_2mortal (newRV_inc (*svp));
-          else
+  else
-            ssv = *svp;
+    ssv = *svp;
-          sv_setsv (sv, ssv);
+  sv_setsv (sv, ssv);
-          return 0;
+  return 0;
-        }
-    }
-  return orig_sigelem_get ? orig_sigelem_get (aTHX_ sv, mg) : 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)
                           SAVETMPS;
                           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;
      * 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 mimic whatever perl is normally
      * doing in that case. YMMV.
      */
 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));
         }
   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);
         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;
+	}
         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);
           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 *

Diff Legend

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

Comparing Coro/Coro/State.xs (file contents): Revision 1.457 by root, Fri Jun 17 04:49:22 2016 UTC vs. Revision 1.472 by root, Thu Aug 31 16:24:19 2017 UTC

Diff Legend

Comparing Coro/Coro/State.xs (file contents):
Revision 1.457 by root, Fri Jun 17 04:49:22 2016 UTC vs.
Revision 1.472 by root, Thu Aug 31 16:24:19 2017 UTC