halfs-0.2: Halfs/BufferBlockCache.hs
{-# OPTIONS -fglasgow-exts #-}
module Halfs.BufferBlockCache ( BufferBlockCache, getBlockFromCacheOrDevice
, getNewBlockFromCacheOrDevice
, getBlockFromDevice, markBlockDirty, checkBBCache
, createCache, syncBBCache, clearBBCache )
where
import Halfs.FSRW (FSRW, unsafeLiftIORW)
import Halfs.Utils (DiskAddress, fromJustErr)
import Halfs.BufferBlock
import Control.Monad.Error (MonadError)
import Data.Queue
import System.RawDevice(RawDevice, newBufferBlockHandle)
-- base
import Data.Map(Map)
import qualified Data.Map as Map
import Control.Concurrent(MVar, modifyMVar_, modifyMVar, readMVar, newMVar)
import Control.Monad.Error(throwError, catchError)
import Control.Exception(assert)
import Control.Monad(liftM, when)
-- |Maps the disk address to a cache of the blocks.
data BufferBlockCache
= forall s . BufferBlockCache (MVar (BBCacheStore s))
data BBCacheStore s = BBCacheStore { bbcache :: !(Map (RawDevice, DiskAddress) (BufferBlock s))
, _bbhits :: !Int
, _bbmisses :: !Int
, _cachereuse :: !(CacheReuseQueue s)
}
-- |If the cache grows beyond this size, we flush something.
maxBBCacheSize :: Int
maxBBCacheSize = 500
checkBBCache :: BufferBlockCache -> IO ( Int -- size
, Int -- Num dirty
, Int -- cache hits
, Int -- cache misses
)
checkBBCache (BufferBlockCache cache) = do
store@(BBCacheStore fm hit miss _) <- readMVar cache
numDirty <- liftM (length . filter id) $ sequence [ getDirty bb | bb <- Map.elems fm ]
return (Map.size fm, assert (verifyCacheSize store) numDirty,hit,miss)
verifyCacheSize :: BBCacheStore s -> Bool
verifyCacheSize store = Map.size (bbcache store) <= maxBBCacheSize
-- |Should only be called on a read-only FSRoot. FIX: Verify that
-- there aren't any dirty blocks?
clearBBCache :: (FSRW m) => BufferBlockCache -> m ()
clearBBCache c
= modifyCache_ c (\_ -> return $ BBCacheStore Map.empty 0 0 emptyCRQ)
-- |Returns a new, empty cache
createCache :: Int -> IO (BufferBlockCache)
createCache _ = liftM BufferBlockCache $ newMVar $ BBCacheStore Map.empty 0 0 emptyCRQ
-- maxAddress = 100000
-- |This block MUST be in the cache. This function marks it as dirty.
markBlockDirty :: (FSRW m)
=> BufferBlockCache
-> RawDevice
-> DiskAddress
-> m ()
markBlockDirty c dev addr =
-- assert (addr < maxAddress && addr > (0 - maxAddress)) $ do
modifyCache_ c (\ cache@(BBCacheStore fm hits misses crq) ->
let bb = fromJustErr
"internal: attempt to mark a block not in the cache."
(Map.lookup (dev, addr) (assert (verifyCacheSize cache) fm))
in do setDirty bb True
return $ BBCacheStore fm hits misses crq)
-- |This block MUST be in the cache. This function unmarks the busy block.
-- |Sync the BB cache. Fix; can we do this in one pass? Alters the
-- cache itself as a side-effect. Not the FSRoot.
syncBBCache :: (FSRW m)
=> BufferBlockCache
-> m ()
syncBBCache c = modifyCache_ c (\ store@(BBCacheStore cache hits misses crq) -> do
let l = Map.toList (assert (verifyCacheSize store) cache)
l' <- mapM (\ ((dev, addr), bb) -> do
syncBB dev bb
return ((dev, addr), bb)) l
return $ BBCacheStore (Map.fromList l') hits misses crq)
-- |Attempts to read from the cache; if it fails, will read from the
-- raw device. Alters the cache, but that's a reference in the
-- fsroot, so happens as a side-effect.
-- Whe need to use the BufferBlockCache pattern match so as we have the same
-- 'forall' over all this function, rather than use two calls to modifyCache,
-- which would have two distinct forall s.
getBlockFromCacheOrDevice' :: (MonadError e m,FSRW m)
=> BufferBlockCache
-> RawDevice
-> DiskAddress
-> Bool -- True for allocation from free list
-> (forall s . BufferBlock s -> m a) -- scoped use
-> m a
getBlockFromCacheOrDevice' (BufferBlockCache bbc) dev da' free cont = do
-- assert (da' < maxAddress && da' > (0 - maxAddress)) $ do
-- unsafeLiftIORW $ print ("getBlockFromCacheOrDevice",da')
rr <- unsafeLiftIORW $ modifyMVar bbc (\ (BBCacheStore cache hits misses crq) -> do
let da = abs da'
case Map.lookup (dev, da) cache of
Just bb -> do incLock bb
when free $ do
zeroBufferBlock bb
setRecent bb True
internal_da <- getDiskAddr bb
assert (internal_da == da) $ return ()
return (BBCacheStore cache (if free then hits else succ hits) misses crq,bb)
_ | isFull crq -> do
(reclaimed,crq') <- syncOneBB crq
key_dev <- getRawDevice reclaimed
key_da <- getDiskAddr reclaimed
let key = (key_dev,key_da)
-- now we re-initiate the block
clearLock reclaimed
setDirty reclaimed False
setDiskAddr reclaimed da
if free
then zeroBufferBlock reclaimed
else getBlockFromDevice'' dev da reclaimed
incLock reclaimed
let cache2 = Map.delete key cache
let cache3 = Map.insert (dev,da) reclaimed cache2
return (BBCacheStore cache3 hits (if free then misses else succ misses) crq',reclaimed)
_ -> do
-- cache is not full yet, so keep filling
block <- newBufferBlockHandle
newBB <- mkBufferBlock block dev da
if free
then zeroBufferBlock newBB
else getBlockFromDevice'' dev da newBB
incLock newBB
crq' <- bootstrapCRQ newBB crq
let cache2 = Map.insert (dev,da) newBB cache
return (BBCacheStore cache2 hits (if free then misses else succ misses) crq', newBB)
)
let unlock = unsafeLiftIORW $ modifyMVar_ bbc (\ (BBCacheStore cache hits misses crq) -> do
when (((hits + misses) `mod` 10000) == 0 && (hits + misses) /= 0) $ do
putStrLn $ "Cache: " ++ show (hits + misses) ++ " lookups, "
++ show ((hits * 100) `div` (hits + misses)) ++ "% hits"
let da = abs da'
case Map.lookup (dev, da) cache of
Just bb -> do decLock bb
-- print $ "getBlockFromCacheOrDevice (from cache) unlocking (" ++ show (bbDiskAddr bb') ++ ")"
return $ BBCacheStore cache hits misses crq
Nothing -> do
print "getBlockFromCacheOrDevice (not in cache, should still be here!)"
error "getBlockFromCacheOrDevice (not in cache, should still be here!)"
)
r <- catchError (cont rr)
(\ e -> do -- unsafeLiftIORW $ print "exception inside cont inside BBC getBlock"
unlock
throwError e)
unlock
return r
where
syncOneBB crq = do
(bb,crq') <- rotateCRQ crq
lock <- getLock bb
recent <- getRecent bb
-- print ("syncOne: ", lock, recent)
if lock > 0 || recent
then syncOneBB crq' -- keep looking
else do
-- print ("syncing(1) ")
devi <- getRawDevice bb
syncBB devi bb
return (bb,crq')
-- maybeReclaimSomeBlock :: BBCacheStore -> IO (BBCacheStore, BufferBlockHandle)
getBlockFromCacheOrDevice :: (MonadError e m,FSRW m)
=> BufferBlockCache
-> RawDevice
-> DiskAddress
-> (forall s . BufferBlock s -> m a) -- scoped use
-> m a
getBlockFromCacheOrDevice bbc dev da cont =
getBlockFromCacheOrDevice' bbc dev da False cont
getNewBlockFromCacheOrDevice :: (MonadError e m,FSRW m)
=> BufferBlockCache
-> RawDevice
-> DiskAddress
-> (forall s . BufferBlock s -> m a) -- scoped use
-> m a
getNewBlockFromCacheOrDevice bbc dev da cont =
getBlockFromCacheOrDevice' bbc dev da True cont
-- |Allocates a new block. Caller is responsible for this block from
-- now on; it is unlocked and not in the cache.
getBlockFromDevice :: (FSRW m)
=> RawDevice
-> DiskAddress
-> (forall s . BufferBlock s -> m a) -- scoped use
-> m a
getBlockFromDevice rawDevice da cont = do
-- assert (d < maxAddress && d > (0 - maxAddress)) $ do
buffer <- unsafeLiftIORW $ newBufferBlockHandle
-- Here's one of the few cases I don't see getting rid of "unsafe"
-- calls. This call is for reading only, calls straight down to
-- device, and is completely necessary to call ultimately from
-- all FSRead, FSWrite, and IO monads.
newBB <- unsafeLiftIORW $ mkBufferBlock buffer rawDevice da
unsafeLiftIORW $ devBufferRead rawDevice da newBB
cont newBB
-- TODO: INLINE, there is nothing left here.
getBlockFromDevice'' :: (FSRW m)
=> RawDevice
-> DiskAddress
-> BufferBlock s -- ^BinHandle to re-use
-> m ()
getBlockFromDevice'' rawDevice da' buffer = do
-- assert (da' < maxAddress && da' > (0 - maxAddress)) $ do
let da = abs da'
-- Here's one of the few cases I don't see getting rid of "unsafe"
-- calls. This call is for reading only, calls straight down to
-- the device, and is completely necessary to call ultimately from
-- all FSRead, FSWrite, and IO monads.
unsafeLiftIORW $ devBufferRead rawDevice da buffer
return ()
-- ------------------------------------------------------------
-- * Internal
-- ------------------------------------------------------------
-- |Syncs this bufferblock to disk; marks it as clean.
syncBB :: RawDevice -> BufferBlock s -> IO ()
syncBB dev b = do
lock <- getLock b
if lock > 0 then return () -- Locked; skip it!
else do
dirty <- getDirty b
if dirty then do -- Otherwise; write to disk, mark as clean.
addr <- getDiskAddr b
devBufferWrite dev addr b
setDirty b False
return ()
else return ()
modifyCache_ :: (FSRW m)
=> BufferBlockCache
-> (forall s . BBCacheStore s -> IO (BBCacheStore s)) -- ^in the IO monad in case we need to alter the buffer itself
-> m ()
modifyCache_ (BufferBlockCache mv) f = unsafeLiftIORW $ modifyMVar_ mv f
{- UNUSED:
modifyCache :: (FSRW m)
=> BufferBlockCache
-> (forall s . BBCacheStore s -> IO (BBCacheStore s, a)) -- ^in the IO monad in case we need to alter the buffer itself
-> m a
modifyCache (BufferBlockCache mv) f = unsafeLiftIORW $ modifyMVar mv f
-}
------------------------------------------------------------------------------
data CacheReuseQueue s = CacheReuseQueue
{ _crq_large :: !(Queue (BufferBlock s))
, _crq_secondchance :: !(Queue (BufferBlock s))
}
emptyCRQ :: CacheReuseQueue s
emptyCRQ = CacheReuseQueue emptyQueue emptyQueue
isFull :: CacheReuseQueue s -> Bool
isFull (CacheReuseQueue q q2) = queueLength q + queueLength q2 >= maxBBCacheSize
bootstrapCRQ :: BufferBlock s -> CacheReuseQueue s -> IO (CacheReuseQueue s)
bootstrapCRQ bb (CacheReuseQueue q q2)
| queueLength q < (maxBBCacheSize - secondChanceBBCacheSize) = do
() <- return $ assert (queueLength q2 == 0) $ ()
return $ CacheReuseQueue (addToQueue q bb) q2
| otherwise = do
() <- return $ assert (queueLength q == (maxBBCacheSize - secondChanceBBCacheSize)) $ ()
() <- return $ assert (queueLength q2 < secondChanceBBCacheSize) $ ()
case deQueue (addToQueue q bb) of
Nothing -> error "insertCRQ: failure, should not happen"
Just (bb',q') -> do
setRecent bb' False
return $ CacheReuseQueue q' (addToQueue q2 bb')
--
rotateCRQ :: CacheReuseQueue s -> IO (BufferBlock s,CacheReuseQueue s)
rotateCRQ (CacheReuseQueue q q2) = assert (queueLength q + queueLength q2 == maxBBCacheSize) $
case deQueue q of
Just (bb,q') ->
case deQueue q2 of
Just (bb2,q2') -> do
setRecent bb False
return ( bb2
, CacheReuseQueue (addToQueue q' bb2) (addToQueue q2' bb)
)
Nothing -> error "second chance queue in CRQ is empty!!"
Nothing -> error "main queue in CRQ is empty!!"
secondChanceBBCacheSize :: Int
secondChanceBBCacheSize = maxBBCacheSize `div` 8