You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
200 lines
6.1 KiB
200 lines
6.1 KiB
15 years ago
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
# Redistribution and use in source and binary forms, with or without
|
||
|
|
# modification, are permitted provided that the following conditions are met:
|
||
|
|
#
|
||
|
|
# - Redistributions of source code must retain the above copyright notice,
|
||
|
|
# this list of conditions and the following disclaimer.
|
||
|
|
#
|
||
|
|
# - Redistributions in binary form must reproduce the above copyright
|
||
|
|
# notice, this list of conditions and the following disclaimer in the
|
||
|
|
# documentation and/or other materials provided with the distribution.
|
||
|
|
#
|
||
|
|
# - All advertising materials mentioning features or use of this software
|
||
|
|
# must display the following acknowledgement: This product includes software
|
||
|
|
# developed by OmniTI Computer Consulting.
|
||
|
|
#
|
||
|
|
# - Neither name of the company nor the names of its contributors may be
|
||
|
|
# used to endorse or promote products derived from this software without
|
||
|
|
# specific prior written permission.
|
||
|
|
#
|
||
|
|
# THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS `AS IS'' AND ANY
|
||
|
|
# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||
|
|
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||
|
|
# DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
|
||
|
|
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
||
|
|
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||
|
|
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
|
||
|
|
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||
|
|
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||
|
|
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||
|
|
#
|
||
|
|
# Copyright (c) 2004 OmniTI Computer Consulting
|
||
|
|
# All rights reserved
|
||
|
|
# The following code was written by George Schlossnagle <george@omniti.com>
|
||
|
|
# and is provided completely free and without any warranty.
|
||
|
|
#
|
||
|
|
|
||
|
|
#
|
||
|
|
# This script is designed to convert the tmon.out output emitted
|
||
|
|
# from Perl's Devel::DProf profiling package. To use this:
|
||
|
|
#
|
||
|
|
# 1) Run your perl script as
|
||
|
|
# > perl -d:DProf yoursript.pl
|
||
|
|
# This will create a file called tmon.out. If you want to
|
||
|
|
# inspect it on the command line, look at the man page
|
||
|
|
# for dprofp for details.
|
||
|
|
#
|
||
|
|
# 2) Run
|
||
|
|
# > dprof2calltree -f tmon.out
|
||
|
|
# or
|
||
|
|
# > dprof2calltree -f tmon.out -o cachegrind.out.foo
|
||
|
|
#
|
||
|
|
# This creates a cachegrind-style file called cachgrind.out.tmon.out or
|
||
|
|
# cachegrind.out.foo, respecitvely.
|
||
|
|
#
|
||
13 years ago
|
# 3) Run tdecachegrind cachegrind.out.foo
|
||
|
15 years ago
|
#
|
||
|
|
# 4) Enjoy!
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use Config;
|
||
|
|
use Getopt::Std;
|
||
|
|
use IO::File;
|
||
|
|
|
||
|
|
my @callstack;
|
||
|
|
my %function_info;
|
||
|
|
my $tree = {};
|
||
|
|
my $total_cost = 0;
|
||
|
|
my %opts;
|
||
|
|
|
||
|
|
getopt('f:o:', \%opts);
|
||
|
|
|
||
|
|
my $infd;
|
||
|
|
usage() unless ($opts{'f'} && ($infd = IO::File->new($opts{'f'}, "r")));
|
||
|
|
|
||
|
|
my $outfd;
|
||
|
|
my $outfile = $opts{'o'};
|
||
|
|
unless($outfile) {
|
||
|
|
$opts{'f'} =~ m!([^/]+)$!;
|
||
|
|
$outfile = "cachegrind.out.$1";
|
||
|
|
}
|
||
|
|
$outfd = new IO::File $outfile, "w";
|
||
|
|
usage() unless defined $outfd;
|
||
|
|
|
||
|
|
while(<$infd>) {
|
||
|
|
last if /^PART2/;
|
||
|
|
}
|
||
|
|
while(<$infd>) {
|
||
|
|
chomp;
|
||
|
|
my @args = split;
|
||
|
|
if($args[0] eq '@') {
|
||
|
|
# record timing event
|
||
|
|
my $call_element = pop @callstack;
|
||
|
|
if($call_element) {
|
||
|
|
$call_element->{'cost'} += $args[3];
|
||
|
|
$call_element->{'cumm_cost'} += $args[3];
|
||
|
|
$total_cost += $args[3];
|
||
|
|
push @callstack, $call_element;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif($args[0] eq '&') {
|
||
|
|
# declare function
|
||
|
|
$function_info{$args[1]}->{'package'} = $args[2];
|
||
|
|
if($args[2] ne 'main') {
|
||
|
|
$function_info{$args[1]}->{'name'} = $args[2]."::".$args[3];
|
||
|
|
} else {
|
||
|
|
$function_info{$args[1]}->{'name'} = $args[3];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif($args[0] eq '+') {
|
||
|
|
# push myself onto the stack
|
||
|
|
my $call_element = { 'specifier' => $args[1], 'cost' => 0 };
|
||
|
|
push @callstack, $call_element;
|
||
|
|
}
|
||
|
|
elsif($args[0] eq '-') {
|
||
|
|
my $called = pop @callstack;
|
||
|
|
my $called_id = $called->{'specifier'};
|
||
|
|
my $caller = pop @callstack;
|
||
|
|
if (exists $tree->{$called_id}) {
|
||
|
|
$tree->{$called_id}->{'cost'} += $called->{'cost'};
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$tree->{$called_id} = $called;
|
||
|
|
}
|
||
|
|
if($caller) {
|
||
|
|
$caller->{'child_calls'}++;
|
||
|
|
my $caller_id = $caller->{'specifier'};
|
||
|
|
if(! exists $tree->{$caller_id} ) {
|
||
|
|
$tree->{$caller_id} = { 'specifier' => $caller_id, 'cost' => 0 };
|
||
|
|
# $tree->{$caller_id} = $caller;
|
||
|
|
}
|
||
|
|
$caller->{'cumm_cost'} += $called->{'cumm_cost'};
|
||
|
|
$tree->{$caller_id}->{'called_funcs'}->[$tree->{$caller_id}->{'call_counter'}++]->{$called_id} += $called->{'cumm_cost'};
|
||
|
|
push @callstack, $caller;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif($args[0] eq '*') {
|
||
|
|
# goto &func
|
||
|
|
# replace last caller with self
|
||
|
|
my $call_element = pop @callstack;
|
||
|
|
$call_element->{'specifier'} = $args[1];
|
||
|
|
push @callstack, $call_element;
|
||
|
|
}
|
||
|
|
else {print STDERR "Unexpected line: $_\n";}
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Generate output
|
||
|
|
#
|
||
|
|
my $output = '';
|
||
|
|
$output .= "events: Tick\n";
|
||
|
|
$output .= "summary: $total_cost\n";
|
||
|
|
$output .= "cmd: your script\n\n";
|
||
|
|
foreach my $specifier ( keys %$tree ) {
|
||
|
|
my $caller_package = $function_info{$specifier}->{'package'} || '???';
|
||
|
|
my $caller_name = $function_info{$specifier}->{'name'} || '???';
|
||
|
|
my $include = find_include($caller_package);
|
||
|
|
$output .= "ob=\n";
|
||
|
|
$output .= sprintf "fl=%s\n", find_include($caller_package);
|
||
|
|
$output .= sprintf "fn=%s\n", $caller_name;
|
||
|
|
$output .= sprintf "1 %d\n", $tree->{$specifier}->{'cost'};
|
||
|
|
if(exists $tree->{$specifier}->{'called_funcs'}) {
|
||
|
|
foreach my $items (@{$tree->{$specifier}->{'called_funcs'}}) {
|
||
|
|
while(my ($child_specifier, $costs) = each %$items) {
|
||
|
|
$output .= sprintf "cfn=%s\n", $function_info{$child_specifier}->{'name'};
|
||
|
|
$output .= sprintf "cfi=%s\n", find_include($function_info{$child_specifier}->{'package'});
|
||
|
|
$output .= "calls=1\n";
|
||
|
|
$output .= sprintf "1 %d\n", $costs;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$output .= "\n";
|
||
|
|
}
|
||
|
13 years ago
|
print STDERR "Writing tdecachegrind output to $outfile\n";
|
||
|
15 years ago
|
$outfd->print($output);
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
sub find_include {
|
||
|
|
my $module = shift;
|
||
|
|
$module =~ s!::!/!g;
|
||
|
|
for (@INC) {
|
||
|
|
if ( -f "$_/$module.pm" ) {
|
||
|
|
return "$_/$module.pm";
|
||
|
|
}
|
||
|
|
if ( -f "$_/$module.so" ) {
|
||
|
|
return "$_/$module.so";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return "???";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub usage() {
|
||
|
|
print STDERR "dprof2calltree -f <tmon.out> [-o outfile]\n";
|
||
|
|
exit -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# vim: set sts=2 ts=2 bs ai expandtab :
|