From 987c96916e35a543383e96eebb4ef8b2c8ef66d0 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sat, 11 Oct 2014 01:21:12 -0700 Subject: Fold join to const or stringify where possible MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- MANIFEST | 1 + lib/B/Deparse-core.t | 4 ++-- op.c | 27 +++++++++++++++++++++++++-- opcode.h | 2 +- regen/opcodes | 2 +- sv.c | 6 +++++- t/lib/warnings/9uninit | 1 - t/lib/warnings/op | 2 +- t/op/opt.t | 36 ++++++++++++++++++++++++++++++++++++ 9 files changed, 72 insertions(+), 9 deletions(-) create mode 100644 t/op/opt.t 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"; +} -- cgit v1.2.1