Email	Print Reprint
	add to:
	Del.icio.us Digg Google Furl	Slashdot Y! MyWeb Blink

Example 1: Profile output for Memoize.pm and fibonacci.pl.

Back to Article

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 mjd-perl-memoize+@plover.com 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__

Previous Page | 1 | 2

RELATED ARTICLES Highly Scalable Parallel Sorting SC09 Storage Challenge Award Nozzle: Counteracting Memory Exploits Experts Consider Robots, Legal Issues ACLU Launches dotRights		TOP 5 ARTICLES No Top Articles.