This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
op.c: Stop copying constants under ithreads
authorFather Chrysostomos <sprout@cpan.org>
Wed, 19 Jun 2013 03:34:21 +0000 (20:34 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Fri, 26 Jul 2013 06:47:59 +0000 (23:47 -0700)
This fixes bugs #21979, #89188, #109746, #114838 and #115388 and
mostly fixes #109744 and #105906 (other issues still remain in those
two tickets).

Because the PADTMP flag was doing double duty, indicating that a
pad slot was in use in addition to indicating a target, constants
could not be shared between pad slots, as freeing one const op (and
turning of its PADTMP flag in pad_free) would mark some other pad
slot as free.

I believe this may have been fixed already by change 3b1c21fabed,
which made const ops use pad_swipe (which removes the SV from the
pad) instead of pad_free (which marks it as available for reuse).  But
the copying still happens.

In any case, as of the previous commit, whether a pad slot for a con-
stant is in use is now stored in the pad name.  Slots in use for const
ops now have &PL_sv_no names.

So there is no longer any reason to copy the constants.

The difference can be observed thus:

Before:

$ ./perl -lIlib -MDevel::Peek -e 'sub foo(){42} Dump foo; Dump foo'
SV = IV(0x7f94ea02ef10) at 0x7f94ea02ef20
  REFCNT = 2
  FLAGS = (PADTMP,IOK,READONLY,pIOK)
  IV = 42
SV = IV(0x7f94ea02eeb0) at 0x7f94ea02eec0
  REFCNT = 1
  FLAGS = (PADTMP,IOK,READONLY,pIOK)
  IV = 42

After:

$ ./perl -lIlib -MDevel::Peek -e 'sub foo(){42} Dump foo; Dump foo'
SV = IV(0x7f894882ef10) at 0x7f894882ef20
  REFCNT = 3
  FLAGS = (IOK,READONLY,pIOK)
  IV = 42
SV = IV(0x7f894882ef10) at 0x7f894882ef20
  REFCNT = 3
  FLAGS = (IOK,READONLY,pIOK)
  IV = 42

Notice the different addresses.

There are still special cases for copying &PL_sv_undef, which I need
to tackle.

Since most constants created by â€˜use constant’ have the PADMY flag on
(since they reside in lexical variables inside constant.pm) and PADMY
and PADTMP are exclusive, I have stop turning on PADTMP for constants.
It is no longer necessary now, since before its purpose was to mark
pad entries as being in use.  That means many to-do tests pass.

dist/constant/t/constant.t
ext/B/t/OptreeCheck.pm
ext/B/t/optree_constants.t
op.c
pad.c
t/op/not.t
t/op/ref.t

index 6b2ac27..d39c05a 100644 (file)
@@ -363,7 +363,6 @@ eval q{
        local $TODO;
        if ($Config::Config{useithreads}) {
            skip "fails under threads", 1 if $] < 5.019001;
-           $TODO = ' ';
        }
        like $@, qr/^Modification of a read-only value attempted at /,
            '... and immutable through refgen, too';
@@ -387,7 +386,6 @@ SKIP: {
     local $TODO;
     if ($Config::Config{useithreads}) {
        skip "fails under threads", 1 if $] < 5.019001;
-       $TODO = ' ';
     }
     like $@, qr/^Modification of a read-only value attempted at /,
        '... and immutable through refgen, too';
index 4552313..547f017 100644 (file)
@@ -213,7 +213,8 @@ They're both required, and the correct one is selected for the platform
 being tested, and saved into the synthesized property B<wanted>.
 
 Individual sample lines may be suffixed with whitespace followed
-by (<|<=|==|>=|>)5.nnnn to select that line only for the listed perl
+by (<|<=|==|>=|>)5.nnnn (up to two times) to
+select that line only for the listed perl
 version; the whitespace and conditional are stripped.
 
 =head2 bcopts => $bcopts || [ @bcopts ]
@@ -641,9 +642,10 @@ sub mkCheckRex {
 
     # strip out conditional lines
 
-    $str =~ s{^(.*?)\s+(<|<=|==|>=|>)\s*(5\.\d+)\ *\n}
+    $str =~ s{^(.*?)   \s+(<|<=|==|>=|>)\s*(5\.\d+)
+                   (?:\s+(<|<=|==|>=|>)\s*(5\.\d+))? \ *\n}
      {
-       my ($line, $cmp, $version) = ($1,$2,$3);
+       my ($line, $cmp, $version, $cmp2, $v2) = ($1,$2,$3,$4,$5,$6);
        my $repl = "";
        if (  $cmp eq '<'  ? $] <  $version
            : $cmp eq '<=' ? $] <= $version
@@ -651,11 +653,19 @@ sub mkCheckRex {
            : $cmp eq '>=' ? $] >= $version
            : $cmp eq '>'  ? $] >  $version
            : die("bad comparision '$cmp' in string [$str]\n")
