# xprofile.pl - create profile report -*- cperl -*-
#
# Time-stamp: <03/11/01 21:19:19 keuchel@netwave.de>

# I have not tried loading symbols from pdb files. Using a map file
# seems to be easier.

use XML::Writer;        # Generate XML file
use Win32::API;         # Undecorate Win32 function names
use Getopt::Long;       # Command line parsing
use Pod::Usage;         # Help me, oh help me

$map_file   = $ENV{'XPROFILE_MAP'};
$prof       = $ENV{'XPROFILE_INPUT'};
$result     = $ENV{'XPROFILE_OUTPUT'};

# Taken from dbghelp.h -- I'm sure I didn't have to do this, but oh well..
# Enable full undecoration
use constant UNDNAME_COMPLETE                => 0x0000;
# Remove leading underscores from MS extended keywords
use constant UNDNAME_NO_LEADING_UNDERSCORES  => 0x0001;
# Disable expansion of MS extended keywords
use constant UNDNAME_NO_MS_KEYWORDS          => 0x0002;
# Disable expansion of return type for primary declaration
use constant UNDNAME_NO_FUNCTION_RETURNS     => 0x0004;
# Disable expansion of the declaration model
use constant UNDNAME_NO_ALLOCATION_MODEL     => 0x0008;
# Disable expansion of the declaration language specifier
use constant UNDNAME_NO_ALLOCATION_LANGUAGE  => 0x0010;
# NYI Disable expansion of MS keywords on the 'this' type for primary declaration
use constant UNDNAME_NO_MS_THISTYPE          => 0x0020;
# NYI Disable expansion of CV modifiers on the 'this' type for primary declaration
use constant UNDNAME_NO_CV_THISTYPE          => 0x0040;
# Disable all modifiers on the 'this' type
use constant UNDNAME_NO_THISTYPE             => 0x0060;
# Disable expansion of access specifiers for members
use constant UNDNAME_NO_ACCESS_SPECIFIERS    => 0x0080;
# Disable expansion of 'throw-signatures' for functions and pointers to functions
use constant UNDNAME_NO_THROW_SIGNATURES     => 0x0100;
# Disable expansion of 'static' or 'virtual'ness of members
use constant UNDNAME_NO_MEMBER_TYPE          => 0x0200;
# Disable expansion of MS model for UDT returns
use constant UNDNAME_NO_RETURN_UDT_MODEL     => 0x0400;
# Undecorate 32-bit decorated names
use constant UNDNAME_32_BIT_DECODE           => 0x0800;
# Crack only the name for primary declaration;
#  return just [scope::]name.  Does expand template params
use constant UNDNAME_NAME_ONLY               => 0x1000;
# Don't undecorate arguments to function
use constant UNDNAME_NO_ARGUMENTS            => 0x2000;
# Don't undecorate special names (v-table, vcall, vector xxx, metatype, etc;
use constant UNDNAME_NO_SPECIAL_SYMS         => 0x4000;

use constant UNDECORATE_PROTO =>
   UNDNAME_NO_ACCESS_SPECIFIERS | UNDNAME_NO_THROW_SIGNATURES |
   UNDNAME_NO_ALLOCATION_MODEL  | UNDNAME_NO_ALLOCATION_LANGUAGE |
   UNDNAME_NO_MEMBER_TYPE;

use constant UNDECORATE_NAME => UNDNAME_NAME_ONLY;

use constant FN_ADDR                         => 'addr';
use constant FN_PROTO                        => 'prototype';
use constant FN_NAME                         => 'name';
use constant FN_COUNT                        => 'count';
use constant FN_AVG                          => 'avg';
use constant FN_FILE                         => 'file';
use constant FN_SIZE                         => 'size';
use constant FN_TIME                         => 'time';
use constant FN_NOCHILDREN                   => 'time-nochild';
use constant FN_NOCHILDRENAVG                => 'time-nochildavg';

