linux/gprof-callgraph/gprof-callgraph.pl-20010101

   1 #!/usr/bin/perl -w
   2 #
   3 # Author: Petter Reinholdtsen <pere@td.org.uit.no>
   4 # Date:   2000-12-17
   5 #
   6 # Parse output from gprof, and generate graph output for daVinci or xvcg.
   7 #
   8 # This is alpha quality code, and indended as proof of consept.  The
   9 # idea is based on the C++ implementation cg by ? (look up name).
  10 #
  11 # Todo:
  12 #   - Encode # calls and time used into graph (color, edge width, dashed, etc)
  13 #   - Add daVinci output mode
  14 #   - Detect non-GNU gprof, and correct flags for this case
  15 #   - Clean up code
  16 #   - Use getopt to choose output mode and if unused functions should be
  17 #     included.
  18 #
  19 # ChangeLog:
  20 #   2000-12-30 Petter Reinholdtsen <pere@td.org.uit.no>
  21 #     Changed to skip unused functions.
  22
  23 use strict;
  24
  25 my $url = "http://www.student.uit.no/~pere/linux/";
  26
  27 my $debug = 0;
  28
  29 # For GNU gprof
  30 my $gprofopt = "-c -z";
  31
  32 # Which program to profile
  33 my $program = shift;
  34
  35 # Only show called functions (flag) [dont work yet]
  36 my $used_only = 1;
  37
  38 # Map from function name, to list of funcion calling this function
  39 my %pre;
  40
  41 # Map from function name, to list of function called
  42 my %post;
  43
  44 # Map from function id to function name
  45 my %func;
  46
  47 # Used during parsing
  48 my @parents = ();
  49 my @children = ();
  50
  51 parse_gnu_gprof($program);
  52 dump_graph_vcg();
  53
  54 exit(0);
  55
  56 sub parse_gnu_gprof
  57 {
  58     my ($program) = @_;
  59     my $current = "";
  60
  61     # Flag set when parsing gprof call graph output
  62     my $ingraph = 0;
  63
  64     open(GPROF, "gprof $gprofopt $program |") || die "Unable to run gprof";
  65     while (<GPROF>) {
  66         chomp;
  67
  68         $ingraph = 1 if (/Call graph/);
  69         $ingraph = 0 if (/This table describes the call tree/);
  70         next unless $ingraph;
  71
  72         if (/^-+$/) { # End of current entry
  73             debugmsg(1, "Registering \"$current\"\n") if defined $current;
  74
  75             if ($current) {
  76                 $pre{$current} =  [@parents]  if (@parents);
  77                 $post{$current}=  [@children] if (@children);
  78             } else {
  79                 debugmsg(1, "No current func!\n");
  80             }
  81
  82             $current  = "";
  83             @children = ();
  84             @parents  = ();
  85             next;
  86         }
  87
  88         if (/^\[\d+\]?\s/) {
  89             $current = parse_current_func($_);
  90         }
  91
  92         # Match the parent and child functions.  Examples:
  93         #                          2             get_ll_tempfile <cycle 3> [36]
  94         #       0.00    0.00       0/5           __getproperty [891]
  95         if (/^\s+[\d.]+\s/) {
  96             parse_parent_or_child($current, $_);
  97         }
  98     }
  99     close(GPROF);
 100 }
 101
 102 sub sort_func_name {
 103     return $func{$a} cmp $func{$b}
 104 }
 105
 106 # Match current function, ie lines like these (notice the GNU
 107 # gprof bug in the last line):
 108 # Skip unused functions.
 109 #
 110 # [1]      0.0    0.00    0.00       0         <cycle 1 as a whole> [1]
 111 # [4]      0.0    0.00    0.00       9         incache [4]
 112 # [10000   0.0    0.00    0.00       9         incache [10000
 113 # [10]     0.0    0.00    0.00       7         fndentry [10]
 114 # [11]     0.0    0.00    0.00       7         get_property <cycle 3> [11]
 115 sub parse_current_func {
 116     my $line = shift;
 117     if(/^\[(\d+)\]?\s+([\d.]+)\s+([\d.]+)\s+([\d.]+)\s+([\d\+]*)\s+(.+)\s+\[(\d+)\]$/) {
 118         # Name the extracted variables
 119         my ($id, $ptime, $selftime, $chtime, $called, $name, $index) =
 120             ($1, $2, $3, $4, $5, $6, $7);
 121
 122         # I'm not quite sure if this would ever happen
 123         print "Bad index or id: $id != $index\n " if ($id != $index);
 124
 125         # If this function wasn't called, skip to the next one
 126         return undef if ($used_only && !$called);
 127
 128         if ($name =~ m/^\<.+\>$/) {
 129             # cycle, not a function
 130             debugmsg(1, "Cycle \"$name\" index $index\n");
 131             return undef;
 132         }
 133         return save_func_name($name, $id);
 134     } else {
 135         debugmsg(0, "Bad formatting of line \"$line\"\n");
 136         exit;
 137     }
 138 }
 139
 140 #
 141 # Match parents and child of the current function.
 142 # Skip unused functions.
 143 #
 144 sub parse_parent_or_child
 145 {
 146     my ($current, $line) = @_;
 147     my ($selftime, $chtime, $countinfo, $name, $index) = $line =~
 148         m%^\s+([\d.]*)\s+([\d.]*)\s+([\d/\+]+)\s+(.+)\s\[(\d+)\]$%;
 149     if (!defined $name) {
 150         debugmsg(0, "Unable to parse \"$_\"\n");
 151         next;
 152     }
 153
 154     # Check if this function was called at all
 155     if ($used_only) {
 156         my ($this, $total) = split(/\//, $countinfo);
 157         return unless (defined $total && 0 < $this);
 158     }
 159
 160     debugmsg(1, "Called: $countinfo\n");
 161
 162     $name = save_func_name($name, $index);
 163
 164     if ($current) {
 165         push(@children, $name);
 166     } else {
 167         push(@parents, $name);
 168     }
 169 }
 170
 171 #
 172 # Store decoded function name in hash with the function index as key
 173 #
 174 sub save_func_name {
 175     my ($name, $id) = @_;
 176     my $current = $name;
 177
 178     # Remove cycle information
 179     $current =~ s/\s*\<.+\>//;
 180
 181     $func{$id} = $current;
 182     debugmsg(1, "Name: \"$name\" -> \"$current\"\n");
 183     return $id;
 184 }
 185 #
 186 # Output current graph database
 187 #
 188 sub dump_graph_raw {
 189     my $current;
 190     for $current (sort sort_func_name keys %func) {
 191         my $name = $func{$current};
 192         print "Func: \"" . $name . "\" [$current]\n";
 193
 194         # Print callers
 195         if (defined $pre{$current}) {
 196             my $f;
 197             for $f (sort sort_func_name @{$pre{$current}}) {
 198                 print " " . $func{$f} . " [$f] -> \"$name\"\n";
 199             }
 200         }
 201
 202         # Print called
 203         if (defined $post{$current}) {
 204             my $f;
 205             for $f (sort sort_func_name @{$post{$current}}) {
 206                 print " \"$name\" -> \"" . $func{$f} . "\" [$f]\n";
 207             }
 208         }
 209     }
 210 }
 211
 212 sub vcg_edge
 213 {
 214     my ($src, $dst, $thickness, $comment) = @_;
 215     my $buffer = "  edge: {".
 216           " sourcename: \"$src\"".
 217           " targetname: \"$dst\"" .
 218           " thickness: $thickness }";
 219     $buffer .= " /* $comment */\n" if ($comment);
 220     return $buffer;
 221 }
 222
 223 #
 224 # Output current graph database in vcg format
 225 #
 226 sub dump_graph_vcg {
 227     my $current;
 228
 229     my %printed;
 230
 231     print <<EOF;
 232 /*
 233  * VCG formatted call graph for program "$program" based on gprof output.
 234  *
 235  * Check <URL:$url> for more information.
 236  */
 237
 238 graph: {
 239   title: "Profiling $program"
 240   orientation: left_to_right
 241
 242 EOF
 243
 244     # First print all the nodes
 245     for $current (sort sort_func_name keys %func) {
 246         my $name = $func{$current};
 247         print "  node: { title: \"$current\" label: \"$name\" borderwidth: 0}\n"
 248     }
 249
 250     print "\n";
 251
 252     # Then print all the edges
 253     for $current (sort sort_func_name keys %func) {
 254         my $name = $func{$current};
 255
 256         if (defined $pre{$current}) {
 257             my $content = 0;
 258             my $buffer = "  /* \"$name\" callers */\n";
 259             my $f;
 260             for $f (sort sort_func_name @{$pre{$current}}) {
 261                 if (!exists $printed{"$f:$current"}) {
 262                     my $prename = $func{$f};
 263                     my $thickness = 1;
 264                     $buffer .= vcg_edge($f, $current, $thickness, $prename);
 265                     $printed{"$f:$current"} = 1;
 266                     $content++;
 267                 }
 268             }
 269             $buffer .= "\n";
 270             print $buffer if (0 < $content);
 271         }
 272
 273         if (defined $post{$current}) {
 274             my $content = 0;
 275             my $buffer = "  /* \"$name\" called */\n";
 276             my $f;
 277             for $f (sort sort_func_name @{$post{$current}}) {
 278                 if (!exists $printed{"$current:$f"}) {
 279                     my $postname = $func{$f};
 280                     my $thickness = 1;
 281                     $buffer .= vcg_edge($current, $f, $thickness, $postname);
 282                     $printed{"$current:$f"} = 1;
 283                     $content++;
 284                 }
 285             }
 286             $buffer .= "\n";
 287             print $buffer if (0 < $content);
 288         }
 289     }
 290     print <<EOF;
 291 }
 292 EOF
 293 }
 294 #
 295 # Output current graph database in daVinci format
 296 #
 297 sub dump_graph_daVinci {
 298     my $current;
 299
 300     my %printed = ();
 301
 302     print "[\n";
 303
 304     # First print all the nodes
 305     for $current (sort sort_func_name keys %func) {
 306         my $name = $func{$current};
 307         print "  l(\"$current\",n(\"$name\",[],[\n";
 308         # Print callers
 309         if (defined $pre{$current}) {
 310             my $f;
 311             for $f (sort sort_func_name @{$pre{$current}}) {
 312                 print "l(\"$f\"->\"$current\",e(\"B\",[],";
 313                 if ($printed{$f}) {
 314                     print "r(\"$f\"";
 315                 }
 316                 print "  edge: { sourcename: \"$f\" targetname: \"$current\"" .
 317                     " thickness: 1 }\n";
 318             }
 319         }
 320
 321         # Print called
 322         if (defined $post{$current}) {
 323             my $f;
 324             for $f (sort sort_func_name @{$post{$current}}) {
 325                 print "  edge: { sourcename: \"$current\" targetname: \"$f\"" .
 326                     " thickness: 1 }\n";
 327             }
 328         }
 329     }
 330     print <<EOF;
 331 }
 332 EOF
 333 }
 334
 335 sub debugmsg
 336 {
 337     my ($level, $msg) = @_;
 338     print STDERR $msg if ($level <= $debug);
 339 }