+        and !$cmp2 || (
+             $cmp2 eq '<'  ? $] <  $v2
+           : $cmp2 eq '<=' ? $] <= $v2
+           : $cmp2 eq '==' ? $] == $v2
+           : $cmp2 eq '>=' ? $] >= $v2
+           : $cmp2 eq '>'  ? $] >  $v2
+           : die("bad comparision '$cmp2' in string [$str]\n")
+         )
        ) {
            $repl = "$line\n";
        }
        $repl;
-     }gem;
+     }gemx;
 
     $tc->{wantstr} = $str;
 
index bfd355e..d08c6be 100644 (file)
@@ -348,7 +348,8 @@ checkOptree ( name  => 'lc*,uc*,gt,lt,ge,le,cmp',
 # n           <$> const[PV "b-cmp-a"] s ->o
 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
 # q        <$> const[PVNV 0] s/SHORT ->r      < 5.017002
-# q        <$> const[PVNV 0] s/FOLD,SHORT ->r >=5.017002
+# q        <$> const[PVNV 0] s/FOLD,SHORT ->r >=5.017002 < 5.019001
+# q        <$> const[SPECIAL sv_no] s/FOLD,SHORT ->r >=5.019001
 EOT_EOT
 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->r
diff --git a/op.c b/op.c
index bc62048..f7cfe39 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1752,16 +1752,7 @@ S_finalize_op(pTHX_ OP* o)
         * for reference counts, sv_upgrade() etc. */
        if (cSVOPo->op_sv) {
            const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
-           if (o->op_type != OP_METHOD_NAMED &&
-               (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
-           {
-               /* If op_sv is already a PADTMP/MY then it is being used by
-                * some pad, so make a copy. */
-               sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
-               if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
-               SvREFCNT_dec(cSVOPo->op_sv);
-           }
-           else if (o->op_type != OP_METHOD_NAMED
+           if (o->op_type != OP_METHOD_NAMED
                && cSVOPo->op_sv == &PL_sv_undef) {
                /* PL_sv_undef is hack - it's unsafe to store it in the
                   AV that is the pad, because av_fetch treats values of
@@ -1775,7 +1766,6 @@ S_finalize_op(pTHX_ OP* o)
            }
            else {
                SvREFCNT_dec(PAD_SVl(ix));
-               SvPADTMP_on(cSVOPo->op_sv);
                PAD_SETSV(ix, cSVOPo->op_sv);
                /* XXX I don't know how this isn't readonly already. */
                if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
diff --git a/pad.c b/pad.c
index 3586b64..8e7c47c 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1638,7 +1638,7 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
                "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
                PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
 
-    if (PL_curpad[po])
+    if (PL_curpad[po] && !SvPADMY(PL_curpad[po]))
        SvPADTMP_off(PL_curpad[po]);
     if (refadjust)
        SvREFCNT_dec(PL_curpad[po]);
index e82f627..54de3b0 100644 (file)
@@ -88,6 +88,5 @@ for (!1) { eval { $_ = 43 } }
 like $@, qr/^Modification of a read-only value attempted at /,
    'not 1 is read-only';
 require Config;
-$::TODO = 'not fixed yet' if $Config::Config{useithreads};;
 is \!0, \$yes, '!0 returns the same value each time [perl #114838]';
 is \!1, \$no,  '!1 returns the same value each time [perl #114838]';
index acd278e..a6564ce 100644 (file)
@@ -793,7 +793,6 @@ for (3) {
     like $@, qr/^Modification of a read-only/,
        'assignment to value aliased to literal number';
     require Config;
-    local $::TODO = " " if $Config::Config{useithreads};
     eval { ${\$_} = 4 };
     like $@, qr/^Modification of a read-only/,
        'refgen does not allow assignment to value aliased to literal number';
@@ -803,14 +802,11 @@ for ("4eounthouonth") {
     like $@, qr/^Modification of a read-only/,
        'assignment to value aliased to literal string';
     require Config;
-    local $::TODO = " " if $Config::Config{useithreads};
     eval { ${\$_} = 4 };
     like $@, qr/^Modification of a read-only/,
        'refgen does not allow assignment to value aliased to literal string';
 }
 {
-    local $::TODO = ' '
-       if $Config::Config{useithreads} && $Config::Config{mad};
     my $aref = \123;
     is \$$aref, $aref,
        '[perl #109746] referential identity of \literal under threads+mad'