File: ExpireLRU.pm

package info (click to toggle)
libmemoize-expirelru-perl 0.55-1
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd, squeeze, wheezy
  • size: 88 kB
  • ctags: 13
  • sloc: perl: 334; makefile: 2
file content (395 lines) | stat: -rw-r--r-- 10,620 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
###########################################################################
# File    - ExpireLRU.pm
#	    Created 12 Feb, 2000, Brent B. Powers
#
# Purpose - This package implements LRU expiration. It does this by
#	    using a bunch of different data structures. Tuning
#	    support is included, but costs performance.
#
# ToDo    - Test the further tie stuff
#
# Copyright(c) 2000 Brent B. Powers and B2Pi LLC
#
# You may copy and distribute this program under the same terms as
# Perl itself.
#
###########################################################################
package Memoize::ExpireLRU;

use strict;
use AutoLoader qw(AUTOLOAD);
use Carp;
use vars qw($DEBUG $VERSION);

$DEBUG = 0;
$VERSION = '0.55';

# Usage:  memoize func ,
# 		TIE => [
# 			Memoize::ExpireLRU,
# 			CACHESIZE => n,
# 			TUNECACHESIZE => m,
#			INSTANCE => IDString
# 			TIE => [...]
# 		       ]

#############################################
##
## This used to all be a bit more reasonable, but then it turns out
## that Memoize doesn't call FETCH if EXISTS returns true and it's in
## scalar context. Thus, everything really has to be done in the
## EXISTS code. Harumph.
##
#############################################

use vars qw(@AllTies $EndDebug);

$EndDebug = 0;

1;

sub TIEHASH {
    my ($package, %args, %cache, @index, @Tune, @Stats);
    ($package, %args)= @_;
    my($self) = bless \%args => $package;
    $self->{CACHESIZE} or
	    croak "Memoize::ExpireLRU: CACHESIZE must be specified >0; aborting";
    $self->{TUNECACHESIZE} ||= 0;
    delete($self->{TUNECACHESIZE}) unless $self->{TUNECACHESIZE};
    $self->{C} = \%cache;
    $self->{I} = \@index;
    defined($self->{INSTANCE}) or $self->{INSTANCE} = "$self";
    foreach (@AllTies) {
	if ($_->{INSTANCE} eq $self->{INSTANCE}) {
	    croak "Memoize::ExpireLRU: Attempt to register the same routine twice; aborting";
	}
    }
    if ($self->{TUNECACHESIZE}) {
	$EndDebug = 1;
	for (my $i = 0; $i < $args{TUNECACHESIZE}; $i++) {
	    $Stats[$i] = 0;
	}
	$self->{T} = \@Stats;
	$self->{TI} = \@Tune;
	$self->{cm} = $args{ch} = $args{th} = 0;
	
    }

    if ($self->{TIE}) {
	my($module, $modulefile, @opts, $rc, %tcache);
	($module, @opts) = @{$args{TIE}};
	$modulefile = $module . '.pm';
	$modulefile =~ s{::}{/}g;
	eval { require $modulefile };
	if ($@) {
	    croak "Memoize::ExpireLRU: Couldn't load hash tie module `$module': $@; aborting";
	}
	$rc = (tie %tcache => $module, @opts);
	unless ($rc) {
	    croak "Memoize::ExpireLRU: Couldn't tie hash to `$module': $@; aborting";
	}

	## Preload our cache
	foreach (keys %tcache) {
	    $self->{C}->{$_} = $tcache{$_}
	}
	$self->{TiC} = \%tcache;
    }

    push(@AllTies, $self);
    return $self;
}

