Devel::Profiler - a Perl profiler compatible with dprofpp

  $ perl -MDevel::Profiler script.pl

  use Devel::Profiler;

  $ dprofpp

  perl -MDevel::Profiler script.pl

  use Devel::Profiler buffer_size => 1024;

  http://rt.cpan.org

  Automated Perl Test Account
  Andreas Marcel Riechert
  Simon Rosenthal
  Jasper Zhao

package Devel::Profiler;

use 5.006;
use strict;
use warnings;

our $VERSION = 0.04;

use B;
use Time::HiRes qw(time);

# set this to see a running chatter from the module.  Don't do this
# and then use the profiling results - the time spent printing
# debugging text is not accounted for in the profile.  Also, the
# overhead timing is turned off during debugging.
use constant DEBUG => $ENV{DEVEL_PROFILER_DEBUG} || 0;

# scan for subroutines 
INIT { init() }

# finish up
END { end() }

# initialize module
sub init {
    print STDERR __PACKAGE__ . "::init() called\n" if DEBUG;
    our $INIT = 1;
    our $PID = $$; # remember pid
    start_output();
    scan();
    start_clock();
    emit_pulse(1);
}

# write final results and close output file
sub end {
    our $INIT;
    return unless $INIT;
    print STDERR __PACKAGE__ . "::end() called\n" if DEBUG;

    # fake exits for subs remaining on stack.  Devel::DProf doesn't
    # bother, preferring to leave it to dprofpp -F.
    fake_exits();

    # empty the buffer
    empty_buffer();

    # emit the final timings
    emit_final_times();

    our $PID;
    if ($PID == $$) {
        close(FH) or die "Unable to close Devel::Profiler output file: $!";
    }
}

# take parameters from use line
sub import {
    my $pkg = shift;
    print STDERR __PACKAGE__ . "::import(", join(', ', @_), ") called\n"
      if DEBUG;
    die "Invalid import options for Devel::Profiler " . 
      "- must be a list of key-value pairs."
        if @_ % 2;

    # check for typos
    for (my $i = 0; $i < @_; $i += 2) {
        die "Unknown option name for Devel::Profiler : '$_[$i]'."
          unless grep { $_[$i] eq $_ } qw(output_file bad_pkgs bad_subs
                                          buffer_size override_caller
                                          package_filter sub_filter hz);
    }

    # setup defaults and allow @_ to override
    our %OPT = ( output_file     => 'tmon.out',
                 bad_pkgs        => [qw(UNIVERSAL Time::HiRes B Carp Exporter
                                        Cwd Config CORE DynaLoader XSLoader
                                        AutoLoader)],
                 bad_subs        => [],
                 buffer_size     => 64 * 1024,
                 override_caller => 1,
                 package_filter  => [],
                 sub_filter      => [],
                 hz              => 1000,
                 @_ );

    # push on list of pkgs to always avoid
    push @{$OPT{bad_pkgs}}, "Devel::Profiler", "DB";

    # compile lists into hashes for faster lookup
    $OPT{bad_pkgs} = { map { ($_, 1) } @{$OPT{bad_pkgs}} };
    $OPT{bad_subs} = { map { ($_, 1) } @{$OPT{bad_subs}} };

    # make sure package_filter is an array
    $OPT{package_filter} = [ $OPT{package_filter} ]
      unless ref $OPT{package_filter} eq 'ARRAY';

    # make sure sub_filter is an array
    $OPT{sub_filter} = [ $OPT{sub_filter} ]
      unless ref $OPT{sub_filter} eq 'ARRAY';
      
    # promote buffer size to global, it's used in profile_sub too
    # frequently to be accessed in a hash
    our $BUFFER_SIZE = $OPT{buffer_size};

    # same for hz
    our $HZ = $OPT{hz};

    # override caller
    *CORE::GLOBAL::caller = \&my_caller
      if $OPT{override_caller};
}

#
# scanning and instrumentation
#

