Stop renamed packages from making reset() crash

This only affected threaded builds.  I think the comments in the added
test explain well enough what was happening.

The solution is to store a stashpad offset in the pmop, instead of the
name of the stash.  This is similar to what was done with cop stashes
in d4d03940c58a.

Not only does this fix the crash, but it also makes compilation faster
and saves memory (no separate malloc for every m?pat?).

I had to move Safefree(PL_stashpad) later on in perl_destruct, because
freeing a pmop causes the PL_stashpad to be accessed, and pmops can be
freed during sv_clean_all.  Its previous location was not a problem
for cops, as PL_stashpad[cop->cop_stashoff] is only accessed when
PL_curcop==that_cop and Perl code is running, not when cops are freed.

diff --git a/embed.fnc b/embed.fnc
index e7ac5f1..3dea370 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1761,11 +1761,7 @@ s        |void   |unwind_handler_stack|NULLOK const void *p
 #if defined(PERL_IN_OP_C)
 sRn    |bool   |is_handle_constructor|NN const OP *o|I32 numargs
 sR     |I32    |is_list_assignment|NULLOK const OP *o
-#  ifdef USE_ITHREADS
-so     |void   |forget_pmop    |NN PMOP *const o|U32 flags
-#  else
-so     |void   |forget_pmop    |NN PMOP *const o
-#  endif
+s      |void   |forget_pmop    |NN PMOP *const o
 s      |void   |find_and_forget_pmops  |NN OP *o
 s      |void   |cop_free       |NN COP *cop
 s      |OP*    |modkids        |NULLOK OP *o|I32 type

diff --git a/embed.h b/embed.h
index da45a43..25bd724 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1401,6 +1401,7 @@
 #define find_and_forget_pmops(a)       S_find_and_forget_pmops(aTHX_ a)
 #define fold_constants(a)      S_fold_constants(aTHX_ a)
 #define force_list(a)          S_force_list(aTHX_ a)
+#define forget_pmop(a)         S_forget_pmop(aTHX_ a)
 #define gen_constant_list(a)   S_gen_constant_list(aTHX_ a)
 #define gv_ename(a)            S_gv_ename(aTHX_ a)
 #define inplace_aassign(a)     S_inplace_aassign(aTHX_ a)

diff --git a/op.c b/op.c
index 15930b6..766ca19 100644 (file)
--- a/op.c
+++ b/op.c
@@ -654,12 +654,6 @@ S_op_destroy(pTHX_ OP *o)
     FreeOp(o);
 }
 
-#ifdef USE_ITHREADS
-#  define forget_pmop(a,b)     S_forget_pmop(aTHX_ a,b)
-#else
-#  define forget_pmop(a,b)     S_forget_pmop(aTHX_ a)
-#endif
-
 /* Destructor */
 
 void
@@ -877,7 +871,7 @@ clear_pmop:
        if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
            op_free(cPMOPo->op_code_list);
        cPMOPo->op_code_list = NULL;
-       forget_pmop(cPMOPo, 1);
+       forget_pmop(cPMOPo);
        cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
         /* we use the same protection as the "SAFE" version of the PM_ macros
          * here since sv_clean_all might release some PMOPs
@@ -920,9 +914,6 @@ S_cop_free(pTHX_ COP* cop)
 
 STATIC void
 S_forget_pmop(pTHX_ PMOP *const o
-#ifdef USE_ITHREADS
-             , U32 flags
-#endif
              )
 {
     HV * const pmstash = PmopSTASH(o);
@@ -955,10 +946,6 @@ S_forget_pmop(pTHX_ PMOP *const o
     }
     if (PL_curpm == o) 
        PL_curpm = NULL;
-#ifdef USE_ITHREADS
-    if (flags)
-       PmopSTASH_free(o);
-#endif
 }
 
 STATIC void
@@ -974,7 +961,7 @@ S_find_and_forget_pmops(pTHX_ OP *o)
            case OP_PUSHRE:
            case OP_MATCH:
            case OP_QR:
-               forget_pmop((PMOP*)kid, 0);
+               forget_pmop((PMOP*)kid);
            }
            find_and_forget_pmops(kid);
            kid = kid->op_sibling;

diff --git a/op.h b/op.h
index 97228b1..c1800df 100644 (file)
--- a/op.h
+++ b/op.h
@@ -371,10 +371,7 @@ struct pmop {
     union {
        OP *    op_pmreplstart; /* Only used in OP_SUBST */
 #ifdef USE_ITHREADS
-       struct {
-            char *     op_pmstashpv;   /* Only used in OP_MATCH, with PMf_ONCE set */
-            U32     op_pmstashflags;  /* currently only SVf_UTF8 or 0 */
-        } op_pmstashthr;
+       PADOFFSET op_pmstashoff; /* Only used in OP_MATCH, with PMf_ONCE set */
 #else
        HV *    op_pmstash;
 #endif
