#!/home/johnh/BIN/perl5 -w

#
# dmalloc_summarize
# Copyright (C) 1997 by USC/ISI
# $Id: dmalloc_summarize,v 1.6 1998/05/18 23:42:40 johnh Exp $
#
# Copyright (c) 1997 University of Southern California.
# All rights reserved.                                            
#                                                                
# Redistribution and use in source and binary forms are permitted
# provided that the above copyright notice and this paragraph are
# duplicated in all such forms and that any documentation, advertising
# materials, and other materials related to such distribution and use
# acknowledge that the software was developed by the University of
# Southern California, Information Sciences Institute.  The name of the
# University may not be used to endorse or promote products derived from
# this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
# 


sub usage {
    print STDERR <<END;
usage: $0 [executable] <logfile

Post-process a dmalloc logfile (read from standard input).

If an EXECUTABLE is specified, unknown symbols will be translated
according to that executable.
END
    exit 1;
}

require 5.000;
use strict;
use IPC::Open2;

# process args
use Getopt::Long;
&usage if ($#ARGV >= 0 && $ARGV[0] eq '-?');
my(%opts);
my($exe) = undef;
if ($#ARGV >= 0) {
    $exe = $ARGV[0];
};
# &GetOptions(\%opts, qw(v a e=s o=s@));
#&usage if ($#ARGV != 0);
my($totcount, $totgross) = (0, 0);

######################################################################

sub safe_inc {
    my($hashref, $key, $inc) = @_;
    if (!defined($hashref->{$key})) {
	$hashref->{$key} = $inc;
    } else {
	$hashref->{$key} += $inc;
    };
}

######################################################################

my($gdb_pid);

sub gdb_start {
    $SIG{'PIPE'} = sub { mydie("ERROR: premature end-of-data.\n"); };
    $gdb_pid = open2('GDB_RDR', 'GDB_WTR', 'gdb', '-nx', '-q', $exe) ||
	 die "$0: cannot run gdb on $exe\n";
    # tidy things up
    # prompt becomes a magic number to look for
    print GDB_WTR "set prompt (gdb)\\n\nset print asm-demangle on\nset height 0\n";
    # Start the program in hopes of linking the dynamic libraries
    # (this works on Linux/Redhat 5.0, at least).
    print GDB_WTR "b main\nrun\n";
}

my($gdb_sync_token) = 0;
sub gdb_sync {
    #
    # Sync up where we are in the gdb stream.
    # We do this by getting gdb to make a unique token
    # and then reading until we find it, plus one more line (for the prompt).
    #
    print GDB_WTR "echo MagicSyncToken-$gdb_sync_token\\n\n";
    my($line);
    while (defined($line = <GDB_RDR>)) {
	last if ($line =~ /^MagicSyncToken-$gdb_sync_token/);
    };
    $line = <GDB_RDR>;  # toss the prompt
    die "$0: gdb_sync sync problem\n" if ($line !~ /\(gdb\)/);
    $gdb_sync_token++;
}

sub never_called {
    <GDB_RDR>; <GDB_WTR>;   # hack for warnings
}

sub interpret_name {
    my($name) = @_;
    return $name if ($name !~ /^ra/);
    return $name if (!defined($exe));

    gdb_start() if (!defined($gdb_pid));

    ($a) = ($name =~ /ra=([0-9a-fA-FxX]+)/);
    return $name if (!defined($a));
    gdb_sync();
    print GDB_WTR "info line *($a)\n";
    my($something) = undef;
    my($file_line, $function);
    while (<GDB_RDR>) {
	# sample output:
	#
	# (gdb)
	# info line *(0x809f93e)
	# No line number information available for address 
	#   0x809f93e <TclObject::bind(char const *, int *)+26>
	# (gdb)
	# info line *(0x804bfd7)
	# Line 113 of "scheduler.cc"
	#    starts at address 0x804bfd0 <Scheduler::rc_schedule(Handler *, Event *, double)+12>
	#    and ends at 0x804bfea <Scheduler::rc_schedule(Handler *, Event *, double)+38>.
	# (gdb)
	#
	if (/^\(gdb\)$/) {
	    last if ($something);
	    next;   # skip prompts
	};
	$something = 1;
	if (/^Line (\d+) of "([^"]+)"/) { # "
	    $file_line = "$2:$1";
	};
	if (/\<(.*)\+\d+\>/) {
	    $function = $1;
	};
    };
    my($n) = "";
    $n .= "$function " if (defined($function));
    $n .= "[$file_line] " if (defined($file_line));
    $n .= " ($name)" if ($n ne '');
    $n = $name if ($n eq '');
    return $n;
}


######################################################################

my(%allocers) = ();

# read the data
sub read_data {
    while (<STDIN>) {
        next if (!/\d:\s+not freed:\s+'([^']+)'\s+\((\d+)\s+bytes\)\s+from\s+'([^']*)'$/);
        my($pointer, $size, $allocer) = ($1, $2, $3);
    
        if (!defined($allocers{$allocer})) {
    	$allocers{$allocer} = {};
    	$allocers{$allocer}->{'sizes'} = {};
        };
        safe_inc($allocers{$allocer}, 'nsizes', 1)
            if (!defined($allocers{$allocer}->{'sizes'}{$size}));
        safe_inc($allocers{$allocer}->{'sizes'}, $size, 1);
        safe_inc($allocers{$allocer}, 'subcount', 1);
        safe_inc($allocers{$allocer}, 'subgross', $size);
        $totcount++;
        $totgross += $size;
    }
}


# print the report
sub form {
    printf "%10s %10s %10s %s\n", @_[1,2,3,0];
}


sub by_size {
    return $allocers{$b}->{'subgross'} <=> $allocers{$a}->{'subgross'};
}

sub print_report {
    form ('function', 'size', 'count', 'gross');
    form ('total', '', $totcount, $totgross);
    $| = 0; $| = 1;   # flush stdio since we're going to fork
    my($allocer, $size);
    foreach $allocer (sort by_size keys %allocers) {
        my($head) = interpret_name($allocer);
        my($sizes);
        if ($allocers{$allocer}->{'nsizes'} > 1) {
    	my($subcount, $subgross) = ($allocers{$allocer}->{'subcount'},
    				    $allocers{$allocer}->{'subgross'});
            form($head, 'subtotal', $subcount, $subgross);
    	$head = "\"";
        };
        foreach $size (sort {$a<=>$b} keys %{$allocers{$allocer}->{'sizes'}}) {
    	my($count) = $allocers{$allocer}->{'sizes'}{$size};
    	my($gross) = $count * $size;
    	form ($head, $size, $count, $gross);
    	$head = "\"";
        };
    };
}

read_data;
print_report;

exit 0;