# traverse all packages intrumenting all subroutines found
sub scan {
    our (%OPT, $INIT);
    return unless $INIT;
    my %saw_pkg;  # packages touched on this pass

    my ($sym, $glob, $code);

    my @pkgs = ('main::');    
  PKG: while (@pkgs) {
        my $pkg = pop @pkgs;
        
        # is it a bad package?
        next if is_bad_pkg($pkg);

        # haven't I seen this place before?
        next if exists $saw_pkg{$pkg}; $saw_pkg{$pkg} = 1;           
        
        print STDERR "\n\n", __PACKAGE__, "::scan examining $pkg\n" 
          if DEBUG;
        
        no strict 'refs'; # need symbolic references to diddle symbol tables
        while (($sym, $glob) = each %{$pkg}) {
            next if $sym eq $pkg; # self ref?  (%main::main::main::...)
            
            # found a subpackage?
            if ($sym =~ /\:\:$/) {
                if ($pkg ne 'main::') {
                    push(@pkgs, "$pkg$sym");
                } else {
                    push(@pkgs, $sym);
                }
                next;
            }
            
            # found a code ref?  then instrument it
            instrument($pkg, $sym, $code) 
              if defined($code = *{$glob}{CODE}) and ref $code eq 'CODE';
              
        }
    }
}

sub is_bad_pkg {
    my $pkg = shift;
    our %OPT;
    our %KNOWN_PKGS;

    # take off trailing ::
    substr($pkg, -2, 2) = "";

    # check cache to avoid calling package filters thousands of times
    if (exists $KNOWN_PKGS{$pkg}) {
        return $KNOWN_PKGS{$pkg};
    }

    # check stop-list
    elsif (exists $OPT{bad_pkgs}{$pkg}) {
        $KNOWN_PKGS{$pkg} = 1;
        return 1;
    }

    # don't profile pragmata
    elsif ($pkg =~ /^[a-z\:]+$/ and $pkg ne 'main') {
        $KNOWN_PKGS{$pkg} = 1;
        return 1;
    }
    
    # check package filters if we have any
    elsif ($OPT{package_filter}) {
        foreach my $filter (@{$OPT{package_filter}}) {
            unless ($filter->($pkg)) {
                $KNOWN_PKGS{$pkg} = 1;
                return 1;
            }
        }
    }

    $KNOWN_PKGS{$pkg} = 0;
    return 0;
}

# check sub tables
sub is_bad_sub {
    my ($pkg, $sub) = @_;
    our %OPT;

    # check package
    return 1 if is_bad_pkg($pkg);

    # take off trailing ::
    substr($pkg, -2, 2) = "";

    # check sub filters if we have any (not worth caching because subs
    # are checked usually only once or twice)
    if ($OPT{sub_filter}) {
        foreach my $filter (@{$OPT{sub_filter}}) {
            return 1 unless $filter->($pkg, $sub);
        }
    }

    return 0;
}

# instrument a single subroutine
sub instrument {
    my ($pkg, $sym, $code) = @_;
    my $name = "$pkg$sym";
    our %OPT;
    our %my_code; # hash of code addresses of instrumented subroutines

    print STDERR __PACKAGE__ . 
      "::instrument($pkg, $sym) called.\n"
        if DEBUG;

    # is this a bad sub
    return if is_bad_sub($pkg, $sym);

    # never profile DESTROY
    return if $sym eq 'DESTROY';

    # is this subroutine already instrumented?
    return if exists $my_code{$name};

    # is this subroutine a fake?  Trying to instrument fake subs leads
    # to certains doom.  See: http://perlmonks.org/index.pl?node_id=168546
    return unless defined(&{$name});
    
    # try to guess if this is an imported alias
    my $real_pkg = get_real_package($code);
    if (defined $real_pkg and $pkg ne $real_pkg) {
        my $real_name = "$real_pkg$sym";
        if (not exists $my_code{$real_name}) {
            no strict 'refs';
            instrument($real_pkg, $sym, \&{$name});
        }
        if (exists $my_code{$real_name}) {
            no strict 'refs';
            no warnings 'redefine';
            *{$name} = \&{$real_name};
        }
        return;
    }

    # don't wrap AUTOLOAD - it breaks $AUTOLOAD for some reason
    return if $name =~ /::AUTOLOAD$/;
    
    # check stop-list
    return if exists $OPT{bad_subs}{$name};

    # don't instrument constants
    return if is_constant($name, $code);

    # create a profiling stub for the sub
    no strict 'refs';
    no warnings 'redefine';	    
    (my $pkg_name = $real_pkg) =~ s/\:\:$//;               
    if (defined(my $proto = prototype($name))) {
        # create wrapper around calling prof_code
        *{$name} = 
          eval "sub ($proto) { profile_sub(\$pkg_name,\$sym,\$code,\@_) }";
    } else {
        # assign the prof code directly
        *{$name} = sub { profile_sub($pkg_name, $sym, $code, @_); };
    }

    # save prof_code for use later
    $my_code{$name} = \&{$name};

    print STDERR __PACKAGE__ . 
      "::instrument installed sub for $name\n" 
        if DEBUG;
}

