Take #1: use mutable hashtables + RWLock.

Author: portnov

package.yaml

@@ -24,7 +24,9 @@ dependencies:
 - mtl
 - containers
 - unordered-containers
+- hashtables
 - concurrent-extra
+- stm-containers
 - psqueues
 - aeson
 - yaml

src/AI/AlphaBeta.hs

@@ -91,34 +91,33 @@ getPossibleMoves :: GameRules rules => AICacheHandle rules eval -> Side -> Board
 getPossibleMoves handle side board = Monitoring.timed "ai.possible_moves.duration" $ do
     let rules = aichRules handle
     Monitoring.increment "ai.possible_moves.calls"
-    return $ possibleMoves rules side board
---   (result, hit) <- liftIO $ atomically $ do
---       memo <- readTVar (aichPossibleMoves handle)
---       let rules = aichRules handle
---       let bc = boardCounts board
---           bk = boardKey board
---       let moves = possibleMoves rules side board
---       case lookupBoardMap (bc, bk) memo of
---           Nothing -> do
---             let value = case side of
---                          First -> (Just moves, Nothing) 
---                          Second -> (Nothing, Just moves)
---             let memo' = putBoardMap board value memo
---             writeTVar (aichPossibleMoves handle) memo'
---             return (moves, False)
---           Just (Just cachedMoves, _) | side == First -> return (cachedMoves, True)
---           Just (_, Just cachedMoves) | side == Second -> return (cachedMoves, True)
---           Just (mbMoves1, mbMoves2) -> do
---             let value
---                  | side == First = (Just moves, mbMoves2)
---                  | otherwise     = (mbMoves1, Just moves)
---             let memo' = putBoardMap board value memo
---             writeTVar (aichPossibleMoves handle) memo'
---             return (moves, False)
---   if hit
---     then Monitoring.increment "ai.possible_moves.hit"
---     else Monitoring.increment "ai.possible_moves.miss"
---   return result
+    -- return $ possibleMoves rules side board
+    (result, hit) <- liftIO $ do
+        let memo = aichPossibleMoves handle
+        let rules = aichRules handle
+        let bc = boardCounts board
+            bk = boardKey board
+        let moves = possibleMoves rules side board
+        mbItem <- lookupBoardMap memo board
+        case mbItem of
+            Nothing -> do
+              let value = case side of
+                           First -> (Just moves, Nothing) 
+                           Second -> (Nothing, Just moves)
+              putBoardMap memo board value
+              return (moves, False)
+            Just (Just cachedMoves, _) | side == First -> return (cachedMoves, True)
+            Just (_, Just cachedMoves) | side == Second -> return (cachedMoves, True)
+            Just (mbMoves1, mbMoves2) -> do
+              let value
+                   | side == First = (Just moves, mbMoves2)
+                   | otherwise     = (mbMoves1, Just moves)
+              putBoardMap memo board value
+              return (moves, False)
+    if hit
+      then Monitoring.increment "ai.possible_moves.hit"
+      else Monitoring.increment "ai.possible_moves.miss"
+    return result
 
 -- | General driver / controller for Alpha-Beta prunning algorithm.
 -- This method is responsible in running scoreAB method on all possible moves
