Devel::Profile - tell me why my perl program runs so slowly

    perl -d:Profile program.pl
    less prof.out

	perl -d:Profile test.pl  

    time elapsed (wall):   86.8212
    time running program:  65.7657  (75.75%)
    time profiling (est.): 21.0556  (24.25%)
    number of calls:       647248

    %Time    Sec.     #calls   sec/call  F  name
    31.74   20.8770     2306   0.009053     Configable::init_from_config
    20.09   13.2116   144638   0.000091     Configable::init_field_from_config
    17.49   11.5043   297997   0.000039     Configable::has_attr
     8.22    5.4028      312   0.017317     MonEl::recycle
     7.54    4.9570    64239   0.000077     Configable::inherit
     5.02    3.3042   101289   0.000033     MonEl::unique
    [...]

    Yellowstone National Park.
    Devel::DProfLB

# -*- perl -*-

# Copyright (c) 2002 by Jeff Weisberg
# Author: Jeff Weisberg <jaw+profile @ tcp4me.com>
# Date: 2002-Jun-21 22:19 (EDT)
# Function: code profiler
#
# $Id: Profile.pm,v 1.22 2007/03/08 02:25:42 jaw Exp $

# Dost thou love life? Then do not squander time
#   -- Benjamin Franklin

# start as:
#   env PERL5DB='BEGIN{require "src/Profile.pm"}' perl -d program.pl
#   or: perl -d:Profile program.pl
# data gets saved in 'prof.out'

# motivation:
#   Devel::DProf appears to have issues. when it is used
#     9 times out of 10 it produces output that is unusable by dprofpp (even with -F)
#     the statistics are often obviously wrong
#     it causes crashage
# of course, this code isn't really any better....

    ;
# more POD at end

package Devel::Profile;
$VERSION = "1.05";

package DB;
BEGIN {
    sub DB {}
    require Time::HiRes; Time::HiRes->import('time');
}

my $t0     = time();	# start time
my $tsav   = $t0;	# time of last save
my $tacc   = 0;		# total time accumulated
my $tacc0  = 0;		# total time accumulated at start (or reset)
my $call   = 0;		# total number of calls
my $except = 0;		# total number of exceptions handled (est)
my $saving = 0;		# save in progress
my $tprof_save = 0;	# time spent saving data
my %prof_calls = ();	# number of calls per sub
my %prof_times = ();	# total time per sub
my %prof_flags = ();	# flags
my @prof_stack = ();	# call stack, to account for subs that haven't returned
my $want_reset = 0;	# reset request pending
my $prof_pid   = $$;	# process id

my $TSAVE = defined($ENV{PERL_PROFILE_SAVETIME}) ? $ENV{PERL_PROFILE_SAVETIME} : 120; 
my $NCALOOP = 1000;

$SIG{USR2} = \&reset;

sub sub {

    my $ti = time();	# wall time at start
    # save first, keeps timing calculations simpler
    if( !$saving && $TSAVE && ($ti - $tsav) > $TSAVE ){
	save();
	$ti = time();	# update to account for save
    }
    
    my $st = $tacc;	# accum time at start
    my $sx = $sub;
    if( ref $sx ){
	my @c = caller;
	# was 0, now 1
	# nb: @c = (pkg, file, line, ...)
	$sx = "<anon>:$c[1]:$c[2]";
    }
    push @prof_stack, [$sx, $ti, $st];
    my $ss = @prof_stack;
    
    my( $wa, $r, @r );
    $wa = wantarray;
    if( $wa ){
	@r = &$sub;
    }elsif( defined $wa ){
	$r = &$sub;
    }else{
	&$sub;
    }

    if( $ss < @prof_stack ){
	# we took an exception - account for aborted subs
	# print STDERR "exception detected!\n";
	
	while( $ss < @prof_stack ){
	    my $sk = pop @prof_stack;
	    my $sn = $sk->[0];
	    my $t  = time() - $sk->[1] - ($tacc - $sk->[2]);
	    $tacc += $t;
	    $prof_times{$sn} += $t;
	    $prof_calls{$sn} ++;
	    $prof_flags{$sn} |= 2;
	    $call ++;
	}
	$except++;
	$prof_flags{$sx} |= 4;
    }
    
    if( pop @prof_stack ){		# do not update if reset
	my $t = time() - $ti		# total time of called sub
	    - ($tacc - $st);		# minus time of subs it called
	$tacc += $t;
	$prof_times{$sx} += $t;		# We take no note of time
	$prof_calls{$sx} ++;		# But from its loss
	$call ++;			#   -- Edward Young, Night Thoughts
    }

    if( $wa ){
	@r;
    }else{
	$r;
    }
}

