From b2c336803a600e9c4f1f26168f7267aa3d4eb0ae Mon Sep 17 00:00:00 2001 From: Jacek Ablewicz Date: Wed, 30 Mar 2016 09:21:59 +0200 Subject: [PATCH] Bug 16166: Improve L1 cache performance Bug 16044 introduced two-level caching mechanism to Koha::Cache. By default, get_from_cache() returns a deep copy of the data structures stored in L1 cache (aka "safe mode"). For extremely big and/or complex data structures (like MARC framework hash-of-hashes-of-hashes returned by GetMarcStructure() ), deep-cloning is currently very sub-optimal (i.e., 2-3x slower after Bug 16044); this patch addresses that particular issue. See also: Bug 16044 comments #18 - #23 Test plan: 1) apply patch 2) flush L2 cache if necessary (restart memcached daemon) 3) profile GetMarcStructure() calls before / after patch, e.g. by running some script which calls it often (like catalogue search w/ XSLT processing turned on, etc.) 4) after Bug 16044 + Bug 16166, GetMarcStructure() should be faster than before, in all possible circumstances --- Koha/Cache.pm | 51 ++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 40 insertions(+), 11 deletions(-) diff --git a/Koha/Cache.pm b/Koha/Cache.pm index 8370d3e..5c918d0 100644 --- a/Koha/Cache.pm +++ b/Koha/Cache.pm @@ -38,7 +38,7 @@ The first, traditional OO interface provides the following functions: use strict; use warnings; use Carp; -use Clone qw( clone ); +use Storable qw(freeze thaw); use Module::Load::Conditional qw(can_load); use Koha::Cache::Object; @@ -281,9 +281,17 @@ sub set_in_cache { $expiry //= $self->{timeout}; my $set_sub = $self->{ref($self->{$cache}) . "_set"}; + my $flag = '-CF0'; # 0: scalar, 1: freezed data structure # Set in L1 cache - $L1_cache{ $key } = $value; + if (ref($value)) { + $value = freeze($value); + $L1_cache{ $key } = [ (undef, $value) ]; + $flag = '-CF1'; + } else { + $L1_cache{ $key } = $value; + } + $value .= $flag; # We consider an expiry of 0 to be inifinite if ( $expiry ) { return $set_sub @@ -321,21 +329,42 @@ sub get_from_cache { # Return L1 cache value if exists if ( exists $L1_cache{$key} ) { - # No need to deep copy if it's a scalar - # Or if we do not need to deep copy - return $L1_cache{$key} - if not ref $L1_cache{$key} or $unsafe; - return clone $L1_cache{$key}; + if (ref($L1_cache{$key})) { + if ($unsafe) { + $L1_cache{$key}->[0] ||= thaw($L1_cache{$key}->[1]); + return $L1_cache{$key}->[0]; + } else { + return thaw($L1_cache{$key}->[1]); + } + } else { + # No need to deep copy if it's a scalar + return $L1_cache{$key}; + } } my $get_sub = $self->{ref($self->{$cache}) . "_get"}; my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); - # Update the L1 cache when fetching the L2 cache - # Otherwise the L1 cache won't ever be populated - $L1_cache{$key} = $value; + return if ref($value); + return unless (defined($value) && length($value) >= 4); + + my $flag = substr($value, -4, 4, ''); + if ($flag eq '-CF0') { + # it's a scalar + $L1_cache{$key} = $value; + return $value; + } elsif ($flag eq '-CF1') { + # it's a freezed data structure + my $thawed; + eval { $thawed = thaw($value); }; + return if $@; + $L1_cache{$key} = [ (undef, $value) ]; + $L1_cache{$key}->[0] = $thawed if $unsafe; + return $thawed; + } - return $value; + # Unknown value / data type returned from L2 cache + return; } =head2 clear_from_cache -- 1.7.10.4