sub EXISTS {
    my($self, $key) = @_;

    $DEBUG and print STDERR " >> $self->{INSTANCE} >> EXISTS: $key\n";

    if (exists $self->{C}->{$key}) {
	my($t, $i);#, %t, %r);

	## Adjust the positions in the index cache
	##    1. Find the old entry in the array (and do the stat's)
	$i = _find($self->{I}, $self->{C}->{$key}->{t}, $key);
	if (!defined($i)) {
	    print STDERR "Cache trashed (unable to find $key)\n";
	    DumpCache($self->{INSTANCE});
	    ShowStats;
	    die "Aborting...";
	}

	##    2. Remove the old entry from the array
	$t = splice(@{$self->{I}}, $i, 1);

	##    3. Update the timestamp of the new array entry, as
	##  well as that in the cache
	$self->{C}->{$key}->{t} = $t->{t} = time;

	##    4. Store the updated entry back into the array as the MRU
	unshift(@{$self->{I}}, $t);

	##    5. Adjust stats
	if (defined($self->{T})) {
	    $self->{T}->[$i]++ if defined($self->{T});
	    $self->{ch}++;
	}

	if ($DEBUG) {
	    print STDERR "    Cache hit at $i";
	    print STDERR " ($self->{ch})" if defined($self->{T});
	    print STDERR ".\n";
	}

	return 1;
    } else {
	if (exists($self->{TUNECACHESIZE})) {
	    $self->{cm}++;
	    $DEBUG and print STDERR "    Cache miss ($self->{cm}).\n";
 	    ## Ughhh. A linear search
	    my($i, $j);
	    for ($i = $j = $self->{CACHESIZE}; $i <= $#{$self->{T}}; $i++) {
		next unless defined($self->{TI})
			&& defined($self->{TI}->[$i- $j])
			&& defined($self->{TI}->[$i - $j]->{k})
			&& $self->{TI}->[$i - $j]->{k} eq $key;
		$self->{T}->[$i]++;
		$self->{th}++;
		$DEBUG and print STDERR "    TestCache hit at $i. ($self->{th})\n";
		splice(@{$self->{TI}}, $i - $j, 1);
		return 0;
	    }
	} else {
	    $DEBUG and print STDERR "    Cache miss.\n";
	}
	return 0;
    }
}

sub STORE {
    my ($self, $key, $value) = @_;
    $DEBUG and print STDERR " >> $self->{INSTANCE} >> STORE: $key $value\n";

    my(%r, %t);
    $t{t} = $r{t} = time;
    $r{v} = $value;
    $t{k} = $key;

    # Store the value into the hash
    $self->{C}->{$key} = \%r;
    ## As well as the tied cache, if it exists
    $self->{TC}->{$key} = $value if defined($self->{TC});

    # By definition, this item is the MRU, so add it to the beginning
    # of the LRU queue. Since this is a STORE, we know it doesn't already
    # exist.
    unshift(@{$self->{I}}, \%t);
    ## Update the tied cache
    $self->{TC}->{$key} = $value if defined($self->{TC});

    ## Do we have too many entries?
    while (scalar(@{$self->{I}}) > $self->{CACHESIZE}) {
	## Chop off whatever is at the end
	## Get the key
	$key = pop(@{$self->{I}});
	delete($self->{C}->{$key->{k}});
	delete($self->{TC}->{$key->{k}}) if defined($self->{TC});
	## Throw it to the beginning of the test cache
	unshift(@{$self->{TI}}, $key) if defined($self->{T});
    }

    ## Now, what about the Tuning Index
    if (defined($self->{T})) {
	if (scalar(@{$self->{TI}}) > $self->{TUNECACHESIZE} - $self->{CACHESIZE}) {
	    $#{$self->{TI}} = $self->{TUNECACHESIZE} - $self->{CACHESIZE} - 1;
	}
    }

    $value;
}

sub FETCH {
    my($self, $key) = @_;

    $DEBUG and print STDERR " >> $self->{INSTANCE} >> FETCH: $key\n";

    return $self->{C}->{$key}->{v};
}

sub _find ( $$$ ) {
    my($Aref, $time, $key) = @_;
    my($t, $b, $n, $l);

    $t = $#{$Aref};
    $n = $b = 0;
    $l = -2;

    while ($time != $Aref->[$n]->{t}) {
	if ($time < $Aref->[$n]->{t}) {
	    $b = $n;
	} else {
	    $t = $n;
	}
	if ($t <= $b) {
	    ## Trouble, we're out.
	    if ($Aref->[$t]->{t} == $time) {
		$n = $t;
	    } elsif ($Aref->[$b]->{t} == $time) {
		$n = $b;
	    } else {
		## Really big trouble
		## Complain loudly
		print "Trouble\n";
		return undef;
	    }
	} else {
	    $n = $b + (($t - $b) >> 1);
	    $n++ if $l == $n;
	    $l = $n;
	}
    }
    ## Drop down in the array until the time isn't the time
    while (($n > 0) && ($time == $Aref->[$n-1]->{t})) {
	$n--;
    }
    while (($time == $Aref->[$n]->{t}) && ($key ne $Aref->[$n]->{k})) {
	$n++;
    }
    if ($key ne $Aref->[$n]->{k}) {
	## More big trouble
	print "More trouble\n";
	return undef;
    }
    return $n;
}

