|
Recursive subroutines are essential for many tasks. But they can slow your app to a crawl if handled incorrectly. Perl's profiler can help pinpoint the bottlenecks.
April 09, 2001
URL:http://www.drdobbs.com/profiling-in-perl/184404580
Recursive subroutines are essential for many tasks. But they can slow your app to a crawl if handled incorrectly. Perl's profiler can help pinpoint the bottlenecks.
In the previous article in this series I introduced you to the Perl debugger and showed you how to write your own. As an example, I created a couple of tools that are typically called profilers because they give information about the program being executed. Now let's use one of the popular profilers available from the Comprehensive Perl Archive Network (CPAN).
Profilers allow you to look at the execution of a program from different perspectives. One of the profilers that I created in the last article allowed me to see the number of times a line was executed during the run of the program (a line profiler) so that I could see which statements were being executed the most. The Devel::SmallProf module does that as well as measuring the total execution time of each of the lines. The time that the program spends on a particular bit of code can be more important than the number of times that it is executed (although the two may be related).
Consider one of the examples from the previous article. This one line of code may take several seconds or even minutes, because it does a lot behind the scenes to fetch information over a network:
#!/usr/bin/perl use LWP::Simple; getstore( 'http://www.perl.org', 'www.perl.org.html' ); __END__ |
However, a seemingly more complex line takes no time at all:
#!/usr/bin/perl
print map { $_ ** 2 } grep { $_ % 2 } sort { $a <=> $b } @ARGV;
__END__
|
You can easily tell where the program spends its time in these simple examples, but in a large project, you probably will not be able to tell simply by inspection. Indeed, this is why programmers created profilers.
You invoke the profiler by specifying which debugger you want to use through the -d switch. Remember that perl assumes the module is in the Devel::* namespace.
prompt$ perl -d:SmallProf my_script.pl |
The Devel::SmallProf module sends its results (the profile) to a special file called smallprof.out in the current working directory.
To demonstrate this profiler I created a small program with a
recursive subroutine to calculate Fibonacci numbers, which I
call fibonacci.pl. Around the year 1202 while
travelling the world, Leonardo
Pisano Fibonacci wondered how fast rabbits could breed. If
two rabbits bred to produce two more rabbits, and then each of
those pairs bred, ad infinitum, how many rabbits are there at a
particular point in time? More precisely, Fibonacci asked in
his mathematical treatise Liber abbaci:
A certain man put a pair of rabbits in a place surrounded on all sides by a wall. How many pairs of rabbits can be produced from that pair in a year if it is supposed that every month each pair begets a new pair which from the second month on becomes productive?
To describe this situation, Fibonacci came up with a sequence of numbers such that the next number in the sequence is the sum of the previous two, with the boundary condition that the first two numbers in the sequence are 0 and 1. If I name the function which generates the Nth Fibonacci number F(N), and F(0) is 0 and F(1) is 1 by definition, then F(2) is F( 2 - 1 ) + F( 2 - 2 ) which is F(1) + F(0), which turns out to be 1. Going on, F(3) is F( 3 - 1 ) + F( 3 - 2 ), which is F(2) + F(1) which we expand to F( 2 - 1 ) + F( 2 - 2 ) + F(1), which is F(1) + F(0) + F(1) which is 2. As N gets larger, I have to do a lot more work to compute the Fibonacci number, and a lot more work to take care of all of those rabbits. Since I notice the recursive nature of the computation, I can write a recursive subroutine (that calls itself) to do the work. This example not only shows how computationally expensive recursive subroutines can be, but I can highlight another Perl module that is a drop-in fix for that.
#!/usr/bin/perl
sub fibonacci
{
my $index = shift;
return 0 if $index == 0;
return 1 if $index == 1;
return fibonacci( $index - 1 ) + fibonacci( $index - 2 );
}
print "F($ARGV[0]) is ", fibonacci($ARGV[0]), "\n";
__END__
|
My test program takes a single argument (which shows up in the first element of the special @ARGV array, $ARGV[0]) — the Fibonacci number to compute.
prompt$ perl fibonacci.pl 10 F(10) is 55 |
The larger N is, the longer the program takes to complete and the time to finish increases exponentially with N. Try it yourself to see if your computer is faster than mine:
|
Performance of
|
| N | F(N) | time, seconds |
| 5 | 5 | 0 |
| 10 | 55 | 0 |
| 15 | 610 | 0.01 |
| 20 | 6,765 | 0.1 |
| 25 | 75,025 | 1 |
| 30 | 832,040 | 12 |
| 35 | 9,227,465 | 136 |
| 40 | 102,334,155 | 1607 |
Why is this program so slow for N above 30? The Devel::SmallProf module gives me a big hint. I already know why it is slow because I made this program to be slow, but in a much larger code base, especially one you inherit, you may not know ahead of time which parts are slow.
I run fibonacci.pl using the Devel::SmallProf debugger to determine the Fibonacci number for N = 40 — the number of rabbits I would have after about three years.
prompt$ perl -d:SmallProf fibonacci.pl 40 |
================ SmallProf version 0.9 ================
Profile of fib.pl Page 1
=================================================================
count wall tm cpu time line
0 0.000000 0.000000 1:#!/usr/bin/perl
0 0.000000 0.000000 2:
0 0.000000 0.000000 3:sub fibonacci
331160281 0.000000 0.000000 4: {
331160281 11031.59 16482.02 5: my $index = shift;
0 0.000000 0.000000 6:
331160281 15974.55 20532.39 7: return 0 if $index == 0;
267914295 15604.80 19898.51 8: return 1 if $index == 1;
0 0.000000 0.000000 9:
165580140 16967.53 18064.83 10: return fibonacci( $index - 1 ) +
0 0.000000 0.000000 11: }
0 0.000000 0.000000 12:
1 0.000116 0.000000 13:print "F($ARGV[0]) is ", fibonacci($ARGV[0]),
0 0.000000 0.000000 14:
0 0.000000 0.000000 15:__END__
|
The output has several columns. The first column shows the number of times that line was executed. The next two columns show the total real time (i.e. wall clock time) from Time::HiRes and CPU time (the time actually spent on the computation), from times, for the line. Then the line number is displayed in front the line of code.
Simply looking at the first column of smallprof.out I notice that the program executes some lines of code a very large number of times, even though I only directly called the fibonacci() routine once. Every time I want to compute a Fibonacci number, I have to compute other numbers, and the same for each of those. I end up doing the same work over and over again which wastes the computer's time. However, now that I have identified the problem I can fix it.
Now I can rework this table to include the number of times the fibonacci() subroutine is called. Ambitious readers can calculate the coefficient for Omega( 1.6N ).
|
Performance of fibonacci()
|
In this case, I can solve the problem by caching the results in between invocations of the subroutine. If I remember what F(N-1) is, I do not have to compute it the next time I need it. I could store these previous results in a globally scoped array, but then I would have to do a bit more coding, and I would have to do similar coding for each routine that I wanted to fix. However, laziness is one of the three virtues of a true programmer. Laziness means creating a general solution that we can use over and over again to make our lives easier. I just described the Memoize module.
The Memoize module is a drop-in solution that caches the results of subroutines so that we do not have to waste time doing work that we have already done. The module, through its magic, memoizes, or remembers the result of, a call to a subroutine with a particular argument list. In this case, Memoize stores the results of each call to fibonacci() so that we do not have to keep calling the subroutine.
I modified my earlier program to use the Memoize module. I simply tell Memoize which functions need help and let it do the rest.
#!/usr/bin/perl
use Memoize;
memoize('fibonacci');
sub fibonacci
{
my $index = shift;
return 0 if $index == 0;
return 1 if $index == 1;
return fibonacci( $index - 1 ) + fibonacci( $index - 2 );
}
print "F($ARGV[0]) is ", fibonacci($ARGV[0]), "\n";
__END__
|
If I run this program for N = 40 I find that it finishes almost instantaneously (at least compared to the last program). If I use the Devel::SmallProf module I can see the change when I run the script again.
prompt$ perl -d:SmallProf fibonacci.pl 40 |
Since I have run another script under the Devel::SmallProf debugger, the previous results in smallprof.out are overwritten with the new results. Now smallprof.out contains the new profile shown in Example 1.
The smallprof.out file, which I have edited to remove several other pages
of output dealing with behind-the-scenes magic from Memoize
and its included modules, shows some extra code pulled in from Memoize,
but it takes almost no time to do its magic. However, I notice the same lines
in the fibonacci() routine run only 41 times. The same lines for
the same input were executed 204,668,309 times in the previous program. The
Memoize
did its magic and drastically sped up my program. The Devel::SmallProf
module is the magic which told me what to fix.
Now that you know how to use a profiler to get information about a program, try the Devel::SmallProf module or some of the other profilers found on Devel::*. Your code will be running faster in no time, which will give you more time to care for all of those rabbits.
brian d foy has been a Perl user since 1994. He is founder of the first Perl users group, NY.pm, and Perl Mongers, the Perl advocacy organization. He has been teaching Perl through Stonehenge Consulting for the past three years, and has been a featured speaker at The Perl Conference, Perl University, YAPC, COMDEX, and Builder.com. Some of brian's other articles have appeared in The Perl Journal.
output omitted
================ SmallProf version 0.9 ================
Profile of /usr/lib/perl5/site_perl/5.005/Memoize.pm Page 10
=================================================================
count wall tm cpu time line
0 0.000000 0.000000 1:# -*- mode: perl; perl-indent-level: 2; -*-
0 0.000000 0.000000 2:# Memoize.pm
0 0.000000 0.000000 3:#
0 0.000000 0.000000 4:# Transparent memoization of idempotent
0 0.000000 0.000000 5:#
0 0.000000 0.000000 6:# Copyright 1998, 1999 M-J. Dominus.
0 0.000000 0.000000 7:# You may copy and distribute this program
0 0.000000 0.000000 8:# same terms as Perl itself. If in doubt,
0 0.000000 0.000000 9:# write to [email protected] for a
0 0.000000 0.000000 10:#
0 0.000000 0.000000 11:# Version 0.62 beta $Revision: 1.17 $ $Date:
0 0.000000 0.000000 12:
0 0.000000 0.000000 13:package Memoize;
0 0.000000 0.000000 14:$VERSION = '0.62';
0 0.000000 0.000000 15:
0 0.000000 0.000000 16:# Compile-time constants
314 0.003152 0.030000 17:sub SCALAR () { 0 }
4 0.000039 0.000000 18:sub LIST () { 1 }
0 0.000000 0.000000 19:
0 0.000000 0.000000 20:
0 0.000000 0.000000 21:#
0 0.000000 0.000000 22:# Usage memoize(functionname/ref,
0 0.000000 0.000000 23:# { NORMALIZER => coderef,
0 0.000000 0.000000 24:# LIST_CACHE => descriptor,
0 0.000000 0.000000 25:#
0 0.000000 0.000000 26:
0 0.000000 0.000000 27:use Carp;
0 0.000000 0.000000 28:use Exporter;
0 0.000000 0.000000 29:use vars qw($DEBUG);
0 0.000000 0.000000 30:@ISA = qw(Exporter);
0 0.000000 0.000000 31:@EXPORT = qw(memoize);
0 0.000000 0.000000 32:@EXPORT_OK = qw(unmemoize flush_cache);
0 0.000000 0.000000 33:use strict;
0 0.000000 0.000000 34:
0 0.000000 0.000000 35:my %memotable;
0 0.000000 0.000000 36:my %revmemotable;
0 0.000000 0.000000 37:my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT
0 0.000000 0.000000 38:my %IS_CACHE_TAG = map {($_ => 1)}
0 0.000000 0.000000 39:
0 0.000000 0.000000 40:# Raise an error if the user tries to specify
0 0.000000 0.000000 41:# tie for LIST_CACHE
0 0.000000 0.000000 42:
0 0.000000 0.000000 43:my %scalar_only = map {($_ => 1)} qw(DB_File
0 0.000000 0.000000 44:
1 0.000000 0.000000 45:sub memoize {
1 0.000017 0.000000 46: my $fn = shift;
1 0.000017 0.000000 47: my %options = @_;
1 0.000014 0.000000 48: my $options = \%options;
0 0.000000 0.000000 49:
1 0.000018 0.000000 50: unless (defined($fn) &&
0 0.000000 0.000000 51: (ref $fn eq 'CODE' || ref $fn eq '')) {
0 0.000000 0.000000 52: croak "Usage: memoize
0 0.000000 0.000000 53: }
0 0.000000 0.000000 54:
1 0.000017 0.000000 55: my $uppack = caller; # TCL me Elmo!
1 0.000008 0.000000 56: my $cref; # Code reference to original
================ SmallProf version 0.9 ================
Profile of /usr/lib/perl5/site_perl/5.005/Memoize.pm Page 11
=================================================================
count wall tm cpu time line
1 0.000012 0.000000 57: my $name = (ref $fn ? undef : $fn);
0 0.000000 0.000000 58:
0 0.000000 0.000000 59: # Convert function names to code references
1 0.000182 0.000000 60: $cref = &_make_cref($fn, $uppack);
0 0.000000 0.000000 61:
0 0.000000 0.000000 62: # Locate function prototype, if any
1 0.000014 0.000000 63: my $proto = prototype $cref;
1 0.000012 0.000000 64: if (defined $proto) { $proto = "($proto)" }
1 0.000015 0.000000 65: else { $proto = "" }
0 0.000000 0.000000 66:
0 0.000000 0.000000 67: # Goto considered harmful! Hee hee hee.
1 0.000541 0.000000 68: my $wrapper = eval "sub $proto { unshift
0 0.000000 0.000000 69: # Actually I would like to get rid of the
0 0.000000 0.000000 70: # to be any other way to set the prototype
0 0.000000 0.000000 71:
0 0.000000 0.000000 72:# --- THREADED PERL COMMENT ---
0 0.000000 0.000000 73:# The above line might not work under
0 0.000000 0.000000 74:# semantics are broken. If that's the case,
0 0.000000 0.000000 75:# my $wrapper = eval "sub {
0 0.000000 0.000000 76:# Confirmed 1998-12-27 this does work.
0 0.000000 0.000000 77:# 1998-12-29: Sarathy says this bug is fixed
0 0.000000 0.000000 78:# However, the module still fails, although
0 0.000000 0.000000 79:
1 0.000017 0.000000 80: my $normalizer = $options{NORMALIZER};
1 0.000012 0.000000 81: if (defined $normalizer && ! ref
0 0.000000 0.000000 82: $normalizer = _make_cref($normalizer,
0 0.000000 0.000000 83: }
0 0.000000 0.000000 84:
1 0.000010 0.000000 85: my $install_name;
1 0.000014 0.000000 86: if (defined $options->{INSTALL}) {
0 0.000000 0.000000 87: # INSTALL => name
0 0.000000 0.000000 88: $install_name = $options->{INSTALL};
1 0.000018 0.000000 89: } elsif (! exists $options->{INSTALL}) {
0 0.000000 0.000000 90: # No INSTALL option provided; use
1 0.000014 0.000000 91: $install_name = $name;
0 0.000000 0.000000 92: } else {
0 0.000000 0.000000 93: # INSTALL => undef means don't install
0 0.000000 0.000000 94: }
0 0.000000 0.000000 95:
1 0.000010 0.000000 96: if (defined $install_name) {
1 0.000030 0.000000 97: $install_name = $uppack . '::' .
0 0.000000 0.000000 98: unless $install_name =~ /::/;
0 0.000000 0.000000 99: no strict;
1 0.000026 0.000000 100: local($^W) = 0; # ``Subroutine
2 0.000048 0.000000 101: *{$install_name} = $wrapper; # Install
0 0.000000 0.000000 102: }
0 0.000000 0.000000 103:
1 0.000067 0.000000 104: $revmemotable{$wrapper} = "" . $cref; #
0 0.000000 0.000000 105:
0 0.000000 0.000000 106: # These will be the caches
1 0.000013 0.000000 107: my %caches;
3 0.000059 0.000000 108: for my $context (qw(SCALAR LIST)) {
0 0.000000 0.000000 109: # suppress subsequent 'uninitialized
2 0.000059 0.000000 110: $options{"${context}_CACHE"} ||= '';
0 0.000000 0.000000 111:
2 0.000041 0.000000 112: my $cache_opt =
================ SmallProf version 0.9 ================
Profile of /usr/lib/perl5/site_perl/5.005/Memoize.pm Page 12
=================================================================
count wall tm cpu time line
2 0.000021 0.000000 113: my @cache_opt_args;
2 0.000018 0.000000 114: if (ref $cache_opt) {
0 0.000000 0.000000 115: @cache_opt_args = @$cache_opt;
0 0.000000 0.000000 116: $cache_opt = shift @cache_opt_args;
0 0.000000 0.000000 117: }
2 0.000022 0.000000 118: if ($cache_opt eq 'FAULT') { # no cache
0 0.000000 0.000000 119: $caches{$context} = undef;
2 0.000021 0.000000 120: } elsif ($cache_opt eq 'HASH') { # user-
0 0.000000 0.000000 121: $caches{$context} = $cache_opt_args[0];
2 0.000023 0.000000 122: } elsif ($cache_opt eq '' ||
0 0.000000 0.000000 123: # default is that we make up an in-
2 0.000063 0.000000 124: $caches{$context} = {};
0 0.000000 0.000000 125: # (this might get tied later, or MERGEd
0 0.000000 0.000000 126: } else {
0 0.000000 0.000000 127: croak "Unrecognized option to
0 0.000000 0.000000 128: }
0 0.000000 0.000000 129: }
0 0.000000 0.000000 130:
0 0.000000 0.000000 131: # Perhaps I should check here that you
0 0.000000 0.000000 132: # options. But if you did, it does do
0 0.000000 0.000000 133: # both get merged to the same in-memory
1 0.000016 0.000000 134: if ($options{SCALAR_CACHE} eq 'MERGE') {
0 0.000000 0.000000 135: $caches{SCALAR} = $caches{LIST};
1 0.000017 0.000000 136: } elsif ($options{LIST_CACHE} eq 'MERGE') {
0 0.000000 0.000000 137: $caches{LIST} = $caches{SCALAR};
0 0.000000 0.000000 138: }
0 0.000000 0.000000 139:
0 0.000000 0.000000 140: # Now deal with the TIE options
0 0.000000 0.000000 141: {
2 0.000023 0.000000 142: my $context;
3 0.000060 0.000000 143: foreach $context (qw(SCALAR LIST)) {
0 0.000000 0.000000 144: # If the relevant option wasn't `TIE',
2 0.000337 0.000000 145: _my_tie($context, $caches{$context},
0 0.000000 0.000000 146: }
0 0.000000 0.000000 147: }
0 0.000000 0.000000 148:
0 0.000000 0.000000 149: # We should put some more stuff in here
0 0.000000 0.000000 150: # We've been saying that for serveral
0 0.000000 0.000000 151: # And you know what? More stuff keeps
1 0.000092 0.000000 152: $memotable{$cref} =
0 0.000000 0.000000 153: {
0 0.000000 0.000000 154: O => $options, # Short keys here for
0 0.000000 0.000000 155: N => $normalizer,
0 0.000000 0.000000 156: U => $cref,
0 0.000000 0.000000 157: MEMOIZED => $wrapper,
0 0.000000 0.000000 158: PACKAGE => $uppack,
0 0.000000 0.000000 159: NAME => $install_name,
0 0.000000 0.000000 160: S => $caches{SCALAR},
0 0.000000 0.000000 161: L => $caches{LIST},
0 0.000000 0.000000 162: };
0 0.000000 0.000000 163:
1 0.000031 0.000000 164: $wrapper # Return just memoized version
0 0.000000 0.000000 165:}
0 0.000000 0.000000 166:
0 0.000000 0.000000 167:# This function tries to load a tied hash
2 0.000000 0.000000 168:sub _my_tie {
================ SmallProf version 0.9 ================
Profile of /usr/lib/perl5/site_perl/5.005/Memoize.pm Page 13
=================================================================
count wall tm cpu time line
2 0.000036 0.000000 169: my ($context, $hash, $options) = @_;
2 0.000039 0.000000 170: my $fullopt = $options-
0 0.000000 0.000000 171:
0 0.000000 0.000000 172: # We already checked to make sure that this
2 0.000023 0.000000 173: my $shortopt = (ref $fullopt) ? $fullopt-
0 0.000000 0.000000 174:
2 0.000050 0.000000 175: return unless defined $shortopt &&
0 0.000000 0.000000 176:
0 0.000000 0.000000 177: my @args = ref $fullopt ? @$fullopt : ();
0 0.000000 0.000000 178: shift @args;
0 0.000000 0.000000 179: my $module = shift @args;
0 0.000000 0.000000 180: if ($context eq 'LIST' &&
0 0.000000 0.000000 181: croak("You can't use $module for
0 0.000000 0.000000 182: }
0 0.000000 0.000000 183: my $modulefile = $module . '.pm';
0 0.000000 0.000000 184: $modulefile =~ s{::}{/}g;
0 0.000000 0.000000 185: eval { require $modulefile };
0 0.000000 0.000000 186: if ($@) {
0 0.000000 0.000000 187: croak "Memoize: Couldn't load hash tie
0 0.000000 0.000000 188: }
0 0.000000 0.000000 189:# eval { import $module };
0 0.000000 0.000000 190:# if ($@) {
0 0.000000 0.000000 191:# croak "Memoize: Couldn't import hash tie
0 0.000000 0.000000 192:# }
0 0.000000 0.000000 193:# eval "use $module ()";
0 0.000000 0.000000 194:# if ($@) {
0 0.000000 0.000000 195:# croak "Memoize: Couldn't use hash tie
0 0.000000 0.000000 196:# }
0 0.000000 0.000000 197: my $rc = (tie %$hash => $module, @args);
0 0.000000 0.000000 198: unless ($rc) {
0 0.000000 0.000000 199: croak "Memoize: Couldn't tie hash to
0 0.000000 0.000000 200: }
0 0.000000 0.000000 201: 1;
0 0.000000 0.000000 202:}
0 0.000000 0.000000 203:
0 0.000000 0.000000 204:sub flush_cache {
0 0.000000 0.000000 205: my $func = _make_cref($_[0], scalar
0 0.000000 0.000000 206: my $info =
0 0.000000 0.000000 207: die "$func not memoized" unless defined
0 0.000000 0.000000 208: for my $context (qw(S L)) {
0 0.000000 0.000000 209: my $cache = $info->{$context};
0 0.000000 0.000000 210: if (tied %$cache && ! (tied %$cache)-
0 0.000000 0.000000 211: my $funcname = defined($info->{NAME}) ?
0 0.000000 0.000000 212: "function $info->{NAME}" :
0 0.000000 0.000000 213: my $context = {S => 'scalar', L =>
0 0.000000 0.000000 214: croak "Tied cache hash for $context-
0 0.000000 0.000000 215: } else {
0 0.000000 0.000000 216: %$cache = ();
0 0.000000 0.000000 217: }
0 0.000000 0.000000 218: }
0 0.000000 0.000000 219:}
0 0.000000 0.000000 220:
0 0.000000 0.000000 221:# This is the function that manages the memo
0 0.000000 0.000000 222:sub _memoizer {
79 0.001108 0.000000 223: my $orig = shift; # stringized version of
79 0.001127 0.000000 224: my $info = $memotable{$orig};
================ SmallProf version 0.9 ================
Profile of /usr/lib/perl5/site_perl/5.005/Memoize.pm Page 14
=================================================================
count wall tm cpu time line
79 0.000889 0.000000 225: my $normalizer = $info->{N};
0 0.000000 0.000000 226:
79 0.000639 0.020000 227: my $argstr;
79 0.012471 0.000000 228: my $context = (wantarray() ? LIST :
0 0.000000 0.000000 229:
79 0.000763 0.000000 230: if (defined $normalizer) {
0 0.000000 0.000000 231: no strict;
0 0.000000 0.000000 232: if ($context == SCALAR) {
0 0.000000 0.000000 233: $argstr = &{$normalizer}(@_);
0 0.000000 0.000000 234: } elsif ($context == LIST) {
0 0.000000 0.000000 235: ($argstr) = &{$normalizer}(@_);
0 0.000000 0.000000 236: } else {
0 0.000000 0.000000 237: croak "Internal error \#41; context was
0 0.000000 0.000000 238: }
0 0.000000 0.000000 239: } else { # Default
79 0.091889 0.010000 240: $argstr = join $;,@_; # $;,@_;?
0 0.000000 0.000000 241: }
0 0.000000 0.000000 242:
79 0.012210 0.020000 243: if ($context == SCALAR) {
78 0.001069 0.010000 244: my $cache = $info->{S};
78 0.000772 0.000000 245: _crap_out($info->{NAME}, 'scalar') unless
78 0.001056 0.010000 246: if (exists $cache->{$argstr}) {
38 0.001693 0.010000 247: return $cache->{$argstr};
0 0.000000 0.000000 248: } else {
80 0.004003 0.010000 249: my $val = &{$info->{U}}(@_);
0 0.000000 0.000000 250: # Scalars are considered to be lists;
40 0.000709 0.000000 251: if ($info->{O}{SCALAR_CACHE} eq
0 0.000000 0.000000 252: $cache->{$argstr} = [$val];
0 0.000000 0.000000 253: } else {
40 0.000859 0.000000 254: $cache->{$argstr} = $val;
0 0.000000 0.000000 255: }
40 0.003255 0.000000 256: $val;
0 0.000000 0.000000 257: }
1 0.000151 0.000000 258: } elsif ($context == LIST) {
1 0.000015 0.000000 259: my $cache = $info->{L};
1 0.000011 0.000000 260: _crap_out($info->{NAME}, 'list') unless
1 0.000014 0.000000 261: if (exists $cache->{$argstr}) {
0 0.000000 0.000000 262: my $val = $cache->{$argstr};
0 0.000000 0.000000 263: return ($val) unless ref $val eq
0 0.000000 0.000000 264: # An array ref is ambiguous. Did the
0 0.000000 0.000000 265: # an array ref? Or did we cache a
0 0.000000 0.000000 266: # an anonymous array?
0 0.000000 0.000000 267: # If LISTCONTEXT=>MERGE, then the
0 0.000000 0.000000 268: # so we know for sure:
0 0.000000 0.000000 269: return ($val) if $info->{O}{LIST_CACHE}
0 0.000000 0.000000 270: # Otherwise, we're doomed. ###BUG
0 0.000000 0.000000 271: return @$val;
0 0.000000 0.000000 272: } else {
2 0.000082 0.000000 273: my $q = $cache->{$argstr} = [&{$info-
1 0.000590 0.000000 274: @$q;
0 0.000000 0.000000 275: }
0 0.000000 0.000000 276: } else {
0 0.000000 0.000000 277: croak "Internal error \#42; context was
0 0.000000 0.000000 278: }
0 0.000000 0.000000 279:}
0 0.000000 0.000000 280:
================ SmallProf version 0.9 ================
Profile of /usr/lib/perl5/site_perl/5.005/Memoize.pm Page 15
=================================================================
count wall tm cpu time line
0 0.000000 0.000000 281:sub unmemoize {
0 0.000000 0.000000 282: my $f = shift;
0 0.000000 0.000000 283: my $uppack = caller;
0 0.000000 0.000000 284: my $cref = _make_cref($f, $uppack);
0 0.000000 0.000000 285:
0 0.000000 0.000000 286: unless (exists $revmemotable{$cref}) {
0 0.000000 0.000000 287: croak "Could not unmemoize function `$f',
0 0.000000 0.000000 288: }
0 0.000000 0.000000 289:
0 0.000000 0.000000 290: my $tabent =
0 0.000000 0.000000 291: unless (defined $tabent) {
0 0.000000 0.000000 292: croak "Could not figure out how to
0 0.000000 0.000000 293: }
0 0.000000 0.000000 294: my $name = $tabent->{NAME};
0 0.000000 0.000000 295: if (defined $name) {
0 0.000000 0.000000 296: no strict;
0 0.000000 0.000000 297: local($^W) = 0; # ``Subroutine
0 0.000000 0.000000 298: *{$name} = $tabent->{U}; # Replace with
0 0.000000 0.000000 299: }
0 0.000000 0.000000 300: undef $memotable{$revmemotable{$cref}};
0 0.000000 0.000000 301: undef $revmemotable{$cref};
0 0.000000 0.000000 302:
0 0.000000 0.000000 303: # This removes the last reference to the
0 0.000000 0.000000 304: # my ($old_function, $memotabs) =
0 0.000000 0.000000 305: # undef $tabent;
0 0.000000 0.000000 306:
0 0.000000 0.000000 307:# # Untie the memo tables if they were tied.
0 0.000000 0.000000 308:# my $i;
0 0.000000 0.000000 309:# for $i (0,1) {
0 0.000000 0.000000 310:# if (tied %{$memotabs->[$i]}) {
0 0.000000 0.000000 311:# warn "Untying hash #$i\n";
0 0.000000 0.000000 312:# untie %{$memotabs->[$i]};
0 0.000000 0.000000 313:# }
0 0.000000 0.000000 314:# }
0 0.000000 0.000000 315:
0 0.000000 0.000000 316: $tabent->{U};
0 0.000000 0.000000 317:}
0 0.000000 0.000000 318:
1 0.000000 0.000000 319:sub _make_cref {
1 0.000019 0.000000 320: my $fn = shift;
1 0.000023 0.000000 321: my $uppack = shift;
1 0.000009 0.000000 322: my $cref;
1 0.000008 0.000000 323: my $name;
0 0.000000 0.000000 324:
1 0.000012 0.000000 325: if (ref $fn eq 'CODE') {
0 0.000000 0.000000 326: $cref = $fn;
1 0.000014 0.000000 327: } elsif (! ref $fn) {
1 0.000019 0.000000 328: if ($fn =~ /::/) {
0 0.000000 0.000000 329: $name = $fn;
0 0.000000 0.000000 330: } else {
1 0.000025 0.000000 331: $name = $uppack . '::' . $fn;
0 0.000000 0.000000 332: }
0 0.000000 0.000000 333: no strict;
1 0.000021 0.000000 334: if (defined $name and !defined(&$name)) {
0 0.000000 0.000000 335: croak "Cannot operate on nonexistent
0 0.000000 0.000000 336: }
================ SmallProf version 0.9 ================
Profile of /usr/lib/perl5/site_perl/5.005/Memoize.pm Page 16
=================================================================
count wall tm cpu time line
0 0.000000 0.000000 337:# $cref = \&$name;
2 0.000040 0.000000 338: $cref = *{$name}{CODE};
0 0.000000 0.000000 339: } else {
0 0.000000 0.000000 340: my $parent = (caller(1))[3]; # Function
0 0.000000 0.000000 341: croak "Usage: argument 1 to `$parent'
0 0.000000 0.000000 342: }
1 0.000010 0.000000 343: $DEBUG and warn "${name}($fn) => $cref in
1 0.000020 0.000000 344: $cref;
0 0.000000 0.000000 345:}
0 0.000000 0.000000 346:
0 0.000000 0.000000 347:sub _crap_out {
0 0.000000 0.000000 348: my ($funcname, $context) = @_;
0 0.000000 0.000000 349: if (defined $funcname) {
0 0.000000 0.000000 350: croak "Function `$funcname' called in
0 0.000000 0.000000 351: } else {
0 0.000000 0.000000 352: croak "Anonymous function called in
0 0.000000 0.000000 353: }
0 0.000000 0.000000 354:}
0 0.000000 0.000000 355:
0 0.000000 0.000000 356:1;
output omitted
================ SmallProf version 0.9 ================
Profile of fibonacci.pl Page 28
=================================================================
count wall tm cpu time line
0 0.000000 0.000000 1:#!/usr/bin/perl
0 0.000000 0.000000 2:
0 0.000000 0.000000 3:use Memoize;
0 0.000000 0.000000 4:
1 0.000204 0.000000 5:memoize('fibonacci');
0 0.000000 0.000000 6:
0 0.000000 0.000000 7:sub fibonacci
0 0.000000 0.000000 8: {
41 0.000663 0.000000 9: my $index = shift;
0 0.000000 0.000000 10:
41 0.000446 0.000000 11: return 0 if $index == 0;
40 0.000395 0.000000 12: return 1 if $index == 1;
0 0.000000 0.000000 13:
39 0.002819 0.000000 14: return fibonacci( $index - 1 ) +
0 0.000000 0.000000 15: }
0 0.000000 0.000000 16:
1 0.000078 0.000000 17:print "F($ARGV[0]) is ", fibonacci($ARGV[0]),
0 0.000000 0.000000 18:
0 0.000000 0.000000 19:__END__
|
Terms of Service | Privacy Statement | Copyright © 2024 UBM Tech, All rights reserved.