sub save {
    return if $saving;
    unless( $call ){
	# nothing to report
	$tsav = time();
	return;
    }
    $saving = 1;

    # only parent process
    return unless $$ == $prof_pid;
    
    my $tnow = time();
    my $ttwall = $tnow - $t0;
    my $f = $ENV{PERL_PROFILE_FILENAME} || 'prof.out';
    open( F, "> $f" ) || die "open failed, $f $!\n";

    # calc. an estimate of Tadj (overhead of DB::sub)
    # Tadj = 3/4 of the fastest sub
    my $tadj;
    foreach my $s (keys %prof_times){
	next unless $prof_calls{$s} >= 10;
	my $t = $prof_times{$s} / $prof_calls{$s};
	$tadj = $t if !defined($tadj) || $t < $tadj;
    }
    $tadj *= .75;
    
    # adjust run times
    my( %times, %calls, %flags );
    %calls = %prof_calls;
    %flags = %prof_flags;
    foreach (keys %prof_times){
	$times{$_} = $prof_times{$_} - $tadj * $prof_calls{$_};
    }
    
    # calculate profiling overhead, and hide our droppings
    my $calladj = 0;
    my $tprof = $tadj * $call + $times{Devel::Profile::__db_calibrate_adj} + $tprof_save;
    delete $times{Devel::Profile::__db_calibrate_adj};
    $calladj = 0 - $prof_calls{Devel::Profile::__db_calibrate_adj};
    
    # calc time of subs that never finished, by unwinding the saved call stack
    my $xend = $tnow;
    my $xacc = $tacc;
    foreach my $sk (reverse @prof_stack){
	# since it didn't return, we only adjust by half of Tadj
	my $sn = $sk->[0];
	my $t = $xend - $sk->[1] - ($xacc - $sk->[2]);
	$times{ $sn } += $t - $tadj/2;
	$calls{ $sn } ++;
	# and since we are using different math, and a different estimate of
	# the profiling overhead, we display a flag alerting the user
	$flags{ $sn } |= 2;
	$xend = $sk->[1];
	$xacc = $sk->[2];
	$tprof += $tadj/2;
	$calladj ++;
    }
    
    # calc time for other: "naked" code, ???
    unless( $ENV{PERL_PROFILE_DONT_OTHER} ){
	my $tnaked = $xend - $t0 - ($tacc - $tacc0);
	if( $tnaked < 0 ){
	    # dang! mis-estimates threw our numbers off by too much
	    # print STDERR "dang: $tnaked = $xend - $t0 - ($tacc - $tacc0)\n";
	    $tnaked = 0;
	}
	$times{'<other>'} = $tnaked;
	$calls{'<other>'} = 0;
	$flags{'<other>'} |= 1;
    }

    # total run time of program
    my $tt;
    foreach (values %times){$tt += $_}

    # dreams are very curious and unaccountable things
    #   -- Homer, Odyssey
    # unaccounted for "missing" time
    my $tmissing = $ttwall - $tt - $tprof;
    
    printf F "time elapsed (wall):   %.4f\n",           $ttwall;
    printf F "time running program:  %.4f  (%.2f%%)\n", $tt,       100 * $tt / $ttwall;
    printf F "time profiling (est.): %.4f  (%.2f%%)\n", $tprof,    100 * $tprof / $ttwall;
    printf F "missing time:          %.4f  (%.2f%%)\n", $tmissing, 100 * $tmissing / $ttwall
	if( $tmissing / $ttwall > 0.0001 );
    print F "number of calls:       ", $call + $calladj, "\n";
    print F "number of exceptions:  $except\n" if $except;
    
    print F "\n%Time    Sec.     \#calls   sec/call  F  name\n";
    foreach my $s (sort {$times{$b} <=> $times{$a}} keys %times){
	my $c = $calls{$s};
	my $t = $times{$s};
	my $tpc = $t / ($c || 1);
	my $pct = $t * 100 / $tt;
	my $sp = $s;

	if( substr($sp, 0, 6) eq '<anon>' ){
	    # make prettier
	    if( length($sp) > 35 ){
		$sp = '<anon>:...' . substr($sp, -28, 28);
	    }
	}
	
	printf F "%5.2f %9.4f  %7d  %9.6f %2s  $sp\n", 
	$pct, $t, $c, $tpc, F($flags{$s});
    }
    close F;

    # Let every man be master of his time
    #   -- Shakespeare, Macbeth
    # account for time spent saving data
    $tsav = time();
    my $telap = $tsav - $tnow;
    $tacc += $telap;
    $tprof_save += $telap;
    
    $saving = 0;
    reset() if $want_reset;
}

# 1=> *, 2=>?, 4=>x
sub F {
    ('', '*', '?', '?*', 'x', 'x*', 'x?', 'X?')[shift || 0];
}

sub reset {
    if( $saving ){
	$want_reset = 1;
	return;
    }
    save();
    $t0     = time();
    $tacc0  = $tacc;
    $call   = 0;
    $except = 0;
    %prof_calls = ();
    %prof_times = ();
    %prof_flags = ();
    @prof_stack = ();
    $want_reset = 0;
}

END {
    save();
}

################################################################
package Devel::Profile;
use strict;
sub __db_calibrate_adj {
    my $x = shift;
}
for my $i (1..$NCALOOP){
    __db_calibrate_adj();
}

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

#	o   When execution of the program reaches a subroutine
#	    call, a call to "&DB::sub"(args) is made instead, with
#	    "$DB::sub" holding the name of the called subroutine.
#	    This doesn't happen if the subroutine was compiled in
#	    the "DB" package.)

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

    ;

1;