#!/usr/bin/perl -w
#
# Author: Petter Reinholdtsen <pere@td.org.uit.no>
# Date:   2000-12-17
#
# Parse output from gprof, and generate graph output for daVinci or xvcg.
#
# This is alpha quality code, and indended as proof of consept.  The
# idea is based on the C++ implementation cg by ? (look up name).
#
# Todo:
#   - Encode # calls and time used into graph (color, edge width, dashed, etc)
#   - Add daVinci output mode
#   - Detect non-GNU gprof, and correct flags for this case
#   - Clean up code
#   - Use getopt to choose output mode and if unused functions should be
#     included.
#
# ChangeLog:
#   2000-12-30 Petter Reinholdtsen <pere@td.org.uit.no>
#     Changed to skip unused functions.

use strict;

my $url = "http://www.student.uit.no/~pere/linux/";

my $debug = 0;

# For GNU gprof
my $gprofopt = "-c -z";

# Which program to profile
my $program = shift;

# Only show called functions (flag) [dont work yet]
my $used_only = 1;

# Map from function name, to list of funcion calling this function
my %pre;

# Map from function name, to list of function called
my %post;

# Map from function id to function name
my %func;

# Used during parsing
my @parents = ();
my @children = ();

parse_gnu_gprof($program);
dump_graph_vcg();

exit(0);

sub parse_gnu_gprof
{
    my ($program) = @_;
    my $current = "";

    # Flag set when parsing gprof call graph output
    my $ingraph = 0;

    open(GPROF, "gprof $gprofopt $program |") || die "Unable to run gprof";
    while (<GPROF>) {
        chomp;

        $ingraph = 1 if (/Call graph/);
        $ingraph = 0 if (/This table describes the call tree/);
        next unless $ingraph;

        if (/^-+$/) { # End of current entry
            debugmsg(1, "Registering \"$current\"\n") if defined $current;

            if ($current) {
                $pre{$current} =  [@parents]  if (@parents);
                $post{$current}=  [@children] if (@children);
            } else {
                debugmsg(1, "No current func!\n");
            }

            $current  = "";
            @children = ();
            @parents  = ();
            next;
        }

        if (/^\[\d+\]?\s/) {
            $current = parse_current_func($_);
        }

        # Match the parent and child functions.  Examples:
        #                          2             get_ll_tempfile <cycle 3> [36]
        #       0.00    0.00       0/5           __getproperty [891]
        if (/^\s+[\d.]+\s/) {
            parse_parent_or_child($current, $_);
        }
    }
    close(GPROF);
}

sub sort_func_name {
    return $func{$a} cmp $func{$b}
}

# Match current function, ie lines like these (notice the GNU
# gprof bug in the last line):
# Skip unused functions.
#
# [1]      0.0    0.00    0.00       0         <cycle 1 as a whole> [1]
# [4]      0.0    0.00    0.00       9         incache [4]
# [10000   0.0    0.00    0.00       9         incache [10000
# [10]     0.0    0.00    0.00       7         fndentry [10]
# [11]     0.0    0.00    0.00       7         get_property <cycle 3> [11]
sub parse_current_func {
    my $line = shift;
    if(/^\[(\d+)\]?\s+([\d.]+)\s+([\d.]+)\s+([\d.]+)\s+([\d\+]*)\s+(.+)\s+\[(\d+)\]$/) {
        # Name the extracted variables
        my ($id, $ptime, $selftime, $chtime, $called, $name, $index) =
            ($1, $2, $3, $4, $5, $6, $7);

        # I'm not quite sure if this would ever happen
        print "Bad index or id: $id != $index\n " if ($id != $index);

        # If this function wasn't called, skip to the next one
        return undef if ($used_only && !$called);

        if ($name =~ m/^\<.+\>$/) {
            # cycle, not a function
            debugmsg(1, "Cycle \"$name\" index $index\n");
            return undef;
        }
        return save_func_name($name, $id);
    } else {
        debugmsg(0, "Bad formatting of line \"$line\"\n");
        exit;
    }
}