END {
    print STDERR ShowStats() if $EndDebug;
}

__END__

sub DumpCache ( $ ) {
    ## Utility routine to display the caches of the given instance
    my($Instance, $self, $p) = shift;
    foreach $self (@AllTies) {

	next unless $self->{INSTANCE} eq $Instance;

	$p = "$Instance:\n    Cache Keys:\n";

	foreach my $x (@{$self->{I}}) {
	    ## The cache is at $self->{C} (->{$key})
	    $p .= "        '$x->{k}'\n";
	}
	$p .= "    Test Cache Keys:\n";
	foreach my $x (@{$self->{TI}}) {
	    $p .= "        '$x->{k}'\n";
	}
	return $p;
    }
    return "Instance $Instance not found\n";
}


sub ShowStats () {
    ## Utility routine to show statistics
    my($k) = 0;
    my($p) = '';
    foreach my $self (@AllTies) {
	next unless defined($self->{T});
	$p .= "ExpireLRU Statistics:\n" unless $k;
	$k++;

	$p .= <<EOS;

                   ExpireLRU instantiation: $self->{INSTANCE}
                                Cache Size: $self->{CACHESIZE}
                   Experimental Cache Size: $self->{TUNECACHESIZE}
                                Cache Hits: $self->{ch}
                              Cache Misses: $self->{cm}
Additional Cache Hits at Experimental Size: $self->{th}
                             Distribution : Hits
EOS
	for (my $i = 0; $i < $self->{TUNECACHESIZE}; $i++) {
	    if ($i == $self->{CACHESIZE}) {
		$p .= "                                     ----   -----\n";
	    }
	    $p .= sprintf("                                      %3d : %s\n",
			  $i, $self->{T}->[$i]);
	}
    }
    return $p;
}

=head1 NAME

Memoize - Expiry plug-in for Memoize that adds LRU cache expiration

=head1 SYNOPSIS

    use Memoize;

    memoize('slow_function',
	    TIE => [Memoize::ExpireLRU,
		    CACHESIZE => n,
	           ]);

Note that one need not C<use> this module. It will be found by the
Memoize module.

The argument to CACHESIZE must be an integer. Normally, this is all
that is needed. Additional options are available:

	TUNECACHESIZE => m,
	INSTANCE => 'descriptive_name',
	TIE => '[DB_File, $filename, O_RDWR | O_CREATE, 0666]'

=head1 DESCRIPTION

For the theory of Memoization, please see the Memoize module
documentation. This module implements an expiry policy for Memoize
that follows LRU semantics, that is, the last n results, where n is
specified as the argument to the C<CACHESIZE> parameter, will be
cached.

=head1 PERFORMANCE TUNING

It is often quite difficult to determine what size cache will give
optimal results for a given function. To aid in determining this,
ExpireLRU includes cache tuning support. Enabling this causes a
definite performance hit, but it is often useful before code is
released to production.

To enable cache tuning support, simply specify the optional
C<TUNECACHESIZE> parameter with a size greater than that of the
C<CACHESIZE> parameter.

When the program exits, a set of statistics will be printed to
stderr. If multiple routines have been memoized, separate sets of
statistics are printed for each routine. The default names are
somewhat cryptic: this is the purpose of the C<INSTANCE>
parameter. The value of this parameter will be used as the identifier
within the statistics report.

=head1 DIAGNOSTIC METHODS

Two additional routines are available but not
exported. Memoize::ExpireLRU::ShowStats returns a string identical to
the statistics report printed to STDERR at the end of the program if
test caches have been enabled; Memoize::ExpireLRU::DumpCache takes the
instance name of a memoized function as a parameter, and returns a
string describing the current state of that instance.

=head1 AUTHOR

Brent B. Powers (B2Pi), Powers@B2Pi.com

Copyright(c) 1999 Brent B. Powers. All rights reserved. This program
is free software, you may redistribute it and/or modify it under the
same terms as Perl itself.

=head1 SEE ALSO

Memoize

=cut