{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE RankNTypes #-}
-- The BlockCache stores the currently fetched blocks
-- and is consulted first to avoid requesting too much
-- from the debuggee. The BlockCache can either be populated
-- via a call to RequestBlocks or on demand on a cache miss.

module GHC.Debug.Client.BlockCache(BlockCache, BlockCacheRequest(..)
                                  , handleBlockReq, emptyBlockCache, bcSize, addBlocks) where

import GHC.Debug.Types.Ptr
import GHC.Debug.Types
import qualified Data.HashMap.Strict as HM
import GHC.Word
import Data.Hashable
import Data.IORef
import Data.Bits
import Data.List (sort)
import Data.Binary

newtype BlockCache = BlockCache (HM.HashMap Word64 RawBlock)

instance Binary BlockCache where
  get :: Get BlockCache
get = HashMap Word64 RawBlock -> BlockCache
BlockCache forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
  put :: BlockCache -> Put
put (BlockCache HashMap Word64 RawBlock
hm) = forall t. Binary t => t -> Put
put (forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Word64 RawBlock
hm)

emptyBlockCache :: BlockCache
emptyBlockCache :: BlockCache
emptyBlockCache = HashMap Word64 RawBlock -> BlockCache
BlockCache forall k v. HashMap k v
HM.empty

addBlock :: RawBlock -> BlockCache -> BlockCache
addBlock :: RawBlock -> BlockCache -> BlockCache
addBlock rb :: RawBlock
rb@(RawBlock (BlockPtr Word64
bp) Word16
_ ByteString
_) (BlockCache HashMap Word64 RawBlock
bc) =
  HashMap Word64 RawBlock -> BlockCache
BlockCache (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Word64
bp RawBlock
rb HashMap Word64 RawBlock
bc)


addBlocks :: [RawBlock] -> BlockCache -> BlockCache
addBlocks :: [RawBlock] -> BlockCache -> BlockCache
addBlocks [RawBlock]
bc BlockCache
bs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr RawBlock -> BlockCache -> BlockCache
addBlock BlockCache
bs [RawBlock]
bc

lookupClosure :: ClosurePtr -> BlockCache -> Maybe RawBlock
lookupClosure :: ClosurePtr -> BlockCache -> Maybe RawBlock
lookupClosure (ClosurePtr Word64
cp) (BlockCache HashMap Word64 RawBlock
b) =
  forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Word64
cp forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement Word64
blockMask) HashMap Word64 RawBlock
b

bcSize :: BlockCache -> Int
bcSize :: BlockCache -> Int
bcSize (BlockCache HashMap Word64 RawBlock
b) = forall k v. HashMap k v -> Int
HM.size HashMap Word64 RawBlock
b

_bcKeys :: BlockCache -> [ClosurePtr]
_bcKeys :: BlockCache -> [ClosurePtr]
_bcKeys (BlockCache HashMap Word64 RawBlock
b) = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Word64 -> ClosurePtr
mkClosurePtr (forall k v. HashMap k v -> [k]
HM.keys HashMap Word64 RawBlock
b)

data BlockCacheRequest a where
  LookupClosure :: ClosurePtr -> BlockCacheRequest RawClosure
  PopulateBlockCache :: BlockCacheRequest [RawBlock]

deriving instance Show (BlockCacheRequest a)
deriving instance Eq (BlockCacheRequest a)

instance Hashable (BlockCacheRequest a) where
  hashWithSalt :: Int -> BlockCacheRequest a -> Int
hashWithSalt Int
s (LookupClosure ClosurePtr
cpt) = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1 :: Int) forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClosurePtr
cpt
  hashWithSalt Int
s BlockCacheRequest a
PopulateBlockCache  = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
2 :: Int)

handleBlockReq :: (forall a . Request a -> IO a) -> IORef BlockCache -> BlockCacheRequest resp -> IO resp
handleBlockReq :: forall resp.
(forall a. Request a -> IO a)
-> IORef BlockCache -> BlockCacheRequest resp -> IO resp
handleBlockReq forall a. Request a -> IO a
do_req IORef BlockCache
ref (LookupClosure ClosurePtr
cp) = do
  BlockCache
bc <- forall a. IORef a -> IO a
readIORef IORef BlockCache
ref
  let mrb :: Maybe RawBlock
mrb = ClosurePtr -> BlockCache -> Maybe RawBlock
lookupClosure ClosurePtr
cp BlockCache
bc
  RawBlock
rb <- case Maybe RawBlock
mrb of
               Maybe RawBlock
Nothing -> do
                  RawBlock
rb <- forall a. Request a -> IO a
do_req (ClosurePtr -> Request RawBlock
RequestBlock ClosurePtr
cp)
                  forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockCache
ref (\BlockCache
bc' -> (RawBlock -> BlockCache -> BlockCache
addBlock RawBlock
rb BlockCache
bc', ()))
                  return RawBlock
rb
               Just RawBlock
rb -> do
                 forall (m :: * -> *) a. Monad m => a -> m a
return RawBlock
rb
  return (ClosurePtr -> RawBlock -> RawClosure
extractFromBlock ClosurePtr
cp RawBlock
rb)
handleBlockReq forall a. Request a -> IO a
do_req IORef BlockCache
ref BlockCacheRequest resp
PopulateBlockCache = do
  [RawBlock]
blocks <- forall a. Request a -> IO a
do_req Request [RawBlock]
RequestAllBlocks
--  mapM_ (\rb -> print ("NEW", rawBlockAddr rb)) blocks
  forall a. Show a => a -> IO ()
print (String
"CACHING", forall (t :: * -> *) a. Foldable t => t a -> Int
length [RawBlock]
blocks)
  forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockCache
ref ((,()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawBlock] -> BlockCache -> BlockCache
addBlocks [RawBlock]
blocks)
  return [RawBlock]
blocks