Home | History | Annotate | Download | only in callgrind 
      1 #! /usr/bin/perl -w
      2 ##--------------------------------------------------------------------##
      3 ##--- Control supervision of applications run with callgrind       ---##
      4 ##---                                            callgrind_control ---##
      5 ##--------------------------------------------------------------------##
      6 
      7 #  This file is part of Callgrind, a cache-simulator and call graph
      8 #  tracer built on Valgrind.
      9 #
     10 #  Copyright (C) 2003-2011 Josef Weidendorfer <Josef.Weidendorfer (at] gmx.de>
     11 #
     12 #  This program is free software; you can redistribute it and/or
     13 #  modify it under the terms of the GNU General Public License as
     14 #  published by the Free Software Foundation; either version 2 of the
     15 #  License, or (at your option) any later version.
     16 #
     17 #  This program is distributed in the hope that it will be useful, but
     18 #  WITHOUT ANY WARRANTY; without even the implied warranty of
     19 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
     20 #  General Public License for more details.
     21 #
     22 #  You should have received a copy of the GNU General Public License
     23 #  along with this program; if not, write to the Free Software
     24 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
     25 #  02111-1307, USA.
     26 
     27 sub getCallgrindPids {
     28 
     29   @pids = ();
     30   open LIST, "vgdb $vgdbPrefixOption -l|";
     31   while(<LIST>) {
     32       if (/^use --pid=(\d+) for \S*?valgrind\s+(.*?)\s*$/) {
     33 	  $pid = $1;
     34 	  $cmd = $2;
     35 	  if (!($cmd =~ /--tool=callgrind/)) { next; }
     36 	  while($cmd =~ s/^-+\S+\s+//) {}
     37 	  $cmdline{$pid} = $cmd;
     38 	  $cmd =~ s/^(\S*).*/$1/;
     39 	  $cmd{$pid} = $cmd;
     40 	  #print "Found PID $pid, cmd '$cmd{$pid}', cmdline '$cmdline{$pid}'.\n";
     41 	  push(@pids, $pid);
     42       }
     43   }
     44   close LIST;
     45 }
     46 
     47 sub printHeader {
     48   if ($headerPrinted) { return; }
     49   $headerPrinted = 1;
     50 
     51   print "Observe the status and control currently active callgrind runs.\n";
     52   print "(C) 2003-2011, Josef Weidendorfer (Josef.Weidendorfer\@gmx.de)\n\n";
     53 }
     54 
     55 sub printVersion {
     56   print "callgrind_control-@VERSION@\n";
     57   exit;
     58 }
     59 
     60 sub shortHelp {
     61   print "See '$0 -h' for help.\n";
     62   exit;
     63 }
     64 
     65 sub printHelp {
     66   printHeader;
     67 
     68   print "Usage: callgrind_control [options] [pid|program-name...]\n\n";
     69   print "If no pids/names are given, an action is applied to all currently\n";
     70   print "active Callgrind runs. Default action is printing short information.\n\n";
     71   print "Options:\n";
     72   print "  -h --help         Show this help text\n";
     73   print "  --version         Show version\n";
     74   print "  -s --stat         Show statistics\n";
     75   print "  -b --back         Show stack/back trace\n";
     76   print "  -e [<A>,...]      Show event counters for <A>,... (default: all)\n";
     77   print "  --dump[=<s>]      Request a dump optionally using <s> as description\n";
     78   print "  -z --zero         Zero all event counters\n";
     79   print "  -k --kill         Kill\n";
     80   print "  -i --instr=on|off Switch instrumentation state on/off\n";
     81   print "Uncommon options:\n";
     82   print "  --vgdb-prefix=<prefix> Only provide this if the same was given to Valgrind\n";
     83   print "\n";
     84   exit;
     85 }
     86 
     87 
     88 #
     89 # Parts more or less copied from cg_annotate (author: Nicholas Nethercote)
     90 #
     91 
     92 sub prepareEvents {
     93 
     94   @events = split(/\s+/, $events);
     95   %events = ();
     96   $n = 0;
     97   foreach $event (@events) {
     98     $events{$event} = $n;
     99     $n++;
    100   }
    101   if (@show_events) {
    102     foreach my $show_event (@show_events) {
    103       (defined $events{$show_event}) or
    104 	print "Warning: Event `$show_event' is not being collected\n";
    105     }
    106   } else {
    107     @show_events = @events;
    108   }
    109   @show_order = ();
    110   foreach my $show_event (@show_events) {
    111     push(@show_order, $events{$show_event});
    112   }
    113 }
    114 
    115 sub max ($$) 
    116 {
    117     my ($x, $y) = @_;
    118     return ($x > $y ? $x : $y);
    119 }
    120 
    121 sub line_to_CC ($)
    122 {
    123     my @CC = (split /\s+/, $_[0]);
    124     (@CC <= @events) or die("Line $.: too many event counts\n");
    125     return \@CC;
    126 }
    127 
    128 sub commify ($) {
    129     my ($val) = @_;
    130     1 while ($val =~ s/^(\d+)(\d{3})/$1,$2/);
    131     return $val;
    132 }
    133 
    134 sub compute_CC_col_widths (@) 
    135 {
    136     my @CCs = @_;
    137     my $CC_col_widths = [];
    138 
    139     # Initialise with minimum widths (from event names)
    140     foreach my $event (@events) {
    141         push(@$CC_col_widths, length($event));
    142     }
    143     
    144     # Find maximum width count for each column.  @CC_col_width positions
    145     # correspond to @CC positions.
    146     foreach my $CC (@CCs) {
    147         foreach my $i (0 .. scalar(@$CC)-1) {
    148             if (defined $CC->[$i]) {
    149                 # Find length, accounting for commas that will be added
    150                 my $length = length $CC->[$i];
    151                 my $clength = $length + int(($length - 1) / 3);
    152                 $CC_col_widths->[$i] = max($CC_col_widths->[$i], $clength); 
    153             }
    154         }
    155     }
    156     return $CC_col_widths;
    157 }
    158 
    159 # Print the CC with each column's size dictated by $CC_col_widths.
    160 sub print_CC ($$) 
    161 {
    162     my ($CC, $CC_col_widths) = @_;
    163 
    164     foreach my $i (@show_order) {
    165         my $count = (defined $CC->[$i] ? commify($CC->[$i]) : ".");
    166         my $space = ' ' x ($CC_col_widths->[$i] - length($count));
    167         print("$space$count ");
    168     }
    169 }
    170 
    171 sub print_events ($)
    172 {
    173     my ($CC_col_widths) = @_;
    174 
    175     foreach my $i (@show_order) { 
    176         my $event       = $events[$i];
    177         my $event_width = length($event);
    178         my $col_width   = $CC_col_widths->[$i];
    179         my $space       = ' ' x ($col_width - $event_width);
    180         print("$space$event ");
    181     }
    182 }
    183 
    184 
    185 
    186 #
    187 # Main
    188 #
    189 
    190 # To find the list of active pids, we need to have
    191 # the --vgdb-prefix option if given.
    192 $vgdbPrefixOption = "";
    193 foreach $arg (@ARGV) {
    194     if ($arg =~ /^--vgdb-prefix=.*$/) {
    195         $vgdbPrefixOption=$arg;
    196     }
    197     next;
    198 }
    199 
    200 getCallgrindPids;
    201 
    202 $requestEvents = 0;
    203 $requestDump = 0;
    204 $switchInstr = 0;
    205 $headerPrinted = 0;
    206 $dumpHint = "";
    207 
    208 $verbose = 0;
    209 
    210 %spids = ();
    211 foreach $arg (@ARGV) {
    212   if ($arg =~ /^-/) {
    213     if ($requestDump == 1) { $requestDump = 2; }
    214     if ($requestEvents == 1) { $requestEvents = 2; }
    215 
    216     if ($arg =~ /^(-h|--help)$/) {
    217 	printHelp;
    218     }
    219     elsif ($arg =~ /^--version$/) {
    220 	printVersion;
    221     }
    222     elsif ($arg =~ /^--vgdb-prefix=.*$/) {
    223         # handled during the initial parsing.
    224         next;
    225     }
    226     elsif ($arg =~ /^-v$/) {
    227 	$verbose++;
    228 	next;
    229     }
    230     elsif ($arg =~ /^(-s|--stat)$/) {
    231 	$printStatus = 1;
    232 	next;
    233     }
    234     elsif ($arg =~ /^(-b|--back)$/) {
    235 	$printBacktrace = 1;
    236 	next;
    237     }
    238     elsif ($arg =~ /^-e$/) {
    239 	$requestEvents = 1;
    240 	next;
    241     }
    242     elsif ($arg =~ /^(-d|--dump)(|=.*)$/) {
    243 	if ($2 ne "") {
    244 	    $requestDump = 2;
    245 	    $dumpHint = substr($2,1);
    246 	}
    247 	else {
    248 	    # take next argument as dump hint
    249 	    $requestDump = 1;
    250 	}
    251 	next;
    252     }
    253     elsif ($arg =~ /^(-z|--zero)$/) {
    254 	$requestZero = 1;
    255 	next;
    256     }
    257     elsif ($arg =~ /^(-k|--kill)$/) {
    258 	$requestKill = 1;
    259 	next;
    260     }
    261     elsif ($arg =~ /^(-i|--instr)(|=on|=off)$/) {
    262 	$switchInstr = 2;
    263 	if ($2 eq "=on") {
    264 	    $switchInstrMode = "on";
    265 	}
    266 	elsif ($2 eq "=off") {
    267 	    $switchInstrMode = "off";
    268 	}
    269 	else {
    270 	    # check next argument for "on" or "off"
    271 	    $switchInstr = 1;
    272 	}
    273 	next;
    274     }
    275     else {
    276 	print "Error: unknown command line option '$arg'.\n";
    277 	shortHelp;
    278     }
    279   }
    280 
    281   if ($arg =~ /^[A-Za-z_]/) {
    282     # arguments of -d/-e/-i are non-numeric
    283     if ($requestDump == 1) {
    284       $requestDump = 2;
    285       $dumpHint = $arg;
    286       next;
    287     }
    288 
    289     if ($requestEvents == 1) {
    290       $requestEvents = 2;
    291       @show_events = split(/,/, $arg);
    292       next;
    293     }
    294 
    295     if ($switchInstr == 1) {
    296       $switchInstr = 2;
    297       if ($arg eq "on") {
    298 	  $switchInstrMode = "on";
    299       }
    300       elsif ($arg eq "off") {
    301 	  $switchInstrMode = "off";
    302       }
    303       else {
    304 	  print "Error: need to specify 'on' or 'off' after '-i'.\n";
    305 	  shortHelp;
    306       }
    307       next;
    308     }
    309   }
    310 
    311   if (defined $cmd{$arg}) { $spids{$arg} = 1; next; }
    312   $nameFound = 0;
    313   foreach $p (@pids) {
    314     if ($cmd{$p} =~ /$arg$/) {
    315       $nameFound = 1;
    316       $spids{$p} = 1;
    317     }
    318   }
    319   if ($nameFound) { next; }
    320 
    321   print "Error: Callgrind task with PID/name '$arg' not detected.\n";
    322   shortHelp;
    323 }
    324 
    325 
    326 if ($switchInstr == 1) {
    327   print "Error: need to specify 'on' or 'off' after '-i'.\n";
    328   shortHelp;
    329 }
    330 
    331 if (scalar @pids == 0) {
    332   print "No active callgrind runs detected.\n";
    333   exit;
    334 }
    335 
    336 @spids = keys %spids;
    337 if (scalar @spids >0) { @pids = @spids; }
    338 
    339 $vgdbCommand = "";
    340 $waitForAnswer = 0;
    341 if ($requestDump) {
    342   $vgdbCommand = "dump";
    343   if ($dumpHint ne "") { $vgdbCommand .= " ".$dumpHint; }
    344 }
    345 if ($requestZero) { $vgdbCommand = "zero"; }
    346 if ($requestKill) { $vgdbCommand = "v.kill"; }
    347 if ($switchInstr) { $vgdbCommand = "instrumentation ".$switchInstrMode; }
    348 if ($printStatus || $printBacktrace || $requestEvents) {
    349   $vgdbCommand = "status internal";
    350   $waitForAnswer = 1;
    351 }
    352 
    353 foreach $pid (@pids) {
    354   $pidstr = "PID $pid: ";
    355   if ($pid >0) { print $pidstr.$cmdline{$pid}; }
    356 
    357   if ($vgdbCommand eq "") {
    358       print "\n";
    359       next;
    360   }
    361   if ($verbose>0) {
    362       print " [requesting '$vgdbCommand']\n";
    363   } else {
    364       print "\n";
    365   }
    366   open RESULT, "vgdb $vgdbPrefixOption --pid=$pid $vgdbCommand|";
    367 
    368   @tids = ();
    369   $ctid = 0;
    370   %fcount = ();
    371   %func = ();
    372   %calls = ();
    373   %events = ();
    374   @events = ();
    375   @threads = ();
    376   %totals = ();
    377 
    378   $exec_bbs = 0;
    379   $dist_bbs = 0;
    380   $exec_calls = 0;
    381   $dist_calls = 0;
    382   $dist_ctxs = 0;
    383   $dist_funcs = 0;
    384   $threads = "";
    385   $events = "";
    386 
    387   while(<RESULT>) {
    388     if (/function-(\d+)-(\d+): (.+)$/) {
    389       if ($ctid != $1) {
    390 	$ctid = $1;
    391 	push(@tids, $ctid);
    392 	$fcount{$ctid} = 0;
    393       }
    394       $fcount{$ctid}++;
    395       $func{$ctid,$fcount{$ctid}} = $3;
    396     }
    397     elsif (/calls-(\d+)-(\d+): (.+)$/) {
    398       if ($ctid != $1) { next; }
    399       $calls{$ctid,$fcount{$ctid}} = $3;
    400     }
    401     elsif (/events-(\d+)-(\d+): (.+)$/) {
    402       if ($ctid != $1) { next; }
    403       $events{$ctid,$fcount{$ctid}} = line_to_CC($3);
    404     }
    405     elsif (/events-(\d+): (.+)$/) {
    406       if (scalar @events == 0) { next; }
    407       $totals{$1} = line_to_CC($2);
    408     }
    409     elsif (/executed-bbs: (\d+)/) { $exec_bbs = $1; }
    410     elsif (/distinct-bbs: (\d+)/) { $dist_bbs = $1; }
    411     elsif (/executed-calls: (\d+)/) { $exec_calls = $1; }
    412     elsif (/distinct-calls: (\d+)/) { $dist_calls = $1; }
    413     elsif (/distinct-functions: (\d+)/) { $dist_funcs = $1; }
    414     elsif (/distinct-contexts: (\d+)/) { $dist_ctxs = $1; }
    415     elsif (/events: (.+)$/) { $events = $1; prepareEvents; }
    416     elsif (/threads: (.+)$/) { $threads = $1; @threads = split " ", $threads; }
    417     elsif (/instrumentation: (\w+)$/) { $instrumentation = $1; }
    418   }
    419 
    420   #if ($? ne "0") { print " Got Error $?\n"; }
    421   if (!$waitForAnswer) { print "  OK.\n"; next; }
    422 
    423   if ($instrumentation eq "off") {
    424     print "  No information available as instrumentation is switched off.\n\n";
    425     exit;
    426   }
    427 
    428   if ($printStatus) {
    429     if ($requestEvents <1) {
    430       print "  Number of running threads: " .($#threads+1). ", thread IDs: $threads\n";
    431       print "  Events collected: $events\n";
    432     }
    433 
    434     print "  Functions: ".commify($dist_funcs);
    435     print " (executed ".commify($exec_calls);
    436     print ", contexts ".commify($dist_ctxs).")\n";
    437 
    438     print "  Basic blocks: ".commify($dist_bbs);
    439     print " (executed ".commify($exec_bbs);
    440     print ", call sites ".commify($dist_calls).")\n";
    441   }
    442 
    443   if ($requestEvents >0) {
    444     $totals_width = compute_CC_col_widths(values %totals);
    445     print "\n  Totals:";
    446     print_events($totals_width);
    447     print("\n");
    448     foreach $tid (@tids) {
    449       print "   Th".substr("  ".$tid,-2)."  ";
    450       print_CC($totals{$tid}, $totals_width);
    451       print("\n");
    452     }
    453   }
    454 
    455   if ($printBacktrace) {
    456 
    457     if ($requestEvents >0) {
    458       $totals_width = compute_CC_col_widths(values %events);
    459     }
    460 
    461     foreach $tid (@tids) {
    462       print "\n  Frame: ";
    463       if ($requestEvents >0) {
    464 	print_events($totals_width);
    465       }
    466       print "Backtrace for Thread $tid\n";
    467 
    468       $i = $fcount{$tid};
    469       $c = 0;
    470       while($i>0 && $c<100) {
    471 	$fc = substr(" $c",-2);
    472 	print "   [$fc]  ";
    473 	if ($requestEvents >0) {
    474 	  print_CC($events{$tid,$i-1}, $totals_width);
    475 	}
    476 	print $func{$tid,$i};
    477 	if ($i > 1) {
    478 	  print " (".$calls{$tid,$i-1}." x)";
    479 	}
    480 	print "\n";
    481 	$i--;
    482 	$c++;
    483       }
    484       print "\n";
    485     }
    486   }
    487   print "\n";
    488 }
    489 	
    490