Fold join to const or stringify where possible

Due to the exigencies of the implementation, "$_->$*" ends up with a
join op (join $", $$_), which is unnecessary.  This gave me the idea
of folding it where possible (instead of trying to tackle it in
toke.c), which would also make explicit joins benefit, too.

If the arguments are a simple scalar or constant followed by a
single-item list, then the join can become a stringify, and the sepa-
rator can simply disappear.

Further (and this is unrelated to "$_->$*"), if all of join’s argu-
ments are constant, the whole thing can be folded to a const op.

diff --git a/MANIFEST b/MANIFEST
index 66ba5df..c620292 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5150,6 +5150,7 @@ t/op/negate.t                     See if unary minus works
 t/op/not.t                     See if not works
 t/op/numconvert.t              See if accessing fields does not change numeric values
 t/op/oct.t                     See if oct and hex work
+t/op/opt.t                     Test presence of some op optimisations
 t/op/ord.t                     See if ord works
 t/op/or.t                      See if || works in weird situations
 t/op/overload_integer.t                See if overload::constant for integer works after "use".

diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t
index c624218..6662baa 100644 (file)
--- a/lib/B/Deparse-core.t
+++ b/lib/B/Deparse-core.t
@@ -36,7 +36,7 @@ BEGIN {
 
 use strict;
 use Test::More;
-plan tests => 4018;
+plan tests => 4006;
 
 use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
                                     # logic to add CORE::
@@ -522,7 +522,7 @@ hex              01    $
 index            23    p
 int              01    $
 ioctl            3     p
-join             123   p
+join             13    p
 keys             1     - # also tested specially
 kill             123   p
 # last handled specially

diff --git a/op.c b/op.c
index 9a8cfb6..f1cdc0a 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3872,6 +3872,7 @@ S_fold_constants(pTHX_ OP *o)
     OP * VOL curop;
     OP *newop;
     VOL I32 type = o->op_type;
+    bool folded;
     SV * VOL sv = NULL;
     int ret = 0;
     I32 oldscope;
@@ -4018,6 +4019,7 @@ S_fold_constants(pTHX_ OP *o)
     if (ret)
        goto nope;
 
+    folded = o->op_folded;
     op_free(o);
     assert(sv);
     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
@@ -4030,7 +4032,11 @@ S_fold_constants(pTHX_ OP *o)
     else
     {
        newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
-       if (type != OP_STRINGIFY) newop->op_folded = 1;
+       /* OP_STRINGIFY and constant folding are used to implement qq.
+          Here the constant folding is an implementation detail that we
+          want to hide.  If the stringify op is itself already marked
+          folded, however, then it is actually a folded join.  */
+       if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
     }
     return newop;
 
@@ -10606,7 +10612,7 @@ Perl_ck_split(pTHX_ OP *o)
 OP *
 Perl_ck_join(pTHX_ OP *o)
 {
-    const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
+    OP * const kid = OP_SIBLING(cLISTOPo->op_first);
 
     PERL_ARGS_ASSERT_CK_JOIN;
 
@@ -10622,6 +10628,23 @@ Perl_ck_join(pTHX_ OP *o)
                        SVfARG(msg), SVfARG(msg));
        }
     }
+    if (kid->op_type == OP_CONST  /* an innocent, unsuspicious separator */
+     || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
+     || (kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
+       && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))
+    {
+       const OP * const bairn = OP_SIBLING(kid); /* the list */
+       if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
+        && PL_opargs[bairn->op_type] & OA_RETSCALAR)
+       {
+           OP * const ret = convert(OP_STRINGIFY, 0,
+                                    op_sibling_splice(o, kid, 1, NULL));
+           op_free(o);
+           ret->op_folded = 1;
+           return ret;
+       }
+    }
+
     return ck_fun(o);
 }
 

diff --git a/opcode.h b/opcode.h
index 8117fd9..142c75e 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -1888,7 +1888,7 @@ EXTCONST U32 PL_opargs[] = {
        0x00091480,     /* unpack */
        0x0002140f,     /* pack */
        0x00111408,     /* split */
-       0x0002140d,     /* join */
+       0x0002140f,     /* join */
        0x00002401,     /* list */
        0x00224200,     /* lslice */
        0x00002405,     /* anonlist */

diff --git a/regen/opcodes b/regen/opcodes
index c60e623..d610d30 100644 (file)
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -240,7 +240,7 @@ kvhslice    key/value hash slice    ck_null         m@      H L
 unpack         unpack                  ck_fun          u@      S S?
 pack           pack                    ck_fun          fmst@   S L
 split          split                   ck_split        t@      S S S
-join           join or string          ck_join         mst@    S L
+join           join or string          ck_join         fmst@   S L
 
 # List operators.
 

diff --git a/sv.c b/sv.c
index 36dc003..7383248 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -15743,17 +15743,21 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv)
 {
     if (PL_op) {
        SV* varname = NULL;
+       const char *desc;
        if (uninit_sv && PL_curpad) {
            varname = find_uninit_var(PL_op, uninit_sv,0);
            if (varname)
                sv_insert(varname, 0, 0, " ", 1);
        }
+       desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
+               ? "join or string"
+               : OP_DESC(PL_op);
         /* PL_warn_uninit_sv is constant */
         GCC_DIAG_IGNORE(-Wformat-nonliteral);
        /* diag_listed_as: Use of uninitialized value%s */
        Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
                SVfARG(varname ? varname : &PL_sv_no),
-               " in ", OP_DESC(PL_op));
+               " in ", desc);
         GCC_DIAG_RESTORE;
     }
     else {

diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
index d9e5b9b..e01bc8b 100644 (file)
--- a/t/lib/warnings/9uninit
+++ b/t/lib/warnings/9uninit
@@ -1126,7 +1126,6 @@ Use of uninitialized value $m1 in regexp compilation at - line 8.
 Use of uninitialized value $g1 in split at - line 8.
 Use of uninitialized value $m2 in split at - line 8.
 Use of uninitialized value $m1 in join or string at - line 10.
-Use of uninitialized value $m1 in join or string at - line 11.
 Use of uninitialized value $m2 in join or string at - line 11.
 Use of uninitialized value $m1 in join or string at - line 12.
 Use of uninitialized value $m2 in join or string at - line 12.

diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index c051a78..5ea70fa 100644 (file)
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -387,7 +387,7 @@ $a{0} ;                     # OP_HELEM
 @a{0} ;                        # OP_HSLICE
 unpack "a", "a" ;      # OP_UNPACK
 pack $a,"" ;           # OP_PACK
-join "" ;              # OP_JOIN
+join "", @_ ;          # OP_JOIN
 (@a)[0,1] ;            # OP_LSLICE
                        # OP_ANONLIST
                        # OP_ANONHASH

diff --git a/t/op/opt.t b/t/op/opt.t
new file mode 100644 (file)
index 0000000..6a9fa4d
--- /dev/null
+++ b/t/op/opt.t
@@ -0,0 +1,36 @@
+#!./perl
+
+# Use B to test that optimisations are not inadvertently removed.
+
+BEGIN {
+    chdir 't';
+    require './test.pl';
+    skip_all_if_miniperl("No B under miniperl");
+    @INC = '../lib';
+}
+
+plan 11;
+
+use B 'svref_2object';
+
+for (['CONSTANT', sub {          join "foo", $_ }],
+     ['$var'    , sub {          join  $_  , $_ }],
+     ['$myvar'  , sub { my $var; join  $var, $_ }],
+) {
+    my($sep,$sub) = @$_;
+    my $last_expr = svref_2object($sub)->ROOT->first->last;
+    is $last_expr->name, 'stringify',
+      "join($sep, \$scalar) optimised to stringify";
+}
+
+for (['CONSTANT', sub {          join "foo", "bar"    }, 0, "bar"    ],
+     ['CONSTANT', sub {          join "foo", "bar", 3 }, 1, "barfoo3"],
+     ['$var'    , sub {          join  $_  , "bar"    }, 0, "bar"    ],
+     ['$myvar'  , sub { my $var; join  $var, "bar"    }, 0, "bar"    ],
+) {
+    my($sep,$sub,$is_list,$expect) = @$_;
+    my $last_expr = svref_2object($sub)->ROOT->first->last;
+    my $tn = "join($sep, " . ($is_list?'list of constants':'const') . ")";
+    is $last_expr->name, 'const', "$tn optimised to constant";
+    is $sub->(), $expect, "$tn folded correctly";
+}