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