t/perf/optree.t

   1 #!./perl
   2
   3 # Use B to test that optimisations are not inadvertently removed,
   4 # by examining particular nodes in the optree.
   5
   6 BEGIN {
   7     chdir 't';
   8     require './test.pl';
   9     skip_all_if_miniperl("No B under miniperl");
  10     @INC = '../lib';
  11 }
  12
  13 plan 59;
  14
  15 use v5.10; # state
  16 use B qw(svref_2object
  17          OPpASSIGN_COMMON_SCALAR
  18          OPpASSIGN_COMMON_RC1
  19          OPpASSIGN_COMMON_AGG
  20       );
  21
  22
  23 # Test that OP_AASSIGN gets the appropriate
  24 # OPpASSIGN_COMMON* flags set.
  25 #
  26 # Too few flags set is likely to cause code to misbehave;
  27 # too many flags set unnecessarily slows things down.
  28 # See also the tests in t/op/aassign.t
  29
  30 for my $test (
  31     # Each anon array contains:
  32     # [
  33     #   expected flags:
  34     #      a 3 char string, each char showing whether we expect a
  35     #      particular flag to be set:
  36     #           '-' indicates any char not set, while
  37     #           'S':  char 0: OPpASSIGN_COMMON_SCALAR,
  38     #           'R':  char 1: OPpASSIGN_COMMON_RC1,
  39     #           'A'   char 2: OPpASSIGN_COMMON_AGG,
  40     #   code to eval,
  41     #   description,
  42     # ]
  43
  44     [ "---", '() = (1, $x, my $y, @z, f($p))', 'no LHS' ],
  45     [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = ()', 'no RHS' ],
  46     [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = (1,2)', 'safe RHS' ],
  47     [ "---", 'my @a = (1,2)', 'safe RHS: my array' ],
  48     [ "---", 'my %h = (1,2)', 'safe RHS: my hash' ],
  49     [ "---", 'my ($a,$b,$c,$d) = 1..6; ($a,$b) = ($c,$d);', 'non-common lex' ],
  50     [ "---", '($x,$y) = (1,2)', 'pkg var LHS only' ],
  51     [ "---", 'my $p; my ($x,$y) = ($p, $p)', 'my; dup lex var on RHS' ],
  52     [ "---", 'my $p; my ($x,$y); ($x,$y) = ($p, $p)', 'dup lex var on RHS' ],
  53     [ "---", 'my ($self) = @_', 'LHS lex scalar only' ],
  54     [ "--A", 'my ($self, @rest) = @_', 'LHS lex mixed' ],
  55     [ "-R-", 'my ($x,$y) = ($p, $q)', 'pkg var RHS only' ],
  56     [ "S--", '($x,$y) = ($p, $q)', 'pkg scalar both sides' ],
  57     [ "--A", 'my (@a, @b); @a = @b', 'lex ary both sides' ],
  58     [ "-R-", 'my ($x,$y,$z,@a); ($x,$y,$z) = @a ', 'lex vars to lex ary' ],
  59     [ "--A", '@a = @b', 'pkg ary both sides' ],
  60     [ "--A", 'my (%a,%b); %a = %b', 'lex hash both sides' ],
  61     [ "--A", '%a = %b', 'pkg hash both sides' ],
  62     [ "--A", 'my $x; @a = ($a[0], $a[$x])', 'common ary' ],
  63     [ "--A", 'my ($x,@a); @a = ($a[0], $a[$x])', 'common lex ary' ],
  64     [ "S-A", 'my $x; ($a[$x], $a[0]) = ($a[0], $a[$x])', 'common ary elems' ],
  65     [ "S-A", 'my ($x,@a); ($a[$x], $a[0]) = ($a[0], $a[$x])',
  66                                                     'common lex ary elems' ],
  67     [ "--A", 'my $x; my @a = @$x', 'lex ary may have stuff' ],
  68     [ "-RA", 'my $x; my ($b, @a) = @$x', 'lex ary may have stuff' ],
  69     [ "--A", 'my $x; my %a = @$x', 'lex hash may have stuff' ],
  70     [ "-RA", 'my $x; my ($b, %a) = @$x', 'lex hash may have stuff' ],
  71     [ "--A", 'my (@a,@b); @a = ($b[0])', 'lex ary and elem' ],
  72     [ "S-A", 'my @a; ($a[1],$a[0]) = @a', 'lex ary and elem' ],
  73     [ "--A", 'my @x; @y = $x[0]', 'pkg ary from lex elem' ],
  74     [ "---", '(undef,$x) = f()', 'single scalar on LHS' ],
  75     [ "---", '($x,$y) = ($x)', 'single scalar on RHS, no AGG' ],
  76     [ "--A", '($x,@b) = ($x)', 'single scalar on RHS' ],
  77     [ "--A", 'my @a; @a = (@a = split())',      'split a/a'   ],
  78     [ "--A", 'my (@a,@b); @a = (@b = split())', 'split a/b'   ],
  79     [ "---", 'my @a; @a = (split(), 1)',        '(split(),1)' ],
  80     [ "---", '@a = (split(//, @a), 1)',         'split(@a)'   ],
  81     [ "--A", 'my @a; my $ar = @a; @a = (@$ar = split())', 'a/ar split'  ],
  82 ) {
  83     my ($exp, $code, $desc) = @$test;
  84     my $sub = eval "sub { $code }"
  85         or die
  86             "aassign eval('$code') failed: this test needs to be rewritten:\n"
  87             . $@;
  88
  89     my $last_expr = svref_2object($sub)->ROOT->first->last;
  90     if ($last_expr->name ne 'aassign') {
  91         die "Expected aassign but found ", $last_expr->name,
  92             "; this test needs to be rewritten"
  93     }
  94     my $got =
  95         (($last_expr->private & OPpASSIGN_COMMON_SCALAR) ? 'S' : '-')
  96       . (($last_expr->private & OPpASSIGN_COMMON_RC1)    ? 'R' : '-')
  97       . (($last_expr->private & OPpASSIGN_COMMON_AGG)    ? 'A' : '-');
  98     is $got, $exp,  "OPpASSIGN_COMMON: $desc: '$code'";
  99 }
 100
 101
 102 # join -> stringify/const
 103
 104 for (['CONSTANT', sub {          join "foo", $_ }],
 105      ['$var'    , sub {          join  $_  , $_ }],
 106      ['$myvar'  , sub { my $var; join  $var, $_ }],
 107 ) {
 108     my($sep,$sub) = @$_;
 109     my $last_expr = svref_2object($sub)->ROOT->first->last;
 110     is $last_expr->name, 'stringify',
 111       "join($sep, \$scalar) optimised to stringify";
 112 }
 113
 114 for (['CONSTANT', sub {          join "foo", "bar"    }, 0, "bar"    ],
 115      ['CONSTANT', sub {          join "foo", "bar", 3 }, 1, "barfoo3"],
 116      ['$var'    , sub {          join  $_  , "bar"    }, 0, "bar"    ],
 117      ['$myvar'  , sub { my $var; join  $var, "bar"    }, 0, "bar"    ],
 118 ) {
 119     my($sep,$sub,$is_list,$expect) = @$_;
 120     my $last_expr = svref_2object($sub)->ROOT->first->last;
 121     my $tn = "join($sep, " . ($is_list?'list of constants':'const') . ")";
 122     is $last_expr->name, 'const', "$tn optimised to constant";
 123     is $sub->(), $expect, "$tn folded correctly";
 124 }
 125
 126
 127 # list+pushmark in list context elided out of the execution chain
 128 is svref_2object(sub { () = ($_, ($_, $_)) })
 129     ->START # nextstate
 130     ->next  # pushmark
 131     ->next  # gvsv
 132     ->next  # should be gvsv, not pushmark
 133   ->name, 'gvsv',
 134   "list+pushmark in list context where list's elder sibling is a null";
 135
 136
 137 # nextstate multiple times becoming one nextstate
 138
 139 is svref_2object(sub { 0;0;0;0;0;0;time })->START->next->name, 'time',
 140   'multiple nextstates become one';
 141
 142
 143 # pad[ahs]v state declarations in void context
 144
 145 is svref_2object(sub{state($foo,@fit,%far);state $bar;state($a,$b); time})
 146     ->START->next->name, 'time',
 147   'pad[ahs]v state declarations in void context';
 148
 149
 150 # pushmark-padsv-padav-padhv in list context --> padrange
 151
 152 {
 153     my @ops;
 154     my $sub = sub { \my( $f, @f, %f ) };
 155     my $op = svref_2object($sub)->START;
 156     push(@ops, $op->name), $op = $op->next while $$op;
 157     is "@ops", "nextstate padrange refgen leavesub", 'multi-type padrange'
 158 }
 159
 160
 161 # rv2[ahs]v in void context
 162
 163 is svref_2object(sub { our($foo,@fit,%far); our $bar; our($a,$b); time })
 164     ->START->next->name, 'time',
 165   'rv2[ahs]v in void context';
 166
 167
 168 # split to array
 169
 170 for(['@pkgary'      , '@_'       ],
 171     ['@lexary'      , 'my @a; @a'],
 172     ['my(@array)'   , 'my(@a)'   ],
 173     ['local(@array)', 'local(@_)'],
 174     ['@{...}'       , '@{\@_}'   ],
 175 ){
 176     my($tn,$code) = @$_;
 177     my $sub = eval "sub { $code = split }";
 178     my $split = svref_2object($sub)->ROOT->first->last;
 179     is $split->name, 'split', "$tn = split swallows up the assignment";
 180 }
 181
 182
 183 # stringify with join kid --> join
 184 is svref_2object(sub { "@_" })->ROOT->first->last->name, 'join',
 185   'qq"@_" optimised from stringify(join(...)) to join(...)';