sub get_real_package {
    my $obj = B::svref_2object(shift);
    return unless $obj and ref $obj eq 'B::CV';

    my $gv  = $obj->GV;
    return unless $gv  and ref $gv  eq 'B::GV';

    my $egv = $gv->EGV;
    my $stash;
    if ($egv and ref $egv eq 'B::GV') {
        $stash = $egv->STASH;
    } else {
        $stash = $gv->STASH;
    }
    if ($stash and ref $stash eq 'B::HV') {
        return $stash->NAME . '::';
    }
    return;
}

# detect constants - is this the only/best way to do it?
sub is_constant {
    no strict 'refs';
    my $name = shift;
    my $code = shift;

    # must have any empty prototype to be a constnat
    my $proto = prototype($code);
    return 0 if defined $proto and length $proto;

    # attempt to redefine - this will cause a warning for a real
    # constant that starts with "Constant"
    my $is_const;
    {
        local $SIG{__WARN__} = sub { $is_const = 1 if $_[0] =~ /^Constant/ };
        eval { *{$name} = sub { "TEST" } }; # set it to something else
        eval { *{$name} = $code; };            # and set it back
    }

    print STDERR __PACKAGE__ . "::is_constant : $name is a constant.\n"
      if DEBUG and $is_const;

    # all done
    return $is_const;
}


#
# profiling stub
#

