{-# 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