Create a gist now

Instantly share code, notes, and snippets.

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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment