nytprofcalls

#!/usr/bin/perl
##########################################################
# 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://metacpan.org/release/Devel-NYTProf/
#
##########################################################

use warnings;
use strict;

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

our $VERSION = '6.05';
    
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;


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;
}


my $last_subid = 0;
my %subname2id;

my %option;
my %attribute;


# 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 $callbacks = {
    OPTION    => sub { my (undef, $k, $v) = @_; $option{$k} = $v },
    ATTRIBUTE => sub { my (undef, $k, $v) = @_; $attribute{$k} = $v },
};
$callbacks->{SUB_ENTRY}  = \&on_sub_entry_log if $opt_verbose;
$callbacks->{SUB_RETURN} = \&on_sub_return_build_call_stack;
$callbacks->{all_loaded} = sub {
    output_call_path_hash( extract_call_path_hash($root) );
};


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


exit 0;


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


sub on_sub_return_build_call_stack {
    # $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);
}


# build hash of call paths ("subid;subid;subid" => value) from the call tree
sub extract_call_path_hash {
    my ($root) = @_;

    my %subid_call_path_hash;
    visit_nodes_depth_first($root, [], sub {
        my ($node, $path) = @_;
        $subid_call_path_hash{ join(";", @$path) } += $node->{v}
            if @$path;
        %$node = (); # reclaim memory as we go
    });
    return \%subid_call_path_hash;
}


sub output_call_path_hash {
    my ($subid_call_path_hash) = @_;

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

    # 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;

    # output the subid_call_path_hash hash using subroutine names
    my @keys = keys %$subid_call_path_hash;
    @keys = sort @keys if $opt_stable;
    for my $subidpath (@keys) {
        my @path = map { $subid2name{$_} } split ";", $subidpath;
        my $path = join(";", @path);
        my $v = $subid_call_path_hash->{$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\n"
        if $opt_verbose;
}


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_nodes_depth_first { # 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_nodes_depth_first($childnode, $path, $sub);
    }
    pop @$path;

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


__END__

=head1 NAME

nytprofcalls - experimental

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