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 -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 "\n";
     82   exit;
     83 }
     84 
     85 
     86 #
     87 # Parts more or less copied from cg_annotate (author: Nicholas Nethercote)
     88 #
     89 
     90 sub prepareEvents {
     91 
     92   @events = split(/\s+/, $events);
     93   %events = ();
     94   $n = 0;
     95   foreach $event (@events) {
     96     $events{$event} = $n;
     97     $n++;
     98   }
     99   if (@show_events) {
    100     foreach my $show_event (@show_events) {
    101       (defined $events{$show_event}) or
    102 	print "Warning: Event `$show_event' is not being collected\n";
    103     }
    104   } else {
    105     @show_events = @events;
    106   }
    107   @show_order = ();
    108   foreach my $show_event (@show_events) {
    109     push(@show_order, $events{$show_event});
    110   }
    111 }
    112 
    113 sub max ($$) 
    114 {
    115     my ($x, $y) = @_;
    116     return ($x > $y ? $x : $y);
    117 }
    118 
    119 sub line_to_CC ($)
    120 {
    121     my @CC = (split /\s+/, $_[0]);
    122     (@CC <= @events) or die("Line $.: too many event counts\n");
    123     return \@CC;
    124 }
    125 
    126 sub commify ($) {
    127     my ($val) = @_;
    128     1 while ($val =~ s/^(\d+)(\d{3})/$1,$2/);
    129     return $val;
    130 }
    131 
    132 sub compute_CC_col_widths (@) 
    133 {
    134     my @CCs = @_;
    135     my $CC_col_widths = [];
    136 
    137     # Initialise with minimum widths (from event names)
    138     foreach my $event (@events) {
    139         push(@$CC_col_widths, length($event));
    140     }
    141     
    142     # Find maximum width count for each column.  @CC_col_width positions
    143     # correspond to @CC positions.
    144     foreach my $CC (@CCs) {
    145         foreach my $i (0 .. scalar(@$CC)-1) {
    146             if (defined $CC->[$i]) {
    147                 # Find length, accounting for commas that will be added
    148                 my $length = length $CC->[$i];
    149                 my $clength = $length + int(($length - 1) / 3);
    150                 $CC_col_widths->[$i] = max($CC_col_widths->[$i], $clength); 
    151             }
    152         }
    153     }
    154     return $CC_col_widths;
    155 }
    156 
    157 # Print the CC with each column's size dictated by $CC_col_widths.
    158 sub print_CC ($$) 
    159 {
    160     my ($CC, $CC_col_widths) = @_;
    161 
    162     foreach my $i (@show_order) {
    163         my $count = (defined $CC->[$i] ? commify($CC->[$i]) : ".");
    164         my $space = ' ' x ($CC_col_widths->[$i] - length($count));
    165         print("$space$count ");
    166     }
    167 }
    168 
    169 sub print_events ($)
    170 {
    171     my ($CC_col_widths) = @_;
    172 
    173     foreach my $i (@show_order) { 
    174         my $event       = $events[$i];
    175         my $event_width = length($event);
    176         my $col_width   = $CC_col_widths->[$i];
    177         my $space       = ' ' x ($col_width - $event_width);
    178         print("$space$event ");
    179     }
    180 }
    181 
    182 
    183 
    184 #
    185 # Main
    186 #
    187 
    188 getCallgrindPids;
    189 
    190 $requestEvents = 0;
    191 $requestDump = 0;
    192 $switchInstr = 0;
    193 $headerPrinted = 0;
    194 $dumpHint = "";
    195 $verbose = 0;
    196 
    197 %spids = ();
    198 foreach $arg (@ARGV) {
    199   if ($arg =~ /^-/) {
    200     if ($requestDump == 1) { $requestDump = 2; }
    201     if ($requestEvents == 1) { $requestEvents = 2; }
    202 
    203     if ($arg =~ /^(-h|--help)$/) {
    204 	printHelp;
    205     }
    206     elsif ($arg =~ /^--version$/) {
    207 	printVersion;
    208     }
    209     elsif ($arg =~ /^-v$/) {
    210 	$verbose++;
    211 	next;
    212     }
    213     elsif ($arg =~ /^(-s|--stat)$/) {
    214 	$printStatus = 1;
    215 	next;
    216     }
    217     elsif ($arg =~ /^(-b|--back)$/) {
    218 	$printBacktrace = 1;
    219 	next;
    220     }
    221     elsif ($arg =~ /^-e$/) {
    222 	$requestEvents = 1;
    223 	next;
    224     }
    225     elsif ($arg =~ /^(-d|--dump)(|=.*)$/) {
    226 	if ($2 ne "") {
    227 	    $requestDump = 2;
    228 	    $dumpHint = substr($2,1);
    229 	}
    230 	else {
    231 	    # take next argument as dump hint
    232 	    $requestDump = 1;
    233 	}
    234 	next;
    235     }
    236     elsif ($arg =~ /^(-z|--zero)$/) {
    237 	$requestZero = 1;
    238 	next;
    239     }
    240     elsif ($arg =~ /^(-k|--kill)$/) {
    241 	$requestKill = 1;
    242 	next;
    243     }
    244     elsif ($arg =~ /^(-i|--instr)(|=on|=off)$/) {
    245 	$switchInstr = 2;
    246 	if ($2 eq "=on") {
    247 	    $switchInstrMode = "on";
    248 	}
    249 	elsif ($2 eq "=off") {
    250 	    $switchInstrMode = "off";
    251 	}
    252 	else {
    253 	    # check next argument for "on" or "off"
    254 	    $switchInstr = 1;
    255 	}
    256 	next;
    257     }
    258     else {
    259 	print "Error: unknown command line option '$arg'.\n";
    260 	shortHelp;
    261     }
    262   }
    263 
    264   if ($arg =~ /^[A-Za-z_]/) {
    265     # arguments of -d/-e/-i are non-numeric
    266     if ($requestDump == 1) {
    267       $requestDump = 2;
    268       $dumpHint = $arg;
    269       next;
    270     }
    271 
    272     if ($requestEvents == 1) {
    273       $requestEvents = 2;
    274       @show_events = split(/,/, $arg);
    275       next;
    276     }
    277 
    278     if ($switchInstr == 1) {
    279       $switchInstr = 2;
    280       if ($arg eq "on") {
    281 	  $switchInstrMode = "on";
    282       }
    283       elsif ($arg eq "off") {
    284 	  $switchInstrMode = "off";
    285       }
    286       else {
    287 	  print "Error: need to specify 'on' or 'off' after '-i'.\n";
    288 	  shortHelp;
    289       }
    290       next;
    291     }
    292   }
    293 
    294   if (defined $cmd{$arg}) { $spids{$arg} = 1; next; }
    295   $nameFound = 0;
    296   foreach $p (@pids) {
    297     if ($cmd{$p} =~ /$arg$/) {
    298       $nameFound = 1;
    299       $spids{$p} = 1;
    300     }
    301   }
    302   if ($nameFound) { next; }
    303 
    304   print "Error: Callgrind task with PID/name '$arg' not detected.\n";
    305   shortHelp;
    306 }
    307 
    308 
    309 if ($switchInstr == 1) {
    310   print "Error: need to specify 'on' or 'off' after '-i'.\n";
    311   shortHelp;
    312 }
    313 
    314 if (scalar @pids == 0) {
    315   print "No active callgrind runs detected.\n";
    316   exit;
    317 }
    318 
    319 @spids = keys %spids;
    320 if (scalar @spids >0) { @pids = @spids; }
    321 
    322 $vgdbCommand = "";
    323 $waitForAnswer = 0;
    324 if ($requestDump) {
    325   $vgdbCommand = "dump";
    326   if ($dumpHint ne "") { $vgdbCommand .= " ".$dumpHint; }
    327 }
    328 if ($requestZero) { $vgdbCommand = "zero"; }
    329 if ($requestKill) { $vgdbCommand = "v.kill"; }
    330 if ($switchInstr) { $vgdbCommand = "instrumentation ".$switchInstrMode; }
    331 if ($printStatus || $printBacktrace || $requestEvents) {
    332   $vgdbCommand = "status internal";
    333   $waitForAnswer = 1;
    334 }
    335 
    336 foreach $pid (@pids) {
    337   $pidstr = "PID $pid: ";
    338   if ($pid >0) { print $pidstr.$cmdline{$pid}; }
    339 
    340   if ($vgdbCommand eq "") {
    341       print "\n";
    342       next;
    343   }
    344   if ($verbose>0) {
    345       print " [requesting '$vgdbCommand']\n";
    346   } else {
    347       print "\n";
    348   }
    349   open RESULT, "vgdb --pid=$pid $vgdbCommand|";
    350 
    351   @tids = ();
    352   $ctid = 0;
    353   %fcount = ();
    354   %func = ();
    355   %calls = ();
    356   %events = ();
    357   @events = ();
    358   @threads = ();
    359   %totals = ();
    360 
    361   $exec_bbs = 0;
    362   $dist_bbs = 0;
    363   $exec_calls = 0;
    364   $dist_calls = 0;
    365   $dist_ctxs = 0;
    366   $dist_funcs = 0;
    367   $threads = "";
    368   $events = "";
    369 
    370   while(<RESULT>) {
    371     if (/function-(\d+)-(\d+): (.+)$/) {
    372       if ($ctid != $1) {
    373 	$ctid = $1;
    374 	push(@tids, $ctid);
    375 	$fcount{$ctid} = 0;
    376       }
    377       $fcount{$ctid}++;
    378       $func{$ctid,$fcount{$ctid}} = $3;
    379     }
    380     elsif (/calls-(\d+)-(\d+): (.+)$/) {
    381       if ($ctid != $1) { next; }
    382       $calls{$ctid,$fcount{$ctid}} = $3;
    383     }
    384     elsif (/events-(\d+)-(\d+): (.+)$/) {
    385       if ($ctid != $1) { next; }
    386       $events{$ctid,$fcount{$ctid}} = line_to_CC($3);
    387     }
    388     elsif (/events-(\d+): (.+)$/) {
    389       if (scalar @events == 0) { next; }
    390       $totals{$1} = line_to_CC($2);
    391     }
    392     elsif (/executed-bbs: (\d+)/) { $exec_bbs = $1; }
    393     elsif (/distinct-bbs: (\d+)/) { $dist_bbs = $1; }
    394     elsif (/executed-calls: (\d+)/) { $exec_calls = $1; }
    395     elsif (/distinct-calls: (\d+)/) { $dist_calls = $1; }
    396     elsif (/distinct-functions: (\d+)/) { $dist_funcs = $1; }
    397     elsif (/distinct-contexts: (\d+)/) { $dist_ctxs = $1; }
    398     elsif (/events: (.+)$/) { $events = $1; prepareEvents; }
    399     elsif (/threads: (.+)$/) { $threads = $1; @threads = split " ", $threads; }
    400     elsif (/instrumentation: (\w+)$/) { $instrumentation = $1; }
    401   }
    402 
    403   #if ($? ne "0") { print " Got Error $?\n"; }
    404   if (!$waitForAnswer) { print "  OK.\n"; next; }
    405 
    406   if ($instrumentation eq "off") {
    407     print "  No information available as instrumentation is switched off.\n\n";
    408     exit;
    409   }
    410 
    411   if ($printStatus) {
    412     if ($requestEvents <1) {
    413       print "  Number of running threads: " .($#threads+1). ", thread IDs: $threads\n";
    414       print "  Events collected: $events\n";
    415     }
    416 
    417     print "  Functions: ".commify($dist_funcs);
    418     print " (executed ".commify($exec_calls);
    419     print ", contexts ".commify($dist_ctxs).")\n";
    420 
    421     print "  Basic blocks: ".commify($dist_bbs);
    422     print " (executed ".commify($exec_bbs);
    423     print ", call sites ".commify($dist_calls).")\n";
    424   }
    425 
    426   if ($requestEvents >0) {
    427     $totals_width = compute_CC_col_widths(values %totals);
    428     print "\n  Totals:";
    429     print_events($totals_width);
    430     print("\n");
    431     foreach $tid (@tids) {
    432       print "   Th".substr("  ".$tid,-2)."  ";
    433       print_CC($totals{$tid}, $totals_width);
    434       print("\n");
    435     }
    436   }
    437 
    438   if ($printBacktrace) {
    439 
    440     if ($requestEvents >0) {
    441       $totals_width = compute_CC_col_widths(values %events);
    442     }
    443 
    444     foreach $tid (@tids) {
    445       print "\n  Frame: ";
    446       if ($requestEvents >0) {
    447 	print_events($totals_width);
    448       }
    449       print "Backtrace for Thread $tid\n";
    450 
    451       $i = $fcount{$tid};
    452       $c = 0;
    453       while($i>0 && $c<100) {
    454 	$fc = substr(" $c",-2);
    455 	print "   [$fc]  ";
    456 	if ($requestEvents >0) {
    457 	  print_CC($events{$tid,$i-1}, $totals_width);
    458 	}
    459 	print $func{$tid,$i};
    460 	if ($i > 1) {
    461 	  print " (".$calls{$tid,$i-1}." x)";
    462 	}
    463 	print "\n";
    464 	$i--;
    465 	$c++;
    466       }
    467       print "\n";
    468     }
    469   }
    470   print "\n";
    471 }
    472 	
    473