{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
module GHC.Debug.Client.RequestCache(RequestCache
                                    , cacheReq
                                    , lookupReq
                                    , lookupBlocks
                                    , emptyRequestCache
                                    , clearMovableRequests
                                    , putCache
                                    , getCache ) where

import qualified Data.HashMap.Strict as HM
import GHC.Debug.Types
import Unsafe.Coerce
import Data.Binary
import Control.Monad

newtype RequestCache = RequestCache (HM.HashMap AnyReq AnyResp)

instance Binary RequestCache where
  get :: Get RequestCache
get = Get RequestCache
getCache
  put :: RequestCache -> Put
put = RequestCache -> Put
putCache

cacheReq :: Request resp -> resp -> RequestCache -> RequestCache
cacheReq :: forall resp. Request resp -> resp -> RequestCache -> RequestCache
cacheReq Request resp
req resp
resp (RequestCache HashMap AnyReq AnyResp
rc)
  -- Don't cache the results of writes, such as pause/unpause
  | Request resp -> Bool
forall a. Request a -> Bool
isWriteRequest Request resp
req = HashMap AnyReq AnyResp -> RequestCache
RequestCache HashMap AnyReq AnyResp
rc
  | Bool
otherwise = HashMap AnyReq AnyResp -> RequestCache
RequestCache (AnyReq
-> AnyResp -> HashMap AnyReq AnyResp -> HashMap AnyReq AnyResp
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (Request resp -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request resp
req) (resp -> (resp -> Put) -> AnyResp
forall a. a -> (a -> Put) -> AnyResp
AnyResp resp
resp (Request resp -> resp -> Put
forall a. Request a -> a -> Put
putResponseBinary Request resp
req)) HashMap AnyReq AnyResp
rc)

lookupReq :: forall resp . Request resp -> RequestCache -> Maybe resp
lookupReq :: forall resp. Request resp -> RequestCache -> Maybe resp
lookupReq Request resp
req (RequestCache HashMap AnyReq AnyResp
rc) = AnyResp -> resp
forall resp. AnyResp -> resp
coerceResult (AnyResp -> resp) -> Maybe AnyResp -> Maybe resp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnyReq -> HashMap AnyReq AnyResp -> Maybe AnyResp
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Request resp -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request resp
req) HashMap AnyReq AnyResp
rc
  where
    coerceResult :: AnyResp -> resp
    coerceResult :: forall resp. AnyResp -> resp
coerceResult (AnyResp a
a a -> Put
_) = a -> resp
forall a b. a -> b
unsafeCoerce a
a

lookupBlocks :: RequestCache -> [RawBlock]
lookupBlocks :: RequestCache -> [RawBlock]
lookupBlocks c :: RequestCache
c@(RequestCache HashMap AnyReq AnyResp
rc) =
  let all_blocks :: [RawBlock]
all_blocks = case Request [RawBlock] -> RequestCache -> Maybe [RawBlock]
forall resp. Request resp -> RequestCache -> Maybe resp
lookupReq Request [RawBlock]
RequestAllBlocks RequestCache
c of
                        Just [RawBlock]
bs -> [RawBlock]
bs
                        Maybe [RawBlock]
Nothing -> []

      get_block :: AnyReq -> AnyResp -> [RawBlock] -> [RawBlock]
      get_block :: AnyReq -> AnyResp -> [RawBlock] -> [RawBlock]
get_block (AnyReq (RequestBlock {})) (AnyResp a
resp a -> Put
_) [RawBlock]
bs = a -> RawBlock
forall a b. a -> b
unsafeCoerce a
resp RawBlock -> [RawBlock] -> [RawBlock]
forall a. a -> [a] -> [a]
: [RawBlock]
bs
      get_block AnyReq
_ AnyResp
_ [RawBlock]
bs = [RawBlock]
bs

      individual_blocks :: [RawBlock]
individual_blocks = (AnyReq -> AnyResp -> [RawBlock] -> [RawBlock])
-> [RawBlock] -> HashMap AnyReq AnyResp -> [RawBlock]
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey AnyReq -> AnyResp -> [RawBlock] -> [RawBlock]
get_block [] HashMap AnyReq AnyResp
rc

  in ([RawBlock]
all_blocks [RawBlock] -> [RawBlock] -> [RawBlock]
forall a. [a] -> [a] -> [a]
++ [RawBlock]
individual_blocks)


emptyRequestCache :: RequestCache
emptyRequestCache :: RequestCache
emptyRequestCache = HashMap AnyReq AnyResp -> RequestCache
RequestCache HashMap AnyReq AnyResp
forall k v. HashMap k v
HM.empty

-- These get/put functions are a lot like the ones for serialising info
-- to/from the debuggee but we are careful that each one reads a bounded
-- amount of input.

