- #!/usr/local/bin/perl -w
- use strict;
- use POSIX "floor";
- # any commands in this list will have timings calculated for their sub-commands also.
- my @do_sub_commands = ( qw(p4) );
- #my @do_sub_commands = ();
- # sum numbers found in arguments (recursively), which may be:
- # scalars, lists, list refs, or hash refs (values of hash are summed)
- # dies if anything else encountered.
- sub sum {
- my $total = 0;
- for(@_) {
- if( ! ref ) {
- die "'$_' is not a number" unless /^[0-9.]+/ && ( /\./g ) <= 1;
- $total += $_ ;
- }
- elsif( ref eq "ARRAY" ) {
- $total += sum( @$_ );
- }
- elsif( ref eq "HASH" ) {
- $total += sum( values %$_ );
- }
- else {
- die "can't sum a " . ref() . " reference.";
- }
- }
- return $total;
- }
- sub test_sum {
- my @list = ( 2, 3, 4 );
- my %h = ( a => 1, b => 2, c => 3 );
- print "\n";
- print sum( 0, 1, 2, 3, 4, 5 ), "\n";
- print sum( @list ), "\n";
- print sum( \@list ), "\n";
- print sum( \@list, 1 ), "\n";
- print sum( \@list, @list ), "\n";
- print sum( \%h ), "\n";
- print sum( \%h, 1 ), "\n";
- print sum( \%h, \@list ), "\n";
- print sum( \%h, \@list, 3 ), "\n";
- }
- my %perl_times;
- my %os_times;
- my %overhead_times;
- my %run_counts;
- my @stack;
- while (<>) {
- chomp;
- my @f = split;
- if( @f < 3 ) {
- warn "not enough fields on line $. of $ARGV\n";
- next;
- }
- my $time = $f[0];
- my $what = $f[1];
- if( $what !~ /^(BEG|END|ELA)$/ ) {
- warn "line $. of profile log was not a BEG, END or ELA marker\n";
- next;
- }
- #--------------------
- # get parts of command line
- my %this_data;
- my %subcmd_data;
- $this_data{time} = $time;
- $this_data{what} = $what;
- my $command = $f[2];
- shift @f for(1..3);
- $this_data{command} = $command;
- #--------------------
- # if we want detail profiling on the sub-commands of this command,
- # figure out what the sub-command is, and add its timings.
- my $subcommand;
- if ( grep { $_ eq $command } @do_sub_commands ) {
- if( $what eq "ELA" ) {
- while( @f ) {
- if( $f[0] =~ /^-/ ) {
- shift @f; # shift off the option flag
- if( $f[0] eq '-' || $f[0] !~ /^-/ ) {
- shift @f; # shift off the parameter
- }
- }
- else {
- $subcommand = shift @f;
- last;
- }
- }
- }
- else {
- $subcommand = shift @f;
- }
- die "??? no subcommand found for $command '$_'\n"
- unless defined $subcommand;
- }
- if( defined $subcommand ) {
- $subcmd_data{time} = $time;
- $subcmd_data{what} = $what;
- $subcmd_data{command} = "$command $subcommand";
- }
- #--------------------
- # add up times
- if( $this_data{what} eq "BEG" ) {
- push @stack, \%this_data;
- $run_counts{ $this_data{command} }++ ;
- if( keys %subcmd_data ) {
- push @stack, \%subcmd_data ;
- $run_counts{ $subcmd_data{command} }++ ;
- }
- }
- elsif( $this_data{what} eq "ELA" ) {
- $os_times { $this_data{command} } += $this_data{time};
- $os_times { $subcmd_data{command} } += $subcmd_data{time}
- if( defined $subcommand ) ;
- }
- else { # 'END'
- if( defined $subcommand ) {
- my %prev_data = %{ pop @stack };
- die "END command did not match BEG command at top of stack.\n"
- unless $subcmd_data{command} eq $prev_data{command};
- my $elapsed = $subcmd_data{time} - $prev_data{time};
- $perl_times{ $subcmd_data{command} } += $elapsed;
- }
- my %prev_data = %{ pop @stack };
- die "END command did not match BEG command at top of stack.\n"
- unless $this_data{command} eq $prev_data{command};
- my $elapsed = $this_data{time} - $prev_data{time};
- $perl_times{ $this_data{command} } += $elapsed;
- }
- }
- die "No input data\n" unless $.;
- my $total_key = "~TOTAL"; # sorts last
- my $os_times_present = keys %os_times;
- $perl_times{$total_key} = sum \%perl_times;
- $os_times{$total_key} = sum \%os_times
- if $os_times_present;
- ## print "total perl times: $perl_times{$total_key}\n";
- ## print "total os times: $os_times{$total_key}\n";
- ## print join "", map { sprintf "%10.6f seconds (via perl) in $_ \n", $perl_times{$_} } sort keys %perl_times;
- ## print join "", map { sprintf "%10.6f seconds (via time) in $_ \n", $os_times {$_} } sort keys %os_times;
- my @keys_both = grep { exists $os_times{$_} } keys %perl_times;
- $overhead_times{$_} = $perl_times{$_} - $os_times{$_} for @keys_both;
- ## print join "", map { sprintf "%10.6f seconds overhead in $_\n", $perl_times{$_} - $os_times{$_} } sort @keys_both;
- my %all_unique_keys = map { $_ => 1 } sort( keys %perl_times, keys %os_times );
- $all_unique_keys{'~'} = 1; # separator before TOTAL
- sub percentage {
- my ($num, $denom) = @_;
- return floor ( .5 + $num / $denom * 100 ) ;
- }
- # args:
- # 1. timing hash ref
- # 2. hash key
- sub print_timing {
- my ($h, $k) = @_;
- die unless $h && $k;
- # print timing
- my $timing;
- if( defined $h->{$k} ) {
- $timing = $h->{$k};
- printf "%6.2f ", $timing;
- }
- else {
- print " ";
- }
- # if this is a subcommand, print percent that subcommand is of command
- if( defined $timing && $k =~ /(\S+)\s+\S+/ ) {
- # print percentage of total command time if this is a subcommand
- printf " %2d%% ", percentage $h->{$k}, $h->{$1} ;
- }
- else {
- printf " ";
- }
- # print timing per each commmand
- if( defined $timing && exists $run_counts{$k} ) {
- my $time_each = $timing / $run_counts{$k} ;
- printf "%6.3f ", $time_each;
- }
- else {
- print " ";
- }
- print "| ";
- }
- my $max_key_len = 0;
- for( keys %all_unique_keys ) {
- $max_key_len = length if length > $max_key_len;
- }
- ## ---------------------
- ## output
- sub underline {
- print "-" for 1..$max_key_len;
- print "-----";
- print "----"; # over run counts
- for(1..3) {
- print "-------"; # over timing
- print "-----"; # over %
- print "-------"; # over time per each
- print "--";
- last unless $os_times_present;
- }
- print "\n";
- }
- print "\n";
- underline;
- # print header
- print " " for 1..$max_key_len;
- print " | ";
- print "runs"; # over run count
- print " | ";
- for(
- " perl ",
- "os time",
- "ovrhead"
- ) {
- print "$_"; # over number
- print " (%) "; # over %
- print " each "; # over time per each
- print "| ";
- last unless $os_times_present;
- }
- print "\n";
- # header underline
- underline;
- # print data
- for( sort keys %all_unique_keys ) {
- my $key = $_;
- if( $key eq "~" ) { # special underline mark
- underline;
- next;
- }
- $key =~ s/~// ; # special sorting character
- $key .= " " while length $key < $max_key_len;
- print $key, " | ";
- if( defined $run_counts{$_} ) {
- printf "%4d ", $run_counts{$_};
- }
- else {
- print " ";
- }
- print "| ";
- print_timing \%perl_times, $_ ;
- if( $os_times_present ) {
- print_timing \%os_times, $_ ;
- print_timing \%overhead_times, $_ ;
- }
- print "\n";
- }
- print "\n";
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#2 | 2679 | John Fetkovich | profiling fixes | 22 years ago | |
#1 | 2666 | John Fetkovich | Analyze vcp profiling output files (created when vcp is run with VCPPROFILE ... environment var is set to filename to write to.) « |
22 years ago |