@@ -454,30 +451,13 @@ struct pmop {
 
 #ifdef USE_ITHREADS
 
-#  define PmopSTASHPV(o)                                               \
-    (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv : NULL)
-#  if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-#    define PmopSTASHPV_set(o,pv)      ({                              \
-       assert((o)->op_pmflags & PMf_ONCE);                             \
-       ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv = savesharedpv(pv));  \
-    })
-#  else
-#    define PmopSTASHPV_set(o,pv)                                      \
-    ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv = savesharedpv(pv))
-#  endif
-#  define PmopSTASH_flags(o)           ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashflags)
-#  define PmopSTASH_flags_set(o,flags) ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashflags = flags)
-#  define PmopSTASH(o)         (PmopSTASHPV(o)                                     \
-                                ? gv_stashpv((o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv,   \
-                                            GV_ADD | PmopSTASH_flags(o)) : NULL)
-#  define PmopSTASH_set(o,hv)  (PmopSTASHPV_set(o, (hv) ? HvNAME_get(hv) : NULL), \
-                                PmopSTASH_flags_set(o,                            \
-                                            ((hv) && HvNAME_HEK(hv) &&           \
-                                                        HvNAMEUTF8(hv))           \
-                                                ? SVf_UTF8                        \
-                                                : 0))
-#  define PmopSTASH_free(o)    PerlMemShared_free(PmopSTASHPV(o))
-
+#  define PmopSTASH(o)         ((o)->op_pmflags & PMf_ONCE                         \
+                                ? PL_stashpad[(o)->op_pmstashstartu.op_pmstashoff]   \
+                                : NULL)
+#  define PmopSTASH_set(o,hv)  \
+       (assert_((o)->op_pmflags & PMf_ONCE)                            \
+        (o)->op_pmstashstartu.op_pmstashoff =                          \
+           (hv) ? alloccopstash(hv) : NULL)
 #else
 #  define PmopSTASH(o)                                                 \
     (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstash : NULL)
@@ -489,13 +469,10 @@ struct pmop {
 #  else
 #    define PmopSTASH_set(o,hv)        ((o)->op_pmstashstartu.op_pmstash = (hv))
 #  endif
-#  define PmopSTASHPV(o)       (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : NULL)
-   /* op_pmstashstartu.op_pmstash is not refcounted */
-#  define PmopSTASHPV_set(o,pv)        PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
-/* Note that if this becomes non-empty, then S_forget_pmop in op.c will need
-   changing */
-#  define PmopSTASH_free(o)    
 #endif
+#define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : NULL)
+   /* op_pmstashstartu.op_pmstash is not refcounted */
+#define PmopSTASHPV_set(o,pv)  PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
 
 struct svop {
     BASEOP

diff --git a/perl.c b/perl.c
index fe71325..a6f9c14 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -845,7 +845,6 @@ perl_destruct(pTHXx)
            ary[i] = &PL_sv_undef;
        }
     }
-    Safefree(PL_stashpad);
 #endif
 
 
@@ -1079,6 +1078,10 @@ perl_destruct(pTHXx)
     while (sv_clean_all() > 2)
        ;
 
+#ifdef USE_ITHREADS
+    Safefree(PL_stashpad); /* must come after sv_clean_all */
+#endif
+
     AvREAL_off(PL_fdpid);              /* no surviving entries */
     SvREFCNT_dec(PL_fdpid);            /* needed in io_close() */
     PL_fdpid = NULL;

diff --git a/proto.h b/proto.h
index 0f19ccd..2351b32 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4846,15 +4846,6 @@ PERL_CALLCONV void       Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop
        assert(idop)
 
 #endif
-#if !(defined(USE_ITHREADS))
-#  if defined(PERL_IN_OP_C)
-STATIC void    S_forget_pmop(pTHX_ PMOP *const o)
-                       __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_FORGET_PMOP   \
-       assert(o)
-
-#  endif
-#endif
 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
 PERL_CALLCONV char*    Perl_my_bzero(char* loc, I32 len)
                        __attribute__nonnull__(1);
@@ -5769,6 +5760,11 @@ STATIC OP*       S_fold_constants(pTHX_ OP *o)
        assert(o)
 
 STATIC OP*     S_force_list(pTHX_ OP* arg);
+STATIC void    S_forget_pmop(pTHX_ PMOP *const o)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORGET_PMOP   \
+       assert(o)
+
 STATIC OP*     S_gen_constant_list(pTHX_ OP* o);
 STATIC SV*     S_gv_ename(pTHX_ GV *gv)
                        __attribute__nonnull__(pTHX_1);
@@ -5901,13 +5897,6 @@ STATIC OP*       S_too_many_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags)
 #define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV \
        assert(o); assert(namesv)
 
-#  if defined(USE_ITHREADS)
-STATIC void    S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
-                       __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_FORGET_PMOP   \
-       assert(o)
-
-#  endif
 #endif
 #if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
 PERL_CALLCONV void     Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, SV * const *new_const_svp)

diff --git a/t/op/reset.t b/t/op/reset.t
index f9ebeee..291bc39 100644 (file)
--- a/t/op/reset.t
+++ b/t/op/reset.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 use strict;
 
-plan tests => 29;
+plan tests => 30;
 
 package aiieee;
 
@@ -103,6 +103,23 @@ is join("-", $scratch::a//'u', do { no strict; ${"scratch::\0foo"} }//'u'),
    "u-u",
    'reset "\0char"';
 
+# This used to crash under threaded builds, because pmops were remembering
+# their stashes by name, rather than by pointer.
+fresh_perl_is( # it crashes more reliably with a smaller script
+  'package bar;
+   sub foo {
+     m??;
+     BEGIN { *baz:: = *bar::; *bar:: = *foo:: }
+     # The name "bar" no langer refers to the same package
+   }
+   undef &foo; # so freeing the op does not remove it from the stash’s list
+   $_ = "";
+   push @_, ($_) x 10000;  # and its memory is scribbled over
+   reset;  # so reset on the original package tries to reset an invalid op
+   print "ok\n";',
+  "ok\n", {},
+  "no crash if package is effectively renamed before op is freed");
+
 
 undef $/;
 my $prog = <DATA>;