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@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 28sub 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 66sub 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 74sub printVersion { 75 print "callgrind_control-@VERSION@\n"; 76 exit; 77} 78 79sub shortHelp { 80 print "See '$0 -h' for help.\n"; 81 exit; 82} 83 84sub 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 111sub 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 134sub max ($$) 135{ 136 my ($x, $y) = @_; 137 return ($x > $y ? $x : $y); 138} 139 140sub 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 147sub commify ($) { 148 my ($val) = @_; 149 1 while ($val =~ s/^(\d+)(\d{3})/$1,$2/); 150 return $val; 151} 152 153sub 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. 179sub 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 190sub 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 209getCallgrindPids; 210 211$requestEvents = 0; 212$requestDump = 0; 213$switchInstr = 0; 214$headerPrinted = 0; 215$dumpHint = ""; 216$gotW = 0; 217$workingDir = ""; 218 219%spids = (); 220foreach $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 348if ($gotW == 1) { 349 print "Error: no directory specified after '-w'.\n"; 350 shortHelp; 351} 352 353if ($switchInstr == 1) { 354 print "Error: need to specify 'on' or 'off' after '-i'.\n"; 355 shortHelp; 356} 357 358if ($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 376if (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; 385if (scalar @spids >0) { @pids = @spids; } 386 387$command = ""; 388$waitForAnswer = 0; 389if ($requestDump) { 390 $command = "Dump"; 391 if ($dumpHint ne "") { $command .= " ".$dumpHint; } 392} 393if ($requestZero) { $command = "Zero"; } 394if ($requestKill) { $command = "Kill"; } 395if ($switchInstr) { $command = $switchInstrMode."Instrumentation"; } 396if ($printStatus || $printBacktrace || $requestEvents) { 397 $command = "Status"; 398 $waitForAnswer = 1; 399} 400 401foreach $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