#!./perl
#
# opcount.t
#
# Test whether various constructs have the right numbers of particular op
# types. This is chiefly to test that various optimisations are not
# inadvertently removed.
#
# For example the array access in sub { $a[0] } should get optimised from
# aelem into aelemfast. So we want to test that there are 1 aelemfast, 0
# aelem and 1 ex-aelem ops in the optree for that sub.

BEGIN {
    chdir 't';
    require './test.pl';
    skip_all_if_miniperl("No B under miniperl");
    @INC = '../lib';
}

use warnings;
use strict;

plan 2249;

use B ();


{
    my %counts;

    # for a given op, increment $count{opname}. Treat null ops
    # as "ex-foo" where possible

    sub B::OP::test_opcount_callback {
        my ($op) = @_;
        my $name = $op->name;
        if ($name eq 'null') {
            my $targ = $op->targ;
            if ($targ) {
                $name = "ex-" . substr(B::ppname($targ), 3);
            }
        }
        $counts{$name}++;
    }

    # Given a code ref and a hash ref of expected op counts, check that
    # for each opname => count pair, whether that op appears that many
    # times in the op tree for that sub. If $debug is 1, display all the
    # op counts for the sub.

    sub test_opcount {
        my ($debug, $desc, $coderef, $expected_counts) = @_;

        %counts = ();
        B::walkoptree(B::svref_2object($coderef)->ROOT,
                        'test_opcount_callback');

        if ($debug) {
            note(sprintf "%3d %s", $counts{$_}, $_) for sort keys %counts;
        }

        my @exp;
        for (sort keys %$expected_counts) {
            my ($c, $e) = ($counts{$_}//0, $expected_counts->{$_});
            if ($c != $e) {
                push @exp, "expected $e, got $c: $_";
            }
        }
        ok(!@exp, $desc);
        if (@exp) {
            diag($_) for @exp;
        }
    }    
}

# aelem => aelemfast: a basic test that this test file works

test_opcount(0, "basic aelemfast",
                sub { our @a; $a[0] = 1 },
                {
                    aelem      => 0,
                    aelemfast  => 1,
                    'ex-aelem' => 1,
                }
            );

# Porting/bench.pl tries to create an empty and active loop, with the
# ops executed being exactly the same apart from the additional ops
# in the active loop. Check that this remains true.

{
    test_opcount(0, "bench.pl empty loop",
                sub { for my $x (1..$ARGV[0]) { 1; } },
                {
                     aelemfast => 1,
                     and       => 1,
                     const     => 1,
                     enteriter => 1,
                     iter      => 1,
                     leaveloop => 1,
                     leavesub  => 1,
                     lineseq   => 2,
                     nextstate => 2,
                     null      => 1,
                     pushmark  => 1,
                     unstack   => 1,
                }
            );

    no warnings 'void';
    test_opcount(0, "bench.pl active loop",
                sub { for my $x (1..$ARGV[0]) { $x; } },
                {
                     aelemfast => 1,
                     and       => 1,
                     const     => 1,
                     enteriter => 1,
                     iter      => 1,
                     leaveloop => 1,
                     leavesub  => 1,
                     lineseq   => 2,
                     nextstate => 2,
                     null      => 1,
                     padsv     => 1, # this is the additional active op
                     pushmark  => 1,
                     unstack   => 1,
                }
            );
}

#
# multideref
#
# try many permutations of aggregate lookup expressions

{
    package Foo;

    my (@agg_lex, %agg_lex, $i_lex, $r_lex);
    our (@agg_pkg, %agg_pkg, $i_pkg, $r_pkg);

    my $f;
    my @bodies = ('[0]', '[128]', '[$i_lex]', '[$i_pkg]',
                   '{foo}', '{$i_lex}', '{$i_pkg}',
                  );

    for my $prefix ('$f->()->', '$agg_lex', '$agg_pkg', '$r_lex->', '$r_pkg->')
    {
        for my $mod ('', 'local', 'exists', 'delete') {
            for my $body0 (@bodies) {
                for my $body1 ('', @bodies) {
                    for my $body2 ('', '[2*$i_lex]') {
                        my $code = "$mod $prefix$body0$body1$body2";
                        my $sub = "sub { $code }";
                        my $coderef = eval $sub
                            or die "eval '$sub': $@";

                        my %c = (aelem         => 0,
                                 aelemfast     => 0,
                                 aelemfast_lex => 0,
                                 exists        => 0,
                                 delete        => 0,
                                 helem         => 0,
                                 multideref    => 0,
                        );

                        my $top = 'aelem';
                        if ($code =~ /^\s*\$agg_...\[0\]$/) {
                            # we should expect aelemfast rather than multideref
                            $top = $code =~ /lex/ ? 'aelemfast_lex'
                                                  : 'aelemfast';
                            $c{$top} = 1;
                        }
                        else {
                            $c{multideref} = 1;
                        }

                        if ($body2 ne '') {
                            # trailing index; top aelem/exists/whatever
                            # node is kept
                            $top = $mod unless $mod eq '' or $mod eq 'local';
                            $c{$top} = 1
                        }

                        ::test_opcount(0, $sub, $coderef, \%c);
                    }
                }
            }
        }
    }
}


# multideref: ensure that the prefix expression and trailing index
# expression are optimised (include aelemfast in those expressions)


test_opcount(0, 'multideref expressions',
                sub { ($_[0] // $_)->[0]{2*$_[0]} },
                {
                    aelemfast  => 2,
                    helem      => 1,
                    multideref => 1,
                },
            );

# multideref with interesting constant indices


test_opcount(0, 'multideref const index',
                sub { $_->{1}{1.1} },
                {
                    helem      => 0,
                    multideref => 1,
                },
            );

use constant my_undef => undef;
test_opcount(0, 'multideref undef const index',
                sub { $_->{+my_undef} },
                {
                    helem      => 1,
                    multideref => 0,
                },
            );

# multideref when its the first op in a subchain

test_opcount(0, 'multideref op_other etc',
                sub { $_{foo} = $_ ? $_{bar} : $_{baz} },
                {
                    helem      => 0,
                    multideref => 3,
                },
            );

# multideref without hints

{
    no strict;
    no warnings;

    test_opcount(0, 'multideref no hints',
                sub { $_{foo}[0] },
                {
                    aelem      => 0,
                    helem      => 0,
                    multideref => 1,
                },
            );
}

# exists shouldn't clash with aelemfast

test_opcount(0, 'multideref exists',
                sub { exists $_[0] },
                {
                    aelem      => 0,
                    aelemfast  => 0,
                    multideref => 1,
                },
            );