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