RequestCache.hs

{-# 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 = getCache
  put = putCache

cacheReq :: Request resp -> resp -> RequestCache -> RequestCache
cacheReq req resp (RequestCache rc)
  -- Don't cache the results of writes, such as pause/unpause
  | isWriteRequest req = RequestCache rc
  | otherwise = RequestCache (HM.insert (AnyReq req) (AnyResp resp (putResponseBinary req)) rc)

lookupReq :: forall resp . Request resp -> RequestCache -> Maybe resp
lookupReq req (RequestCache rc) = coerceResult <$> HM.lookup (AnyReq req) rc
  where
    coerceResult :: AnyResp -> resp
    coerceResult (AnyResp a _) = unsafeCoerce a

lookupBlocks :: RequestCache -> [RawBlock]
lookupBlocks c@(RequestCache rc) =
  let all_blocks = case lookupReq RequestAllBlocks c of
                        Just bs -> bs
                        Nothing -> []

      get_block :: AnyReq -> AnyResp -> [RawBlock] -> [RawBlock]
      get_block (AnyReq (RequestBlock {})) (AnyResp resp _) bs = unsafeCoerce resp : bs
      get_block _ _ bs = bs

      individual_blocks = HM.foldrWithKey get_block [] rc

  in (all_blocks ++ individual_blocks)


emptyRequestCache :: RequestCache
emptyRequestCache = RequestCache 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 RequestVersion       = Version <$> get <*> get <*> getProfilingMode <*> get
getResponseBinary (RequestPause {})    = get
getResponseBinary RequestResume        = get
getResponseBinary RequestRoots         = get
getResponseBinary (RequestClosure {}) = get
getResponseBinary (RequestInfoTable{}) = getInfoTable
getResponseBinary (RequestSRT {}) = get
getResponseBinary (RequestStackBitmap {}) = get
getResponseBinary (RequestFunBitmap {}) = get
getResponseBinary (RequestConstrDesc _)  = getConstrDescCache
getResponseBinary RequestPoll          = get
getResponseBinary RequestSavedObjects  = get
getResponseBinary (RequestSourceInfo _c) = getIPE
getResponseBinary RequestAllBlocks = get
getResponseBinary RequestBlock {}  = get
getResponseBinary RequestCCS {}  = getCCS
getResponseBinary RequestCC {}  = getCC
getResponseBinary RequestIndexTable {}  = getIndexTable
getResponseBinary RequestCCSMainPtr {}  = getCCSMainPtr

putResponseBinary :: Request a -> a -> Put
putResponseBinary RequestVersion (Version w1 w2 vprof tntc) = put w1 >> put w2 >> putProfilingMode vprof >> put tntc
putResponseBinary (RequestPause {}) w  = put w
putResponseBinary RequestResume w      = put w
putResponseBinary RequestRoots  rs     = put rs
putResponseBinary (RequestClosure {}) rcs = put rcs
putResponseBinary (RequestInfoTable {}) r = putInfoTable r
putResponseBinary (RequestSRT {}) rcs = put rcs
putResponseBinary (RequestStackBitmap {}) pbm = put pbm
putResponseBinary (RequestFunBitmap {}) pbm = put pbm
putResponseBinary (RequestConstrDesc _) cd  = putConstrDescCache cd
putResponseBinary RequestPoll         r = put r
putResponseBinary RequestSavedObjects os = putList os
putResponseBinary (RequestSourceInfo _c) ipe = putIPE ipe
putResponseBinary RequestAllBlocks rs = put rs
putResponseBinary RequestBlock {} r = put r
putResponseBinary RequestCCS{} r = putCCS r
putResponseBinary RequestCC{} r = putCC r
putResponseBinary RequestIndexTable{} r = putIndexTable r
putResponseBinary RequestCCSMainPtr{} r = putCCSMainPtr r

putConstrDescCache :: ConstrDesc -> Put
putConstrDescCache (ConstrDesc a b c) = do
  put a
  put b
  put c

getConstrDescCache :: Get ConstrDesc
getConstrDescCache =
  ConstrDesc <$> get <*> get <*> get

putLine :: AnyReq -> AnyResp -> Put -> Put
putLine (AnyReq req) (AnyResp resp p) k = putRequest req >> p resp >> k

getCacheLine :: Get (AnyReq, AnyResp)
getCacheLine = do
  AnyReq req <- getRequest
  resp <- getResponseBinary req
  return (AnyReq req, AnyResp resp (putResponseBinary req))

putCache :: RequestCache -> Put
putCache (RequestCache rc) = do
  put (HM.size rc)
  HM.foldrWithKey putLine (return ()) rc

getCache :: Get RequestCache
getCache = do
  n <- get
  RequestCache . HM.fromList <$> replicateM n 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 rc) = RequestCache (HM.filterWithKey (\(AnyReq r) _ -> isImmutableRequest r) rc)