Permalink
Fetching contributors…
Cannot retrieve contributors at this time
145 lines (120 sloc) 3.46 KB
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use 5.022000;
use autodie;
use Getopt::Long;
use JSON::XS;
use Data::Dumper;
use Term::ANSIColor;
use List::Util qw/sum max/;
no warnings 'recursion';
# run server process by following command:
# SINGLE_PROCESS=1 perl6-m --profile-filename=aaa.json --profile -Ilib bin/crustup --port=5000 eg/hello.psgi6
# call servers.
# ab -n 1000 -c 1 http://localhost:5000/exit
# then, terminate proc.
# http://localhost:5000/exit
#
# aggregate result:
# perl author/moar-profiler-cli.pl < aaa.json
my $sort = 'inclusive';
GetOptions(
's|sort=s' => \$sort,
'r|reverse!' => \my $reverse,
'c|callee=i' => \my $show_callee,
'l|limit=i' => \my $limit,
);
our $CALLEE_DUMP_LEVEL = 0;
my $json = join("",<>);
my $dat = JSON::XS->new->max_depth(1024)->decode($json);
my %id_rec_depth;
my %id_to_inclusive;
my %id_to_entries;
my %id_to_exclusive;
my %node_id_to_name;
my %node_id_to_file;
my %node_id_to_line;
my %id_to_callee;
my $walk; $walk = sub {
my ($node) = @_;
my $id = $node->{id};
if (!$node_id_to_name{$id}) {
$node_id_to_name{$id} = $node->{name} || '<anon>';
$node_id_to_line{$id} = $node->{line} || '<unknown>';
$node_id_to_file{$id} = $node->{file} || '<unknown>';
}
unless ($id_to_entries{$id}) {
$id_to_inclusive{$id} = 0;
$id_to_exclusive{$id} = 0;
$id_rec_depth{$id} = 0;
}
$id_to_entries{$id} = $node->{entries};
$id_to_exclusive{$id} += $node->{exclusive_time};
if ($id_rec_depth{$id} == 0) {
$id_to_inclusive{$id} += $node->{inclusive_time};
}
if ($node->{callees}) {
$id_rec_depth{$id}++;
for (@{$node->{callees}}) {
$id_to_callee{$_->{id}}{$id}++;
$walk->($_);
}
$id_rec_depth{$id}--;
}
};
my $root = $dat->[0]->{call_graph};
$walk->($root);
my $total_inclusive = $root->{inclusive_time};
my $total_exclusive = sum values %id_to_exclusive;
my @ids = keys %id_to_inclusive;
if ($sort eq 'inclusive') {
@ids = sort { $id_to_inclusive{$a} <=> $id_to_inclusive{$b} } @ids;
} elsif ($sort eq 'exclusive') {
@ids = sort { $id_to_exclusive{$a} <=> $id_to_exclusive{$b} } @ids;
} else {
die "unknown sort mode: '$sort'\n";
}
if ($reverse) {
@ids = reverse @ids;
}
print "sorted by $sort\n";
printf("%s %s %s %s %s\n",
'inclusive',
'exclusive',
'name',
'file',
'line');
my $i = 0;
for my $id (@ids) {
my $line = sprintf("%s(%.2f%%) %s(%.2f%%) %s %s %s\n",
$id_to_inclusive{$id},
eval { ($id_to_inclusive{$id} / $total_inclusive)*100 } // '-',
$id_to_exclusive{$id},
eval { ($id_to_exclusive{$id} / $total_exclusive)*100 } // '-',
$node_id_to_name{$id},
$node_id_to_file{$id},
$node_id_to_line{$id});
if ($show_callee) {
$line = colored(['green'], $line);
}
print $line;
if ($show_callee) {
dump_callee($id);
}
if (defined($limit) && $i++ > $limit) {
last;
}
}
sub dump_callee {
my $id = shift;
my @callee_ids = sort keys %{$id_to_callee{$id} // {}};
for my $callee_id (@callee_ids) {
printf "%s %s %s %s %s\n", (' ' x $CALLEE_DUMP_LEVEL), $callee_id, $node_id_to_name{$callee_id}, $node_id_to_file{$callee_id}, $node_id_to_line{$callee_id};
if ($CALLEE_DUMP_LEVEL < $show_callee-1) {
local $CALLEE_DUMP_LEVEL = $CALLEE_DUMP_LEVEL + 1;
dump_callee($callee_id);
}
}
}