callgrind/callgrind_control.in

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