#! /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;

  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-3.5.0\n";
  exit;
}

sub shortHelp {
  print "See '$0 -h' for help.\n";
  exit;
}

sub printHelp {
  printHeader;

  print "Usage: callgrind_control [options] [pid|program-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 --help        Show this help text\n";
  print "  --version        Show version\n";
  print "  -l --long        Show more information\n";
  print "  -s --stat        Show statistics\n";
  print "  -b --back        Show stack/back trace\n";
  print "  -e [<A>,...]     Show event counters for <A>,... (default: all)\n";
  print "  --dump[=<s>]     Request a dump optionally using <s> as description\n";
  print "  -z --zero        Zero all event counters\n";
  print "  -k --kill        Kill\n";
  print "  --instr=<on|off> Switch instrumentation state on/off\n";
  print "  -w=<dir>         Specify the startup directory of an active 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;
$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|--help)$/) {
	printHelp;
    }
    elsif ($arg =~ /^--version$/) {
	printVersion;
    }
    elsif ($arg =~ /^(-l|--long)$/) {
	$printLong = 1;
	next;
    }
    elsif ($arg =~ /^(-s|--stat)$/) {
	$printStatus = 1;
	next;
    }
    elsif ($arg =~ /^(-b|--back)$/) {
	$printBacktrace = 1;
	next;
    }
    elsif ($arg =~ /^-e$/) {
	$requestEvents = 1;
	next;
    }
    elsif ($arg =~ /^(-d|--dump)(|=.*)$/) {
	if ($2 ne "") {
	    $requestDump = 2;
	    $dumpHint = substr($2,1);
	}
	else {
	    # take next argument as dump hint
	    $requestDump = 1;
	}
	next;
    }
    elsif ($arg =~ /^(-z|--zero)$/) {
	$requestZero = 1;
	next;
    }
    elsif ($arg =~ /^(-k|--kill)$/) {
	$requestKill = 1;
	next;
    }
    elsif ($arg =~ /^(-i|--instr)(|=on|=off)$/) {
	$switchInstr = 2;
	if ($2 eq "=on") {
	    $switchInstrMode = "+";
	}
	elsif ($2 eq "=off") {
	    $switchInstrMode = "-";
	}
	else {
	    # check next argument for "on" or "off"
	    $switchInstr = 1;
	}
	next;
    }
    elsif ($arg =~ /^-w(|=.*)$/) {
	if ($1 ne "") {
	    $gotW = 2;
	    $workingDir = substr($1,1);
	}
	else {
	    # take next argument as working directory
	    $gotW = 1;
	}
	next;
    }
    else {
	print "Error: unknown command line option '$arg'.\n";
	shortHelp;
    }
  }

  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;
      if ($arg eq "on") {
	  $switchInstrMode = "+";
      }
      elsif ($arg eq "off") {
	  $switchInstrMode = "-";
      }
      else {
	  print "Error: need to specify 'on' or 'off' after '-i'.\n";
	  shortHelp;
      }
      next;
    }
  }

  if ($gotW == 1) {
      $gotW = 2;
      $workingDir = $arg;
      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; }

  print "Error: Callgrind task with PID/name '$arg' not detected.\n";
  shortHelp;
}

if ($gotW == 1) {
  print "Error: no directory specified after '-w'.\n";
  shortHelp;
}

if ($switchInstr == 1) {
  print "Error: need to specify 'on' or 'off' after '-i'.\n";
  shortHelp;
}

if ($workingDir ne "") {
    if (!-d $workingDir) {
	print "Error: directory '$workingDir' does not exist.\n";
	shortHelp;
    }

    # 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";
}