use constant XML_FUNC                        => 'function';
use constant XML_FUNC_REF                    => 'function-ref';
use constant XML_CHILD_FUNC_REF              => 'child-ref';
use constant XML_FUNC_NAMES                  => 'function-names';
use constant XML_ADDR                        => FN_ADDR;
use constant XML_COUNT                       => FN_COUNT;
use constant XML_TIME                        => FN_TIME;
use constant XML_CHILDTIME                   => 'childtime';
use constant XML_FUNC_NAME                   => FN_NAME;
use constant XML_FUNC_PROTOTYPE              => FN_PROTO;
use constant XML_FUNC_FILE                   => FN_FILE;
use constant XML_FUNC_SIZE                   => FN_SIZE;
use constant XML_PROFILE                     => 'Profile';
use constant XML_RESULTS                     => 'Results';
use constant XML_TIMER_FREQ                  => 'TimerFrequency';

$dll           = '';
$cvs           = '';
$xml           = '';
$text          = '';
$decorated     = '';
$attempt_load  = 0;
$ident_length  = 255;
$file_count    = 0;
$timer_freq    = 0;
@fn_adr        = ();

sub show_man_and_quit {
   pod2usage(-existstatus => 0, -verbose => 2);
}

sub show_usage_and_quit {
   pod2usage(1);
}

sub process_filename {
   my ($filename) = @_;

   if($filename =~ /\.map$/i) {
      $map_file   = $filename;
   } elsif( !$file_count ) {
      $prof       = $filename;
      $file_count = 1;
   } else {
      $result     = $filename;
   }
}

sub read_parameters_from_result_file {
   # Load parameters from result file, if required.  First line is the name of the
   # program (which we don't need if we already have a map file), second line
   # is the timer resolution.
   open PROF, "<$prof" or die "Cannot open profile $prof";
   while(<PROF> ) {
      chomp;

      if( $. == 1 ) {
         next if(length($map_file));

         # Attempt to deduce map file from profile file
         if( /.*\\(.*)\..*$/ ) {    # Extract filename
            $map_file = $1 . ".map";

            print STDERR "Attempting to use map name: $map_file, deduced from $prof.\n";
         }
      } else {
         if( /\#\D*(\d*)$/ ) {
            $timer_freq = scalar($1);
         }

         last;
      }
   }

   if( !$timer_freq ) {
      print STDERR "Unable to deduce timer frequency from profiler results.\n";

      $timer_freq = 1;
   }

   close PROF;
}

# Functions to play with the function name we're showing the user.
sub keep_decorated_name { return @_[0]; }

sub undecorate_name {
   my ($decorated_name, $options) = @_;

   if( !$undecorate_api ) {
      $attempt_load = 1;

      $undecorate_api = new Win32::API("dbghelp", "UnDecorateSymbolName",
                                       [P, P, N, N], N);

      if( !$undecorate_api ) {
         print STDERR "Undecorated symbol names not available.\n";
         $fn_name = \&keep_decorated_name;

         return keep_decorated_name($decorated_name);
      }
   }

   $undecorated_name = " " x $ident_length;

   my $len = $undecorate_api->Call($decorated_name, $undecorated_name,
                                   $ident_length,
                                   $options ? $options : UNDECORATE_PROTO);

   if (!$len) {
      $undecorated_name = $decorated_name;    # Keep it decorated then.
   } else {
      $undecorated_name = substr($undecorated_name, 0, $len);
   }

   return $undecorated_name;
}

sub parse_parameters {
   GetOptions('help|?' => \$help, 'man' => \$man, 'decorated' => \$decorated,
              'xml' => \$xml, 'cvs' => \$cvs, 'text' => \$text, 'dll' => \$dll,
              'ident=n' => \$ident_length,
              '<>' => \&process_filename) or pod2usage(2);
   show_usage_and_quit() if $help;
   show_man_and_quit() if $man;

   if(!length($prof)) {
      show_usage_and_quit();
   }

   if(length($result) ) {
      # Instead of writing to STDOUT; write to a file.
      open STDOUT, ">$result" or die "Unable to open result file $result";
   }

   read_parameters_from_result_file();

   if( !length($map_file) ) {
      show_usage_and_quit();
   }

   # Parameter validation

   if( $text ) { $cvs = $xml = ''; }
   if( $cvs ) { $xml = ''; }
   if( $xml || !($cvs || $text) ) { $xml = 1; }

   if( !$decorated ) {
      $fn_name = \&undecorate_name;
   } else {
      $fn_name = \&keep_decorated_name;
   }
}

