From f87323c2926605792ee02b84783d8f3d4dbd605f Mon Sep 17 00:00:00 2001 From: minima Date: Sun, 29 Sep 2002 17:28:32 +0000 Subject: [PATCH] add LRU caching --- Changes | 2 + perl/Chain.pm | 22 ++++++----- perl/DXProt.pm | 2 +- perl/DXUser.pm | 20 ++++++++-- perl/LRU.pm | 100 +++++++++++++++++++++++++++++++++++++++++++++++++ perl/Prefix.pm | 53 +++++++++----------------- 6 files changed, 150 insertions(+), 49 deletions(-) create mode 100644 perl/LRU.pm diff --git a/Changes b/Changes index 069f8e16..bb4f33df 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,5 @@ +29Sep02======================================================================= +1. Added LRU caching to DXUsers and Prefix. 28Sep02======================================================================= 1. Put some transparent caching into Prefix.pm to see if this has a performance impact. diff --git a/perl/Chain.pm b/perl/Chain.pm index cb3a2be8..8afd62f0 100644 --- a/perl/Chain.pm +++ b/perl/Chain.pm @@ -30,10 +30,11 @@ sub setcheck # constructor sub new { - my $name = shift; - my $ref = shift; + my $pkg = shift; + my $name = ref $pkg || $pkg; + my $self = []; - push @$self, $self, $self, $ref; + push @$self, $self, $self, @_; return bless $self, $name; } @@ -44,7 +45,7 @@ sub ins $docheck && _check($p); - my $q = ref $ref && $ref->isa('Chain') ? $ref : new Chain $ref; + my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref); $q->[PREV] = $p->[PREV]; $q->[NEXT] = $p; $p->[PREV]->[NEXT] = $q; @@ -68,9 +69,10 @@ sub del $docheck && _check($p); - $p->[PREV]->[NEXT] = $p->[NEXT]; + my $q = $p->[PREV]->[NEXT] = $p->[NEXT]; $p->[NEXT]->[PREV] = $p->[PREV]; - return $p->[PREV]; + $p->[NEXT] = $p->[PREV] = undef; + return $q; } # Is this chain empty? @@ -104,7 +106,7 @@ sub prev $docheck && _check($base); - return $base->[NEXT] == $base ? undef : $base->[PREV] unless $p; + return $base->[PREV] == $base ? undef : $base->[PREV] unless $p; $docheck && _check($p); @@ -161,9 +163,9 @@ Chain - Double linked circular chain handler =head1 SYNOPSIS use Chain; - $base = new Chain; - $p->ins($ref); - $p->add($ref); + $base = new Chain [$obj]; + $p->ins($ref [,$obj]); + $p->add($ref [,$obj]); $ref = $p->obj or $p->obj($ref); $q = $base->next($p); $q = $base->prev($p); diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 2168c7fc..9a4f3673 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -1078,7 +1078,7 @@ sub normal # add this station to the user database, if required my $user = DXUser->get_current($call); - $user = DXUser->new($call) if !$user; + $user = DXUser->new($call) unless $user; if ($field[2] == 1) { $user->name($field[3]); diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 690a8ae4..80a9b641 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -15,6 +15,7 @@ use Fcntl; use IO::File; use DXDebug; use DXUtil; +use LRU; use strict; @@ -24,13 +25,14 @@ $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)) $main::build += $VERSION; $main::branch += $BRANCH; -use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime); +use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize); %u = (); $dbm = undef; $filename = undef; $lastoperinterval = 60*24*60*60; $lasttime = 0; +$lrusize = 500; # hash of valid elements and a simple prompt %valid = ( @@ -121,6 +123,7 @@ sub init } $filename = $fn; + $lru = LRU->newbase("DXUser", $lrusize); } sub del_file @@ -182,8 +185,16 @@ sub get my $pkg = shift; my $call = uc shift; my $data; + + # is it in the LRU cache? + my $ref = $lru->get($call); + return $ref if $ref; + + # search for it unless ($dbm->get($call, $data)) { - return decode($data); + $ref = decode($data); + $lru->put($call, $ref); + return $ref; } return undef; } @@ -233,7 +244,9 @@ sub put $dbm->del($call); delete $self->{annok} if $self->{annok}; delete $self->{dxok} if $self->{dxok}; - $dbm->put($call, $self->encode); + $lru->put($call, $self); + my $ref = $self->encode; + $dbm->put($call, $ref); } # @@ -277,6 +290,7 @@ sub del # for ($dbm->get_dup($call)) { # $dbm->del_dup($call, $_); # } + $lru->remove($call); $dbm->del($call); } diff --git a/perl/LRU.pm b/perl/LRU.pm new file mode 100644 index 00000000..d53b115b --- /dev/null +++ b/perl/LRU.pm @@ -0,0 +1,100 @@ +# +# A class implimenting LRU sematics with hash look up +# +# Copyright (c) 2002 Dirk Koopman, Tobit Computer Co Ltd +# +# $Id$ +# +# The structure of the objects stored are:- +# +# [next, prev, obj, callsign] +# +# The structure of the base is:- +# +# [next, prev, max objects, count ] +# +# + +package LRU; + + +use strict; +use Chain; +use DXVars; +use DXDebug; + +use vars qw(@ISA); +@ISA = qw(Chain); + +use vars qw($VERSION $BRANCH); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); +$main::build += $VERSION; +$main::branch += $BRANCH; + +sub newbase +{ + my $pkg = shift; + my $name = shift; + my $max = shift; + confess "LRU->newbase requires a name and maximal count" unless $name && $max; + return $pkg->SUPER::new({ }, $max, 0, $name); +} + +sub get +{ + my ($self, $call) = @_; + if (my $p = $self->obj->{$call}) { + dbg("LRU $self->[5] cache hit $call") if isdbg('lru'); + $self->rechain($p); + return $p->obj; + } + return undef; +} + +sub put +{ + my ($self, $call, $ref) = @_; + confess("need a call and a reference") unless $call && $ref; + my $p = $self->obj->{$call}; + if ($p) { + # update the reference and rechain it + dbg("LRU $self->[5] cache update $call") if isdbg('lru'); + $p->obj($ref); + $self->rechain($p); + } else { + # delete one of the end of the chain if required + while ($self->[4] >= $self->[3] ) { + $p = $self->prev; + my $call = $p->[3]; + dbg("LRU $self->[5] cache LRUed out $call now $self->[4]/$self->[3]") if isdbg('lru'); + $self->remove($call); + } + + # add a new one + dbg("LRU $self->[5] cache add $call now $self->[4]/$self->[3]") if isdbg('lru'); + $p = $self->new($ref, $call); + $self->add($p); + $self->obj->{$call} = $p; + $self->[4]++; + } +} + +sub remove +{ + my ($self, $call) = @_; + my $q = $self->obj->{$call}; + confess("$call is already removed") unless $q; + dbg("LRU $self->[5] cache remove $call now $self->[4]/$self->[3]") if isdbg('lru'); + $q->obj(1); + $q->SUPER::del; + delete $self->obj->{$call}; + $self->[4]--; +} + +sub count +{ + return $_[0]->[4]; +} + +1; diff --git a/perl/Prefix.pm b/perl/Prefix.pm index a2316a2b..a07ebdbd 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -14,7 +14,7 @@ use DB_File; use Data::Dumper; use DXDebug; use DXUtil; - +use LRU; use strict; @@ -24,28 +24,24 @@ $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)) $main::build += $VERSION; $main::branch += $BRANCH; -use vars qw($db %prefix_loc %pre %cache $misses $hits $matchtotal $lasttime); +use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal); $db = undef; # the DB_File handle %prefix_loc = (); # the meat of the info %pre = (); # the prefix list -%cache = (); # a runtime cache of matched prefixes -$lasttime = 0; # last time this cache was cleared $hits = $misses = $matchtotal = 1; # cache stats +$lrusize = 1000; # size of prefix LRU cache -#my $cachefn = "$main::data/prefix_cache"; +$lru = LRU->newbase('Prefix', $lrusize); sub load { # untie every thing -# unlink $cachefn; - if ($db) { undef $db; untie %pre; %pre = (); %prefix_loc = (); - untie %cache; } # tie the main prefix database @@ -54,9 +50,7 @@ sub load do "$main::data/prefix_data.pl" if !$out; $out = $@ if $@; - # tie the prefix cache -# tie (%cache, "DB_File", $cachefn, O_RDWR|O_CREAT, 0664, $DB_HASH) or confess "can't tie prefix cache to $cachefn $!"; - return $out; + return $out; } sub store @@ -152,14 +146,14 @@ sub matchprefix $matchtotal++; my $s = substr($pref, 0, $i); push @partials, $s; - my $p = $cache{$s}; + my $p = $lru->get($s); if ($p) { $hits++; if (isdbg('prefix')) { my $percent = sprintf "%.1f", $hits * 100 / $misses; dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%"); } - $cache{$_} = $p for @partials; + $lru->put($_, $p) for @partials; return @$p; } else { $misses++; @@ -170,7 +164,7 @@ sub matchprefix dbg("Partial prefix: $pref $s $part" ); } if (@out && $out[0] eq $s) { - $cache{$_} = \@out for @partials; + $lru->put($_, \@out) for @partials; return @out; } } @@ -194,24 +188,13 @@ sub extract my @parts; my ($call, $sp, $i); - # clear out the cache periodically to stop it growing for ever. - if ($main::systime - $lasttime >= 20*60) { - if (isdbg('prefix')) { - my $percent = sprintf "%.1f", $hits * 100 / $misses; - dbg("Prefix Cache Cleared, Hits: $hits/$misses of $matchtotal = $percent\%") ; - } - %cache =(); - $lasttime = $main::systime; - $hits = $misses = $matchtotal = 0; - } - LM: foreach $call (split /,/, $calls) { # first check if the whole thing succeeds either because it is cached # or because it simply is a stored prefix as callsign (or even a prefix) $matchtotal++; $call =~ s/-\d+$//; # ignore SSIDs - my $p = $cache{$call}; + my $p = $lru->get($call); my @nout; if ($p) { $hits++; @@ -225,7 +208,7 @@ LM: foreach $call (split /,/, $calls) { @nout = get($call); if (@nout && $nout[0] eq $call) { $misses++; - $cache{$call} = \@nout; + $lru->put($call, \@nout); dbg("got exact prefix: $nout[0]") if isdbg('prefix'); push @out, @nout; next; @@ -246,7 +229,7 @@ LM: foreach $call (split /,/, $calls) { if (@nout && $nout[0] eq $s) { dbg("got exact multipart prefix: $call $s") if isdbg('prefix'); $misses++; - $cache{$call} = \@nout; + $lru->put($call, \@nout); push @out, @nout; next; } @@ -266,7 +249,7 @@ LM: foreach $call (split /,/, $calls) { if (@try && $try[0] eq $s) { dbg("got 3 part prefix: $call $s") if isdbg('prefix'); $misses++; - $cache{$call} = \@try; + $lru->put($call, \@try); push @out, @try; next; } @@ -289,7 +272,7 @@ LM: foreach $call (split /,/, $calls) { if (@try && $try[0] eq $s) { dbg("got 2 part prefix: $call $s") if isdbg('prefix'); $misses++; - $cache{$call} = \@try; + $lru->put($call, \@try); push @out, @try; next; } @@ -305,7 +288,7 @@ LM: foreach $call (split /,/, $calls) { if (@nout) { dbg("got prefix: $call = $nout[0]") if isdbg('prefix'); $misses++; - $cache{$call} = \@nout; + $lru->put($call, \@nout); push @out, @nout; next; } @@ -350,16 +333,16 @@ L1: for ($n = 0; $n < @parts; $n++) { } if (@try && $try eq $try[0]) { $misses++; - $cache{$call} = \@try; + $lru->put($call, \@try); push @out, @try; } else { $misses++; - $cache{$call} = \@nout; + $lru->put($call, \@nout); push @out, @nout; } } else { $misses++; - $cache{$call} = \@nout; + $lru->put($call, \@nout); push @out, @nout; } next LM; @@ -369,7 +352,7 @@ L1: for ($n = 0; $n < @parts; $n++) { # we are a pirate! @nout = matchprefix('Q'); $misses++; - $cache{$call} = \@nout; + $lru->put($call, \@nout); push @out, @nout; } -- 2.34.1