<font color="red"><i>output omitted</i></font>
================ 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;
<font color="red"><i>output omitted</i></font>
================ 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__
|
