dprofpp.graphviz

   1 #!/usr/bin/env perl
   2 #
   3 # dprofpp.graphviz
   4 # File ID: eee09f82-6069-11de-b30a-000475e441b9
   5 #
   6 # This is a replacement for Devel::DProf's dproffpp,
   7 # which instead produces a graph from the tmon.out
   8 # file.
   9 #
  10 # Downloaded from
  11 # http://cpansearch.perl.org/src/LBROCARD/GraphViz-2.04/examples/dprofpp.graphviz
  12 #
  13 # Example usage:
  14 #   perl -d:DProf test.pl
  15 #   dprofpp.graphviz tmon.out
  16 #
  17 # Will create a file _tmon.png
  18
  19 use strict;
  20 use lib '..';
  21 use GraphViz;
  22
  23 1 until <> eq "PART2\n";
  24
  25 my %package;
  26 my %subroutine;
  27 my %name;
  28 my %id;
  29
  30 my %calls;
  31 my %call_tree;
  32
  33 my @stack = (-1);
  34 $package{-1} = 'main';
  35 $subroutine{-1} = 'main';
  36 $name{-1} = 'main::main';
  37
  38 my $maxcalls;
  39
  40 while (defined(my $line = <>)) {
  41   chomp $line;
  42
  43   if (my($id, $package, $subroutine) = $line =~ m/^& (.+?) (.+?) (.+?)$/) {
  44     my $name = "$package::$subroutine";
  45     $name{$id} = $package . '::' . $subroutine;
  46     $package{$id} = $package;
  47     $subroutine{$id} = $subroutine;
  48   } elsif (my($id) = $line =~ m/^\+ (.+?)$/) {
  49     if (ignore($id)) {
  50       $calls{$id}++;
  51       $call_tree{$stack[-1]}{$id}++;
  52       $maxcalls = $call_tree{$stack[-1]}{$id} > $maxcalls ? $call_tree{$stack[-1]}{$id} : $maxcalls;
  53     }
  54     push @stack, $id;
  55   } elsif (my($id) = $line =~ m/^\- (.+?)$/) {
  56     die "Pop problem!" unless $id = pop @stack;
  57   }
  58 }
  59
  60 warn "Stack not empty: (" . (join ', ', @stack) . ')!' if @stack > 1;
  61
  62 my %time;
  63 my $maxtime = 0.00000001; # To avoid division by zero in traverse() on fast machines
  64
  65 my %id = reverse %name;
  66
  67 my $text = `dprofpp -q -O 50000 tmon.out`;
  68 foreach my $line (split /\n/, $text) {
  69   my(undef, $time, $excl, $cumul, $calls, $secspcall, $callspsec, $name) = split /\s+/, $line;
  70   next unless ignore($id{$name});
  71   $maxtime = $excl > $maxtime ? $excl : $maxtime;
  72   $time{$id{$name}} = $excl;
  73 #  print "$name $excl\n";
  74 }
  75
  76 my $g = GraphViz->new;
  77
  78 my %traversed;
  79
  80 traverse(-1);
  81
  82 sub traverse {
  83   my $id = shift;
  84   return if $traversed{$id}++;
  85
  86   my $count = $time{$id};
  87   my $ratio = $count / $maxtime;
  88   my $w = 100 * (1 - $ratio);
  89
  90   $g->add_node($name{$id}, label => $subroutine{$id}, cluster => $package{$id}, color => "0,1,$ratio", w => $w);
  91
  92   my @called = sort keys %{$call_tree{$id}};
  93
  94   foreach my $called_id (@called) {
  95     traverse($called_id);
  96     my $count = $call_tree{$id}{$called_id};
  97     my $ratio = $count / $maxcalls;
  98     my $w = 100 * (1 - $ratio);
  99
 100
 101     $count = "" if $count == 1;
 102     $g->add_edge($name{$id} => $name{$called_id}, label => $count, color => "0,1,$ratio", w => $w, len => 2);
 103   }
 104 }
 105
 106 #print $g->_as_debug;
 107 open(FP, ">", "_tmon.png") || die("$0: tmon.png: Cannot create file: $!\n");
 108 print(FP $g->as_png);
 109 close(FP);
 110
 111 sub ignore {
 112   my $id = shift;
 113   return 0 if $subroutine{$id} eq 'BEGIN';
 114   return 0 if $subroutine{$id} eq 'END';
 115   return 0 if $subroutine{$id} eq '__ANON__';
 116 #  return 0 if $subroutine{$id} =~ /double|square|cons|id|flip|fst|snd|min|max/; # temporary for clarity
 117   return 1;
 118 }