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