From 1be391f5f5bf2588939fea92809dd629c0a69d99 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 11 Feb 2021 15:10:36 +0100
Subject: [PATCH] fix(arc): reduce lock contention

---
 src/Utils/ARC.hs | 36 ++++++++++++++++++++++++------------
 1 file changed, 24 insertions(+), 12 deletions(-)

diff --git a/src/Utils/ARC.hs b/src/Utils/ARC.hs
index 4d29e10c2..eb86b6134 100644
--- a/src/Utils/ARC.hs
+++ b/src/Utils/ARC.hs
@@ -169,7 +169,7 @@ arcAlterF k f oldARC@ARC{..} now
                       }
     | otherwise -> f Nothing <&> \case
         Nothing -> oldARC
-          { arcGhostRecent = OrdPSQ.insert k now () $ evictGhostToCount arcMaximumGhost arcGhostRecent
+          { arcGhostRecent = OrdPSQ.insert k now () $ evictGhostToCount arcGhostRecent
           }
         Just x@(_, w)
           -> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent
@@ -187,14 +187,13 @@ arcAlterF k f oldARC@ARC{..} now
     evictToSize :: w -> OrdPSQ k ARCTick (v, w) -> w -> OrdPSQ k ARCTick () -> (OrdPSQ k ARCTick (v, w), w, OrdPSQ k ARCTick ())
     evictToSize tSize c cSize ghostC
       | cSize <= tSize = (c, cSize, ghostC)
-      | OrdPSQ.size ghostC >= arcMaximumGhost = evictToSize tSize c cSize $ OrdPSQ.deleteMin ghostC
-      | Just (k', p', (_, w'), c') <- OrdPSQ.minView c = evictToSize tSize c' (cSize - w') $ OrdPSQ.insert k' p' () ghostC
+      | Just (k', p', (_, w'), c') <- OrdPSQ.minView c = evictToSize tSize c' (cSize - w') . evictGhostToCount $ OrdPSQ.insert k' p' () ghostC
       | otherwise = error "evictToSize: cannot reach required size through eviction"
 
-    evictGhostToCount :: Int -> OrdPSQ k ARCTick () -> OrdPSQ k ARCTick ()
-    evictGhostToCount tCount c
-      | OrdPSQ.size c <= tCount = c
-      | Just (_, _, _, c') <- OrdPSQ.minView c = evictGhostToCount tCount c'
+    evictGhostToCount :: OrdPSQ k ARCTick () -> OrdPSQ k ARCTick ()
+    evictGhostToCount c
+      | OrdPSQ.size c <= arcMaximumGhost = c
+      | Just (_, _, _, c') <- OrdPSQ.minView c = evictGhostToCount c'
       | otherwise = error "evictGhostToCount: cannot reach required count through eviction"
 
 lookupARC :: forall k w v.
@@ -217,7 +216,7 @@ insertARC :: forall k w v.
 insertARC k newVal = (runIdentity .) . arcAlterF k (const $ pure newVal)
 
 
-newtype ARCHandle k w v = ARCHandle { _getARCHandle :: TVar (ARC k w v, ARCTick) }
+newtype ARCHandle k w v = ARCHandle { _getARCHandle :: IORef (ARC k w v, ARCTick) }
   deriving (Eq, Typeable)
 
 initARCHandle :: forall k w v m.
@@ -227,7 +226,7 @@ initARCHandle :: forall k w v m.
               => Int -- ^ @arcMaximumGhost@
               -> w -- ^ @arcMaximumWeight@
               -> m (ARCHandle k w v)
-initARCHandle maxGhost maxWeight = fmap ARCHandle . liftIO . newTVarIO $ initARC maxGhost maxWeight
+initARCHandle maxGhost maxWeight = fmap ARCHandle . newIORef $ initARC maxGhost maxWeight
 
 cachedARC' :: forall k w v m.
               ( MonadIO m
@@ -240,9 +239,22 @@ cachedARC' :: forall k w v m.
            -> (Maybe (v, w) -> m (Maybe (v, w)))
            -> m (Maybe v)
 cachedARC' (ARCHandle arcVar) k f = do
-  oldVal <- liftIO $ lookupARC k <$> readTVarIO arcVar
+  oldVal <- lookupARC k <$> readIORef arcVar
   newVal <- f oldVal
-  atomically . modifyTVar' arcVar $ \(arc, tick) -> force $ insertARC k newVal arc tick
+  modifyIORef' arcVar $ force . uncurry (insertARC k newVal)
+  -- Using `modifyIORef'` instead of `atomicModifyIORef'` might very
+  -- well drop newer values computed during the update.
+  --
+  -- Currently we accept that to reduce lock contention.
+  --
+  -- Another alternative would be to use "optimistic locking",
+  -- i.e. read the current value of `arcVar`, compute an updated
+  -- version, and write it back atomically iff the `ARCTick` hasn't
+  -- changed.
+  --
+  -- This was not implemented to avoid the overhead and contention
+  -- likely associated with the atomic transaction required for the
+  -- "compare and swap"
   return $ view _1 <$> newVal
 
 cachedARC :: forall k w v m.
@@ -260,4 +272,4 @@ cachedARC h k f = fromMaybe (error "cachedARC: cachedARC' returned Nothing") <$>
 readARCHandle :: MonadIO m
               => ARCHandle k w v
               -> m (ARC k w v, ARCTick)
-readARCHandle (ARCHandle arcVar) = readTVarIO arcVar
+readARCHandle (ARCHandle arcVar) = readIORef arcVar