{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RecordWildCards #-} module GHC.Debug.Types(module T , Request(..) , ForkOrPause(..) , requestCommandId , doRequest , isWriteRequest , withWriteRequest , isImmutableRequest , AnyReq(..) , AnyResp(..) , CommandId(..) , SourceInformation(..) , ClosureType(..) , Version(..) -- * Serialisation functions , getIPE , putIPE , getInfoTable , putInfoTable , putRequest , getCCS , getCC , putCCS , putCC , putIndexTable , getIndexTable , putCCSMainPtr , getCCSMainPtr , getProfilingMode , putProfilingMode , getRequest ) where import Control.Applicative import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import Data.Word import System.IO import Data.Functor import Data.Binary import Data.Binary.Put import Data.Binary.Get import Data.Hashable import GHC.Debug.Types.Closures as T import GHC.Debug.Types.Ptr as T import GHC.Debug.Types.Version import GHC.Debug.Utils import Control.Concurrent -- | The decision about whether to fork the running process or -- pause it running whilst we are debugging it. data ForkOrPause = Pause | Fork deriving (Eq, Ord, Show, Enum) instance Hashable ForkOrPause where hashWithSalt s v = s `hashWithSalt` (fromEnum v) instance Binary ForkOrPause where put = putWord8 . fromIntegral . fromEnum get = getWord8 >>= toBool where toBool 0 = return (toEnum 0) toBool 1 = return (toEnum 1) toBool c = fail ("Could not map value " ++ show c ++ " to ForkOrPause") -- | A request sent from the debugger to the debuggee parametrized on the result type. data Request a where -- | Request protocol version RequestVersion :: Request Version -- | Pause the debuggee. RequestPause :: ForkOrPause -> Request () -- | Resume the debuggee. RequestResume :: Request () -- | Request the debuggee's root pointers. RequestRoots :: Request [ClosurePtr] -- | Request a closure RequestClosure :: ClosurePtr -> Request RawClosure -- | Request an info table RequestInfoTable :: InfoTablePtr -> Request RawInfoTable -- | Request the SRT of an info table. Some closures, like constructors, can never have SRTs. -- Thunks, functions and stack frames may have SRTs. -- Returns Nothing when the closure does not have an SRT. RequestSRT :: InfoTablePtr -> Request (Maybe ClosurePtr) -- | Wait for the debuggee to pause itself and then -- execute an action. It currently impossible to resume after -- a pause caused by a poll. RequestPoll :: Request () -- | A client can save objects by calling a special RTS method -- This function returns the closures it saved. RequestSavedObjects :: Request [ClosurePtr] -- | Request the pointer bitmap for a stack frame at a given offset -- from a StackPtr. RequestStackBitmap :: StackPtr -> Word32 -> Request PtrBitmap -- | Decode the bitmap contained in a StgFunInfoTable -- Used by PAP and AP closure types. RequestFunBitmap :: Word16 -> ClosurePtr -> Request PtrBitmap -- | Request the constructor description for an info table. -- The info table must be from a 'ConstrClosure' RequestConstrDesc :: InfoTablePtr -> Request ConstrDesc -- | Lookup source information of an info table RequestSourceInfo :: InfoTablePtr -> Request (Maybe SourceInformation) -- | Copy all blocks from the process at once RequestAllBlocks :: Request [RawBlock] -- | Request the block which contains a specific pointer RequestBlock :: ClosurePtr -> Request RawBlock -- | Request the cost center stack RequestCCS :: CCSPtr -> Request CCSPayload -- | Request the cost center entry RequestCC :: CCPtr -> Request CCPayload -- | Request the index table. RequestIndexTable :: IndexTablePtr -> Request IndexTable -- | Request the CCS_MAIN pointer RequestCCSMainPtr :: Request CCSPtr data SourceInformation = SourceInformation { infoName :: !String , infoClosureType :: !ClosureType , infoType :: !String , infoLabel :: !String , infoModule :: !String , infoPosition :: !String } deriving (Show, Eq, Ord) eq1request :: Request a -> Request b -> Bool eq1request r1 r2 = case r1 of RequestVersion -> case r2 of {RequestVersion -> True; _ -> False} RequestPause f1 -> case r2 of {RequestPause f2 -> f1 == f2; _ -> False } RequestResume -> case r2 of {RequestResume -> True; _ -> False } RequestRoots -> case r2 of {RequestRoots -> True; _ -> False } RequestClosure cs -> case r2 of {(RequestClosure cs') -> cs == cs'; _ -> False } RequestInfoTable itp -> case r2 of { (RequestInfoTable itp') -> itp == itp'; _ -> False } RequestSRT itp -> case r2 of { (RequestSRT itp') -> itp == itp'; _ -> False } RequestPoll -> case r2 of { RequestPoll -> True; _ -> False } RequestSavedObjects -> case r2 of {RequestSavedObjects -> True; _ -> False } RequestStackBitmap p o -> case r2 of {(RequestStackBitmap p' o') -> p == p' && o == o'; _ -> False } RequestFunBitmap n cp -> case r2 of {(RequestFunBitmap n' cp') -> n == n' && cp == cp'; _ -> False } RequestConstrDesc cp -> case r2 of { (RequestConstrDesc cp') -> cp == cp'; _ -> False } RequestSourceInfo itp -> case r2 of { (RequestSourceInfo itp') -> itp == itp'; _ -> False } RequestAllBlocks -> case r2 of { RequestAllBlocks -> True; _ -> False } RequestBlock cp -> case r2 of { RequestBlock cp' -> cp == cp'; _ -> False } RequestCCS cp -> case r2 of { RequestCCS cp' -> cp == cp'; _ -> False } RequestCC cp -> case r2 of { RequestCC cp' -> cp == cp'; _ -> False } RequestIndexTable cp -> case r2 of { RequestIndexTable cp' -> cp == cp'; _ -> False } RequestCCSMainPtr -> case r2 of { RequestCCSMainPtr -> True; _ -> False } -- | Whether a request mutates the debuggee state, don't cache these ones isWriteRequest :: Request a -> Bool isWriteRequest r = getConst $ withWriteRequest r (Const False) (const (Const True)) withWriteRequest :: Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a withWriteRequest r def k = case r of RequestPause f -> k (RequestPause f) RequestResume -> k RequestResume RequestPoll -> k RequestPoll _ -> def -- | Requests which will always answer the same. -- For example, info tables are immutable and so requesting an info table -- will always result in the same value and is safe to cache across pause -- lines. isImmutableRequest :: Request a -> Bool isImmutableRequest r = case r of RequestVersion {} -> True RequestInfoTable {} -> True RequestSRT {} -> True RequestSourceInfo {} -> True RequestConstrDesc {} -> True RequestCCS {} -> True RequestCC {} -> True _ -> False deriving instance Show (Request a) deriving instance Eq (Request a) instance Hashable (Request a) where hashWithSalt s r = case r of RequestVersion -> s `hashWithSalt` cmdRequestVersion RequestPause f -> s `hashWithSalt` f `hashWithSalt` cmdRequestPause RequestResume -> s `hashWithSalt` cmdRequestResume RequestRoots -> s `hashWithSalt` cmdRequestRoots RequestClosure cs -> s `hashWithSalt` cmdRequestClosures `hashWithSalt` cs RequestInfoTable itp -> s `hashWithSalt` cmdRequestInfoTables `hashWithSalt` itp RequestSRT itp -> s `hashWithSalt` cmdRequestSRT `hashWithSalt` itp RequestPoll -> s `hashWithSalt` cmdRequestPoll RequestSavedObjects -> s `hashWithSalt` cmdRequestSavedObjects RequestStackBitmap p o -> s `hashWithSalt` cmdRequestStackBitmap `hashWithSalt` p `hashWithSalt` o RequestFunBitmap n cp -> s `hashWithSalt` cmdRequestFunBitmap `hashWithSalt` cp `hashWithSalt` n RequestConstrDesc cp -> s `hashWithSalt` cmdRequestConstrDesc `hashWithSalt` cp RequestSourceInfo itp -> s `hashWithSalt` cmdRequestSourceInfo `hashWithSalt` itp RequestAllBlocks -> s `hashWithSalt` cmdRequestAllBlocks RequestBlock cp -> s `hashWithSalt` cmdRequestBlock `hashWithSalt` cp RequestCCS cp -> s `hashWithSalt` cmdRequestCCS `hashWithSalt` cp RequestCC cp -> s `hashWithSalt` cmdRequestCC `hashWithSalt` cp RequestIndexTable cp -> s `hashWithSalt` cmdRequestIndexTable `hashWithSalt` cp RequestCCSMainPtr -> s `hashWithSalt` cmdRequestCCSMainPtr newtype CommandId = CommandId Word32 deriving (Eq, Ord, Show) deriving newtype (Binary, Hashable) requestCommandId :: Request a -> CommandId requestCommandId r = case r of RequestVersion {} -> cmdRequestVersion RequestPause {} -> cmdRequestPause RequestResume {} -> cmdRequestResume RequestRoots {} -> cmdRequestRoots RequestClosure {} -> cmdRequestClosures RequestInfoTable {} -> cmdRequestInfoTables RequestSRT {} -> cmdRequestSRT RequestPoll {} -> cmdRequestPoll RequestSavedObjects {} -> cmdRequestSavedObjects RequestStackBitmap {} -> cmdRequestStackBitmap RequestFunBitmap {} -> cmdRequestFunBitmap RequestConstrDesc {} -> cmdRequestConstrDesc RequestSourceInfo {} -> cmdRequestSourceInfo RequestAllBlocks {} -> cmdRequestAllBlocks RequestBlock {} -> cmdRequestBlock RequestCCS{} -> cmdRequestCCS RequestCC{} -> cmdRequestCC RequestIndexTable{} -> cmdRequestIndexTable RequestCCSMainPtr{} -> cmdRequestCCSMainPtr cmdRequestVersion :: CommandId cmdRequestVersion = CommandId 1 cmdRequestPause :: CommandId cmdRequestPause = CommandId 2 cmdRequestResume :: CommandId cmdRequestResume = CommandId 3 cmdRequestRoots :: CommandId cmdRequestRoots = CommandId 4 cmdRequestClosures :: CommandId cmdRequestClosures = CommandId 5 cmdRequestInfoTables :: CommandId cmdRequestInfoTables = CommandId 6 cmdRequestStackBitmap :: CommandId cmdRequestStackBitmap = CommandId 7 cmdRequestPoll :: CommandId cmdRequestPoll = CommandId 8 cmdRequestSavedObjects :: CommandId cmdRequestSavedObjects = CommandId 9 cmdRequestConstrDesc :: CommandId cmdRequestConstrDesc = CommandId 11 cmdRequestSourceInfo :: CommandId cmdRequestSourceInfo = CommandId 12 cmdRequestAllBlocks :: CommandId cmdRequestAllBlocks = CommandId 14 cmdRequestBlock :: CommandId cmdRequestBlock = CommandId 15 cmdRequestFunBitmap :: CommandId cmdRequestFunBitmap = CommandId 16 cmdRequestSRT :: CommandId cmdRequestSRT = CommandId 17 cmdRequestCCS :: CommandId cmdRequestCCS = CommandId 18 cmdRequestCC :: CommandId cmdRequestCC = CommandId 19 cmdRequestIndexTable :: CommandId cmdRequestIndexTable = CommandId 20 cmdRequestCCSMainPtr :: CommandId cmdRequestCCSMainPtr = CommandId 21 data AnyReq = forall req . AnyReq !(Request req) instance Hashable AnyReq where hashWithSalt s (AnyReq r) = hashWithSalt s r instance Eq AnyReq where (AnyReq r1) == (AnyReq r2) = eq1request r1 r2 data AnyResp = forall a . AnyResp !a !(a -> Put) putCommand :: CommandId -> Put -> Put putCommand c body = do putWord32be $ fromIntegral (4 + BSL.length body') put c putLazyByteString body' where body' = runPut body putRequest :: Request a -> Put putRequest RequestVersion = putCommand cmdRequestVersion mempty putRequest (RequestPause p) = putCommand cmdRequestPause (put p) putRequest RequestResume = putCommand cmdRequestResume mempty putRequest RequestRoots = putCommand cmdRequestRoots mempty putRequest (RequestClosure cs) = putCommand cmdRequestClosures $ do putWord16be 1 put cs putRequest (RequestInfoTable ts) = putCommand cmdRequestInfoTables $ do putWord16be 1 put ts putRequest (RequestSRT ts) = putCommand cmdRequestSRT $ do putWord16be 1 put ts putRequest (RequestStackBitmap sp o) = putCommand cmdRequestStackBitmap $ put sp >> putWord32be o putRequest (RequestFunBitmap n cp) = putCommand cmdRequestFunBitmap $ put cp >> putWord16be n putRequest (RequestConstrDesc itb) = putCommand cmdRequestConstrDesc $ put itb putRequest RequestPoll = putCommand cmdRequestPoll mempty putRequest RequestSavedObjects = putCommand cmdRequestSavedObjects mempty --putRequest (RequestFindPtr c) = -- putCommand cmdRequestFindPtr $ put c putRequest (RequestSourceInfo it) = putCommand cmdRequestSourceInfo $ put it putRequest (RequestAllBlocks) = putCommand cmdRequestAllBlocks $ return () putRequest (RequestBlock cp) = putCommand cmdRequestBlock $ put cp putRequest (RequestCCS cp) = putCommand cmdRequestCCS $ put cp putRequest (RequestCC cp) = putCommand cmdRequestCC $ put cp putRequest (RequestIndexTable cp) = putCommand cmdRequestIndexTable $ put cp putRequest RequestCCSMainPtr = putCommand cmdRequestCCSMainPtr mempty -- This is used to serialise the RequestCache getRequest :: Get AnyReq getRequest = do len <- getWord32be isolate (fromIntegral len) $ do cmd <- get if | cmd == cmdRequestVersion -> return (AnyReq RequestVersion) | cmd == cmdRequestPause -> do b <- get return (AnyReq (RequestPause b)) | cmd == cmdRequestResume -> return (AnyReq RequestResume) | cmd == cmdRequestRoots -> return (AnyReq RequestRoots) | cmd == cmdRequestClosures -> do _n <- getWord16be -- cs <- replicateM (fromIntegral n) get cp <- get return (AnyReq (RequestClosure cp)) | cmd == cmdRequestInfoTables -> do _n <- getWord16be --itbs <- replicateM (fromIntegral n) get itb <- get return (AnyReq (RequestInfoTable itb)) | cmd == cmdRequestSRT -> do _n <- getWord16be itb <- get return (AnyReq (RequestSRT itb)) | cmd == cmdRequestStackBitmap -> do sp <- get o <- getWord32be return (AnyReq (RequestStackBitmap sp o)) | cmd == cmdRequestFunBitmap -> do cp <- get n <- getWord16be return (AnyReq (RequestFunBitmap n cp)) | cmd == cmdRequestConstrDesc -> do itb <- get return (AnyReq (RequestConstrDesc itb)) | cmd == cmdRequestPoll -> return (AnyReq RequestPoll) | cmd == cmdRequestSavedObjects -> return (AnyReq RequestSavedObjects) | cmd == cmdRequestSourceInfo -> do it <- get return (AnyReq (RequestSourceInfo it)) | cmd == cmdRequestAllBlocks -> return (AnyReq RequestAllBlocks) | cmd == cmdRequestBlock -> do cp <- get return (AnyReq (RequestBlock cp)) | cmd == cmdRequestCCS -> do cp <- get return (AnyReq (RequestCCS cp)) | cmd == cmdRequestCC -> do cp <- get return (AnyReq (RequestCC cp)) | cmd == cmdRequestIndexTable -> do cp <- get return (AnyReq (RequestIndexTable cp)) | cmd == cmdRequestCCSMainPtr -> return (AnyReq RequestCCSMainPtr) | otherwise -> error (show cmd) getResponse :: Request a -> Get a getResponse RequestVersion = Version <$> get <*> get <*> getProfilingMode <*> get getResponse RequestPause {} = get getResponse RequestResume = get getResponse RequestRoots = many get getResponse (RequestClosure {}) = get getResponse (RequestInfoTable {}) = getInfoTable getResponse (RequestSRT {}) = do cptr <- get pure $ guard (cptr /= UntaggedClosurePtr 0) $> cptr -- zipWith (\p (it, r) -> (StgInfoTableWithPtr p it, r)) itps -- <$> replicateM (length itps) getInfoTable getResponse (RequestStackBitmap {}) = get getResponse (RequestFunBitmap {}) = get getResponse (RequestConstrDesc _) = getConstrDesc getResponse RequestPoll = get getResponse RequestSavedObjects = many get getResponse (RequestSourceInfo _c) = getIPE getResponse RequestAllBlocks = many get getResponse RequestBlock {} = get getResponse (RequestCCS {}) = getCCS getResponse (RequestCC {}) = getCC getResponse (RequestIndexTable {}) = getIndexTable getResponse (RequestCCSMainPtr {}) = getCCSMainPtr getProfilingMode :: Get (Maybe ProfilingMode) getProfilingMode = do w <- getWord8 case w of 0 -> pure $ Nothing 1 -> pure $ Just NoProfiling 2 -> pure $ Just RetainerProfiling 3 -> pure $ Just LDVProfiling 4 -> pure $ Just EraProfiling 5 -> pure $ Just OtherProfiling _ -> error $ "Unknown profiling mode: " ++ (show w) putProfilingMode :: Maybe ProfilingMode -> Put putProfilingMode Nothing = putWord8 0 putProfilingMode (Just mode) = case mode of NoProfiling -> putWord8 1 RetainerProfiling -> putWord8 2 LDVProfiling -> putWord8 3 EraProfiling -> putWord8 4 OtherProfiling -> putWord8 5 getCCS :: Get CCSPayload getCCS = do ccsID <- getInt64le ccsCc <- get ccsPrevStack <- do p <- get pure $ guard (p /= CCSPtr 0) $> p ccsIndexTable <- do p <- get pure $ guard (p /= IndexTablePtr 0) $> p ccsRoot <- do p <- get pure $ guard (p /= CCSPtr 0) $> p ccsDepth <- fromIntegral <$> getWord64le ccsSccCount <- getWord64le ccsSelected <- fromIntegral <$> getWord64le ccsTimeTicks <- fromIntegral <$> getWord64le ccsMemAlloc <- getWord64le ccsInheritedAlloc <- getWord64le ccsInheritedTicks <- fromIntegral <$> getWord64le pure CCSPayload{..} putCCS :: CCSPayload -> Put putCCS CCSPayload{..} = do putInt64le ccsID put ccsCc case ccsPrevStack of Nothing -> put (CCSPtr 0) Just x -> put x case ccsIndexTable of Nothing -> put (IndexTablePtr 0) Just x -> put x case ccsRoot of Nothing -> put (CCSPtr 0) Just x -> put x putWord64le $ fromIntegral ccsDepth putWord64le ccsSccCount putWord64le $ fromIntegral ccsSelected putWord64le $ fromIntegral ccsTimeTicks putWord64le ccsMemAlloc putWord64le ccsInheritedAlloc putWord64le $ fromIntegral ccsInheritedTicks getCC :: Get CCPayload getCC = do ccID <- getInt64le ccLabel <- getString ccMod <- getString ccLoc <- getString ccMemAlloc <- get ccTimeTicks <- get ccIsCaf <- (\i -> if i == 0 then False else True ) <$> getWord64be ccLink <- do p <- get pure $ guard (p /= CCPtr 0) $> p pure CCPayload{..} where getString = do len <- getInt32be C8.unpack <$> getByteString (fromIntegral len) putCC :: CCPayload -> Put putCC CCPayload{..} = do putInt64le ccID putString ccLabel putString ccMod putString ccLoc put ccMemAlloc put ccTimeTicks if ccIsCaf then putWord64le 0 else putWord64le 1 case ccLink of Nothing -> put (CCPtr 0) Just x -> put x where putString xs = do putInt32be (fromIntegral $ length xs) putByteString (C8.pack xs) getIndexTable :: Get IndexTable getIndexTable = do itCostCentre <- get itCostCentreStack <- get itNext <- do p <- get pure $ guard (p /= IndexTablePtr 0) $> p itBackEdge <- (\i -> if i == 0 then False else True) <$> getWord8 pure IndexTable{..} putIndexTable :: IndexTable -> Put putIndexTable IndexTable {..} = do put itCostCentre put itCostCentreStack case itNext of Nothing -> put (IndexTablePtr 0) Just x -> put x if itBackEdge then putWord8 0 else putWord8 1 getCCSMainPtr :: Get CCSPtr getCCSMainPtr = get putCCSMainPtr :: CCSPtr -> Put putCCSMainPtr = put getConstrDesc :: Get ConstrDesc getConstrDesc = do len <- getInt32be parseConstrDesc . C8.unpack <$> getByteString (fromIntegral len) getIPE :: Get (Maybe SourceInformation) getIPE = do num <- getInt32be res <- replicateM (fromIntegral num) getOne case res of (id_name:cty:ty:lab:modu:loc:[]) -> return . Just $! SourceInformation id_name (readCTy cty) ty lab modu loc [] -> return Nothing fs -> fail (show ("Expecting 6 or 0 fields in IPE" :: String, fs,num)) where getOne = do !len <- getInt32be !res <- C8.unpack <$> getByteString (fromIntegral len) return res -- All constructor nodes get 0, this is a wibble in the implementation -- of IPEs readCTy "0" = CONSTR readCTy n = toEnum (read @Int n) putIPE :: Maybe SourceInformation -> Put putIPE Nothing = putInt32be 0 putIPE (Just (SourceInformation a ty b c d e)) = do putInt32be 6 putOne a putOne (show (fromEnum ty)) putOne b putOne c putOne d putOne e where putOne s = do putInt32be (fromIntegral $ length s) putByteString (C8.pack s) getInfoTable :: Get RawInfoTable getInfoTable = do !len <- getInt32be !r <- RawInfoTable <$> getByteString (fromIntegral len) return r putInfoTable :: RawInfoTable -> Put putInfoTable (RawInfoTable rc) = do let n = BS.length rc putWord32be (fromIntegral n) putByteString rc data Error = BadCommand | BadStack | AlreadyPaused | NotPaused | NoResume deriving stock (Eq, Ord, Show) instance Exception Error data ResponseCode = Okay | OkayContinues | Error Error deriving stock (Eq, Ord, Show) getResponseCode :: Get ResponseCode getResponseCode = getWord16be >>= f where f 0x0 = pure Okay f 0x1 = pure OkayContinues f 0x100 = pure $ Error BadCommand f 0x104 = pure $ Error BadStack f 0x101 = pure $ Error AlreadyPaused f 0x102 = pure $ Error NotPaused f 0x103 = pure $ Error NoResume f _ = fail "Unknown response code" data Stream a r = Next !a (Stream a r) | End r readFrames :: Handle -> IO (Stream BS.ByteString (Maybe Error)) readFrames hdl = do (respLen, status) <- runGet_ frameHeader <$> BSL.hGet hdl 6 respBody <- BS.hGet hdl (fromIntegral respLen) case status of OkayContinues -> do rest <- readFrames hdl return $ Next respBody rest Okay -> return $ Next respBody (End Nothing) Error err-> return $ End (Just err) where frameHeader :: Get (Word32, ResponseCode) frameHeader = (,) <$> getWord32be <*> getResponseCode throwStream :: Exception e => Stream a (Maybe e) -> [a] throwStream = f where f (Next x rest) = x : f rest f (End Nothing) = [] f (End (Just e)) = throw e concatStream :: Stream BS.ByteString (Maybe Error) -> BSL.ByteString concatStream = BSL.fromChunks . throwStream -- | Perform a request doRequest :: MVar Handle -> Request a -> IO a doRequest mhdl req = withMVar mhdl $ \hdl -> do BSL.hPutStr hdl $ runPut $ putRequest req bframes <- readFrames hdl let x = runGet_ (getResponse req) (concatStream bframes) return x