@@ -352,7 +351,7 @@ runAI ai@(AlphaBeta params rules eval) handle side board = do
     scoreMoves :: [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers [Either Error (PossibleMove, Score)]
     scoreMoves moves dp (alpha, beta) = do
       let var = aichData handle
-      AICache _ processor _ <- liftIO $ atomically $ readTVar var
+      let processor = aichProcessor handle
       let inputs = [
             ScoreMoveInput {
               smiAi = ai,

src/AI/AlphaBeta/Cache.hs

@@ -47,7 +47,7 @@ loadAiCache scoreMove (AlphaBeta params rules eval) = do
   let getKey input = pmResult (smiMove input)
   aiCfg <- asks (gcAiConfig . csConfig)
   processor <- runProcessor (aiThreads aiCfg) getKey scoreMove
-  cache <- liftIO $ atomically $ newTVar $ AICache False processor emptyBoardMap
+  cache <- liftIO newTBoardMap
   cachePath <- do
               home <- liftIO $ getEnv "HOME"
               let directory = home </> ".cache" </> "hcheckers" </> rulesName rules </> "ai.cache"
@@ -100,10 +100,11 @@ loadAiCache scoreMove (AlphaBeta params rules eval) = do
                      fhHandle = fd
                    }
   counts <- liftIO $ atomically $ newTVar $ BoardCounts 50 50 50 50
-  moves <- liftIO $ atomically $ newTVar emptyBoardMap
+  moves <- liftIO newTBoardMap
   let handle = AICacheHandle {
       aichRules = rules,
       aichData = cache,
+      aichProcessor = processor,
       aichPossibleMoves = moves,
       aichWriteQueue = writeQueue,
       aichCleanupQueue = cleanupQueue,
@@ -138,22 +139,6 @@ cacheDumper rules params handle = do
 
 cacheCleaner :: AICacheHandle rules eval -> Checkers ()
 cacheCleaner handle = forever $ do
-    delta <- liftIO $ atomically $ do
-        aic <- readTVar (aichData handle)
-        currentCounts <- readTVar (aichCurrentCounts handle)
-        let cache = aicData aic
-        let oldSize = boardMapSize cache
-        let cache' = M.filterWithKey biggerCounts cache
-            biggerCounts bc _ =
-              (bcFirstMen bc + bcFirstKings bc + bcSecondMen bc + bcSecondKings bc) <=
-              (bcFirstMen currentCounts + bcFirstKings currentCounts + bcSecondMen currentCounts + bcSecondKings currentCounts)
-            aic' = aic {aicData = cache'}
-            newSize = boardMapSize cache'
-            delta = oldSize - newSize
-        writeTVar (aichData handle) aic'
-        return delta
-    $info "cleanup: cleaned {} records" (Single delta)
-
     liftIO $ threadDelay $ 30 * 1000 * 1000
 
 normalize :: BoardSize -> (BoardCounts,BoardKey,Side) -> (BoardCounts,BoardKey,Side)
@@ -173,7 +158,7 @@ lookupAiCache params board depth side handle = do
     -- let fixSign = if side' == side then id else negate
     let bc = boardCounts board
         bk = boardKey board
-    (cachedScore, cachedStats) <- lookupMemory (bc, bk) side
+    (cachedScore, cachedStats) <- lookupMemory board side
     case (cachedScore, cachedStats) of
       (Just result, Nothing) -> do
         Monitoring.increment "cache.hit.memory"
@@ -225,11 +210,12 @@ lookupAiCache params board depth side handle = do
       | statsCount s < 10 = Nothing
       | otherwise = Just s
 
-    lookupMemory :: (BoardCounts, BoardKey) -> Side -> Checkers (Maybe CacheItemSide, Maybe Stats)
-    lookupMemory (bc, bk) side = Monitoring.timed "cache.lookup.memory" $ do
+    lookupMemory :: Board -> Side -> Checkers (Maybe CacheItemSide, Maybe Stats)
+    lookupMemory board side = Monitoring.timed "cache.lookup.memory" $ do
       cfg <- asks (gcAiConfig . csConfig)
-      AICache _ _ cache <- liftIO $ atomically $ readTVar (aichData handle)
-      case lookupBoardMap (bc,bk) cache of
+      let cache = aichData handle
+      mbItem <- liftIO $ lookupBoardMap cache board 
+      case mbItem of
         Nothing -> return (Nothing, Nothing)
         Just (PerBoardData {..}) -> do
           let depths = [dpLast depth .. dpLast depth + aiUseCacheMaxDepthPlus cfg] ++
@@ -269,20 +255,16 @@ putAiCache' params board depth side sideItem handle = do
     now <- liftIO $ getTime Monotonic
     Monitoring.increment "cache.records.put"
     fileCacheEnabled <- asks (aiStoreCache . gcAiConfig . csConfig)
-    liftIO $ atomically $ do
-      aic <- readTVar (aichData handle)
-      let item = case side of
-                   First -> CacheItem {ciFirst = Just sideItem, ciSecond = Nothing}
-                   Second -> CacheItem {ciFirst = Nothing, ciSecond = Just sideItem}
-
-          init = PerBoardData (M.singleton (dpLast depth) item) Nothing
+    let cache = aichData handle
+    let item = case side of
+                 First -> CacheItem {ciFirst = Just sideItem, ciSecond = Nothing}
+                 Second -> CacheItem {ciFirst = Nothing, ciSecond = Just sideItem}
 
-          newAicData = putBoardMapWith (<>) (bc,bk) init (aicData aic)
-          aic' = aic {aicDirty = True, aicData = newAicData}
+        init = PerBoardData (M.singleton (dpLast depth) item) Nothing
 
-          Just perBoard = lookupBoardMap (bc,bk) newAicData
+    liftIO $ putBoardMapWith cache (<>) board init
 
-      writeTVar (aichData handle) aic'
+    liftIO $ atomically $ do
       when (fileCacheEnabled && needWriteFile) $
           putWriteQueue (aichWriteQueue handle) (board, depth, side, sideItem)
       putCleanupQueue (aichCleanupQueue handle) (bc, bk) now
@@ -292,3 +274,4 @@ putAiCache :: GameRules rules => AlphaBetaParams -> Board -> DepthParams -> Side
 putAiCache params board depth side score moves handle = do
   let sideItem = CacheItemSide {cisScore = score}
   putAiCache' params board depth side sideItem handle
+

src/AI/AlphaBeta/Types.hs

@@ -136,7 +136,7 @@ instance Monoid PerBoardData where
 instance Binary PerBoardData
 instance Store PerBoardData
 
-type AIData = BoardMap PerBoardData
+type AIData = TBoardMap PerBoardData
 
 type StorageKey = (DepthParams, BoardKey)
 
@@ -154,12 +154,6 @@ data ScoreMoveInput rules eval = ScoreMoveInput {
   , smiBeta :: Score
   }
 
-data AICache rules eval = AICache {
-    aicDirty :: Bool
-  , aicProcessor :: Processor [MoveAction] (ScoreMoveInput rules eval) (PossibleMove, Score)
-  , aicData :: AIData
-  }
-
 type QueueKey = (BoardCounts, BoardKey)
 
 type IndexBlockNumber = Word32
@@ -168,14 +162,15 @@ type DataBlockNumber = Word32
 data FileType = IndexFile | DataFile
   deriving (Eq, Show)
 
-type MovesMemo = BoardMap (Maybe [PossibleMove], Maybe [PossibleMove])
+type MovesMemo = TBoardMap (Maybe [PossibleMove], Maybe [PossibleMove])
 
 -- | Handle to the instance of AI storage
 -- and related structures
 data AICacheHandle rules eval = AICacheHandle {
     aichRules :: rules
-  , aichData :: TVar (AICache rules eval)
-  , aichPossibleMoves :: TVar MovesMemo
+  , aichData :: AIData
+  , aichProcessor ::  Processor [MoveAction] (ScoreMoveInput rules eval) (PossibleMove, Score)
+  , aichPossibleMoves :: MovesMemo
   , aichWriteQueue :: WriteQueue
   , aichCleanupQueue :: CleanupQueue
   , aichCurrentCounts :: TVar BoardCounts

src/Core/BoardMap.hs

@@ -2,12 +2,15 @@
 module Core.BoardMap where
 
 import Control.Monad
+import Control.Exception (bracket_)
 import qualified Data.Map as M
 import qualified Data.HashMap.Strict as H
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
 import Data.Array.IArray as A
 import Data.Hashable
+import qualified Data.HashTable.IO as HT
+import qualified Control.Concurrent.ReadWriteLock as RWL
 import Data.Store
 import Data.Word
 import Text.Printf
@@ -78,39 +81,41 @@ removeBoardKey a (Piece Man Second) bk = bk {bkSecondMen = deleteLabelSet (aLabe
 removeBoardKey a (Piece King First) bk = bk {bkFirstKings = deleteLabelSet (aLabel a) (bkFirstKings bk)}
 removeBoardKey a (Piece King Second) bk = bk {bkSecondKings = deleteLabelSet (aLabel a) (bkSecondKings bk)}
 
-putBoardMap :: Board -> a -> BoardMap a -> BoardMap a
-putBoardMap board x bmap =
-    M.unionWith H.union bmap init
-  where
-    init = M.singleton (boardCounts board) $ H.singleton (boardKey board) x
-
-putBoardMapWith :: (a -> a -> a) -> (BoardCounts,BoardKey) -> a -> BoardMap a -> BoardMap a
-putBoardMapWith plus (bc,bk) x bmap =
-    M.unionWith (H.unionWith plus) bmap init
-  where
-    init = M.singleton bc $ H.singleton bk x
-
-lookupBoardMap :: (BoardCounts,BoardKey) -> BoardMap a -> Maybe a
-lookupBoardMap (bc,bk) bmap =
-  H.lookup bk =<< M.lookup bc bmap
-
-singleBoardMap :: Board -> a -> BoardMap a
-singleBoardMap board x =
-  M.singleton (boardCounts board) $ H.singleton (boardKey board) x
-
-emptyBoardMap :: BoardMap a
-emptyBoardMap = M.empty
-
-deleteBoardMap :: BoardCounts -> BoardKey -> BoardMap a -> BoardMap a
-deleteBoardMap bc bk bm =
-  let del m = let m' = H.delete bk m
-              in  if H.null m'
-                    then Nothing
-                    else Just m'
-  in  M.update del bc bm
-
-boardMapSize :: BoardMap a -> Int
-boardMapSize bmap = sum $ map H.size $ M.elems bmap
+newTBoardMap :: IO (TBoardMap a)
+newTBoardMap = do
+  lock <- RWL.new
+  m <- HT.newSized (100*1000)
+  return (lock, m)
+
+putBoardMap :: TBoardMap a -> Board -> a -> IO ()
+putBoardMap (lock, bmap) board value =
+  bracket_
+    (RWL.acquireWrite lock)
+    (RWL.releaseWrite lock)
+    (HT.insert bmap (boardCounts board, boardKey board) value)
+
+putBoardMapWith :: TBoardMap a -> (a -> a -> a) -> Board -> a -> IO ()
+putBoardMapWith (lock, bmap) plus board value =
+  bracket_
+    (RWL.acquireWrite lock)
+    (RWL.releaseWrite lock)
+    (do mbOld <- HT.lookup bmap (boardCounts board, boardKey board)
+        case mbOld of
+          Nothing -> HT.insert bmap (boardCounts board, boardKey board) value
+          Just old -> HT.insert bmap (boardCounts board, boardKey board) (plus old value)
+      )
+
+lookupBoardMap :: TBoardMap a -> Board -> IO (Maybe a)
+lookupBoardMap (lock, bmap) board =
+  bracket_
+    (RWL.acquireRead lock)
+    (RWL.releaseRead lock)
+    (HT.lookup bmap (boardCounts board, boardKey board))
+
+boardMapSize :: TBoardMap a -> IO Int
+boardMapSize (_, bmap) = do
+  list <- HT.toList bmap
+  return $ length list
 
 ------------------
 

src/Core/Types.hs

@@ -16,6 +16,7 @@ import Control.Monad.Except
 import Control.Monad.Metrics as Metrics
 import Control.Concurrent
 import Control.Concurrent.STM
+import qualified Control.Concurrent.ReadWriteLock as RWL
 import Data.List
 import Data.Array.Unboxed
 import qualified Data.Map as M
@@ -25,6 +26,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder.Int as Builder
 import qualified Data.HashMap.Strict as H
+import qualified Data.HashTable.IO as HT
 import Data.Text.Format.Heavy
 import Data.Dynamic
 import Data.Aeson (Value)
@@ -193,7 +195,9 @@ data BoardKey = BoardKey {
 
 instance Binary BoardKey
 
-type BoardMap a = M.Map BoardCounts (H.HashMap BoardKey a)
+type BoardMap a = HT.CuckooHashTable (BoardCounts, BoardKey) a
+
+type TBoardMap a = (RWL.RWLock, BoardMap a)
 
 -- | Direction on the board.
 -- For example, B2 is at UpRight of A1.