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.

9 files changed, 72 insertions, 9 deletions

diff --git a/MANIFEST b/MANIFEST
index 66ba5df29d..c620292753 100644
--- 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 c624218078..6662baaada 100644
--- 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 9a8cfb693e..f1cdc0a3d0 100644
--- 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 8117fd9f80..142c75e131 100644
--- 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 c60e623276..d610d309e2 100644
--- 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 36dc00384d..738324809b 100644
--- 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 d9e5b9bed7..e01bc8b761 100644
--- 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 c051a7806f..5ea70fa81b 100644
--- 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
index 0000000000..6a9fa4d5fb
--- /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";
+}