secret
Created

  • Download Gist
gistfile1.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
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"

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.