libdevel-nytprof-perl 5.06+dfsg-2+b1 / usr / bin / nytprofcalls

#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell
##########################################################
# This script is part of the Devel::NYTProf distribution
#
# Copyright, contact and other information can be found
# at the bottom of this file, or by going to:
# http://search.cpan.org/dist/Devel-NYTProf/
#
##########################################################

use warnings;
use strict;

use Devel::NYTProf::Core;
require Devel::NYTProf::Data;

our $VERSION = '5.06';
    
use Data::Dumper;
use Getopt::Long;
use Carp;

GetOptions(
    'help|h'    => \&usage,
    'verbose|v' => \my $opt_verbose,
    'calls!'    => \my $opt_calls, # sum calls instead of time
    'debug|d'   => \my $opt_debug,
    'stable'    => \my $opt_stable, # used for testing (stability)
) or usage();

$opt_verbose++ if $opt_debug;
$|++ if $opt_verbose;

usage() unless @ARGV;


# We're building a tree structure from a stream of "subroutine returned" events.
# (We use these because the subroutine entry events don't have reliable
# value for the subroutine name, and obviously don't have timings.)
#
# Building a call tree from return events is a little tricky because they don't
# appear in natural order. The code can return from a call at any depth
# deeper than the last seen depth.
#
my $root = {};
my @stack = ($root);
my $total_in = 0;

my $last_subid = 0;
my %subname2id;

my $sibling_avoided = 0;
my $siblings_max = 0;

my %option;
my %attribute;


my $callbacks = {

    OPTION    => sub { my (undef, $k, $v) = @_; $option{$k} = $v },
    ATTRIBUTE => sub { my (undef, $k, $v) = @_; $attribute{$k} = $v },

    SUB_ENTRY => sub {
        my (undef, $fid, $line) = @_;
        warn "> at $fid:$line\n" if $opt_verbose;
    },

    SUB_RETURN => sub {
        # $retn_depth is the call stack depth of the sub call we're returning from
        my (undef, $retn_depth, undef, $excl_time, $subname) = @_;

        warn sprintf "< %2d %-10s %s (stack %d)\n", $retn_depth, $subname, $excl_time, scalar @stack
            if $opt_verbose;

        my $v = ($opt_calls) ? 1 : $excl_time;
        $total_in += $v;

        # normalize and merge sibling string evals by setting eval seqn to 0
        $subname =~ s/\( (\w*eval)\s\d+ \) (?= \[ .+? :\d+ \] )/($1 0)/gx;
        # assign an id to the subname for memory efficiency
        my $subid = $subname2id{$subname} ||= ++$last_subid;

        # Either...
        # a) we're returning from some sub deeper than the current stack
        #    in which case we push unnamed sub calls ("0") onto the stack
        #    till we get to the right depth, then fall through to:
        # b) we're returning from the sub on top of the stack.

        while (@stack <= $retn_depth) { # build out the tree if needed
            my $crnt_node = $stack[-1];
            die "panic" if $crnt_node->{0};
            push @stack, ($crnt_node->{0} = {});
        }

        # top of stack:  sub we're returning from
        # next on stack: sub that was the caller
        my $sub_return = pop @stack;
        my $sub_caller = $stack[-1] || die "panic";

        die "panic" unless $sub_return == $sub_caller->{0};
        delete $sub_caller->{0} or die "panic"; # == $sub_return

        # {
        #   0 - as-yet un-returned subs
        #   'v' - cumulative excl_time in this sub
        #   $subid1 => {...} # calls to $subid1 made by this sub
        #   $subid2 => {...}
        # }

        $sub_return->{v} += $v;
        _merge_sub_return_into_caller($sub_caller->{$subid} ||= {}, $sub_return);
    },
};


foreach my $input (@ARGV) {
    warn "Reading $input...\n" if $opt_verbose;
    Devel::NYTProf::Data->new({
        filename => $input,
        quiet => 1,
        callback => $callbacks
    });
}


# transform tree into a simple hash of call paths "subid;subid;subid" => value
my %subidpaths;
visit_node($root, [], sub {
    my ($node, $path) = @_;
    $subidpaths{ join(";", @$path) } += $node->{v}
        if @$path;
});

# output the totals without scaling, so they're in ticks_per_sec units
my $val_scale_factor = 1; # ($opt_calls) ? 1 : 1_000_000 / $attribute{ticks_per_sec};
my $val_format = ($opt_calls || $val_scale_factor==1) ? "%s %d\n" : "%s %.1f\n";
my $total_out = 0;

# ensure subnames don't contain ";" or " "
tr/; /??/ for values %subname2id;
my %subid2name = reverse %subname2id;

# output the subidpaths hash using subroutine names
my @subidpaths = keys %subidpaths;
@subidpaths = sort @subidpaths if $opt_stable;
for my $subidpath (@subidpaths) {
    my @path = map { $subid2name{$_} } split ";", $subidpath;
    my $path = join(";", @path);
    my $v = $subidpaths{$subidpath};
    printf $val_format, join(";", @path), $v * $val_scale_factor;
    $total_out += $v;
}

warn "nytprofcalls inconsistency: total in $total_in doesn't match total out $total_out\n"
    if $total_in != $total_out;

warn sprintf "Done Total $total_in (siblings: avoided $sibling_avoided, max $siblings_max)\n"
    if $opt_verbose;

exit 0;


sub _merge_sub_return_into_caller {
    my ($dest, $new, $recurse) = @_;
    $dest->{v} += delete $new->{v};
    while ( my ($new_called_subid, $new_called_node) = each %$new ) {
        if ($dest->{$new_called_subid}) {
            _merge_sub_return_into_caller($dest->{$new_called_subid}, $new_called_node);
        }
        else {
            $dest->{$new_called_subid} = $new_called_node;
        }
    }
}


sub visit_node { # depth first
    my $node = shift;
    my $path = shift;
    my $sub  = shift;

    warn "visit_node: @{[ %$node ]}\n" if $opt_debug;

    push @$path, undef;
    while ( my ($subid, $childnode) = each %$node) {
        next if $subid eq 'v';
        die "panic" if $subid eq '0';

        $path->[-1] = $subid;
        warn "node @$path: @{[ %$childnode ]}\n" if $opt_debug;
        visit_node($childnode, $path, $sub);
    }
    pop @$path;

    $sub->($node, $path);

    %$node = (); # reclaim memory as we go
}


sub usage {
    print <<END;
usage: [perl] nytprofcalls [opts] nytprof-file [...]

 --help,        -h         Print this message
 --verbose,     -v         Be more verbose

This script of part of the Devel::NYTProf distribution.
See https://metacpan.org/release/Devel-NYTProf for details and copyright.
END
    exit 0;
}

__END__

=head1 NAME

nytprofcalls - experimental

=cut
# vim:ts=8:sw=4:et