Fix problems with -Dr during global destruction

$ cat foo
my $x = '(?{1})';
BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
"a" =~ /a$_/ for $x;

If I run this under PERL_DESTRUCT_LEVEL=2 with the -Dr flag on a non-
threaded build, the output ends with this:

 during global destruction.
 during global destruction.
 during global destruction.
 during global destruction.
 during global destruction.
Attempt to free temp prematurely: SV 0x822610 during global destruction.
Attempt to free temp prematurely: SV 0x802340 during global destruction.
Attempt to free temp prematurely: SV 0x8222d0 during global destruction.
Attempt to free temp prematurely: SV 0x822490 during global destruction.
Attempt to free temp prematurely: SV 0x8224f0 during global destruction.
Scalars leaked: 5

And sometimes I even get assertion failures.  (I suspect hash random-
isation gives me the inconsistent results.)

t/re/recompile.t happened to trigger this bug, producing noisy output.
Since the assertion failures were in sub-processes, the tests passed
anyway.  In this commit I have changed the test to check the status of
the sub-processes, too, before reporting a pass.

This bug appears to have started happening in v5.17.0-424-gd24ca0c,
but I don’t know why.  I suspect it was a latent bug waiting
to happen.

During global destruction, all objects are freed, the main stash is
freed, and then various SVs in interpreter variables are also freed.
Finally, if PERL_DESTRUCT_LEVEL is set, there is one last sweep of all
remaining SVs.  It is during that sweep that this bug occurs.

When the -Dr flag is present, freeing a regular expression causes the
${^RE_DEBUG_FLAGS} flags variable to be looked up.

Symbol lookup can trigger the ‘Global symbol requires package name’
error (which becomes a warning here, due to the way pp_ctl.c:qerror
works).  The code that produces that error assumes that if there is
no stash then the preceding code has detected an attempted stricture
violation.

The preceding code actually tries to provide PL_defstash (aka %main::)
as the stash to look in, since this is a punctuation variable.  But
PL_defstash has been set to null.

The logic that no stash equals a stricture violation is there-
fore faulty.

The attempt to output that error message uses a temporary scalar which
is placed on the mortals stack.  Freeing of the items on the mortals
stack happens before this SV sweep, and not during or afterwards, so
the SV sweep ends up trying to free those mortals itself.  There is a
check in sv_free2, enabled under debugging builds, to see whether the
SV is on the mortals stacking.  If it is, a warning is emitted and the
SV is not freed.

My initial attempt at fixing this was to try to avoid putting a mortal
on the stack in this case.  The code in question doesn’t actually need
to use the mortals stack, since Perl_mess isn’t going to croak, so it
can free the SV itself.  That takes care of the ‘Attempt to free temp
prematurely’ warnings and the final ‘Scalars leaked’.  It doesn’t
solve the ‘during global destruction’ message, but I decided to leave
it in place anyway, since creating an SV and freeing it is a little
more efficient that creating it, pushing it on to the mortals stack,
and having FREETMPS free it later.

That ‘during global destruction’ message is supposed to say ‘Global
symbol...’, but diagnostic messages during global destruction use the
same SV, so it’s not suprising that it gets stomped on before it makes
its way to qerror.  I’m not sure where it gets stomped on, but it’s
not relevant; we need to get rid of the message altogether.

The final solution is to skip the ‘Global symbol...’ error altogether
while sv_clean_all (the final SV sweep) is being called, which we can
detect based on whether PL_in_clean_all is set.

diff --git a/gv.c b/gv.c
index 6d36a1f..c1618c2 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1588,14 +1588,16 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     /* By this point we should have a stash and a name */
 
     if (!stash) {
-       if (add) {
+       if (add && !PL_in_clean_all) {
+           SV * const namesv = newSVpvn_flags(name, len, is_utf8);
            SV * const err = Perl_mess(aTHX_
                 "Global symbol \"%s%"SVf"\" requires explicit package name",
                 (sv_type == SVt_PV ? "$"
                  : sv_type == SVt_PVAV ? "@"
                  : sv_type == SVt_PVHV ? "%"
-                 : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
+                 : ""), SVfARG(namesv));
            GV *gv;
+           SvREFCNT_dec_NN(namesv);
            if (USE_UTF8_IN_NAMES)
                SvUTF8_on(err);
            qerror(err);

diff --git a/t/re/recompile.t b/t/re/recompile.t
index 785dcdb..ad00df8 100644 (file)
--- a/t/re/recompile.t
+++ b/t/re/recompile.t
@@ -61,7 +61,7 @@ sub _comp_n {
     my $status = $?;
 
     my $count = () = $results =~ /Final program:/g;
-    if ($count == $n) {
+    if ($count == $n && !$status) {
        pass($desc);
     }
     else {