sub profile_sub {
    my ($pkg, $sym, $code) = (shift, shift, shift);
    our (%ID, $LAST_ID);
    our @STACK;
    our ($BUFFER, $BUFFER_SIZE);

    # emit a timing mark
    emit_pulse();

    # get id
    my $id = $ID{"$pkg$sym"};
    if (not defined $id) {
        # first entry into sub - assign new ID
        $id = $ID{"$pkg$sym"} = ++$LAST_ID;
        $BUFFER .= "& $id $pkg $sym\n";
    }

    # check if caller is from Devel::Profiler - if it is then this sub
    # was called via goto &sub rather than a normal call
    my @caller = CORE::caller(3);

    #print STDERR "CALLER: ", 
    #  join(', ', map { defined $_ ? $_ : "(undef)" } @caller), "\n";

    if (@STACK and ($caller[3] || "") =~ /^Devel::Profiler/) {
        # emit goto entry mark
        $BUFFER .= "* $id\n";

        # replace top of stack with marker to supress exit
        $STACK[$#STACK] = undef;
    } else {
        # emit entry mark
        $BUFFER .= "+ $id\n";
    }
    
    # push $id and caller data onto stack for use later
    push(@STACK, $id);

    # need to empty buffer?
    empty_buffer() if length($BUFFER) >= $BUFFER_SIZE;

    print STDERR __PACKAGE__, "::profile_sub calling ${pkg}::$sym ($id)\n"
      if DEBUG and $sym ne 'test_sub';

    # make call, in correct context
    my $wantarray = wantarray;
    my ($ret, @ret);

    eval {
        if ($wantarray) {
            @ret = &$code;
        } elsif (defined $wantarray) {
            $ret = &$code;
        } else {
            &$code;
        }	 
    };

    # get returned id from stack, ignore caller data we won't need it now
    $id = pop @STACK;

    print STDERR __PACKAGE__, "::profile_sub ($id) returned\n"
      if DEBUG and defined $id and $sym ne 'test_sub';

    # emit a timing mark
    emit_pulse() if defined $id;

    # did the sub die?
    if ($@) {
        # emit die mark
        $BUFFER .= "/ $id\n" if defined $id;

        if (ref $@) {
            # just rethrow exception objects
            die $@;
        } else {
            # rethrow string die with a new-line to preserve the die
            # location
            die "$@\n";
        }
    }

    # emit exit mark
    $BUFFER .= "- $id\n" if defined $id;

    # need to empty buffer?
    empty_buffer() if length($BUFFER) >= $BUFFER_SIZE;

    # return as appropriate
    if ($wantarray) {
        return @ret;
    } elsif (defined $wantarray) {
        return $ret;
    }
    return;
}

#
# output routines
#


# open output file
sub start_output {
    our (%OPT, $BUFFER, $BUFFER_SIZE, $PID, $HZ);

    # only open files in the parent
    return unless $PID == $$;
 
    # make sure we don't try to write any output while testing
    local $BUFFER_SIZE = 1024 * 1024 * 1024;

    # initialize buffer
    $BUFFER = "";

    # test overhead unless we're debugging, in which case just use fake data
    my ($tests, $real, $user, $sys) = DEBUG ? (10000, 1, 0, 0) :
                                              test_overhead();

    # throw out junk data
    $BUFFER = "";

    # open output file
    open(FH, ">", $OPT{output_file}) or
      die "Unable to open output file \"$OPT{output_file}\" : $!";

    print STDERR __PACKAGE__,
      "::start_output : opened $OPT{output_file} for output.\n"
        if DEBUG;

    # output the preamble
    print FH <<END;
#fOrTyTwO
\$hz=$HZ;
\$XS_VERSION="Devel::Profiler $VERSION";
\$over_utime=$user;
\$over_stime=$sys;
\$over_rtime=$real;
\$over_tests=$tests;
END

    # note location to put final times
    our $OUTPUT_RESULTS_AT = tell(FH);

    # pad with room for results
    print FH " " x 255, "\n";

    # print token to start profiling section
    print FH "PART2\n";
}


# emit a timing pulse if there's anything to output.  called by
# profile_sub.
sub emit_pulse {
    my $force = shift;
    our ($RCLOCK, $UCLOCK, $SCLOCK, $BUFFER, $HZ);
    my  ($rtime, $utime, $stime, $relapse, $uelapse, $selapse);
    $rtime           = time;
    ($utime, $stime) = times;

    # get elapsed time in even HZ
    $relapse         = int(($rtime - $RCLOCK) * $HZ);
    $uelapse         = int(($utime - $UCLOCK) * $HZ);
    $selapse         = int(($stime - $SCLOCK) * $HZ);

    # anything to report?
    if ($relapse or $uelapse or $selapse or $force) {
        $BUFFER .= "@ $uelapse $selapse $relapse\n";

        # update clocks
        $RCLOCK = $rtime;
        $SCLOCK = $stime;
        $UCLOCK = $utime;
    }
}

# fake exits for subs left on the stack
sub fake_exits {
    our (@STACK, $BUFFER);
    while(@STACK) {
        $BUFFER .= "- " . pop(@STACK) . "\n";
    }
}

# empty buffer into OUTPUT
sub empty_buffer {
    our ($RCLOCK, $UCLOCK, $SCLOCK, $BUFFER, $PID, $HZ);
    
    # only output in the parent
    if ($PID != $$) {
        $BUFFER = "";
        return;
    }

    # start a timer to see if this is worth excluding from profile
    my  ($rtime, $utime, $stime, $relapse, $uelapse, $selapse);
    $rtime           = time;
    ($utime, $stime) = times;

    print FH $BUFFER;
    $BUFFER = "";

    # get elapsed time, in even HZ
    $relapse         = int(($rtime - $RCLOCK) * $HZ);
    $uelapse         = int(($utime - $UCLOCK) * $HZ);
    $selapse         = int(($stime - $SCLOCK) * $HZ);
    if ($relapse or $uelapse or $selapse) {
        # use the magic Devel::DProf::write token that tells dprofpp
        # to ignore this time
        print FH "+ & Devel::DProf::write\n",
                  "@ $uelapse $selapse $relapse\n",
                  "- & Devel::DProf::write\n";

        # update clock
        $RCLOCK = $rtime;
        $SCLOCK = $stime;
        $UCLOCK = $utime;
    }
}

# emit final times
sub emit_final_times {
    our ($RCLOCK_START, $UCLOCK_START, $SCLOCK_START, $OUTPUT_RESULTS_AT, 
         $PID, $HZ);
    return unless $PID == $$;

    our $RCLOCK            = time;
    our ($UCLOCK, $SCLOCK) = times;    
    
    my $rfinal = int(($RCLOCK - $RCLOCK_START) * $HZ);
    my $ufinal = int(($UCLOCK - $UCLOCK_START) * $HZ);
    my $sfinal = int(($SCLOCK - $SCLOCK_START) * $HZ);
    
    # seek to the right place
    seek(FH, $OUTPUT_RESULTS_AT, 0) or die "Unable to seek : $!";
    print FH <<END
\$rrun_utime=$ufinal;
\$rrun_stime=$sfinal;
\$rrun_rtime=$rfinal;
END
}

#
# timing routines
#

# synchronize clocks
sub start_clock {
    our $RCLOCK            = time;
    our ($UCLOCK, $SCLOCK) = times;
    our $RCLOCK_START = $RCLOCK;
    our $UCLOCK_START = $UCLOCK;
    our $SCLOCK_START = $SCLOCK;
    print STDERR __PACKAGE__ . "::start_clock ($RCLOCK $UCLOCK $SCLOCK)\n"
      if DEBUG;
}

# determine the profiling overhead
sub test_overhead {
    our $HZ;
    my $n = 10000; # how many times to run the test sub
    my ($utime1, $stime1, $rtime1, $utime2, $stime2, $rtime2);

    # first get times without instrumenting
    ($utime1, $stime1) = times;
    $rtime1            = time;
    test_sub($_) for (0 .. $n);
    ($utime2, $stime2) = times;
    $rtime2            = time;

    my $utime_base = $utime2 - $utime1;
    my $stime_base = $stime2 - $stime1;
    my $rtime_base = $rtime2 - $rtime1;
    
    # run tests to determine how much overhead instrumenting a sub causes
    instrument("Devel::Profiler::", "test_sub", \&test_sub, *test_sub);

    # start clocks for timing fakeup
    start_clock();

    # now measure instrumented times
    ($utime1, $stime1) = times;
    $rtime1            = time;
    test_sub($_) for (0 .. $n);
    ($utime2, $stime2) = times;
    $rtime2            = time;

    # calculate cost of profiling
    my $utime_inst = $utime2 - $utime1;
    my $stime_inst = $stime2 - $stime1;
    my $rtime_inst = $rtime2 - $rtime1;

    return ($n,
            int(($rtime_inst - $rtime_base) * $HZ),
            int(($utime_inst - $utime_base) * $HZ),
            int(($stime_inst - $stime_base) * $HZ));
}

# used to test call overhead.
sub test_sub { }

#
# CORE overrides to keep other modules from noticing my meddling.
# These are installed at INIT along with instrumented subs.
#

# override for caller() that ignores Devel::Profiler frames
sub my_caller {
    my $arg = shift;
    my $target = defined $arg ? $arg : 0;
    my $found = -1;
    my @stack;

    print STDERR __PACKAGE__,"::caller(",(defined($arg) ? $arg : "undef"),")\n"
      if DEBUG;
    dump_caller() if DEBUG > 1;

    # step through stack frames accumulating good ones
    my $i = 1;
    while(my @caller = CORE::caller($i++)) {
        push(@stack, \@caller); # save for later

        # is this a bad one?
        next if $caller[0] eq 'Devel::Profiler';

        # is this a profiled sub?  if so, patch up from 3 frames up
        if ($caller[3] eq 'Devel::Profiler::__ANON__') {
            @caller[3..9] = @{$stack[($i - 5)]}[3..9];
        }
        
        # all done?
        last if ++$found == $target;
    }

    # return nothing if we didn't find it
    return unless $found == $target;

    # return the top of the stack or nothing
    my $c = @stack ? $stack[-1] : [];

    print STDERR "Returning CALLER($target) => [", 
      (map { defined $_ ? "\n\t$_" : "\n\t(undef)" } @$c), "\n]\n"
        if DEBUG;

    if (wantarray) {
        return defined $arg ? @$c : @{$c}[0,1,2];
    } else {
        return $c->[0];
    }
}

#
# debugging routines
#

# pretty-prints the call stack to STDERR
sub dump_caller {
    my $i = 0;
    my @caller;
    my @names = qw(package filename line subroutine hasargs
                   wantarray evaltext is_require hints bitmask);
    while (@caller = CORE::caller($i + 1)) {
        print STDERR "-"x3, " Frame [$i] ", "-"x50, "\n";
        for (0 .. $#caller) {
            printf STDERR "%15s => %s\n", $names[$_], 
              (defined $caller[$_] ? $caller[$_] : "(undef)");
        }
        $i++;
    }
}  


1;
__END__