gistfile1.hs

flushProcess :: (Show k, Ord k, NFData k, Hashable k, KV.KVBackend m k v) =>
                Param m k v -> IO ()
flushProcess p = go
  where
    go = do
      debug "flush: meh"
      xs <- evalCacheSTM p $ CacheSTM $ lift $
            do c  <- H.size ht
               when (c <= maxSize * 2) $
                 retry -- traceShow c retry
               H.toList ht

      debug "flush: still meh"
      xsat <- mapM getAt xs
      let (_, lru) = L.splitAt (maxSize `div` 2) $!
                     map (\(_, a, b) -> (a, b))  $!
                     L.sortBy (\(a, _, _) (b, _, _) -> compare b a) xsat
      let mv = lock p
      debug "flush: take lock"
      atomically $ do x <- readTVar mv
                      when (x /= 0) retry
                      writeTVar mv 1

      debug "flush: got lock"
      flushAll mv lru
      -- putStrLn "done here"
      debug "flush: done"
      go

    ht      = table     p
    maxSize = cacheSize p

    readMany l 0 _  = return l
    readMany l n ch = do
      x <- atomically $ readTChan ch
      readMany (x:l) (n-1) ch

    getAt (k, p@(Ref _ _ tvat)) = do
      at <- liftIO $ atomically $ readTVar tvat
      return (at, k, p)

    flushAll mv ls = do
      mapM flushKey ls
      debug "release lock"
      atomically $ writeTVar mv 0

    flushKey (k, Ref tvst tvex _) = do
      liftIO $ evalCacheSTM p $ CacheSTM $ do
        debug' k
        s  <- lift $ readTVar tvst
        ex <- lift $ readTVar tvex
        ev <- asks toIO
        debug' 2
        case s of
          Write Nothing  -> do
            -- when (ex == Exist) $
            --   unsafeIO' $ ev $ KV.remove k
            debug' 23
            lift $ writeTVar tvst (Read Nothing)
          Write (Just v) -> do
            -- unsafeIO' $ ev $ KV.store k v
            debug' 24
            lift $ writeTVar tvst Unknown
            return ()
          _ -> return ()
        debug' "flushKey done"