#
# Match parents and child of the current function.
# Skip unused functions.
#
sub parse_parent_or_child
{
    my ($current, $line) = @_;
    my ($selftime, $chtime, $countinfo, $name, $index) = $line =~
        m%^\s+([\d.]*)\s+([\d.]*)\s+([\d/\+]+)\s+(.+)\s\[(\d+)\]$%;
    if (!defined $name) {
        debugmsg(0, "Unable to parse \"$_\"\n");
        next;
    }

    # Check if this function was called at all
    if ($used_only) {
        my ($this, $total) = split(/\//, $countinfo);
        return unless (defined $total && 0 < $this);
    }

    debugmsg(1, "Called: $countinfo\n");

    $name = save_func_name($name, $index);

    if ($current) {
        push(@children, $name);
    } else {
        push(@parents, $name);
    }
}

#
# Store decoded function name in hash with the function index as key
#
sub save_func_name {
    my ($name, $id) = @_;
    my $current = $name;

    # Remove cycle information
    $current =~ s/\s*\<.+\>//;

    $func{$id} = $current;
    debugmsg(1, "Name: \"$name\" -> \"$current\"\n");
    return $id;
}
#
# Output current graph database
#
sub dump_graph_raw {
    my $current;
    for $current (sort sort_func_name keys %func) {
        my $name = $func{$current};
        print "Func: \"" . $name . "\" [$current]\n";

        # Print callers
        if (defined $pre{$current}) {
            my $f;
            for $f (sort sort_func_name @{$pre{$current}}) {
                print " " . $func{$f} . " [$f] -> \"$name\"\n";
            }
        }

        # Print called
        if (defined $post{$current}) {
            my $f;
            for $f (sort sort_func_name @{$post{$current}}) {
                print " \"$name\" -> \"" . $func{$f} . "\" [$f]\n";
            }
        }
    }
}

sub vcg_edge
{
    my ($src, $dst, $thickness, $comment) = @_;
    my $buffer = "  edge: {".
          " sourcename: \"$src\"".
          " targetname: \"$dst\"" .
          " thickness: $thickness }";
    $buffer .= " /* $comment */\n" if ($comment);
    return $buffer;
}

#
# Output current graph database in vcg format
#
sub dump_graph_vcg {
    my $current;

    my %printed;

    print <<EOF;
/*
 * VCG formatted call graph for program "$program" based on gprof output.
 *
 * Check <URL:$url> for more information.
 */

graph: {
  title: "Profiling $program"
  orientation: left_to_right

EOF

    # First print all the nodes
    for $current (sort sort_func_name keys %func) {
        my $name = $func{$current};
        print "  node: { title: \"$current\" label: \"$name\" borderwidth: 0}\n"
    }

    print "\n";

    # Then print all the edges
    for $current (sort sort_func_name keys %func) {
        my $name = $func{$current};

        if (defined $pre{$current}) {
            my $content = 0;
            my $buffer = "  /* \"$name\" callers */\n";
            my $f;
            for $f (sort sort_func_name @{$pre{$current}}) {
                if (!exists $printed{"$f:$current"}) {
                    my $prename = $func{$f};
                    my $thickness = 1;
                    $buffer .= vcg_edge($f, $current, $thickness, $prename);
                    $printed{"$f:$current"} = 1;
                    $content++;
                }
            }
            $buffer .= "\n";
            print $buffer if (0 < $content);
        }

        if (defined $post{$current}) {
            my $content = 0;
            my $buffer = "  /* \"$name\" called */\n";
            my $f;
            for $f (sort sort_func_name @{$post{$current}}) {
                if (!exists $printed{"$current:$f"}) {
                    my $postname = $func{$f};
                    my $thickness = 1;
                    $buffer .= vcg_edge($current, $f, $thickness, $postname);
                    $printed{"$current:$f"} = 1;
                    $content++;
                }
            }
            $buffer .= "\n";
            print $buffer if (0 < $content);
        }
    }
    print <<EOF;
}
EOF
}
#
# Output current graph database in daVinci format
#
sub dump_graph_daVinci {
    my $current;

    my %printed = ();

    print "[\n";

    # First print all the nodes
    for $current (sort sort_func_name keys %func) {
        my $name = $func{$current};
        print "  l(\"$current\",n(\"$name\",[],[\n";
        # Print callers
        if (defined $pre{$current}) {
            my $f;
            for $f (sort sort_func_name @{$pre{$current}}) {
                print "l(\"$f\"->\"$current\",e(\"B\",[],";
                if ($printed{$f}) {
                    print "r(\"$f\"";
                }
                print "  edge: { sourcename: \"$f\" targetname: \"$current\"" .
                    " thickness: 1 }\n";
            }
        }

        # Print called
        if (defined $post{$current}) {
            my $f;
            for $f (sort sort_func_name @{$post{$current}}) {
                print "  edge: { sourcename: \"$current\" targetname: \"$f\"" .
                    " thickness: 1 }\n";
            }
        }
    }
    print <<EOF;
}
EOF
}

sub debugmsg
{
    my ($level, $msg) = @_;
    print STDERR $msg if ($level <= $debug);
}