getResponseBinary :: Request a -> Get a
getResponseBinary :: forall a. Request a -> Get a
getResponseBinary Request a
RequestVersion       = Word32 -> Word32 -> Maybe ProfilingMode -> Bool -> a
Word32 -> Word32 -> Maybe ProfilingMode -> Bool -> Version
Version (Word32 -> Word32 -> Maybe ProfilingMode -> Bool -> a)
-> Get Word32 -> Get (Word32 -> Maybe ProfilingMode -> Bool -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
forall t. Binary t => Get t
get Get (Word32 -> Maybe ProfilingMode -> Bool -> a)
-> Get Word32 -> Get (Maybe ProfilingMode -> Bool -> a)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
forall t. Binary t => Get t
get Get (Maybe ProfilingMode -> Bool -> a)
-> Get (Maybe ProfilingMode) -> Get (Bool -> a)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Maybe ProfilingMode)
getProfilingMode Get (Bool -> a) -> Get Bool -> Get a
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Bool
forall t. Binary t => Get t
get
getResponseBinary (RequestPause {})    = Get a
forall t. Binary t => Get t
get
getResponseBinary Request a
RequestResume        = Get a
forall t. Binary t => Get t
get
getResponseBinary Request a
RequestRoots         = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestClosure {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestInfoTable{}) = Get a
Get RawInfoTable
getInfoTable
getResponseBinary (RequestSRT {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestStackBitmap {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestFunBitmap {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestConstrDesc InfoTablePtr
_)  = Get a
Get ConstrDesc
getConstrDescCache
getResponseBinary Request a
RequestPoll          = Get a
forall t. Binary t => Get t
get
getResponseBinary Request a
RequestSavedObjects  = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestSourceInfo InfoTablePtr
_c) = Get a
Get (Maybe SourceInformation)
getIPE
getResponseBinary Request a
RequestAllBlocks = Get a
forall t. Binary t => Get t
get
getResponseBinary RequestBlock {}  = Get a
forall t. Binary t => Get t
get
getResponseBinary RequestCCS {}  = Get a
Get (GenCCSPayload CCSPtr CCPtr)
getCCS
getResponseBinary RequestCC {}  = Get a
Get CCPayload
getCC
getResponseBinary RequestIndexTable {}  = Get a
Get IndexTable
getIndexTable
getResponseBinary RequestCCSMainPtr {}  = Get a
Get CCSPtr
getCCSMainPtr

putResponseBinary :: Request a -> a -> Put
putResponseBinary :: forall a. Request a -> a -> Put
putResponseBinary Request a
RequestVersion (Version Word32
w1 Word32
w2 Maybe ProfilingMode
vprof Bool
tntc) = Word32 -> Put
forall t. Binary t => t -> Put
put Word32
w1 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
forall t. Binary t => t -> Put
put Word32
w2 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ProfilingMode -> Put
putProfilingMode Maybe ProfilingMode
vprof Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Put
forall t. Binary t => t -> Put
put Bool
tntc
putResponseBinary (RequestPause {}) a
w  = a -> Put
forall t. Binary t => t -> Put
put a
w
putResponseBinary Request a
RequestResume a
w      = a -> Put
forall t. Binary t => t -> Put
put a
w
putResponseBinary Request a
RequestRoots  a
rs     = a -> Put
forall t. Binary t => t -> Put
put a
rs
putResponseBinary (RequestClosure {}) a
rcs = a -> Put
forall t. Binary t => t -> Put
put a
rcs
putResponseBinary (RequestInfoTable {}) a
r = RawInfoTable -> Put
putInfoTable a
RawInfoTable
r
putResponseBinary (RequestSRT {}) a
rcs = a -> Put
forall t. Binary t => t -> Put
put a
rcs
putResponseBinary (RequestStackBitmap {}) a
pbm = a -> Put
forall t. Binary t => t -> Put
put a
pbm
putResponseBinary (RequestFunBitmap {}) a
pbm = a -> Put
forall t. Binary t => t -> Put
put a
pbm
putResponseBinary (RequestConstrDesc InfoTablePtr
_) a
cd  = ConstrDesc -> Put
putConstrDescCache a
ConstrDesc
cd
putResponseBinary Request a
RequestPoll         a
r = a -> Put
forall t. Binary t => t -> Put
put a
r
putResponseBinary Request a
RequestSavedObjects a
os = [ClosurePtr] -> Put
forall t. Binary t => [t] -> Put
putList a
[ClosurePtr]
os
putResponseBinary (RequestSourceInfo InfoTablePtr
_c) a
ipe = Maybe SourceInformation -> Put
putIPE a
Maybe SourceInformation
ipe
putResponseBinary Request a
RequestAllBlocks a
rs = a -> Put
forall t. Binary t => t -> Put
put a
rs
putResponseBinary RequestBlock {} a
r = a -> Put
forall t. Binary t => t -> Put
put a
r
putResponseBinary RequestCCS{} a
r = GenCCSPayload CCSPtr CCPtr -> Put
putCCS a
GenCCSPayload CCSPtr CCPtr
r
putResponseBinary RequestCC{} a
r = CCPayload -> Put
putCC a
CCPayload
r
putResponseBinary RequestIndexTable{} a
r = IndexTable -> Put
putIndexTable a
IndexTable
r
putResponseBinary RequestCCSMainPtr{} a
r = CCSPtr -> Put
putCCSMainPtr a
CCSPtr
r

putConstrDescCache :: ConstrDesc -> Put
putConstrDescCache :: ConstrDesc -> Put
putConstrDescCache (ConstrDesc String
a String
b String
c) = do
  String -> Put
forall t. Binary t => t -> Put
put String
a
  String -> Put
forall t. Binary t => t -> Put
put String
b
  String -> Put
forall t. Binary t => t -> Put
put String
c

getConstrDescCache :: Get ConstrDesc
getConstrDescCache :: Get ConstrDesc
getConstrDescCache =
  String -> String -> String -> ConstrDesc
ConstrDesc (String -> String -> String -> ConstrDesc)
-> Get String -> Get (String -> String -> ConstrDesc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get String
forall t. Binary t => Get t
get Get (String -> String -> ConstrDesc)
-> Get String -> Get (String -> ConstrDesc)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get Get (String -> ConstrDesc) -> Get String -> Get ConstrDesc
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get

putLine :: AnyReq -> AnyResp -> Put -> Put
putLine :: AnyReq -> AnyResp -> Put -> Put
putLine (AnyReq Request req
req) (AnyResp a
resp a -> Put
p) Put
k = Request req -> Put
forall a. Request a -> Put
putRequest Request req
req Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
p a
resp Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
k

getCacheLine :: Get (AnyReq, AnyResp)
getCacheLine :: Get (AnyReq, AnyResp)
getCacheLine = do
  AnyReq Request req
req <- Get AnyReq
getRequest
  req
resp <- Request req -> Get req
forall a. Request a -> Get a
getResponseBinary Request req
req
  return (Request req -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request req
req, req -> (req -> Put) -> AnyResp
forall a. a -> (a -> Put) -> AnyResp
AnyResp req
resp (Request req -> req -> Put
forall a. Request a -> a -> Put
putResponseBinary Request req
req))

putCache :: RequestCache -> Put
putCache :: RequestCache -> Put
putCache (RequestCache HashMap AnyReq AnyResp
rc) = do
  Int -> Put
forall t. Binary t => t -> Put
put (HashMap AnyReq AnyResp -> Int
forall k v. HashMap k v -> Int
HM.size HashMap AnyReq AnyResp
rc)
  (AnyReq -> AnyResp -> Put -> Put)
-> Put -> HashMap AnyReq AnyResp -> Put
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey AnyReq -> AnyResp -> Put -> Put
putLine (() -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) HashMap AnyReq AnyResp
rc

getCache :: Get RequestCache
getCache :: Get RequestCache
getCache = do
  Int
n <- Get Int
forall t. Binary t => Get t
get
  HashMap AnyReq AnyResp -> RequestCache
RequestCache (HashMap AnyReq AnyResp -> RequestCache)
-> ([(AnyReq, AnyResp)] -> HashMap AnyReq AnyResp)
-> [(AnyReq, AnyResp)]
-> RequestCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AnyReq, AnyResp)] -> HashMap AnyReq AnyResp
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(AnyReq, AnyResp)] -> RequestCache)
-> Get [(AnyReq, AnyResp)] -> Get RequestCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get (AnyReq, AnyResp) -> Get [(AnyReq, AnyResp)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Get (AnyReq, AnyResp)
getCacheLine

-- | Clear the part of the cache which will become invalid after pausing
-- For example, we need to clear blocks, but can keep the info table
-- caches.
clearMovableRequests :: RequestCache -> RequestCache
clearMovableRequests :: RequestCache -> RequestCache
clearMovableRequests (RequestCache HashMap AnyReq AnyResp
rc) = HashMap AnyReq AnyResp -> RequestCache
RequestCache ((AnyReq -> AnyResp -> Bool)
-> HashMap AnyReq AnyResp -> HashMap AnyReq AnyResp
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HM.filterWithKey (\(AnyReq Request req
r) AnyResp
_ -> Request req -> Bool
forall a. Request a -> Bool
isImmutableRequest Request req
r) HashMap AnyReq AnyResp
rc)