1########################################################################### 2# File - ExpireLRU.pm 3# Created 12 Feb, 2000, Brent B. Powers 4# 5# Purpose - This package implements LRU expiration. It does this by 6# using a bunch of different data structures. Tuning 7# support is included, but costs performance. 8# 9# ToDo - Test the further tie stuff 10# 11# Copyright(c) 2000 Brent B. Powers and B2Pi LLC 12# 13# You may copy and distribute this program under the same terms as 14# Perl itself. 15# 16########################################################################### 17package Memoize::ExpireLRU; 18$Memoize::ExpireLRU::VERSION = '0.56'; 19use 5.006; 20use warnings; 21use strict; 22use AutoLoader qw(AUTOLOAD); 23use Carp; 24 25our $DEBUG = 0; 26 27# Usage: memoize func , 28# TIE => [ 29# Memoize::ExpireLRU, 30# CACHESIZE => n, 31# TUNECACHESIZE => m, 32# INSTANCE => IDString 33# TIE => [...] 34# ] 35 36############################################# 37## 38## This used to all be a bit more reasonable, but then it turns out 39## that Memoize doesn't call FETCH if EXISTS returns true and it's in 40## scalar context. Thus, everything really has to be done in the 41## EXISTS code. Harumph. 42## 43############################################# 44 45our @AllTies; 46our $EndDebug = 0; 47 481; 49 50sub TIEHASH { 51 my ($package, %args, %cache, @index, @Tune, @Stats); 52 ($package, %args)= @_; 53 my($self) = bless \%args => $package; 54 $self->{CACHESIZE} or 55 croak "Memoize::ExpireLRU: CACHESIZE must be specified >0; aborting"; 56 $self->{TUNECACHESIZE} ||= 0; 57 delete($self->{TUNECACHESIZE}) unless $self->{TUNECACHESIZE}; 58 $self->{C} = \%cache; 59 $self->{I} = \@index; 60 defined($self->{INSTANCE}) or $self->{INSTANCE} = "$self"; 61 foreach (@AllTies) { 62 if ($_->{INSTANCE} eq $self->{INSTANCE}) { 63 croak "Memoize::ExpireLRU: Attempt to register the same routine twice; aborting"; 64 } 65 } 66 if ($self->{TUNECACHESIZE}) { 67 $EndDebug = 1; 68 for (my $i = 0; $i < $args{TUNECACHESIZE}; $i++) { 69 $Stats[$i] = 0; 70 } 71 $self->{T} = \@Stats; 72 $self->{TI} = \@Tune; 73 $self->{cm} = $args{ch} = $args{th} = 0; 74 75 } 76 77 if ($self->{TIE}) { 78 my($module, $modulefile, @opts, $rc, %tcache); 79 ($module, @opts) = @{$args{TIE}}; 80 $modulefile = $module . '.pm'; 81 $modulefile =~ s{::}{/}g; 82 eval { require $modulefile }; 83 if ($@) { 84 croak "Memoize::ExpireLRU: Couldn't load hash tie module `$module': $@; aborting"; 85 } 86 $rc = (tie %tcache => $module, @opts); 87 unless ($rc) { 88 croak "Memoize::ExpireLRU: Couldn't tie hash to `$module': $@; aborting"; 89 } 90 91 ## Preload our cache 92 foreach (keys %tcache) { 93 $self->{C}->{$_} = $tcache{$_} 94 } 95 $self->{TiC} = \%tcache; 96 } 97 98 push(@AllTies, $self); 99 return $self; 100} 101 102sub EXISTS { 103 my($self, $key) = @_; 104 105 $DEBUG and print STDERR " >> $self->{INSTANCE} >> EXISTS: $key\n"; 106 107 if (exists $self->{C}->{$key}) { 108 my($t, $i);#, %t, %r); 109 110 ## Adjust the positions in the index cache 111 ## 1. Find the old entry in the array (and do the stat's) 112 $i = _find($self->{I}, $self->{C}->{$key}->{t}, $key); 113 if (!defined($i)) { 114 print STDERR "Cache trashed (unable to find $key)\n"; 115 DumpCache($self->{INSTANCE}); 116 ShowStats(); 117 die "Aborting..."; 118 } 119 120 ## 2. Remove the old entry from the array 121 $t = splice(@{$self->{I}}, $i, 1); 122 123 ## 3. Update the timestamp of the new array entry, as 124 ## well as that in the cache 125 $self->{C}->{$key}->{t} = $t->{t} = time; 126 127 ## 4. Store the updated entry back into the array as the MRU 128 unshift(@{$self->{I}}, $t); 129 130 ## 5. Adjust stats 131 if (defined($self->{T})) { 132 $self->{T}->[$i]++ if defined($self->{T}); 133 $self->{ch}++; 134 } 135 136 if ($DEBUG) { 137 print STDERR " Cache hit at $i"; 138 print STDERR " ($self->{ch})" if defined($self->{T}); 139 print STDERR ".\n"; 140 } 141 142 return 1; 143 } else { 144 if (exists($self->{TUNECACHESIZE})) { 145 $self->{cm}++; 146 $DEBUG and print STDERR " Cache miss ($self->{cm}).\n"; 147 ## Ughhh. A linear search 148 my($i, $j); 149 for ($i = $j = $self->{CACHESIZE}; $i <= $#{$self->{T}}; $i++) { 150 next unless defined($self->{TI}) 151 && defined($self->{TI}->[$i- $j]) 152 && defined($self->{TI}->[$i - $j]->{k}) 153 && $self->{TI}->[$i - $j]->{k} eq $key; 154 $self->{T}->[$i]++; 155 $self->{th}++; 156 $DEBUG and print STDERR " TestCache hit at $i. ($self->{th})\n"; 157 splice(@{$self->{TI}}, $i - $j, 1); 158 return 0; 159 } 160 } else { 161 $DEBUG and print STDERR " Cache miss.\n"; 162 } 163 return 0; 164 } 165} 166 167sub STORE { 168 my ($self, $key, $value) = @_; 169 $DEBUG and print STDERR " >> $self->{INSTANCE} >> STORE: $key $value\n"; 170 171 my(%r, %t); 172 $t{t} = $r{t} = time; 173 $r{v} = $value; 174 $t{k} = $key; 175 176 # Store the value into the hash 177 $self->{C}->{$key} = \%r; 178 ## As well as the tied cache, if it exists 179 $self->{TC}->{$key} = $value if defined($self->{TC}); 180 181 # By definition, this item is the MRU, so add it to the beginning 182 # of the LRU queue. Since this is a STORE, we know it doesn't already 183 # exist. 184 unshift(@{$self->{I}}, \%t); 185 ## Update the tied cache 186 $self->{TC}->{$key} = $value if defined($self->{TC}); 187 188 ## Do we have too many entries? 189 while (scalar(@{$self->{I}}) > $self->{CACHESIZE}) { 190 ## Chop off whatever is at the end 191 ## Get the key 192 $key = pop(@{$self->{I}}); 193 delete($self->{C}->{$key->{k}}); 194 delete($self->{TC}->{$key->{k}}) if defined($self->{TC}); 195 ## Throw it to the beginning of the test cache 196 unshift(@{$self->{TI}}, $key) if defined($self->{T}); 197 } 198 199 ## Now, what about the Tuning Index 200 if (defined($self->{T})) { 201 if (scalar(@{$self->{TI}}) > $self->{TUNECACHESIZE} - $self->{CACHESIZE}) { 202 $#{$self->{TI}} = $self->{TUNECACHESIZE} - $self->{CACHESIZE} - 1; 203 } 204 } 205 206 $value; 207} 208 209sub FETCH { 210 my($self, $key) = @_; 211 212 $DEBUG and print STDERR " >> $self->{INSTANCE} >> FETCH: $key\n"; 213 214 return $self->{C}->{$key}->{v}; 215} 216 217sub _find ( $$$ ) { 218 my($Aref, $time, $key) = @_; 219 my($t, $b, $n, $l); 220 221 $t = $#{$Aref}; 222 $n = $b = 0; 223 $l = -2; 224 225 while ($time != $Aref->[$n]->{t}) { 226 if ($time < $Aref->[$n]->{t}) { 227 $b = $n; 228 } else { 229 $t = $n; 230 } 231 if ($t <= $b) { 232 ## Trouble, we're out. 233 if ($Aref->[$t]->{t} == $time) { 234 $n = $t; 235 } elsif ($Aref->[$b]->{t} == $time) { 236 $n = $b; 237 } else { 238 ## Really big trouble 239 ## Complain loudly 240 print "Trouble\n"; 241 return undef; 242 } 243 } else { 244 $n = $b + (($t - $b) >> 1); 245 $n++ if $l == $n; 246 $l = $n; 247 } 248 } 249 ## Drop down in the array until the time isn't the time 250 while (($n > 0) && ($time == $Aref->[$n-1]->{t})) { 251 $n--; 252 } 253 while (($time == $Aref->[$n]->{t}) && ($key ne $Aref->[$n]->{k})) { 254 $n++; 255 } 256 if ($key ne $Aref->[$n]->{k}) { 257 ## More big trouble 258 print "More trouble\n"; 259 return undef; 260 } 261 return $n; 262} 263 264END { 265 print STDERR ShowStats() if $EndDebug; 266} 267 268__END__ 269 270sub DumpCache ( $ ) { 271 ## Utility routine to display the caches of the given instance 272 my($Instance, $self, $p) = shift; 273 foreach $self (@AllTies) { 274 275 next unless $self->{INSTANCE} eq $Instance; 276 277 $p = "$Instance:\n Cache Keys:\n"; 278 279 foreach my $x (@{$self->{I}}) { 280 ## The cache is at $self->{C} (->{$key}) 281 $p .= " '$x->{k}'\n"; 282 } 283 $p .= " Test Cache Keys:\n"; 284 foreach my $x (@{$self->{TI}}) { 285 $p .= " '$x->{k}'\n"; 286 } 287 return $p; 288 } 289 return "Instance $Instance not found\n"; 290} 291 292 293sub ShowStats () { 294 ## Utility routine to show statistics 295 my($k) = 0; 296 my($p) = ''; 297 foreach my $self (@AllTies) { 298 next unless defined($self->{T}); 299 $p .= "ExpireLRU Statistics:\n" unless $k; 300 $k++; 301 302 $p .= <<EOS; 303 304 ExpireLRU instantiation: $self->{INSTANCE} 305 Cache Size: $self->{CACHESIZE} 306 Experimental Cache Size: $self->{TUNECACHESIZE} 307 Cache Hits: $self->{ch} 308 Cache Misses: $self->{cm} 309Additional Cache Hits at Experimental Size: $self->{th} 310 Distribution : Hits 311EOS 312 for (my $i = 0; $i < $self->{TUNECACHESIZE}; $i++) { 313 if ($i == $self->{CACHESIZE}) { 314 $p .= " ---- -----\n"; 315 } 316 $p .= sprintf(" %3d : %s\n", 317 $i, $self->{T}->[$i]); 318 } 319 } 320 return $p; 321} 322 323=head1 NAME 324 325Memoize::ExpireLRU - Expiry plug-in for Memoize that adds LRU cache expiration 326 327=head1 SYNOPSIS 328 329 use Memoize; 330 331 memoize('slow_function', 332 TIE => [Memoize::ExpireLRU, 333 CACHESIZE => n, 334 ]); 335 336Note that one need not C<use> this module. 337It will be found by the L<Memoize> module. 338 339The argument to C<CACHESIZE> must be an integer. 340Normally, this is all that is needed. 341Additional options are available: 342 343 TUNECACHESIZE => m, 344 INSTANCE => 'descriptive_name', 345 TIE => '[DB_File, $filename, O_RDWR | O_CREATE, 0666]' 346 347=head1 DESCRIPTION 348 349For the theory of Memoization, please see the Memoize module 350documentation. This module implements an expiry policy for Memoize 351that follows LRU semantics, that is, the last n results, where n is 352specified as the argument to the C<CACHESIZE> parameter, will be 353cached. 354 355=head1 PERFORMANCE TUNING 356 357It is often quite difficult to determine what size cache will give 358optimal results for a given function. To aid in determining this, 359ExpireLRU includes cache tuning support. Enabling this causes a 360definite performance hit, but it is often useful before code is 361released to production. 362 363To enable cache tuning support, simply specify the optional 364C<TUNECACHESIZE> parameter with a size greater than that of the 365C<CACHESIZE> parameter. 366 367When the program exits, a set of statistics will be printed to 368stderr. If multiple routines have been memoized, separate sets of 369statistics are printed for each routine. The default names are 370somewhat cryptic: this is the purpose of the C<INSTANCE> 371parameter. The value of this parameter will be used as the identifier 372within the statistics report. 373 374=head1 DIAGNOSTIC METHODS 375 376Two additional routines are available but not 377exported. Memoize::ExpireLRU::ShowStats returns a string identical to 378the statistics report printed to STDERR at the end of the program if 379test caches have been enabled; Memoize::ExpireLRU::DumpCache takes the 380instance name of a memoized function as a parameter, and returns a 381string describing the current state of that instance. 382 383 384=head1 SEE ALSO 385 386L<Memoize> 387 388 389=head1 REPOSITORY 390 391L<https://github.com/neilb/Memoize-ExpireLRU> 392 393 394=head1 AUTHOR 395 396Brent B. Powers (B2Pi), Powers@B2Pi.com 397 398 399=head1 COPYRIGHT AND LICENSE 400 401This software is copyright (c) 1999 by Brent B. Powers. 402 403This is free software; you can redistribute it and/or modify it under 404the same terms as the Perl 5 programming language system itself. 405 406=cut 407