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