sub adjust_dll_addresses() {
  # get the lowest address from profile and derive real load address
  $real_loadaddr = 0xffffffff;
  open PROF, "<$prof" or die "Cannot open profile $prof";
  while (<PROF>) {
    chomp;
    next if(/^\#|^\s*$/);
    ($addr, $count, $total, $avg) = split(/:/);
    $addr = hex($addr);
    $real_loadaddr = $addr if($addr < $real_loadaddr);
  }
  close PROF;

  $real_loadaddr &= 0xFFFF0000;
  $addrdiff = $image_loadaddr - $real_loadaddr;
}

sub parse_mapfile {
   open MAP, "<$map_file" or die "Cannot open mapfile $map_file";
   while(<MAP>) {
       chomp;
       if(/Publics by Value/) {
         $header_seen = 1;
         next;
       }
       elsif(/Preferred load address is ([0-9a-f]+)/) {
         $image_loadaddr = hex($1);
       }

       next if(!$header_seen);
       # Must start with an address; ie: 0001:01949f; other lines are fluff as
       # far as we're concerned.
       next if(!/^ ([0-9A-Fa-f]*):([0-9A-Fa-f])* /);
       # Only use CODE sections -- TODO: actually check that section 1 is a code
       # section, and that there are no others.
       next if(!hex($1) == 1);

       ($dummy, $addr, $name, $rva, $flag, $file) = split(/[ ]+/);
       $addrtab{$rva} = $name;
       $filetab{$rva} = $file;
       # wow, this is not always ascending!
       $size = hex($rva) - hex($prevrva);
       if($size > 0) {
         $sizetab{$prevrva} = $size;
       }
       else {
         $sizetab{$prevrva} = '???';
       }
       $prevrva = $rva;
   }
   close MAP;

   adjust_dll_addresses() if $dll;

   # Speed up search for the actual function starts by sorting in ascending addr
   @fn_adr = sort { hex($a) <=> hex($b) } keys %addrtab;
}

#
# Look for the exact match; or the function just before (SH3). We return the
# hexadecimal value, not the numerical one.
#
sub find_function {
   # straight port from lower_bound -- probably quite bad Perl code.
   my ($adr_hex, $adr_sorted) = @_;

   my $adr = hex($adr_hex);

   # Find largest address <= addr, using a standard binary search algorithm.
   my $half, $middle, $first = 0, $count = scalar(@{$adr_sorted});

   while( $count > 0 ) {
      $half    = $count >> 1;
      $middle  = hex(@{$adr_sorted}[$first + $half]);

      if( $middle < $adr ) {
         $first += $half + 1;
         $count -= $half - 1;
      } else {
         $count = $half;
      }
   }

   if( $first < scalar(@{$adr_sorted}) ) {
      if( hex(@{$adr_sorted}[$first]) != $adr ) {
         $adr_hex = @{$adr_sorted}[$first-1];
      }
   }

   return $adr_hex;
}

sub get_actual_function_address {
   my ($addr) = @_;

   $addr = sprintf "%08x", hex($addr) + $addrdiff if($dll);
   $addr = find_function($addr, \@fn_adr);

   return $addr;
}

sub get_static_function_parameters {
   my ($addr) = @_;

   my %result;

   $result{FN_ADDR()}  = $addr;
   $result{FN_PROTO()} = &$fn_name($addrtab{$addr});
   $result{FN_FILE()}  = $filetab{$addr};
   $result{FN_SIZE()}  = $sizetab{$addr};

   return %result;
}

sub get_function_parameters {
   my ($addr, $count, $total, $childtime) = @_;

   $addr = get_actual_function_address($addr);

   my %result = get_static_function_parameters($addr);

   $result{FN_AVG()}      = $total / $count;
   $result{FN_COUNT()}    = $count;
   $result{FN_TIME()}     = $total;

   if( $childtime ) {
      $result{FN_NOCHILDREN()}     = $total - $childtime;
      $result{FN_NOCHILDRENAVG()}  = $result{FN_NOCHILDREN()} / $count;
   }

   return %result;
}

sub process_results_xml() {
   sub get_static_function_parameters_xml {
      my %results = get_static_function_parameters(@_);

      $results{FN_NAME()} = &$fn_name($addrtab{@_[0]}, UNDECORATE_NAME);

      return %results;
   }

   my $xml_gen = new XML::Writer(OUTPUT => STDOUT, DATA_MODE => 1,
                                 DATA_INDENT => 3);

   $xml_gen->xmlDecl();
   $xml_gen->startTag(XML_PROFILE);
   $xml_gen->dataElement(XML_TIMER_FREQ, $timer_freq);
   $xml_gen->startTag(XML_RESULTS);

   my %functions_used;

   while (<PROF>) {
      chomp;
      next if(/^\#|^\s*$/);        # Skip commented and empty lines

      if(/^C> /) {                  # Start of a child entry?
         my ($child_marker, $addr, $count, $total) = split(/[ |:]/);

         $addr = get_actual_function_address($addr);

         $xml_gen->emptyTag(XML_CHILD_FUNC_REF,
                            XML_ADDR() => $addr,
                            XML_COUNT() => $count,
                            XML_TIME() => $total);

         $functions_used{$addr} = 1;
     } else {                       # Nope -- regular main function
        $xml_gen->endTag() if $xml_gen->in_element(XML_FUNC_REF);

        my ($addr, $count, $total, $childtime) = split(/:/);

        $addr = get_actual_function_address($addr);

        $xml_gen->startTag(XML_FUNC_REF,
                           XML_ADDR() => $addr,
                           XML_COUNT() => $count,
                           XML_TIME() => $total,
                           XML_CHILDTIME() => $childtime);

        $functions_used{$addr} = 1;
     }
   }

   $xml_gen->endTag() if $xml_gen->in_element(XML_FUNC_REF);

   $xml_gen->endTag();     # XML_RESULTS
   $xml_gen->startTag(XML_FUNC_NAMES);

   foreach (keys %functions_used) {
      my %function_params = get_static_function_parameters_xml($_);

      $xml_gen->startTag(XML_FUNC, XML_ADDR() => $function_params{FN_ADDR()});
         $xml_gen->dataElement(XML_FUNC_NAME, $function_params{FN_NAME()});
         $xml_gen->dataElement(XML_FUNC_PROTOTYPE,
                               $function_params{FN_PROTO()});
         $xml_gen->dataElement(XML_FUNC_FILE, $function_params{FN_FILE()});
         $xml_gen->dataElement(XML_FUNC_SIZE, $function_params{FN_SIZE()});
      $xml_gen->endTag();
   }

   $xml_gen->endTag();     # XML_FUNC_NAMES

   $xml_gen->endTag();     # XML_PROFILE
   $xml_gen->end();        # Document
}

sub process_results_text() {
   # I think this section should be removed completely -- we should have an XLS
   # to create CVS and TXT reports from the XML file.

   sub print_child {
      my %params = get_function_parameters(@_);

      if( $cvs ) {
         print "$params{FN_ADDR()};$params{FN_COUNT()};$params{FN_TIME()};";
         print "$params{FN_AVG()};;;$params{FN_FNAME()};$params{FN_FILE()};";
         print "$params{FN_SIZE()}\n";
      } else {
         printf(" %s%7u%10.02f%8.2lf                     %-55s  %-22s%9lu\n",
                $params{FN_ADDR()}, $params{FN_COUNT()},
                $params{FN_TIME()} / $timer_freq, $params{FN_AVG()} / $timer_freq,
                substr($params{FN_PROTO()}, 0, 55),
                substr($params{FN_FILE()}, 0, 22), $params{FN_SIZE()});
      }
   }

   sub print_main {
      my %params = get_function_parameters(@_);

      if ($cvs) {
         print "$params{FN_ADDR()};$params{FN_COUNT()};$params{FN_TIME()} / $timer_freq;";
         print "$params{FN_AVG()} / $timer_freq;$params{FN_NOCHILDREN()} / $timer_freq;";
         print "$params{FN_NOCHILDRENAVG()} / $timer_freq;$params{FN_FNAME()};";
         print "$params{FN_FILE()};$params{FN_SIZE()}\n";
      } else {
         # FIXME!!!
         $addr    = $params{FN_ADDR()};
         $count   = $params{FN_COUNT()};
         $total   = $params{FN_TIME()} / $timer_freq;
         $avg     = $params{FN_AVG()} / $timer_freq;
         $fnonly  = $params{FN_NOCHILDREN()} / $timer_freq;
         $fnavg   = $params{FN_NOCHILDRENAVG()} / $timer_freq;
         $func    = $params{FN_PROTO()};
         $file    = $params{FN_FILE()};
         $size    = $params{FN_SIZE()};
         write;
      }
   }

format STDOUT_TOP =
**** PROFILE REPORT - TIME IS IN MS AND INCLUDES PROFILING TIME ****

RVA        COUNT TIME(+ch)     AVG TIME(-ch)     AVG FUNCTION                                                   FILE                       SIZE
-----------------------------------------------------------------------------------------------------------------------------------------------
.

format STDOUT =
@<<<<<<< @>>>>>> @#####.## @###.## @#####.## @###.## @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<<<<<<<<<  @>>>>>
$addr,   $count, $total,   $avg,   $fnonly,  $fnavg, $func,                                                     $file,                   $size
.

   if ($cvs) {
      print "RVA;COUNT;TOTAL;AVG;NOCHILD;AVGNOCHILD;FUNC;FILE;SIZE\n";
   }

   while (<PROF>) {
     chomp;
     next if(/(^\#|^\s*$)/);      # Skip commented and empty lines.

     if(/^C> /) {
        ($child_marker, $addr, $count, $total) = split(/[ |:]/);

        print_child($addr, $count, $total);
     } else {
        ($addr, $count, $total, $childtime) = split(/:/);

        print_main($addr, $count, $total, $childtime);
     }
   }
}

sub process_results() {
   open PROF, "<$prof" or die "Cannot open profile $prof";

   if( $xml ) {
      process_results_xml()
   } else {
      process_results_text();
   }

   close PROF;
}

parse_parameters();
parse_mapfile();
process_results();

__END__

=head1 NAME

XPROFILE - Poor man's profiler for Win32; profiling for Windows CE.

=head1 SYNOPSIS

xprofile.pl [options] input [mapfile] [output]

Options are: --xml --text --cvs --dll --decorated --ident=n --man

xprofile.pl --man for even more fun.

=head1 DESCRIPTION

Simple report, for a simple profiler.

=head1 INSTALLATION

To use this script, you will need the following:

=over 4

=item A perl engine. (really?) I used ActivePerl v.5.6.1 build 631.

=item XML::Writer if you want XML output

=item Getopt::Long and Pod::Usage

=item Win32::API if you want to use undecorated names, and a recent version of
dbghelp.dll.  If you have Windows 2000 and up there's no problem; otherwise
you will need version 5.0 or later of dbghelp.dll.

=back

=head1 COMMAND LINE OPTIONS

xprofile.pl [options] input [mapfile] [output]

Options: Valid options are

   --text       Output results in text format
   --cvs        Output results in CVS format
   --decorated  Output decorated (mangled) names
   --ident=n    Maximum identifier length; default to 255 (truncated in text mode)
   --dll        Input file indicates a DLL; use relocation algorithm
   --help       You're reading it.


Input:   Text file generated by the profile run.

Mapfile: Mapfile for the module used in the profile run. If it is not
         specified we attempt to load the file based on the input file's
         header, provided the map file is in the same directory.

Output:  Output file name; if not specified, STDOUT is used.

=head1 ENVIRONMENT

Environment variables can be used to specify default values; the command line
can override any of these.

XPROFILE_INPUT:   Input file name; you can include the path.
XPROFILE_MAP:     Input map file; you can also include path.
XPROFILE_OUTPUT:  Output file name; yes yes, you can include the path.

=head1 KNOWN BUGS

This is my first perl script; so it's bloated and slow. I'd appreciate a
modified version from a Perl Guru, hopefully not too obfuscated.

=head1 CREDITS

All credits go to Rainer Keuchel ( I<keuchel@netwave.de> ) for starting this
project. I (Stephane Rouleau I<s.rouleau@videotron.ca>) just tried to learn
Perl doing this, along with XML...

=cut

