zenithsiz/ftmemsim-valgrind
1
0
Fork 0
mirror of https://github.com/Zenithsiz/ftmemsim-valgrind.git synced 2026-02-03 18:13:01 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
ftmemsim-valgrind/callgrind/callgrind_control.in
Josef Weidendorfer ef6f20cad4 callgrind_control: Fix behavior with callgrind runs of another user 
callgrind_control uses files /tmp/callgrind.info.* to be able to
locate running callgrind processes. These files can be read only by
the user which started callgrind. The callgrind_control script
did not check for "permission denied" on opening these files, which
resulted in some unexpected errors. Now, it is checked whether
the "open" was successful, and if not, we skip the according callgrind
process.

Fixes bug 149963.


git-svn-id: svn://svn.valgrind.org/valgrind/trunk@6861
2007-09-18 19:12:57 +00:00

488 lines
12 KiB
Perl
Raw Blame History

#! /usr/bin/perl -w
##--------------------------------------------------------------------##
##--- Control supervision of applications run with callgrind ---##
##--- callgrind_control ---##
##--------------------------------------------------------------------##
# This file is part of Callgrind, a cache-simulator and call graph
# tracer built on Valgrind.
#
# Copyright (C) 2003,2004,2005 Josef Weidendorfer
# Josef.Weidendorfer@gmx.de
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; either version 2 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307, USA.
sub getCallgrindPids {
@pids = ();
foreach $f (</tmp/callgrind.info.*>) {
($pid) = ($f =~ /info\.(\d+)/);
if ($pid eq "") { next; }
$mapfile = "/proc/$pid/maps";
if (!-e $mapfile) { next; }
open MAP, "<$mapfile";
$found = 0;
while(<MAP>) {
# works both for VG 3.0 and VG 3.1+
if (/callgrind/) { $found = 1; }
}
close MAP;
if ($found == 0) { next; }
$res = open INFO, "<$f";
if (!$res) { next; }
while(<INFO>) {
if (/version: (\d+)/) { $mversion{$pid} = $1; }
if (/cmd: (.+)$/) { $cmd{$pid} = $1; }
if (/control: (.+)$/) { $control{$pid} = $1; }
if (/base: (.+)$/) { $base{$pid} = $1; }
if (/result: (.+)$/) { $result{$pid} = $1; }
}
close INFO;
if ($mversion{$pid} > 1) {
print " PID $pid: Unsupported command interface (version $mversion{$pid}) ?!\n\n";
next;
}
push(@pids, $pid);
}
}
sub printHeader {
if ($headerPrinted) { return; }
$headerPrinted = 1;
if ($beQuiet) { return; }
print "Observe the status and control currently active callgrind runs.\n";
print "(C) 2003-2005, Josef Weidendorfer (Josef.Weidendorfer\@gmx.de)\n\n";
}
sub printVersion {
print "callgrind_control-@VERSION@\n";
exit;
}
sub printHelp {
printHeader;
print "Usage: callgrind_control [options] [ <PID>|<Name> ...]\n\n";
print "If no PIDs/Names are given, an action is applied to all currently\n";
print "active Callgrind runs. Default action is printing short information.\n\n";
print "Options:\n";
print " -h Print this help text\n";
print " -v Print version\n";
print " -q Be quiet\n";
print " -l Print more information\n";
print " -s Print status information\n";
print " -b Print backtrace information\n";
print " -e [A,..] Print event counters for A,.. [default: all]\n";
print " -d [str] Request a profile dump, include <str> as trigger hint\n";
print " -z Zero all cost counters\n";
print " -k Kill\n";
print " -i on/off Switch instrumentation state on/off\n";
print " -w <dir> Manually specify the working directory of a callgrind run\n";
print "\n";
exit;
}
#
# Parts more or less copied from ct_annotate (author: Nicholas Nethercote)
#
sub prepareEvents {
@events = split(/\s+/, $events);
%events = ();
$n = 0;
foreach $event (@events) {
$events{$event} = $n;
$n++;
}
if (@show_events) {
foreach my $show_event (@show_events) {
(defined $events{$show_event}) or
print "Warning: Event `$show_event' is not being collected\n";
}
} else {
@show_events = @events;
}
@show_order = ();
foreach my $show_event (@show_events) {
push(@show_order, $events{$show_event});
}
}
sub max ($$)
{
my ($x, $y) = @_;
return ($x > $y ? $x : $y);
}
sub line_to_CC ($)
{
my @CC = (split /\s+/, $_[0]);
(@CC <= @events) or die("Line $.: too many event counts\n");
return \@CC;
}
sub commify ($) {
my ($val) = @_;
1 while ($val =~ s/^(\d+)(\d{3})/$1,$2/);
return $val;
}
sub compute_CC_col_widths (@)
{
my @CCs = @_;
my $CC_col_widths = [];
# Initialise with minimum widths (from event names)
foreach my $event (@events) {
push(@$CC_col_widths, length($event));
}
# Find maximum width count for each column. @CC_col_width positions
# correspond to @CC positions.
foreach my $CC (@CCs) {
foreach my $i (0 .. scalar(@$CC)-1) {
if (defined $CC->[$i]) {
# Find length, accounting for commas that will be added
my $length = length $CC->[$i];
my $clength = $length + int(($length - 1) / 3);
$CC_col_widths->[$i] = max($CC_col_widths->[$i], $clength);
}
}
}
return $CC_col_widths;
}
# Print the CC with each column's size dictated by $CC_col_widths.
sub print_CC ($$)
{
my ($CC, $CC_col_widths) = @_;
foreach my $i (@show_order) {
my $count = (defined $CC->[$i] ? commify($CC->[$i]) : ".");
my $space = ' ' x ($CC_col_widths->[$i] - length($count));
print("$space$count ");
}
}
sub print_events ($)
{
my ($CC_col_widths) = @_;
foreach my $i (@show_order) {
my $event = $events[$i];
my $event_width = length($event);
my $col_width = $CC_col_widths->[$i];
my $space = ' ' x ($col_width - $event_width);
print("$space$event ");
}
}
#
# Main
#
getCallgrindPids;
$requestEvents = 0;
$requestDump = 0;
$switchInstr = 0;
$headerPrinted = 0;
$beQuiet = 0;
$dumpHint = "";
$gotW = 0;
$workingDir = "";
%spids = ();
foreach $arg (@ARGV) {
if ($arg =~ /^-/) {
if ($requestDump == 1) { $requestDump = 2; }
if ($requestEvents == 1) { $requestEvents = 2; }
if ($gotW == 1) { $gotW = 2; }
if ($arg =~ /^-?-h/) { printHelp; }
if ($arg =~ /^-?-v/) { printVersion; }
if ($arg =~ /^-q/) { $beQuiet = 1; next; }
if ($arg =~ /^-l/) { $printLong = 1; next; }
if ($arg =~ /^-s/) { $printStatus = 1; next; }
if ($arg =~ /^-b/) { $printBacktrace = 1; next; }
if ($arg =~ /^-d/) { $requestDump = 1; next; }
if ($arg =~ /^-z/) { $requestZero = 1; next; }
if ($arg =~ /^-k/) { $requestKill = 1; next; }
if ($arg =~ /^-e/) { $requestEvents = 1; next; }
if ($arg =~ /^-i/) { $switchInstr = 1; next; }
if ($arg =~ /^-w/) { $gotW = 1; next; }
printHeader;
print "Unknown option '$arg'.\n\n";
printHelp;
}
if ($arg =~ /^[A-Za-z_]/) {
# arguments of -d/-e/-i are non-numeric
if ($requestDump == 1) {
$requestDump = 2;
$dumpHint = $arg;
next;
}
if ($requestEvents == 1) {
$requestEvents = 2;
@show_events = split(/,/, $arg);
next;
}
if ($switchInstr == 1) {
$switchInstr = 2;
$switchInstrMode = "+";
if (($arg eq "off") || ($arg eq "no")) {
$switchInstrMode = "-";
}
next;
}
}
if ($gotW == 1) {
$gotW = 2;
$workingDir = $arg;
if (!-d $workingDir) {
print "Error: directory '$workingDir' does not exist.\n";
printHelp;
}
next;
}
if (defined $cmd{$arg}) { $spids{$arg} = 1; next; }
$nameFound = 0;
foreach $p (@pids) {
if ($cmd{$p} =~ /^$arg/) {
$nameFound = 1;
$spids{$p} = 1;
}
}
if ($nameFound) { next; }
printHeader;
print "Non-existent Callgrind task with PID/Name '$arg'.\n\n";
printHelp;
}
if ($workingDir ne "") {
# Generate dummy information for dummy pid 0
$pid = "0";
$mversion{$pid} = "1.0";
$cmd{$pid} = "???";
$base{$pid} = $workingDir;
$control{$pid} = "$workingDir/callgrind.cmd";
$result{$pid} = "$workingDir/callgrind.res";
# Only handle this faked callgrind run
@pids = ($pid);
}
if (scalar @pids == 0) {
print "No active callgrind runs detected.\n";
#print "Detection fails when /proc/*/maps is not readable.\n";
print "[Detection can fail on some systems; to work around this,\n";
print " specify the working directory of a callgrind run with '-w']\n";
exit;
}
@spids = keys %spids;
if (scalar @spids >0) { @pids = @spids; }
$command = "";
$waitForAnswer = 0;
if ($requestDump) {
$command = "Dump";
if ($dumpHint ne "") { $command .= " ".$dumpHint; }
}
if ($requestZero) { $command = "Zero"; }
if ($requestKill) { $command = "Kill"; }
if ($switchInstr) { $command = $switchInstrMode."Instrumentation"; }
if ($printStatus || $printBacktrace || $requestEvents) {
$command = "Status";
$waitForAnswer = 1;
}
foreach $pid (@pids) {
$pidstr = "PID $pid: ";
if ($pid >0) { print $pidstr.$cmd{$pid}; }
if ($command eq "") {
if ($printLong) {
#print " " x length $pidstr;
print " (in $base{$pid})\n";
}
else {
print "\n";
}
next;
}
else {
if (! (open CONTROL, ">$control{$pid}")) {
print " [sending '$command' failed: permission denied]\n";
next;
}
print " [requesting '$command'...]\n";
print CONTROL $command;
close CONTROL;
while(-e $control{$pid}) {
# sleep for 250 ms
select(undef, undef, undef, 0.25);
}
}
#print "Reading ".$result{$pid}. "...\n";
if ($result{$pid} eq "") { $waitForAnswer=0; }
if (!$waitForAnswer) { print " OK.\n"; next; }
if (! (open RESULT, "<$result{$pid}")) {
print " Warning: Can't open expected result file $result{$pid}.\n";
next;
}
@tids = ();
$ctid = 0;
%fcount = ();
%func = ();
%calls = ();
%events = ();
@events = ();
@threads = ();
%totals = ();
$exec_bbs = 0;
$dist_bbs = 0;
$exec_calls = 0;
$dist_calls = 0;
$dist_ctxs = 0;
$dist_funcs = 0;
$threads = "";
$events = "";
while(<RESULT>) {
if (/function-(\d+)-(\d+): (.+)$/) {
if ($ctid != $1) {
$ctid = $1;
push(@tids, $ctid);
$fcount{$ctid} = 0;
}
$fcount{$ctid}++;
$func{$ctid,$fcount{$ctid}} = $3;
}
elsif (/calls-(\d+)-(\d+): (.+)$/) {
if ($ctid != $1) { next; }
$calls{$ctid,$fcount{$ctid}} = $3;
}
elsif (/events-(\d+)-(\d+): (.+)$/) {
if ($ctid != $1) { next; }
$events{$ctid,$fcount{$ctid}} = line_to_CC($3);
}
elsif (/events-(\d+): (.+)$/) {
if (scalar @events == 0) { next; }
$totals{$1} = line_to_CC($2);
}
elsif (/executed-bbs: (\d+)/) { $exec_bbs = $1; }
elsif (/distinct-bbs: (\d+)/) { $dist_bbs = $1; }
elsif (/executed-calls: (\d+)/) { $exec_calls = $1; }
elsif (/distinct-calls: (\d+)/) { $dist_calls = $1; }
elsif (/distinct-functions: (\d+)/) { $dist_funcs = $1; }
elsif (/distinct-contexts: (\d+)/) { $dist_ctxs = $1; }
elsif (/events: (.+)$/) { $events = $1; prepareEvents; }
elsif (/threads: (.+)$/) { $threads = $1; @threads = split " ", $threads; }
elsif (/instrumentation: (\w+)$/) { $instrumentation = $1; }
}
unlink $result{$pid};
if ($instrumentation eq "off") {
print " No information available as instrumentation is switched off.\n\n";
exit;
}
if ($printStatus) {
if ($requestEvents <1) {
print " Number of running threads: " .($#threads+1). ", thread IDs: $threads\n";
print " Events collected: $events\n";
}
print " Functions: ".commify($dist_funcs);
print " (executed ".commify($exec_calls);
print ", contexts ".commify($dist_ctxs).")\n";
print " Basic blocks: ".commify($dist_bbs);
print " (executed ".commify($exec_bbs);
print ", call sites ".commify($dist_calls).")\n";
}
if ($requestEvents >0) {
$totals_width = compute_CC_col_widths(values %totals);
print "\n Totals:";
print_events($totals_width);
print("\n");
foreach $tid (@tids) {
print " Th".substr(" ".$tid,-2)." ";
print_CC($totals{$tid}, $totals_width);
print("\n");
}
}
if ($printBacktrace) {
if ($requestEvents >0) {
$totals_width = compute_CC_col_widths(values %events);
}
foreach $tid (@tids) {
print "\n Frame: ";
if ($requestEvents >0) {
print_events($totals_width);
}
print "Backtrace for Thread $tid\n";
$i = $fcount{$tid};
$c = 0;
while($i>0 && $c<100) {
$fc = substr(" $c",-2);
print " [$fc] ";
if ($requestEvents >0) {
print_CC($events{$tid,$i-1}, $totals_width);
}
print $func{$tid,$i};
if ($i > 1) {
print " (".$calls{$tid,$i-1}." x)";
}
print "\n";
$i--;
$c++;
}
print "\n";
}
}
print "\n";
}
Reference in New Issue View Git Blame Copy Permalink