summaryrefslogtreecommitdiffstats
path: root/tdecachegrind/converters/dprof2calltree
diff options
context:
space:
mode:
authorTimothy Pearson <kb9vqf@pearsoncomputing.net>2012-01-30 20:20:24 -0600
committerTimothy Pearson <kb9vqf@pearsoncomputing.net>2012-01-30 20:20:24 -0600
commitcfccedd9c8db3af36d7c5635ca212fa170bb6ff5 (patch)
treec80df038c9b6e40b4e28c26203de0dd9b1cd1593 /tdecachegrind/converters/dprof2calltree
parent2020f146a7175288d0aaf15cd91b95e545bbb915 (diff)
downloadtdesdk-cfccedd9c8db3af36d7c5635ca212fa170bb6ff5.tar.gz
tdesdk-cfccedd9c8db3af36d7c5635ca212fa170bb6ff5.zip
Part 2 of prior commit
Diffstat (limited to 'tdecachegrind/converters/dprof2calltree')
-rw-r--r--tdecachegrind/converters/dprof2calltree199
1 files changed, 199 insertions, 0 deletions
diff --git a/tdecachegrind/converters/dprof2calltree b/tdecachegrind/converters/dprof2calltree
new file mode 100644
index 00000000..f276e188
--- /dev/null
+++ b/tdecachegrind/converters/dprof2calltree
@@ -0,0 +1,199 @@
+#!/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.
+#
+# 3) Run tdecachegrind cachegrind.out.foo
+#
+# 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";
+}
+print STDERR "Writing tdecachegrind output to $outfile\n";
+$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 :