This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/perf/optree.t: expand blurb
[perl5.git] / 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 23;
14
15 use v5.10; # state
16 use B qw 'svref_2object OPpASSIGN_COMMON';
17
18
19 # aassign with no common vars
20 for ('my ($self) = @_',
21      'my @x; @y = $x[0]', # aelemfast_lex
22     )
23 {
24     my $sub = eval "sub { $_ }";
25     my $last_expr =
26       svref_2object($sub)->ROOT->first->last;
27     if ($last_expr->name ne 'aassign') {
28         die "Expected aassign but found ", $last_expr->name,
29             "; this test needs to be rewritten" 
30     }
31     is $last_expr->private & OPpASSIGN_COMMON, 0,
32       "no ASSIGN_COMMON for $_";
33 }    
34
35
36 # join -> stringify/const
37
38 for (['CONSTANT', sub {          join "foo", $_ }],
39      ['$var'    , sub {          join  $_  , $_ }],
40      ['$myvar'  , sub { my $var; join  $var, $_ }],
41 ) {
42     my($sep,$sub) = @$_;
43     my $last_expr = svref_2object($sub)->ROOT->first->last;
44     is $last_expr->name, 'stringify',
45       "join($sep, \$scalar) optimised to stringify";
46 }
47
48 for (['CONSTANT', sub {          join "foo", "bar"    }, 0, "bar"    ],
49      ['CONSTANT', sub {          join "foo", "bar", 3 }, 1, "barfoo3"],
50      ['$var'    , sub {          join  $_  , "bar"    }, 0, "bar"    ],
51      ['$myvar'  , sub { my $var; join  $var, "bar"    }, 0, "bar"    ],
52 ) {
53     my($sep,$sub,$is_list,$expect) = @$_;
54     my $last_expr = svref_2object($sub)->ROOT->first->last;
55     my $tn = "join($sep, " . ($is_list?'list of constants':'const') . ")";
56     is $last_expr->name, 'const', "$tn optimised to constant";
57     is $sub->(), $expect, "$tn folded correctly";
58 }
59
60
61 # list+pushmark in list context elided out of the execution chain
62 is svref_2object(sub { () = ($_, ($_, $_)) })
63     ->START # nextstate
64     ->next  # pushmark
65     ->next  # gvsv
66     ->next  # should be gvsv, not pushmark
67   ->name, 'gvsv',
68   "list+pushmark in list context where list's elder sibling is a null";
69
70
71 # nextstate multiple times becoming one nextstate
72
73 is svref_2object(sub { 0;0;0;0;0;0;time })->START->next->name, 'time',
74   'multiple nextstates become one';
75
76
77 # pad[ahs]v state declarations in void context 
78
79 is svref_2object(sub{state($foo,@fit,%far);state $bar;state($a,$b); time})
80     ->START->next->name, 'time',
81   'pad[ahs]v state declarations in void context';
82
83
84 # rv2[ahs]v in void context
85
86 is svref_2object(sub { our($foo,@fit,%far); our $bar; our($a,$b); time })
87     ->START->next->name, 'time',
88   'rv2[ahs]v in void context';
89
90
91 # split to array
92
93 for(['@pkgary'      , '@_'       ],
94     ['@lexary'      , 'my @a; @a'],
95     ['my(@array)'   , 'my(@a)'   ],
96     ['local(@array)', 'local(@_)'],
97     ['@{...}'       , '@{\@_}'   ],
98 ){
99     my($tn,$code) = @$_;
100     my $sub = eval "sub { $code = split }";
101     my $split = svref_2object($sub)->ROOT->first->last;
102     is $split->name, 'split', "$tn = split swallows up the assignment";
103 }
104
105
106 # stringify with join kid --> join
107 is svref_2object(sub { "@_" })->ROOT->first->last->name, 'join',
108   'qq"@_" optimised from stringify(join(...)) to join(...)';