From 31aa35ed8649299de181d2b16690ee68d9098e5a Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 27 Sep 2023 11:31:04 +0200 Subject: [PATCH 01/21] add getSourceLinks custom request ; generate distinct variable references for each stack frame ; attach source location info for 'code' variables --- dap-estgi-server/dap-estgi-server.cabal | 2 + dap-estgi-server/src/CustomCommands.hs | 43 ++++++++ dap-estgi-server/src/Main.hs | 137 ++++++++++++++++++------ 3 files changed, 151 insertions(+), 31 deletions(-) create mode 100644 dap-estgi-server/src/CustomCommands.hs diff --git a/dap-estgi-server/dap-estgi-server.cabal b/dap-estgi-server/dap-estgi-server.cabal index c1030b4..2141f13 100644 --- a/dap-estgi-server/dap-estgi-server.cabal +++ b/dap-estgi-server/dap-estgi-server.cabal @@ -17,6 +17,8 @@ extra-source-files: CHANGELOG.md executable dap-estgi + other-modules: + CustomCommands main-is: Main.hs ghc-options: diff --git a/dap-estgi-server/src/CustomCommands.hs b/dap-estgi-server/src/CustomCommands.hs new file mode 100644 index 0000000..3cab19c --- /dev/null +++ b/dap-estgi-server/src/CustomCommands.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +module CustomCommands where + +import GHC.Generics ( Generic ) + +import Data.Text +import Data.Aeson +import DAP.Utils + +data GetSourceLinksArguments + = GetSourceLinksArguments + { getSourceLinksArgumentsPath :: Text + } deriving stock (Show, Eq, Generic) + +instance FromJSON GetSourceLinksArguments where + parseJSON = genericParseJSONWithModifier + +------------ + +data GetSourceLinksResponse + = GetSourceLinksResponse + { getSourceLinksResponseSourceLinks :: [SourceLink] + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON GetSourceLinksResponse where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- +data SourceLink + = SourceLink + { sourceLinkSourceLine :: Int + , sourceLinkSourceColumn :: Int + , sourceLinkSourceEndLine :: Int + , sourceLinkSourceEndColumn :: Int + , sourceLinkTargetLine :: Int + , sourceLinkTargetColumn :: Int + , sourceLinkTargetEndLine :: Int + , sourceLinkTargetEndColumn :: Int + , sourceLinkTargetPath :: Text + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON SourceLink where + toJSON = genericToJSONWithModifier diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 8f20377..a0d0a01 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -39,6 +39,7 @@ import Control.Monad.State.Strict ( gets ) import Control.Monad import Control.Monad.State.Strict ( gets ) import Data.Aeson ( Value(Null), FromJSON ) +import qualified Data.Aeson as Aeson import Data.IntMap.Strict ( IntMap ) import qualified Data.IntMap.Strict as IntMap import Data.Bimap ( Bimap ) @@ -50,7 +51,7 @@ import Data.Text ( Text ) import qualified Data.Text as T import qualified Data.Text.Lazy as LazyText import Data.Typeable ( typeOf ) -import Data.Maybe ( fromMaybe ) +import Data.Maybe ( fromMaybe, maybeToList ) import Data.List ( sortOn ) import GHC.Generics ( Generic ) import System.Environment ( lookupEnv ) @@ -80,6 +81,8 @@ import qualified Text.Pretty.Simple as PP ---------------------------------------------------------------------------- import DAP hiding (send) ---------------------------------------------------------------------------- +import CustomCommands +---------------------------------------------------------------------------- -- | DAP entry point -- Extracts configuration information from the environment -- Opens a listen socket on a port (defaulting to '4711') @@ -316,6 +319,47 @@ talk CommandLoadedSources = do srcSet <- getsApp sourceCodeSet mapM (getSourceFromSourceRefDescriptor . SourceRef_SourceFileInFullpak) $ filter shouldInclude $ Set.toList srcSet +---------------------------------------------------------------------------- +talk (CustomCommand "getSourceLinks") = do + GetSourceLinksArguments {..} <- getArguments + ESTG {..} <- getDebugSession + sourceLinks <- case Bimap.lookup getSourceLinksArgumentsPath dapSourceNameMap of + Just srcDesc@(SourceRef_SourceFileInFullpak ExtStg{}) -> do + source <- getSourceFromSourceRefDescriptor srcDesc + let Just sourceRef = sourceSourceReference source + (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef + let hsTickishLocMap = M.unionsWith mappend [M.singleton stgPoint [tickish] | (stgPoint, tickish) <- hsSrcLocs] + -- collect tickish locations + estgLocMap = M.unionsWith mappend + [ M.singleton stgPoint [range] + | (SP_Tickish stgPoint, range) <- locations + ] + liftIO $ do + print hsTickishLocMap + print estgLocMap + pure $ + [ SourceLink + { sourceLinkSourceLine = estgStartLine + , sourceLinkSourceColumn = estgStartCol + , sourceLinkSourceEndLine = estgEndLine + , sourceLinkSourceEndColumn = estgEndCol + , sourceLinkTargetLine = srcSpanSLine + , sourceLinkTargetColumn = srcSpanSCol + , sourceLinkTargetEndLine = srcSpanELine + , sourceLinkTargetEndColumn = srcSpanECol + , sourceLinkTargetPath = cs $ getSourceName hsCodeDesc + } + | (stgPoint, hsTickishList) <- M.toList hsTickishLocMap + , estgLocList <- maybeToList $ M.lookup stgPoint estgLocMap + , (((estgStartLine, estgStartCol),(estgEndLine, estgEndCol)), SourceNote{..}) <- zip estgLocList hsTickishList + , let RealSrcSpan'{..} = sourceSpan + , hsCodeDesc <- maybeToList $ Bimap.lookup srcSpanFile haskellSrcPathMap + ] + _ -> pure [] + sendSuccesfulResponse . setBody $ GetSourceLinksResponse + { getSourceLinksResponseSourceLinks = sourceLinks + } + ---------------------------------------------------------------------------- talk CommandModules = do sendModulesResponse (ModulesResponse [] Nothing) @@ -572,12 +616,12 @@ talk CommandVariables = do Just VariablesRef_StackFrameVariables{} -> do variables <- getVariables variablesArgumentsVariablesReference sendVariablesResponse (VariablesResponse variables) - Just (VariablesRef_HeapObject addr) -> do + Just (VariablesRef_HeapObject frameIdDesc addr) -> do stgState <- getStgState ho <- case IntMap.lookup addr $ ssHeap stgState of Nothing -> sendError (ErrorMessage (T.pack $ "Unknown heap object: " ++ show addr)) Nothing Just v -> pure v - variables <- getVariablesForHeapObject stgState ho + variables <- getVariablesForHeapObject stgState frameIdDesc ho -- detect and annotate loops let markLoop v | variableVariablesReference v == 0 @@ -587,6 +631,8 @@ talk CommandVariables = do | otherwise = v {variableName = variableName v <> " "} sendVariablesResponse (VariablesResponse $ map markLoop variables) + Nothing -> do + sendVariablesResponse (VariablesResponse []) ---------------------------------------------------------------------------- talk CommandNext = do NextArguments {..} <- getArguments @@ -789,12 +835,12 @@ generateScopesForTopStackFrame frameIdDesc closureId env = do varList <- forM (M.toList env) $ \(Id (Binder{..}), (_, atom)) -> do let BinderId u = binderId displayName = if binderScope == ModulePublic then cs binderName else cs (show u) - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom pure defaultVariable { variableName = displayName , variableValue = cs variableValue , variableType = Just (cs variableType) - , variableEvaluateName = Just $ displayName <> " evaluate" + -- , variableEvaluateName = Just $ displayName <> " evaluate" , variableVariablesReference = varsRef } setVariables scopeVarablesRef varList @@ -821,10 +867,27 @@ getHeapObjectSummary = \case ApStack{} -> "ApStack" RaiseException{} -> "RaiseException" -getVariablesForHeapObject :: StgState -> HeapObject -> Adaptor ESTG [Variable] -getVariablesForHeapObject stgState = \case +getStgSourceLocJSON :: Id -> Adaptor ESTG (Maybe Text) +getStgSourceLocJSON i = do + (mSource, startL, startC, endL, endC) <- getSourceAndPositionForStgPoint i (SP_Binding i) + let mkPosObject line column = Aeson.object + [ ("line", Aeson.Number $ fromIntegral line) + , ("column", Aeson.Number $ fromIntegral column) + ] + srcLocJson = do + Source{..} <- mSource + path <- sourcePath + pure . cs . Aeson.encode $ Aeson.object + [ ("path", Aeson.String path) + , ("start", mkPosObject startL startC) + , ("end", mkPosObject endL endC) + ] + pure srcLocJson + +getVariablesForHeapObject :: StgState -> DapFrameIdDescriptor -> HeapObject -> Adaptor ESTG [Variable] +getVariablesForHeapObject stgState frameIdDesc = \case Con{..} -> forM (zip [0..] hoConArgs) $ \(idx, atom) -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom pure defaultVariable { variableName = cs $ "arg" ++ show idx , variableValue = cs variableValue @@ -832,9 +895,11 @@ getVariablesForHeapObject stgState = \case , variableVariablesReference = varsRef } Closure{..} -> do + srcLocJson <- getStgSourceLocJSON hoName let bodyVar = defaultVariable { variableName = "code" , variableValue = cs $ show hoName + , variableEvaluateName = srcLocJson } {- TODO: @@ -843,7 +908,7 @@ getVariablesForHeapObject stgState = \case show missing-args-count / is thunk? -} argVarList <- forM (zip [0..] hoCloArgs) $ \(idx, atom) -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom pure defaultVariable { variableName = cs $ "arg" ++ show idx , variableValue = cs variableValue @@ -851,19 +916,28 @@ getVariablesForHeapObject stgState = \case , variableVariablesReference = varsRef } envVarList <- forM (M.toList hoEnv) $ \(Id (Binder{..}), (_, atom)) -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom let BinderId u = binderId displayName = if binderScope == ModulePublic then cs binderName else cs (show u) pure defaultVariable { variableName = displayName , variableValue = cs variableValue , variableType = Just (cs variableType) - , variableEvaluateName = Just $ displayName <> " evaluate" + -- , variableEvaluateName = Just $ displayName <> " evaluate" , variableVariablesReference = varsRef } pure $ bodyVar : argVarList ++ envVarList BlackHole{..} -> do - (ownerVarType, ownerVarValue, ownerVarsRef) <- getAtomTypeAndValueM stgState $ ThreadId hoBHOwnerThreadId + (ownerVarType, ownerVarValue, ownerVarsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ ThreadId hoBHOwnerThreadId + bodyVar <- case hoBHOriginalThunk of + Closure{..} -> do + srcLocJson <- getStgSourceLocJSON hoName + pure . pure $ defaultVariable + { variableName = "code" + , variableValue = cs $ show hoName + , variableEvaluateName = cs <$> srcLocJson + } + _ -> pure [] let onwerVar = defaultVariable { variableName = "owner thread id" , variableValue = cs ownerVarValue @@ -872,17 +946,17 @@ getVariablesForHeapObject stgState = \case } queueVarList <- forM hoBHWaitQueue $ \tid -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState $ ThreadId tid + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ ThreadId tid pure defaultVariable { variableName = "waiting thread id" , variableValue = cs variableValue , variableType = Just (cs variableType) , variableVariablesReference = varsRef } - pure $ onwerVar : queueVarList + pure $ bodyVar ++ onwerVar : queueVarList ApStack{..} -> do resultVarList <- forM hoResult $ \atom -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom pure defaultVariable { variableName = "latest result" , variableValue = cs variableValue @@ -892,7 +966,7 @@ getVariablesForHeapObject stgState = \case -- TODO: hoStack pure resultVarList RaiseException ex -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState ex + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc ex pure $ pure defaultVariable { variableName = "exception" , variableValue = cs variableValue @@ -914,14 +988,14 @@ generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do varList <- forM (M.toList env) $ \(Id (Binder{..}), (_, atom)) -> do -- DMJ: for now everything is local. -- Inspect StaticOrigin to put things top-level, or as arguments, where applicable - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom let BinderId u = binderId displayName = if binderScope == ModulePublic then cs binderName else cs (show u) pure defaultVariable { variableName = displayName , variableValue = cs variableValue , variableType = Just (cs variableType) - , variableEvaluateName = Just $ displayName <> " evaluate" + -- , variableEvaluateName = Just $ displayName <> " evaluate" , variableVariablesReference = varsRef } setVariables scopeVarablesRef varList @@ -940,7 +1014,7 @@ generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do generateScopes frameIdDesc stackCont@(Update addr) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState $ HeapPtr addr + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ HeapPtr addr setVariables scopeVarablesRef [ defaultVariable { variableName = "Thunk Address" @@ -960,7 +1034,7 @@ generateScopes frameIdDesc stackCont@(Apply atoms) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState varList <- forM atoms $ \atom -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom pure defaultVariable { variableName = "Closure argument" , variableValue = cs variableValue @@ -978,7 +1052,7 @@ generateScopes frameIdDesc stackCont@(Apply atoms) = do generateScopes frameIdDesc stackCont@(Catch atom blockAsync interruptible) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom setVariables scopeVarablesRef [ defaultVariable { variableName = "Exception Handler" @@ -1050,7 +1124,7 @@ generateScopes frameIdDesc stackCont@(RunScheduler reason) = do generateScopes frameIdDesc stackCont@(Atomically atom) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom setVariables scopeVarablesRef [ defaultVariable { variableName = "STM action" @@ -1069,8 +1143,8 @@ generateScopes frameIdDesc stackCont@(Atomically atom) = do generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction isRunningAlternative _tlog) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState - (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState primaryAction - (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState alternativeAction + (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState frameIdDesc primaryAction + (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState frameIdDesc alternativeAction setVariables scopeVarablesRef [ defaultVariable { variableName = "First STM action" @@ -1101,8 +1175,8 @@ generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction generateScopes frameIdDesc (CatchSTM action handler) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState - (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState action - (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState handler + (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState frameIdDesc action + (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState frameIdDesc handler setVariables scopeVarablesRef [ defaultVariable { variableName = "STM action" @@ -1136,7 +1210,7 @@ generateScopes frameIdDesc stackCont@DataToTagOp = do generateScopes frameIdDesc stackCont@(RaiseOp atom) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom setVariables scopeVarablesRef [ defaultVariable { variableName = "RaiseOp" @@ -1155,7 +1229,7 @@ generateScopes frameIdDesc stackCont@(RaiseOp atom) = do generateScopes frameIdDesc stackCont@(KeepAlive atom) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom setVariables scopeVarablesRef [ defaultVariable { variableName = "Managed Object" @@ -1233,13 +1307,14 @@ showPrimRep rep = show rep getAtomTypeAndValueM :: StgState + -> DapFrameIdDescriptor -> Atom -> Adaptor ESTG (String, String, Int) -getAtomTypeAndValueM ss@StgState{..} = \case +getAtomTypeAndValueM ss@StgState{..} frameIdDesc = \case HeapPtr addr | Just o <- IntMap.lookup addr ssHeap -> do - varsRef <- getVariablesRef $ VariablesRef_HeapObject addr + varsRef <- getVariablesRef $ VariablesRef_HeapObject frameIdDesc addr pure ("HeapPtr", show addr ++ " " ++ getHeapObjectSummary o ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o), varsRef) atom | (t, v) <- getAtomTypeAndValue ss atom @@ -1348,7 +1423,7 @@ data DapFrameIdDescriptor data DapVariablesRefDescriptor = VariablesRef_StackFrameVariables DapFrameIdDescriptor - | VariablesRef_HeapObject Int + | VariablesRef_HeapObject DapFrameIdDescriptor Int deriving (Show, Eq, Ord) data SourceCodeDescriptor From 2a9a2a777e5edd9e31ccb8b3f86478b6bd0201d5 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Sun, 15 Oct 2023 21:48:19 +0200 Subject: [PATCH 02/21] split into multiple modules --- dap-estgi-server/dap-estgi-server.cabal | 14 + dap-estgi-server/src/Breakpoints.hs | 162 ++ dap-estgi-server/src/CustomCommands.hs | 11 + dap-estgi-server/src/DapBase.hs | 216 +++ dap-estgi-server/src/Graph.hs | 90 ++ .../src/GraphProtocol/Commands.hs | 22 + dap-estgi-server/src/GraphProtocol/Server.hs | 147 ++ dap-estgi-server/src/Inspect/Stack.hs | 199 +++ dap-estgi-server/src/Inspect/Value.hs | 14 + dap-estgi-server/src/Inspect/Value/Atom.hs | 138 ++ .../src/Inspect/Value/HeapObject.hs | 71 + .../src/Inspect/Value/StackContinuation.hs | 121 ++ dap-estgi-server/src/Main.hs | 1345 ++--------------- dap-estgi-server/src/SourceCode.hs | 193 +++ dap-estgi-server/src/SourceLocation.hs | 139 ++ 15 files changed, 1653 insertions(+), 1229 deletions(-) create mode 100644 dap-estgi-server/src/Breakpoints.hs create mode 100644 dap-estgi-server/src/DapBase.hs create mode 100644 dap-estgi-server/src/Graph.hs create mode 100644 dap-estgi-server/src/GraphProtocol/Commands.hs create mode 100644 dap-estgi-server/src/GraphProtocol/Server.hs create mode 100644 dap-estgi-server/src/Inspect/Stack.hs create mode 100644 dap-estgi-server/src/Inspect/Value.hs create mode 100644 dap-estgi-server/src/Inspect/Value/Atom.hs create mode 100644 dap-estgi-server/src/Inspect/Value/HeapObject.hs create mode 100644 dap-estgi-server/src/Inspect/Value/StackContinuation.hs create mode 100644 dap-estgi-server/src/SourceCode.hs create mode 100644 dap-estgi-server/src/SourceLocation.hs diff --git a/dap-estgi-server/dap-estgi-server.cabal b/dap-estgi-server/dap-estgi-server.cabal index 2141f13..f7cc4f0 100644 --- a/dap-estgi-server/dap-estgi-server.cabal +++ b/dap-estgi-server/dap-estgi-server.cabal @@ -18,7 +18,20 @@ extra-source-files: executable dap-estgi other-modules: + Inspect.Stack + Inspect.Value + Inspect.Value.Atom + Inspect.Value.HeapObject + Inspect.Value.StackContinuation CustomCommands + GraphProtocol.Commands + GraphProtocol.Server + Graph + Breakpoints + DapBase + SourceCode + SourceLocation + main-is: Main.hs ghc-options: @@ -47,6 +60,7 @@ executable dap-estgi , zip , bimap , pretty-simple + , network-simple hs-source-dirs: src default-language: diff --git a/dap-estgi-server/src/Breakpoints.hs b/dap-estgi-server/src/Breakpoints.hs new file mode 100644 index 0000000..3b8338d --- /dev/null +++ b/dap-estgi-server/src/Breakpoints.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Breakpoints where + +import Text.Read ( readMaybe ) +import Data.Maybe ( fromMaybe, maybeToList ) +import Data.List ( sortOn ) +import Control.Monad +import Data.String.Conversions (cs) +import qualified Data.Text as T +import qualified Data.Bimap as Bimap +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map +import qualified Stg.Interpreter.Base as Stg +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import Stg.Syntax hiding (sourceName, Scope) +import Stg.IRLocation + +import DAP +import DapBase +import SourceCode + +---------------------------------------------------------------------------- +-- | Clears the currently known breakpoint set +clearBreakpoints :: Adaptor ESTG () +clearBreakpoints = do + updateDebugSession $ \estg -> estg {breakpointMap = mempty} + +---------------------------------------------------------------------------- +-- | Adds new BreakpointId for a givent StgPoint +addNewBreakpoint :: Stg.Breakpoint -> Adaptor ESTG BreakpointId +addNewBreakpoint breakpoint = do + bkpId <- getFreshBreakpointId + updateDebugSession $ \estg@ESTG{..} -> estg {breakpointMap = Map.insertWith mappend breakpoint (IntSet.singleton bkpId) breakpointMap} + pure bkpId + +commandSetBreakpoints :: Adaptor ESTG () +commandSetBreakpoints = do + SetBreakpointsArguments {..} <- getArguments + maybeSourceRef <- getValidSourceRefFromSource setBreakpointsArgumentsSource + + -- the input SourceRef might be a remain of a previous DAP session, update it with the new valid one + let refUpdatedSource = setBreakpointsArgumentsSource { sourceSourceReference = maybeSourceRef } + + clearBreakpoints + {- + supports placing breakpoint on: + - Haskell + - ExtStg + -} + ESTG {..} <- getDebugSession + case (setBreakpointsArgumentsBreakpoints, maybeSourceRef, maybeSourceRef >>= flip Bimap.lookupR dapSourceRefMap) of + -- HINT: breakpoint on Haskell + (Just sourceBreakpoints, Just sourceRef, Just (SourceRef_SourceFileInFullpak hsCodeDesc@(Haskell pkg mod))) + | Just extStgSourceRef <- Bimap.lookup (SourceRef_SourceFileInFullpak $ ExtStg pkg mod) dapSourceRefMap + , Just hsSourceFilePath <- Bimap.lookupR hsCodeDesc haskellSrcPathMap + -> do + (_sourceCodeText, _locations, hsSrcLocs) <- getSourceFromFullPak extStgSourceRef + breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do + -- filter all relevant ranges + {- + SP_RhsClosureExpr + -} + let onlySupported = \case + SP_RhsClosureExpr{} -> True + _ -> True -- TODO + let relevantLocations = filter (onlySupported . fst . fst) $ case sourceBreakpointColumn of + Nothing -> + [ (p, spanSize) + | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs + , srcSpanFile == hsSourceFilePath + , srcSpanSLine <= sourceBreakpointLine + , srcSpanELine >= sourceBreakpointLine + , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) + ] + Just col -> + [ (p, spanSize) + | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs + , srcSpanFile == hsSourceFilePath + , srcSpanSLine <= sourceBreakpointLine + , srcSpanELine >= sourceBreakpointLine + , srcSpanSCol <= col + , srcSpanECol >= col + , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) + ] + debugMessage . cs . unlines $ "relevant haskell locations:" : map show relevantLocations + -- use the first location found + -- HINT: locations are sorted according the span size, small spans are preferred more + case map fst . take 1 $ sortOn snd relevantLocations of + (stgPoint@(SP_RhsClosureExpr _closureName), SourceNote RealSrcSpan'{..} _) : _ -> do + let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int + sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount) + bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint + pure $ defaultBreakpoint + { breakpointVerified = True + , breakpointSource = Just refUpdatedSource + , breakpointLine = Just srcSpanSLine + , breakpointColumn = Just srcSpanSCol + , breakpointEndLine = Just srcSpanELine + , breakpointEndColumn = Just srcSpanECol + , breakpointId = Just bkpId + } + _ -> + pure $ defaultBreakpoint + { breakpointVerified = False + , breakpointSource = Just refUpdatedSource + , breakpointMessage = Just "no hs code found" + } + sendSetBreakpointsResponse breakpoints + + -- HINT: breakpoint on ExtStg + (Just sourceBreakpoints, Just sourceRef, Just (SourceRef_SourceFileInFullpak ExtStg{})) -> do + (_sourceCodeText, locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef + breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do + -- filter all relevant ranges + {- + SP_RhsClosureExpr + -} + let onlySupported = \case + SP_RhsClosureExpr{} -> True + _ -> False + let relevantLocations = filter (onlySupported . fst) $ case sourceBreakpointColumn of + Nothing -> + [ p + | p@(_,((startRow, startCol), (endRow, endCol))) <- locations + , startRow <= sourceBreakpointLine + , endRow >= sourceBreakpointLine + ] + Just col -> + [ p + | p@(_,((startRow, startCol), (endRow, endCol))) <- locations + , startRow <= sourceBreakpointLine + , endRow >= sourceBreakpointLine + , startCol <= col + , endCol >= col + ] + debugMessage . cs $ "relevantLocations: " ++ show relevantLocations + -- use the first location found + case sortOn snd relevantLocations of + (stgPoint@(SP_RhsClosureExpr _closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do + let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int + sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount) + bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint + pure $ defaultBreakpoint + { breakpointVerified = True + , breakpointSource = Just refUpdatedSource + , breakpointLine = Just startRow + , breakpointColumn = Just startCol + , breakpointEndLine = Just endRow + , breakpointEndColumn = Just endCol + , breakpointId = Just bkpId + } + _ -> + pure $ defaultBreakpoint + { breakpointVerified = False + , breakpointSource = Just refUpdatedSource + , breakpointMessage = Just "no code found" + } + sendSetBreakpointsResponse breakpoints + v -> do + sendSetBreakpointsResponse [] diff --git a/dap-estgi-server/src/CustomCommands.hs b/dap-estgi-server/src/CustomCommands.hs index 3cab19c..cc4b294 100644 --- a/dap-estgi-server/src/CustomCommands.hs +++ b/dap-estgi-server/src/CustomCommands.hs @@ -41,3 +41,14 @@ data SourceLink ---------------------------------------------------------------------------- instance ToJSON SourceLink where toJSON = genericToJSONWithModifier + +---------------------------------------------------------------------------- +data ShowVariableGraphStructureArguments + = ShowVariableGraphStructureArguments + { showVariableGraphStructureArgumentsVariablesReference :: Int + } deriving stock (Show, Eq, Generic) + +instance FromJSON ShowVariableGraphStructureArguments where + parseJSON = genericParseJSONWithModifier + +---------------------------------------------------------------------------- diff --git a/dap-estgi-server/src/DapBase.hs b/dap-estgi-server/src/DapBase.hs new file mode 100644 index 0000000..442fe50 --- /dev/null +++ b/dap-estgi-server/src/DapBase.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module DapBase where + +import Data.Bimap ( Bimap ) +import qualified Data.Bimap as Bimap +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map +import Data.IntSet ( IntSet ) +import Data.Set ( Set ) +import Data.IntMap.Strict ( IntMap ) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict ) +import qualified Control.Concurrent.MVar as MVar +import Control.Monad.IO.Class (liftIO) + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import qualified Stg.Interpreter.Base as Stg +import Stg.Interpreter.GC.GCRef +import Stg.Syntax hiding (sourceName, Scope) +import DAP hiding (send) + +type PackageName = Text +type QualifiedModuleName = Text +type BreakpointId = Int +type SourceId = Int +type ThreadId = Int + +{- + IDEA: + pure design + use pure and unique resource descriptors to select items from StgState + maintain a bimap between the pure resource descriptors and DAP integer ids + + IMPORTANT: avoid use of counters + BENEFIT: + DAP request order independence + no resource caching is needed + stateless + use of descriptive resource identification instead of integers + + IDEA: + ResourceID ADT - structured key + idMap :: ResourceID -> Int + + DAP request argument -> estg domian idientifiers + request argument's id -> estg domain + + resource ids + threadRef = thread id + frameRef = thread id + frame index + scopeRef = thread id + frame index + argument index + variablesRef = ?? + sourceRef + + HINT: VariablesRef -> [Variable] + + DAP id types: + thread + stack frame + variable + + + Threads args: NONE + StackTrace args: threadId + Scopes args: frameId + Variables args: variablesRef + ... + Variables +-} + +type StackFrameIndex = Int + +data DapFrameIdDescriptor + = FrameId_CurrentThreadTopStackFrame + | FrameId_ThreadStackFrame ThreadId StackFrameIndex + deriving (Show, Eq, Ord) + +data ValueRoot + = ValueRoot_StackFrame DapFrameIdDescriptor + | ValueRoot_Value (RefNamespace, Int) + deriving (Show, Eq, Ord) + +data DapVariablesRefDescriptor + = VariablesRef_StackFrameVariables DapFrameIdDescriptor +-- | VariablesRef_HeapObject DapFrameIdDescriptor Int + | VariablesRef_Value ValueRoot RefNamespace Int + deriving (Show, Eq, Ord) + +data SourceCodeDescriptor + = Haskell PackageName QualifiedModuleName + | GhcCore PackageName QualifiedModuleName + | GhcStg PackageName QualifiedModuleName + | Cmm PackageName QualifiedModuleName + | Asm PackageName QualifiedModuleName + | ExtStg PackageName QualifiedModuleName + | FFICStub PackageName QualifiedModuleName + | FFIHStub PackageName QualifiedModuleName + | ModInfo PackageName QualifiedModuleName + | ForeignC PackageName FilePath + deriving (Show, Read, Eq, Ord) + +data DapSourceRefDescriptor + = SourceRef_SourceFileInFullpak SourceCodeDescriptor + deriving (Show, Read, Eq, Ord) + +---------------------------------------------------------------------------- +-- | External STG Interpreter application internal state +data ESTG + = ESTG + { debuggerChan :: DebuggerChan + , fullPakPath :: String + , breakpointMap :: Map Stg.Breakpoint IntSet + , sourceCodeSet :: Set SourceCodeDescriptor + , unitIdMap :: Bimap UnitId PackageName + , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor + , dapSourceNameMap :: Bimap Text DapSourceRefDescriptor + + -- application specific resource handling + + , dapSourceRefMap :: !(Bimap DapSourceRefDescriptor Int) + -- ^ Used to track source reference IDs + -- + , dapFrameIdMap :: !(Bimap DapFrameIdDescriptor Int) + -- ^ Used to track stack frame IDs + -- + , dapVariablesRefMap :: !(Bimap DapVariablesRefDescriptor Int) + -- ^ Used to track variablesReferences + -- + , dapStackFrameCache :: !(Map DapFrameIdDescriptor StackContinuation) + -- ^ Stores the assigned StackContinuation for each DAP FrameId (Int) + -- + , nextFreshBreakpointId :: !Int + -- ^ monotinic counter for unique BreakpointId assignment + -- + } + +-- resource handling + +getsApp f = f <$> getDebugSession +modifyApp = updateDebugSession + +---------------------------------------------------------------------------- +-- | Synchronous call to Debugger, sends message and waits for response +sendAndWait :: DebugCommand -> Adaptor ESTG DebugOutput +sendAndWait cmd = do + ESTG {..} <- getDebugSession + let DebuggerChan{..} = debuggerChan + liftIO $ do + MVar.putMVar dbgSyncRequest cmd + MVar.takeMVar dbgSyncResponse + +getStgState :: Adaptor ESTG StgState +getStgState = do + sendAndWait (CmdInternal "get-stg-state") >>= \case + DbgOutStgState stgState -> + pure stgState + otherMessage -> do + let errorMsg + = concat + [ "Unexpected Message received from interpreter: " + , show otherMessage + ] + logInfo (BL8.pack errorMsg) + sendError (ErrorMessage (T.pack errorMsg)) Nothing + +---------------------------------------------------------------------------- +mkThreadLabel :: ThreadState -> String +mkThreadLabel = maybe "" (BL8.unpack . BL8.fromStrict) . tsLabel + +getFrameId :: DapFrameIdDescriptor -> Adaptor ESTG Int +getFrameId key = do + getsApp (Bimap.lookup key . dapFrameIdMap) >>= \case + Just frameId -> pure frameId + Nothing -> do + frameId <- getsApp (succ . Bimap.size . dapFrameIdMap) + modifyApp $ \s -> s {dapFrameIdMap = Bimap.insert key frameId (dapFrameIdMap s)} + pure frameId + +getVariablesRef :: DapVariablesRefDescriptor -> Adaptor ESTG Int +getVariablesRef key = do + getsApp (Bimap.lookup key . dapVariablesRefMap) >>= \case + Just varRef -> pure varRef + Nothing -> do + varRef <- getsApp (succ . Bimap.size . dapVariablesRefMap) + modifyApp $ \s -> s {dapVariablesRefMap = Bimap.insert key varRef (dapVariablesRefMap s)} + pure varRef + +addStackFrameToCache :: DapFrameIdDescriptor -> StackContinuation -> Adaptor ESTG () +addStackFrameToCache frameIdDesc stackCont = do + modifyApp $ \s -> s {dapStackFrameCache = Map.insert frameIdDesc stackCont (dapStackFrameCache s)} + +getStackFrameFromCache :: DapFrameIdDescriptor -> Adaptor ESTG StackContinuation +getStackFrameFromCache frameIdDesc = do + ESTG {..} <- getDebugSession + case Map.lookup frameIdDesc dapStackFrameCache of + Nothing -> sendError (ErrorMessage (T.pack $ "Unknown stack frame: " ++ show frameIdDesc)) Nothing + Just stackCont -> pure stackCont + +-- | Invoked when a StepEvent has occurred +resetObjectLifetimes :: Adaptor ESTG () +resetObjectLifetimes = do + modifyApp $ \s -> s + { dapFrameIdMap = Bimap.empty + , dapVariablesRefMap = Bimap.empty + , dapStackFrameCache = mempty + } + +getFreshBreakpointId :: Adaptor ESTG BreakpointId +getFreshBreakpointId = do + bkpId <- getsApp nextFreshBreakpointId + modifyApp $ \s -> s { nextFreshBreakpointId = nextFreshBreakpointId s + 1 } + pure bkpId diff --git a/dap-estgi-server/src/Graph.hs b/dap-estgi-server/src/Graph.hs new file mode 100644 index 0000000..8b83249 --- /dev/null +++ b/dap-estgi-server/src/Graph.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module Graph where + +import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) +import Data.String.Conversions (cs) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Bimap as Bimap + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import Stg.Interpreter.GC.GCRef +import Stg.Interpreter.Debugger.TraverseState +import Stg.Interpreter.Debug + +import DAP +import DapBase +import CustomCommands +import GraphProtocol.Server +import GraphProtocol.Commands +import Inspect.Value.Atom + +getValueSummary _ valueNameSpace addr = Just $ "TODO: title " ++ show (valueNameSpace, addr) + +customCommandShowVariableGraphStructure :: Adaptor ESTG () +customCommandShowVariableGraphStructure = do + ShowVariableGraphStructureArguments {..} <- getArguments + getsApp (Bimap.lookupR showVariableGraphStructureArgumentsVariablesReference . dapVariablesRefMap) >>= \case + Just VariablesRef_StackFrameVariables{} -> do + -- TODO: create graph from the full stack frame + sendSuccesfulEmptyResponse + Just (VariablesRef_Value _valueRoot valueNameSpace addr) -> do + stgState@StgState{..} <- getStgState + case getValueSummary stgState valueNameSpace addr of + Nothing -> sendError (ErrorMessage (T.pack $ "Unknown object: " ++ show (valueNameSpace, addr))) Nothing + Just valueSummary -> do + {- + TODO + - generate facts for transitive closure of reachable objects into file + - send to graph command service + -} + let fname = "/home/csaba/call-graphs/q3mapviewer-call-graphXXX.tsv" + {- + encodeRef :: Int -> RefNamespace -> GCSymbol + -} + liftIO $ do + --exportReachableGraph :: FilePath -> StgState -> GCSymbol -> IO () + exportReachableGraph fname stgState $ encodeRef addr valueNameSpace + liftIO $ sendGraphCommand LoadGraph + { loadGraphRequest = "loadGraph" + , loadGraphTitle = cs $ show addr ++ " " ++ valueSummary + , loadGraphFilepath = cs fname + } + sendSuccesfulEmptyResponse + +{- + { loadGraphRequest :: Text + , loadGraphTitle :: Text + , loadGraphFilepath :: Text + , "filepath" .= Aeson.String "/home/csaba/call-graphs/q3mapviewer-call-graph.tsv" + | Just o <- IntMap.lookup addr ssHeap + -> do + varsRef <- getVariablesRef $ VariablesRef_HeapObject frameIdDesc addr + pure ("HeapPtr", show addr ++ " " ++ getHeapObjectSummary o ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o), varsRef) + stgState <- getStgState + ESTG {..} <- getDebugSession + sendSuccesfulEmptyResponse +-} + +customCommandShowCallGraph :: Adaptor ESTG () +customCommandShowCallGraph = do + --sendAndWait (CmdInternal "gc") + {- + TODO: + - export call graph + - send command to gephi + -} + let fname = "/home/csaba/call-graphs/dap-estgi-call-graph.tsv" + ESTG {..} <- getDebugSession + StgState{..} <- getStgState + liftIO $ do + writeCallGraph fname ssCallGraph + sendGraphCommand LoadGraph + { loadGraphRequest = "loadGraph" + , loadGraphTitle = cs $ takeFileName fullPakPath ++ " call graph" + , loadGraphFilepath = cs fname + } + sendSuccesfulEmptyResponse diff --git a/dap-estgi-server/src/GraphProtocol/Commands.hs b/dap-estgi-server/src/GraphProtocol/Commands.hs new file mode 100644 index 0000000..a3ef830 --- /dev/null +++ b/dap-estgi-server/src/GraphProtocol/Commands.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +module GraphProtocol.Commands where + +import GHC.Generics ( Generic ) + +import Data.Text +import Data.Aeson +import DAP.Utils + + +data LoadGraph + = LoadGraph + { loadGraphRequest :: Text + , loadGraphTitle :: Text + , loadGraphFilepath :: Text + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON LoadGraph where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- + diff --git a/dap-estgi-server/src/GraphProtocol/Server.hs b/dap-estgi-server/src/GraphProtocol/Server.hs new file mode 100644 index 0000000..61c9437 --- /dev/null +++ b/dap-estgi-server/src/GraphProtocol/Server.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module GraphProtocol.Server where + +import Control.Monad +import Network.Simple.TCP ( serve, HostPreference(Host) ) +import Network.Socket ( socketToHandle, withSocketsDo, SockAddr ) +import System.IO ( hClose, hSetNewlineMode, Handle, Newline(CRLF) + , NewlineMode(NewlineMode, outputNL, inputNL) + , IOMode(ReadWriteMode) ) +import Data.Aeson ( Value, (.=), ToJSON ) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as Aeson + +import qualified Data.ByteString.Char8 as BS + +import Data.Text ( Text ) +import qualified Data.Map.Strict as Map +import Data.Map.Strict ( Map ) + +import DAP +import DAP.Utils (encodeBaseProtocolMessage) +import Data.IORef +import System.IO.Unsafe + +import Control.Concurrent.MVar +import Control.Concurrent.Chan.Unagi.Bounded as Unagi + +serverConfig0 = ServerConfig + { host = "0.0.0.0" + , port = 4721 + , serverCapabilities = defaultCapabilities + , debugLogging = True + } + +{- + TODO: + gephi + - estgi panel + - estgi listener +-} +data GraphEvent + = GraphEventShowCode Text + deriving (Show, Eq, Ord) + +data GraphChan + = GraphChan + { graphSyncRequest :: MVar () + , graphSyncResponse :: MVar () + , graphAsyncEventIn :: InChan GraphEvent + , graphAsyncEventOut :: OutChan GraphEvent + } + deriving Eq + +instance Show GraphChan where + show _ = "GraphChan" + +data GraphServerState + = GraphServerState + { gssHandle :: Handle + , gssGraphChanMap :: Map Text GraphChan + } + +emptyGraphServerState :: GraphServerState +emptyGraphServerState = GraphServerState + { gssHandle = error "missing gssHandle" + , gssGraphChanMap = mempty + } + +{-# NOINLINE graphServerStateIORef #-} +graphServerStateIORef :: IORef GraphServerState +graphServerStateIORef = unsafePerformIO $ newIORef emptyGraphServerState + +registerGraphChan :: Text -> GraphChan -> IO () +registerGraphChan sessionId graphChan = do + modifyIORef' graphServerStateIORef $ \s@GraphServerState{..} -> s {gssGraphChanMap = Map.insert sessionId graphChan gssGraphChanMap} + +sendGraphCommand :: ToJSON a => a -> IO () +sendGraphCommand msg = do + GraphServerState{..} <- readIORef graphServerStateIORef + BS.hPut gssHandle $ encodeBaseProtocolMessage msg + +runGraphServer :: IO () +runGraphServer = withSocketsDo $ do + let ServerConfig{..} = serverConfig0 + serverConfig = serverConfig0 + when debugLogging $ putStrLn ("Running GRAPH server on " <> show port <> "...") + serve (Host host) (show port) $ \(socket, address) -> do + when debugLogging $ do +-- withGlobalLock $ do + putStrLn $ "TCP connection established from " ++ show address + handle <- socketToHandle socket ReadWriteMode + hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF } + modifyIORef' graphServerStateIORef $ \s -> s {gssHandle = handle} + --request <- readPayload handle :: IO (Either String Value) + --print request + -- TODO: process request + -- TODO: send response + --adaptorStateMVar <- initAdaptorState handle address appStore serverConfig request +{- + BS.hPut handle $ encodeBaseProtocolMessage $ + Aeson.object + [ "request" .= Aeson.String "loadGraph" + , "title" .= Aeson.String "Haskell Heap" + , "filepath" .= Aeson.String "/home/csaba/call-graphs/q3mapviewer-call-graph.tsv" + ] +-} + serviceClient handle -- `catch` exceptionHandler handle address debugLogging + +serviceClient :: Handle -> IO () +serviceClient handle = do + {- + get session id from message + lookup the communication cannel based on session id + if there is no match then report and error, or use the first session as a fallback + -} + nextRequest <- readPayload handle :: IO (Either String Value) + print nextRequest + -- echo command + case nextRequest of + Left err -> do + putStrLn $ "error: " ++ err + Right (Aeson.Object json) + | Just "showCode" <- Aeson.lookup "event" json + , Just (Aeson.String pp) <- Aeson.lookup "programPoint" json + -> do + GraphServerState{..} <- readIORef graphServerStateIORef + let GraphChan{..} = head $ Map.elems gssGraphChanMap + Unagi.writeChan graphAsyncEventIn $ GraphEventShowCode pp + {- + let echo = encodeBaseProtocolMessage json + BS.putStrLn echo + BS.hPut handle echo + -} + Right json -> do + putStrLn $ "unknown event: " ++ show nextRequest + -- loop: serve the next request + serviceClient handle + +{- + use cases: + debug one program + 1 vscode + 1 gephi + 1 estgi dap session / program + debug multiple programs +-} \ No newline at end of file diff --git a/dap-estgi-server/src/Inspect/Stack.hs b/dap-estgi-server/src/Inspect/Stack.hs new file mode 100644 index 0000000..c027cdd --- /dev/null +++ b/dap-estgi-server/src/Inspect/Stack.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Inspect.Stack where + +import Data.Typeable ( typeOf ) +import Control.Monad +import Data.String.Conversions (cs) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Map.Strict as Map +import qualified Data.Bimap as Bimap +import qualified Data.IntMap.Strict as IntMap + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import Stg.Syntax hiding (sourceName, Scope) +import Stg.IRLocation + +import DAP +import DapBase +import Inspect.Value.Atom +import Inspect.Value.StackContinuation +import SourceCode +import SourceLocation + +{- + TODO: + done - refactor stack inspection to: + getVariablesForStackContinuation :: ValueRoot -> StackContinuation -> Adaptor ESTG [Variable] + done - store stack frames in cache/map: (ThreadId, FrameIndex) -> StackContinuation +-} + +---------------------------------------------------------------------------- + +getVariablesForStackFrame :: DapFrameIdDescriptor -> Adaptor ESTG [Variable] +getVariablesForStackFrame frameIdDesc = do + let valueRoot = ValueRoot_StackFrame frameIdDesc + case frameIdDesc of + FrameId_CurrentThreadTopStackFrame -> do + StgState{..} <- getStgState + forM (Map.toList ssCurrentClosureEnv) $ \(Id (Binder{..}), (_, atom)) -> do + let BinderId u = binderId + displayName = if binderScope == ModulePublic then cs binderName else cs (show u) + getVariableForAtom displayName valueRoot atom + + FrameId_ThreadStackFrame _threadId _stackFrameIndex -> do + stackCont <- getStackFrameFromCache frameIdDesc + getVariablesForStackContinuation valueRoot stackCont + +getScopesForStackContinuation + :: DapFrameIdDescriptor + -> StackContinuation + -- ^ The stack instruction that we're generating Scopes for + -> Adaptor ESTG [Scope] + -- ^ List of Scopes for this StackFrame +getScopesForStackContinuation frameIdDesc stackCont = do + scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc + let scope = defaultScope + { scopeName = "Locals: " <> T.pack (showStackCont stackCont) + , scopePresentationHint = Just ScopePresentationHintLocals + , scopeVariablesReference = scopeVarablesRef + } + scopeWithSourceLoc <- case stackCont of + CaseOf _ closureId _ _ _ _ -> do + (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr (binderToStgId . unId $ closureId)) + pure scope + { scopeSource = source + , scopeLine = Just line + , scopeColumn = Just column + , scopeEndLine = Just endLine + , scopeEndColumn = Just endColumn + } + _ -> pure scope + pure [scopeWithSourceLoc] + +getScopesForTopStackFrame + :: DapFrameIdDescriptor + -> Id + -> Adaptor ESTG [Scope] +getScopesForTopStackFrame frameIdDesc closureId = do + scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc + (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr . binderToStgId $ unId closureId) + pure + [ defaultScope + { scopeName = "Locals" + , scopePresentationHint = Just ScopePresentationHintLocals + , scopeVariablesReference = scopeVarablesRef + , scopeSource = source + , scopeLine = Just line + , scopeColumn = Just column + , scopeEndLine = Just endLine + , scopeEndColumn = Just endColumn + } + ] + +commandThreads :: Adaptor ESTG () +commandThreads = do + allThreads <- IntMap.toList . ssThreads <$> getStgState + sendThreadsResponse + [ Thread + { threadId = threadId + , threadName = T.pack ("thread id: " <> show threadId <> " " <> threadLabel) + } + | (threadId, threadState) <- allThreads + , isThreadLive $ tsStatus threadState + , let threadLabel = mkThreadLabel threadState + ] + +commandStackTrace :: Adaptor ESTG () +commandStackTrace = do + {- + TODO: + done - use the thread id from the arguments + done - generate source location for stack frames where possible + done - add the top frame derived from the current closure and env + done - generate frameIds properly, store thread id and frame index for each frameId + REQUIREMENT: + move all resource handling code to the application side, the library should only be a message framework + -} + StackTraceArguments {..} <- getArguments + StgState{..} <- getStgState + case IntMap.lookup stackTraceArgumentsThreadId ssThreads of + Nothing -> do + sendError (ErrorMessage (T.pack $ "Unknown threadId: " ++ show stackTraceArgumentsThreadId)) Nothing + + Just ThreadState{..} -> do + -- create the top stack frame from the current closure, but only for the current thread + -- other (not currently running) threads do have everything on the thread stack + topFrame <- case ssCurrentClosure of + Just currentClosureId + | ssCurrentThreadId == stackTraceArgumentsThreadId + -> do + (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr . binderToStgId $ unId currentClosureId) + frameId <- getFrameId FrameId_CurrentThreadTopStackFrame + pure [ defaultStackFrame + { stackFrameId = frameId + , stackFrameName = T.pack (show currentClosureId) + , stackFrameSource = source + , stackFrameLine = line + , stackFrameColumn = column + , stackFrameEndLine = Just endLine + , stackFrameEndColumn = Just endColumn + } + ] + _ -> pure [] + + -- create the rest of frames from the Thread's stack frames + stackFrames <- forM (zip [0..] tsStack) $ \(frameIndex, stackCont) -> do + let frameIdDesc = FrameId_ThreadStackFrame stackTraceArgumentsThreadId frameIndex + addStackFrameToCache frameIdDesc stackCont + frameId <- getFrameId frameIdDesc + case stackCont of + CaseOf _ closureId _ scrutResultId _ _ -> do + -- HINT: use the case scrutinee result's unique binder id to lookup source location info + (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_CaseScrutineeExpr . binderToStgId $ unId scrutResultId) + pure $ defaultStackFrame + { stackFrameId = frameId + , stackFrameName = cs $ "CaseOf " ++ show closureId + , stackFrameSource = source + , stackFrameLine = line + , stackFrameColumn = column + , stackFrameEndLine = Just endLine + , stackFrameEndColumn = Just endColumn + } + + _ -> do + pure $ defaultStackFrame + -- HINT: no source location info + { stackFrameId = frameId + , stackFrameName = T.pack (showStackCont stackCont) + , stackFrameLine = 0 + , stackFrameColumn = 0 + } + + sendStackTraceResponse $ StackTraceResponse + { stackFrames = topFrame ++ stackFrames + , totalFrames = Just (length topFrame + length stackFrames) + } + +commandScopes :: Adaptor ESTG () +commandScopes = do + ScopesArguments {..} <- getArguments + StgState{..} <- getStgState + ESTG {..} <- getDebugSession + case Bimap.lookupR scopesArgumentsFrameId dapFrameIdMap of + Nothing -> do + sendError (ErrorMessage (T.pack $ "Unknown frameId: " ++ show scopesArgumentsFrameId)) Nothing + + Just frameIdDescriptor@FrameId_CurrentThreadTopStackFrame + | Just currentClosureId <- ssCurrentClosure + -> do + scopes <- getScopesForTopStackFrame frameIdDescriptor currentClosureId + sendScopesResponse (ScopesResponse scopes) + + Just frameIdDescriptor@(FrameId_ThreadStackFrame _threadId _frameIndex) -> do + stackFrame <- getStackFrameFromCache frameIdDescriptor + scopes <- getScopesForStackContinuation frameIdDescriptor stackFrame + sendScopesResponse (ScopesResponse scopes) + + _ -> sendScopesResponse (ScopesResponse []) diff --git a/dap-estgi-server/src/Inspect/Value.hs b/dap-estgi-server/src/Inspect/Value.hs new file mode 100644 index 0000000..434f53e --- /dev/null +++ b/dap-estgi-server/src/Inspect/Value.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE RecordWildCards #-} +module Inspect.Value where + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import Stg.Interpreter.GC.GCRef + +import DAP +import DapBase + +getVariablesForValue :: ValueRoot -> RefNamespace -> Int -> Adaptor ESTG [Variable] +getVariablesForValue valueRoot valueNS idx = do + StgState{..} <- getStgState + --case valueNS of + pure [] diff --git a/dap-estgi-server/src/Inspect/Value/Atom.hs b/dap-estgi-server/src/Inspect/Value/Atom.hs new file mode 100644 index 0000000..94535ad --- /dev/null +++ b/dap-estgi-server/src/Inspect/Value/Atom.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module Inspect.Value.Atom where + +import Data.List +import Data.String.Conversions (cs) +import Data.IntMap.Strict ( IntMap ) +import qualified Data.IntMap.Strict as IntMap +import Data.Text ( Text ) +import qualified Data.Text.Lazy as LazyText +import qualified Text.Pretty.Simple as PP + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import Stg.Interpreter.GC.GCRef +import Stg.Syntax hiding (sourceName, Scope) + +import DAP +import DapBase + +showLitNumType :: LitNumType -> String +showLitNumType = \case + LitNumInt8 -> "Int8" + LitNumInt16 -> "Int16" + LitNumInt32 -> "Int32" + LitNumInt64 -> "Int64" + LitNumWord -> "Word" + LitNumWord8 -> "Word8" + LitNumWord16 -> "Word16" + LitNumWord32 -> "Word32" + LitNumWord64 -> "Word64" + +showElemRep :: PrimElemRep -> String +showElemRep = \case + Int8ElemRep -> "Int8Rep" + Int16ElemRep -> "Int16Rep" + Int32ElemRep -> "Int32Rep" + Int64ElemRep -> "Int64Rep" + Word8ElemRep -> "Word8Rep" + Word16ElemRep -> "Word16Rep" + Word32ElemRep -> "Word32Rep" + Word64ElemRep -> "Word64Rep" + FloatElemRep -> "FloatRep" + DoubleElemRep -> "DoubleRep" + +showRubbishType :: Type -> String +showRubbishType (SingleValue primRep) = showPrimRep primRep + +showRubbishType (UnboxedTuple primReps) = + concat + [ "(# " + , intercalate "," (showPrimRep <$> primReps) + , " #)" + ] +showRubbishType PolymorphicRep = show PolymorphicRep + +showPrimRep :: PrimRep -> String +showPrimRep (VecRep n primElemRep) = + concat + [ "<" + , intercalate "," (replicate n (showElemRep primElemRep)) + , ">" + ] +showPrimRep rep = show rep + +getAtomTypeAndValueM + :: ValueRoot + -> Atom + -> Adaptor ESTG (String, String, Int) +getAtomTypeAndValueM valueRoot atom = do + ss@StgState{..} <- getStgState + case atom of + HeapPtr addr + | Just o <- IntMap.lookup addr ssHeap + -> do + varsRef <- getVariablesRef $ VariablesRef_Value valueRoot NS_HeapPtr addr + pure ("HeapPtr", show addr ++ " " ++ getHeapObjectSummary o ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o), varsRef) + _ + | (t, v) <- getAtomTypeAndValue ss atom + -> pure (t, v, 0) + +getAtomTypeAndValue + :: StgState + -> Atom + -> (String, String) +getAtomTypeAndValue StgState{..} = \case + HeapPtr addr + | Just o <- IntMap.lookup addr ssHeap + -> ("HeapPtr", show addr ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o)) + Literal (LitChar char) -> ("Char", [char]) + Literal (LitString bytes) -> ("String", cs bytes) + Literal LitNullAddr -> ("Address", "0x00000000") + Literal (LitFloat float) -> ("Float", show float) + Literal (LitDouble double) -> ("Double", show double) + Literal (LitLabel labelName FunctionLabel{}) -> ("Foreign Function", cs labelName) + Literal (LitLabel labelName DataLabel) -> ("Foreign Data", cs labelName) + Literal (LitNumber num value) -> (showLitNumType num, show value) + Literal (LitRubbish rubbishType) -> ("Rubbish", showRubbishType rubbishType) + Void -> ("Void", "()") + PtrAtom _ x -> ("Ptr", show x) + IntAtom x -> ("Int", show x) + WordAtom x -> ("Word", show x) + FloatAtom x -> ("Float", show x) + DoubleAtom x -> ("Double", show x) + MVar x -> ("MVar", show x) + MutVar x -> ("MutVar", show x) + TVar x -> ("TVar", show x) + Array idx -> ("Array", show idx) + MutableArray idx -> ("MutableArray", show idx) + SmallArray idx -> ("SmallArray", show idx) + SmallMutableArray idx -> ("SmallMutableArray", show idx) + ArrayArray idx -> ("ArrayArray", show idx) + MutableArrayArray idx -> ("MutableArrayArray", show idx) + ByteArray idx -> ("ByteArray", show idx) + MutableByteArray idx -> ("MutableByteArray", show idx) + WeakPointer x -> ("WeakPoint", show x) + StableName x -> ("StableName", show x) + ThreadId x -> ("ThreadId", show x) + LiftedUndefined -> ("LiftedUndefined","undefined") + +getHeapObjectSummary :: HeapObject -> String +getHeapObjectSummary = \case + Con{..} -> "Con: " ++ show hoCon + Closure{..} -> if hoCloMissing == 0 + then "Thunk: " ++ show hoName + else "Closure: " ++ show hoName + BlackHole{} -> "BlackHole" + ApStack{} -> "ApStack" + RaiseException{} -> "RaiseException" + +getVariableForAtom :: Text -> ValueRoot -> Atom -> Adaptor ESTG Variable +getVariableForAtom name valueRoot atom = do + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM valueRoot atom + pure defaultVariable + { variableName = name + , variableValue = cs variableValue + , variableType = Just (cs variableType) + , variableVariablesReference = varsRef + } diff --git a/dap-estgi-server/src/Inspect/Value/HeapObject.hs b/dap-estgi-server/src/Inspect/Value/HeapObject.hs new file mode 100644 index 0000000..6558b82 --- /dev/null +++ b/dap-estgi-server/src/Inspect/Value/HeapObject.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module Inspect.Value.HeapObject where + +import Control.Monad + +import qualified Data.Map.Strict as Map +import Data.String.Conversions (cs) + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import Stg.Syntax hiding (sourceName, Scope) +import Stg.IRLocation + +import DAP +import DapBase +import Inspect.Value.Atom +import SourceLocation + +getVariablesForHeapObject :: ValueRoot -> HeapObject -> Adaptor ESTG [Variable] +getVariablesForHeapObject valueRoot = \case + Con{..} -> forM (zip [0..] hoConArgs) $ \(idx, atom) -> do + let name = cs $ "arg" ++ show idx + getVariableForAtom name valueRoot atom + + Closure{..} -> do + srcLocJson <- getStgSourceLocJSONText . SP_Binding . binderToStgId $ unId hoName + let bodyVar = defaultVariable + { variableName = "code" + , variableValue = cs $ show hoName + , variableEvaluateName = srcLocJson + } + {- + TODO: + show env in subnode + show args in subnode + show missing-args-count / is thunk? + -} + argVarList <- forM (zip [0..] hoCloArgs) $ \(idx, atom) -> do + let name = cs $ "arg" ++ show idx + getVariableForAtom name valueRoot atom + + envVarList <- forM (Map.toList hoEnv) $ \(Id (Binder{..}), (_, atom)) -> do + let BinderId u = binderId + displayName = if binderScope == ModulePublic then cs binderName else cs (show u) + getVariableForAtom displayName valueRoot atom + + pure $ bodyVar : argVarList ++ envVarList + + BlackHole{..} -> do + bodyVar <- case hoBHOriginalThunk of + Closure{..} -> do + srcLocJson <- getStgSourceLocJSONText . SP_Binding . binderToStgId $ unId hoName + pure . pure $ defaultVariable + { variableName = "code" + , variableValue = cs $ show hoName + , variableEvaluateName = cs <$> srcLocJson + } + _ -> pure [] + onwerVar <- getVariableForAtom "owner thread id" valueRoot $ ThreadId hoBHOwnerThreadId + queueVarList <- forM hoBHWaitQueue $ \tid -> getVariableForAtom "waiting thread id" valueRoot $ ThreadId tid + pure $ bodyVar ++ onwerVar : queueVarList + + ApStack{..} -> do + resultVarList <- forM hoResult $ \atom -> do + getVariableForAtom "latest result" valueRoot atom + -- TODO: hoStack + pure resultVarList + + RaiseException ex -> do + sequence [getVariableForAtom "exception" valueRoot ex] diff --git a/dap-estgi-server/src/Inspect/Value/StackContinuation.hs b/dap-estgi-server/src/Inspect/Value/StackContinuation.hs new file mode 100644 index 0000000..a868114 --- /dev/null +++ b/dap-estgi-server/src/Inspect/Value/StackContinuation.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module Inspect.Value.StackContinuation where + +import Control.Monad + +import qualified Data.Map.Strict as Map +import Data.String.Conversions (cs) +import Data.Text ( Text ) +import qualified Data.Text as T + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) +import Stg.Syntax hiding (sourceName, Scope) +import Stg.IRLocation + +import DAP +import DapBase +import Inspect.Value.Atom +import SourceLocation + +showScheduleReason :: ScheduleReason -> Text +showScheduleReason = \case + SR_ThreadFinished -> "Thread Finished" + SR_ThreadFinishedFFICallback -> "Thread Finished FFI Callback" + SR_ThreadBlocked -> "Thread Blocked" + SR_ThreadYield -> "Thread Yield" + SR_ThreadFinishedMain -> "Thread Finished Main" + +getVariablesForStackContinuation :: ValueRoot -> StackContinuation -> Adaptor ESTG [Variable] +getVariablesForStackContinuation valueRoot = \case + CaseOf _ _ env _ _ _ -> do + forM (Map.toList env) $ \(Id (Binder{..}), (_, atom)) -> do + -- DMJ: for now everything is local. + -- Inspect StaticOrigin to put things top-level, or as arguments, where applicable + let BinderId u = binderId + displayName = if binderScope == ModulePublic then cs binderName else cs (show u) + getVariableForAtom displayName valueRoot atom + + Update addr -> do + sequence [getVariableForAtom "Thunk Address" valueRoot $ HeapPtr addr] + + Apply atoms -> do + forM atoms $ \atom -> do + getVariableForAtom "Closure argument" valueRoot atom + + Catch atom blockAsync interruptible -> do + sequence + [ getVariableForAtom "Exception Handler" valueRoot atom + , pure defaultVariable + { variableName = "BlockAsyncExceptions" + , variableValue = T.pack (show blockAsync) + , variableType = Just "Bool" + } + , pure defaultVariable + { variableName = "Interruptible" + , variableValue = T.pack (show interruptible) + , variableType = Just "Bool" + } + ] + + RestoreExMask _ blockAsync interruptible -> do + pure + [ defaultVariable + { variableName = "BlockAsyncExceptions" + , variableValue = T.pack (show blockAsync) + , variableType = Just "Bool" + } + , defaultVariable + { variableName = "Interruptible" + , variableValue = T.pack (show interruptible) + , variableType = Just "Bool" + } + ] + + RunScheduler reason -> do + pure + [ defaultVariable + { variableName = "Schedule Reason" + , variableValue = showScheduleReason reason + } + ] + + Atomically atom -> do + sequence [getVariableForAtom "STM action" valueRoot atom] + + CatchRetry primaryAction alternativeAction isRunningAlternative _tlog -> do + sequence + [ getVariableForAtom "First STM action" valueRoot primaryAction + , getVariableForAtom "Second STM action" valueRoot alternativeAction + , pure defaultVariable + { variableName = "Is running alternative STM action" + , variableValue = T.pack (show isRunningAlternative) + , variableType = Just "Bool" + } + -- todo add tlog + ] + + CatchSTM action handler -> do + sequence + [ getVariableForAtom "STM action" valueRoot action + , getVariableForAtom "Exception Handler" valueRoot handler + ] + + DataToTagOp -> do + pure [] + + RaiseOp atom -> do + sequence [getVariableForAtom "Exception" valueRoot atom] + + KeepAlive atom -> do + sequence [getVariableForAtom "Managed Object" valueRoot atom] + + DebugFrame (RestoreProgramPoint maybeId _) -> do + pure + [ defaultVariable + { variableName = "DebugFrame" + , variableValue = cs (show maybeId) + , variableType = Just "RestoreProgramPoint" + } + ] diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index a0d0a01..69ec533 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -55,12 +55,13 @@ import Data.Maybe ( fromMaybe, maybeToList import Data.List ( sortOn ) import GHC.Generics ( Generic ) import System.Environment ( lookupEnv ) -import System.FilePath ( (-<.>), (), takeDirectory, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) +import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) import Text.Read ( readMaybe ) import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict ) import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi import Control.Concurrent.MVar ( MVar ) import qualified Control.Concurrent.MVar as MVar +import Control.Concurrent ( forkIO ) import qualified System.FilePath.Find as Glob ---------------------------------------------------------------------------- import Stg.Syntax hiding (sourceName, Scope) @@ -73,6 +74,8 @@ import Stg.Interpreter.Base hiding (lookupEnv, getCur import qualified Stg.Interpreter.Base as Stg import Stg.Interpreter.Debugger import Stg.Interpreter.Debugger.UI +import Stg.Interpreter.Debugger.TraverseState +import Stg.Interpreter.GC.GCRef import Stg.IO import Stg.Program import Stg.Fullpak @@ -81,7 +84,16 @@ import qualified Text.Pretty.Simple as PP ---------------------------------------------------------------------------- import DAP hiding (send) ---------------------------------------------------------------------------- +import DapBase import CustomCommands +import GraphProtocol.Commands +import GraphProtocol.Server +import SourceCode +import SourceLocation +import Breakpoints +import Inspect.Value +import Inspect.Stack +import Graph ---------------------------------------------------------------------------- -- | DAP entry point -- Extracts configuration information from the environment @@ -90,7 +102,10 @@ import CustomCommands main :: IO () main = do config <- getConfig - runDAPServer config talk + forkIO runGraphServer + finally (runDAPServer config talk) $ do + putStrLn "dap finished, bye!" + ---------------------------------------------------------------------------- -- | Fetch config from environment, fallback to sane defaults getConfig :: IO ServerConfig @@ -118,6 +133,13 @@ getConfig = do <*> pure capabilities <*> pure True + +findProgram :: String -> IO [FilePath] +findProgram globPattern = do + let isPattern = any (`elem` ("[*?" :: String)) + startDir = joinPath . takeWhile (not . isPattern) . splitPath $ takeDirectory globPattern + Glob.find Glob.always (Glob.filePath Glob.~~? globPattern) startDir + ---------------------------------------------------------------------------- -- | VSCode arguments are custom for attach -- > "arguments": { @@ -137,42 +159,6 @@ data AttachArgs -- ^ Path or glob pattern to .ghc_stgapp file } deriving stock (Show, Eq, Generic) deriving anyclass FromJSON ----------------------------------------------------------------------------- --- | External STG Interpreter application internal state -data ESTG - = ESTG - { debuggerChan :: DebuggerChan - , fullPakPath :: String - , breakpointMap :: Map Stg.Breakpoint IntSet - , sourceCodeSet :: Set SourceCodeDescriptor - , unitIdMap :: Bimap UnitId PackageName - , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor - , dapSourceNameMap :: Bimap Text DapSourceRefDescriptor - - -- application specific resource handling - - , dapSourceRefMap :: !(Bimap DapSourceRefDescriptor Int) - -- ^ Used to track source reference IDs - -- - , dapFrameIdMap :: !(Bimap DapFrameIdDescriptor Int) - -- ^ Used to track stack frame IDs - -- - , dapVariablesRefMap :: !(Bimap DapVariablesRefDescriptor Int) - -- ^ Used to track variablesReferences - -- - , dapVariablesRefStore :: !(IntMap [Variable]) - -- ^ Stores the assigned Variables for each VariablesReference - -- - , nextFreshBreakpointId :: !Int - -- ^ monotinic counter for unique BreakpointId assignment - -- - } - -findProgram :: String -> IO [FilePath] -findProgram globPattern = do - let isPattern = any (`elem` ("[*?" :: String)) - startDir = joinPath . takeWhile (not . isPattern) . splitPath $ takeDirectory globPattern - Glob.find Glob.always (Glob.filePath Glob.~~? globPattern) startDir ---------------------------------------------------------------------------- -- | Intialize ESTG interpreter @@ -195,6 +181,15 @@ initESTG AttachArgs {..} = do , dbgAsyncEventIn = dbgAsyncI , dbgAsyncEventOut = dbgAsyncO } + (graphAsyncI, graphAsyncO) <- liftIO (Unagi.newChan 100) + graphRequestMVar <- liftIO MVar.newEmptyMVar + graphResponseMVar <- liftIO MVar.newEmptyMVar + let graphChan = GraphChan + { graphSyncRequest = graphRequestMVar + , graphSyncResponse = graphResponseMVar + , graphAsyncEventIn = graphAsyncI + , graphAsyncEventOut = graphAsyncO + } estg = ESTG { debuggerChan = dbgChan , fullPakPath = fullpakPath @@ -206,13 +201,78 @@ initESTG AttachArgs {..} = do , dapSourceRefMap = Bimap.fromList $ zip (map SourceRef_SourceFileInFullpak sourceCodeList) [1..] , dapFrameIdMap = Bimap.empty , dapVariablesRefMap = Bimap.empty - , dapVariablesRefStore = mempty + , dapStackFrameCache = mempty , nextFreshBreakpointId = 1 } - flip catch handleDebuggerExceptions - $ registerNewDebugSession __sessionId estg - (loadAndRunProgram True True fullpakPath [] dbgChan DbgStepByStep False defaultDebugSettings) - (handleDebugEvents dbgChan) + flip catch handleDebuggerExceptions $ do + registerNewDebugSession __sessionId estg + [ \_withAdaptor -> loadAndRunProgram True True fullpakPath [] dbgChan DbgStepByStep False defaultDebugSettings + , handleDebugEvents dbgChan + , handleGraphEvents graphChan + ] + liftIO $ registerGraphChan __sessionId graphChan + +{- + Q: do we need sync I/O only between graph server and estgi-dap? + + graph server + map: session id -> graph channel + + esgi-dap + registers sessions to graph server +-} + +---------------------------------------------------------------------------- +-- | Graph Event Handler +handleGraphEvents :: GraphChan -> (Adaptor ESTG () -> IO ()) -> IO () +handleGraphEvents GraphChan{..} withAdaptor = forever $ do + graphEvent <- liftIO (Unagi.readChan graphAsyncEventOut) + withAdaptor $ do + let sendEvent ev = sendSuccesfulEvent ev . setBody + case graphEvent of + -- show heap value implementation + GraphEventShowCode gcsymbol -> do + let root@(ns, idx) = decodeRef . GCSymbol $ cs gcsymbol + {- + TODO: + - create variables references + - send variables references to vscode + -} + varsRef <- getVariablesRef $ VariablesRef_Value (ValueRoot_Value root) ns idx + sendEvent (EventTypeCustom "showValues") $ object + [ "variablesReferences" .= (Aeson.Array . pure . Number $ fromIntegral varsRef) + ] + + -- show code implementation + GraphEventShowCode gcsymbol -> do + {- + TODO: + lookup source loc just like in 'code:' like variable source range encoding + Q: how to convert Text to Id/Binder? + done - generalize source location encodin to program points + + TODO: + done - read GCSymbol + done - lookup stgpoint for GCSymbol when possible + done - get source location for stg point + done - send event, with document name, and source location + -} + StgState{..} <- getStgState + let (ns, idx) = decodeRef . GCSymbol $ cs gcsymbol + case ns of + NS_HeapPtr + | Just Closure{..} <- IntMap.lookup idx ssHeap + -> do + srcLocJson <- getStgSourceLocJSON . SP_Binding . binderToStgId $ unId hoName + sendEvent (EventTypeCustom "showCode") srcLocJson + + | Just BlackHole{..} <- IntMap.lookup idx ssHeap + , Closure{..} <- hoBHOriginalThunk + -> do + srcLocJson <- getStgSourceLocJSON . SP_Binding . binderToStgId $ unId hoName + sendEvent (EventTypeCustom "showCode") srcLocJson + + _ -> logInfo $ BL8.pack ("not program point for " <> show gcsymbol) ---------------------------------------------------------------------------- -- | Debug Event Handler @@ -255,20 +315,6 @@ handleDebuggerExceptions e = do sendTerminatedEvent (TerminatedEvent False) sendExitedEvent (ExitedEvent 1) ----------------------------------------------------------------------------- --- | Clears the currently known breakpoint set -clearBreakpoints :: Adaptor ESTG () -clearBreakpoints = do - updateDebugSession $ \estg -> estg {breakpointMap = mempty} - ----------------------------------------------------------------------------- --- | Adds new BreakpointId for a givent StgPoint -addNewBreakpoint :: Stg.Breakpoint -> Adaptor ESTG BreakpointId -addNewBreakpoint breakpoint = do - bkpId <- getFreshBreakpointId - updateDebugSession $ \estg@ESTG{..} -> estg {breakpointMap = M.insertWith mappend breakpoint (IntSet.singleton bkpId) breakpointMap} - pure bkpId - ---------------------------------------------------------------------------- -- | Main function where requests are received and Events + Responses are returned. -- The core logic of communicating between the client <-> adaptor <-> debugger @@ -320,46 +366,11 @@ talk CommandLoadedSources = do mapM (getSourceFromSourceRefDescriptor . SourceRef_SourceFileInFullpak) $ filter shouldInclude $ Set.toList srcSet ---------------------------------------------------------------------------- -talk (CustomCommand "getSourceLinks") = do - GetSourceLinksArguments {..} <- getArguments - ESTG {..} <- getDebugSession - sourceLinks <- case Bimap.lookup getSourceLinksArgumentsPath dapSourceNameMap of - Just srcDesc@(SourceRef_SourceFileInFullpak ExtStg{}) -> do - source <- getSourceFromSourceRefDescriptor srcDesc - let Just sourceRef = sourceSourceReference source - (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef - let hsTickishLocMap = M.unionsWith mappend [M.singleton stgPoint [tickish] | (stgPoint, tickish) <- hsSrcLocs] - -- collect tickish locations - estgLocMap = M.unionsWith mappend - [ M.singleton stgPoint [range] - | (SP_Tickish stgPoint, range) <- locations - ] - liftIO $ do - print hsTickishLocMap - print estgLocMap - pure $ - [ SourceLink - { sourceLinkSourceLine = estgStartLine - , sourceLinkSourceColumn = estgStartCol - , sourceLinkSourceEndLine = estgEndLine - , sourceLinkSourceEndColumn = estgEndCol - , sourceLinkTargetLine = srcSpanSLine - , sourceLinkTargetColumn = srcSpanSCol - , sourceLinkTargetEndLine = srcSpanELine - , sourceLinkTargetEndColumn = srcSpanECol - , sourceLinkTargetPath = cs $ getSourceName hsCodeDesc - } - | (stgPoint, hsTickishList) <- M.toList hsTickishLocMap - , estgLocList <- maybeToList $ M.lookup stgPoint estgLocMap - , (((estgStartLine, estgStartCol),(estgEndLine, estgEndCol)), SourceNote{..}) <- zip estgLocList hsTickishList - , let RealSrcSpan'{..} = sourceSpan - , hsCodeDesc <- maybeToList $ Bimap.lookup srcSpanFile haskellSrcPathMap - ] - _ -> pure [] - sendSuccesfulResponse . setBody $ GetSourceLinksResponse - { getSourceLinksResponseSourceLinks = sourceLinks - } - +talk (CustomCommand "getSourceLinks") = customCommandGetSourceLinks +---------------------------------------------------------------------------- +talk (CustomCommand "showVariableGraphStructure") = customCommandShowVariableGraphStructure +---------------------------------------------------------------------------- +talk (CustomCommand "showCallGraph") = customCommandShowCallGraph ---------------------------------------------------------------------------- talk CommandModules = do sendModulesResponse (ModulesResponse [] Nothing) @@ -368,199 +379,9 @@ talk CommandPause = do sendAndWait CmdStop sendPauseResponse ---------------------------------------------------------------------------- -talk CommandSetBreakpoints = do - SetBreakpointsArguments {..} <- getArguments - maybeSourceRef <- getValidSourceRefFromSource setBreakpointsArgumentsSource - - -- the input SourceRef might be a remain of a previous DAP session, update it with the new valid one - let refUpdatedSource = setBreakpointsArgumentsSource { sourceSourceReference = maybeSourceRef } - - clearBreakpoints - {- - supports placing breakpoint on: - - Haskell - - ExtStg - -} - ESTG {..} <- getDebugSession - case (setBreakpointsArgumentsBreakpoints, maybeSourceRef, maybeSourceRef >>= flip Bimap.lookupR dapSourceRefMap) of - -- HINT: breakpoint on Haskell - (Just sourceBreakpoints, Just sourceRef, Just (SourceRef_SourceFileInFullpak hsCodeDesc@(Haskell pkg mod))) - | Just extStgSourceRef <- Bimap.lookup (SourceRef_SourceFileInFullpak $ ExtStg pkg mod) dapSourceRefMap - , Just hsSourceFilePath <- Bimap.lookupR hsCodeDesc haskellSrcPathMap - -> do - (_sourceCodeText, _locations, hsSrcLocs) <- getSourceFromFullPak extStgSourceRef - breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do - -- filter all relevant ranges - {- - SP_RhsClosureExpr - -} - let onlySupported = \case - SP_RhsClosureExpr{} -> True - _ -> True -- TODO - let relevantLocations = filter (onlySupported . fst . fst) $ case sourceBreakpointColumn of - Nothing -> - [ (p, spanSize) - | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs - , srcSpanFile == hsSourceFilePath - , srcSpanSLine <= sourceBreakpointLine - , srcSpanELine >= sourceBreakpointLine - , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) - ] - Just col -> - [ (p, spanSize) - | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs - , srcSpanFile == hsSourceFilePath - , srcSpanSLine <= sourceBreakpointLine - , srcSpanELine >= sourceBreakpointLine - , srcSpanSCol <= col - , srcSpanECol >= col - , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) - ] - debugMessage . cs . unlines $ "relevant haskell locations:" : map show relevantLocations - -- use the first location found - -- HINT: locations are sorted according the span size, small spans are preferred more - case map fst . take 1 $ sortOn snd relevantLocations of - (stgPoint@(SP_RhsClosureExpr closureName), SourceNote RealSrcSpan'{..} _) : _ -> do - let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int - sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount) - bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint - pure $ defaultBreakpoint - { breakpointVerified = True - , breakpointSource = Just refUpdatedSource - , breakpointLine = Just srcSpanSLine - , breakpointColumn = Just srcSpanSCol - , breakpointEndLine = Just srcSpanELine - , breakpointEndColumn = Just srcSpanECol - , breakpointId = Just bkpId - } - _ -> - pure $ defaultBreakpoint - { breakpointVerified = False - , breakpointSource = Just refUpdatedSource - , breakpointMessage = Just "no hs code found" - } - sendSetBreakpointsResponse breakpoints - - -- HINT: breakpoint on ExtStg - (Just sourceBreakpoints, Just sourceRef, Just (SourceRef_SourceFileInFullpak ExtStg{})) -> do - (_sourceCodeText, locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef - breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do - -- filter all relevant ranges - {- - SP_RhsClosureExpr - -} - let onlySupported = \case - SP_RhsClosureExpr{} -> True - _ -> False - let relevantLocations = filter (onlySupported . fst) $ case sourceBreakpointColumn of - Nothing -> - [ p - | p@(_,((startRow, startCol), (endRow, endCol))) <- locations - , startRow <= sourceBreakpointLine - , endRow >= sourceBreakpointLine - ] - Just col -> - [ p - | p@(_,((startRow, startCol), (endRow, endCol))) <- locations - , startRow <= sourceBreakpointLine - , endRow >= sourceBreakpointLine - , startCol <= col - , endCol >= col - ] - debugMessage . cs $ "relevantLocations: " ++ show relevantLocations - -- use the first location found - case sortOn snd relevantLocations of - (stgPoint@(SP_RhsClosureExpr closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do - let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int - sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount) - bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint - pure $ defaultBreakpoint - { breakpointVerified = True - , breakpointSource = Just refUpdatedSource - , breakpointLine = Just startRow - , breakpointColumn = Just startCol - , breakpointEndLine = Just endRow - , breakpointEndColumn = Just endCol - , breakpointId = Just bkpId - } - _ -> - pure $ defaultBreakpoint - { breakpointVerified = False - , breakpointSource = Just refUpdatedSource - , breakpointMessage = Just "no code found" - } - sendSetBreakpointsResponse breakpoints - v -> do - sendSetBreakpointsResponse [] +talk CommandSetBreakpoints = commandSetBreakpoints ---------------------------------------------------------------------------- -talk CommandStackTrace = do - {- - TODO: - done - use the thread id from the arguments - done - generate source location for stack frames where possible - done - add the top frame derived from the current closure and env - done - generate frameIds properly, store thread id and frame index for each frameId - REQUIREMENT: - move all resource handling code to the application side, the library should only be a message framework - -} - StackTraceArguments {..} <- getArguments - StgState{..} <- getStgState - case IntMap.lookup stackTraceArgumentsThreadId ssThreads of - Nothing -> do - sendError (ErrorMessage (T.pack $ "Unknown threadId: " ++ show stackTraceArgumentsThreadId)) Nothing - - Just ThreadState{..} -> do - -- create the top stack frame from the current closure, but only for the current thread - -- other (not currently running) threads do have everything on the thread stack - topFrame <- case ssCurrentClosure of - Just currentClosureId - | ssCurrentThreadId == stackTraceArgumentsThreadId - -> do - (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint currentClosureId (SP_RhsClosureExpr currentClosureId) - frameId <- getFrameId FrameId_CurrentThreadTopStackFrame - pure [ defaultStackFrame - { stackFrameId = frameId - , stackFrameName = T.pack (show currentClosureId) - , stackFrameSource = source - , stackFrameLine = line - , stackFrameColumn = column - , stackFrameEndLine = Just endLine - , stackFrameEndColumn = Just endColumn - } - ] - _ -> pure [] - - -- create the rest of frames from the Thread's stack frames - stackFrames <- forM (zip [0..] tsStack) $ \(frameIndex, stackCont) -> case stackCont of - CaseOf _ closureId _ scrutResultId _ _ -> do - -- HINT: use the case scrutinee result's unique binder id to lookup source location info - (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint scrutResultId (SP_CaseScrutineeExpr scrutResultId) - frameId <- getFrameId $ FrameId_ThreadStackFrame stackTraceArgumentsThreadId frameIndex - pure $ defaultStackFrame - { stackFrameId = frameId - , stackFrameName = cs $ "CaseOf " ++ show closureId - , stackFrameSource = source - , stackFrameLine = line - , stackFrameColumn = column - , stackFrameEndLine = Just endLine - , stackFrameEndColumn = Just endColumn - } - - _ -> do - frameId <- getFrameId $ FrameId_ThreadStackFrame stackTraceArgumentsThreadId frameIndex - pure $ defaultStackFrame - -- HINT: no source location info - { stackFrameId = frameId - , stackFrameName = T.pack (showStackCont stackCont) - , stackFrameLine = 0 - , stackFrameColumn = 0 - } - - sendStackTraceResponse $ StackTraceResponse - { stackFrames = topFrame ++ stackFrames - , totalFrames = Just (length topFrame + length stackFrames) - } - +talk CommandStackTrace = commandStackTrace ---------------------------------------------------------------------------- talk CommandSource = do SourceArguments {..} <- getArguments -- save path of fullpak in state @@ -576,52 +397,18 @@ talk CommandSource = do (source, _locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef sendSourceResponse (SourceResponse source Nothing) ---------------------------------------------------------------------------- -talk CommandThreads = do - allThreads <- IntMap.toList . ssThreads <$> getStgState - sendThreadsResponse - [ Thread - { threadId = threadId - , threadName = T.pack ("thread id: " <> show threadId <> " " <> threadLabel) - } - | (threadId, threadState) <- allThreads - , isThreadLive $ tsStatus threadState - , let threadLabel = mkThreadLabel threadState - ] +talk CommandThreads = commandThreads ---------------------------------------------------------------------------- -talk CommandScopes = do - ScopesArguments {..} <- getArguments - StgState{..} <- getStgState - ESTG {..} <- getDebugSession - case Bimap.lookupR scopesArgumentsFrameId dapFrameIdMap of - Nothing -> do - sendError (ErrorMessage (T.pack $ "Unknown frameId: " ++ show scopesArgumentsFrameId)) Nothing - - Just frameIdDescriptor@FrameId_CurrentThreadTopStackFrame - | Just currentClosureId <- ssCurrentClosure - -> do - scopes <- generateScopesForTopStackFrame frameIdDescriptor currentClosureId ssCurrentClosureEnv - sendScopesResponse (ScopesResponse scopes) - - Just frameIdDescriptor@(FrameId_ThreadStackFrame threadId frameIndex) -> do - let stackFrame = (tsStack $ ssThreads IntMap.! threadId) !! frameIndex - scopes <- generateScopes frameIdDescriptor stackFrame - sendScopesResponse (ScopesResponse scopes) - - _ -> sendScopesResponse (ScopesResponse []) - +talk CommandScopes = commandScopes ---------------------------------------------------------------------------- talk CommandVariables = do VariablesArguments {..} <- getArguments getsApp (Bimap.lookupR variablesArgumentsVariablesReference . dapVariablesRefMap) >>= \case - Just VariablesRef_StackFrameVariables{} -> do - variables <- getVariables variablesArgumentsVariablesReference + Just (VariablesRef_StackFrameVariables frameIdDesc) -> do + variables <- getVariablesForStackFrame frameIdDesc sendVariablesResponse (VariablesResponse variables) - Just (VariablesRef_HeapObject frameIdDesc addr) -> do - stgState <- getStgState - ho <- case IntMap.lookup addr $ ssHeap stgState of - Nothing -> sendError (ErrorMessage (T.pack $ "Unknown heap object: " ++ show addr)) Nothing - Just v -> pure v - variables <- getVariablesForHeapObject stgState frameIdDesc ho + Just (VariablesRef_Value valueRoot valueNameSpace addr) -> do + variables <- getVariablesForValue valueRoot valueNameSpace addr -- detect and annotate loops let markLoop v | variableVariablesReference v == 0 @@ -661,907 +448,7 @@ talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) ---------------------------------------------------------------------------- -getSourceAndPositionForStgPoint :: Id -> StgPoint -> Adaptor ESTG (Maybe Source, Int, Int, Int, Int) -getSourceAndPositionForStgPoint (Id Binder{..}) stgPoint = do - ESTG {..} <- getDebugSession - packageName <- case Bimap.lookup binderUnitId unitIdMap of - Nothing -> sendError (ErrorMessage (T.pack $ "Unknown unit id: " ++ show binderUnitId)) Nothing - Just v -> pure v - let moduleName = cs $ getModuleName binderModule - source <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak $ ExtStg packageName moduleName - let Just sourceRef = sourceSourceReference source - (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef - let inModule pkg mod (_, SourceNote{..}) - | RealSrcSpan'{..} <- sourceSpan - , Just hsSrcDesc <- Bimap.lookup srcSpanFile haskellSrcPathMap - = hsSrcDesc == Haskell pkg mod - inModule _ _ _ = False - - stgPointLocs = filter ((== stgPoint) . fst) hsSrcLocs - hsModLocs = filter (inModule packageName moduleName) stgPointLocs - forM_ stgPointLocs $ \(_, tickish) -> liftIO $ print tickish - {- - source location priorities: - - haskell module local - - stg - -} - case hsModLocs of - (_, SourceNote{..}) : _ - | RealSrcSpan'{..} <- sourceSpan - , Just hsSrcDesc <- Bimap.lookup srcSpanFile haskellSrcPathMap - -> do - sourceHs <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak hsSrcDesc - pure (Just sourceHs, srcSpanSLine, srcSpanSCol, srcSpanELine, srcSpanECol) - _ -> do - case filter ((== stgPoint) . fst) locations of - (_, ((line, column),(endLine, endColumn))) : _ -> do - pure (Just source, line, column, endLine, endColumn) - _ -> do - pure (Just source, 0, 0, 0, 0) - ----------------------------------------------------------------------------- - ----------------------------------------------------------------------------- --- | Retrieves list of modules from .fullpak file -getSourceCodeListFromFullPak :: FilePath -> IO ([SourceCodeDescriptor], Bimap UnitId PackageName, Bimap Name SourceCodeDescriptor) -getSourceCodeListFromFullPak fullPakPath = do - rawEntries <- fmap unEntrySelector . M.keys <$> withArchive fullPakPath getEntries - let folderNames = Set.fromList (takeDirectory <$> rawEntries) - appInfoName = "app.info" - appInfoBytes <- readModpakL fullPakPath appInfoName id - AppInfo{..} <- decodeThrow (BL8.toStrict appInfoBytes) - let unitIdMap = Bimap.fromList - [ (UnitId $ cs ciUnitId, cs ciPackageName) - | CodeInfo{..} <- aiLiveCode - ] - {- - program source content: - haskell modules - foreign files - -} - let rawEntriesSet = Set.fromList rawEntries - moduleCodeItems pkg mod = - [ Haskell pkg mod - , GhcCore pkg mod - , GhcStg pkg mod - , Cmm pkg mod - , Asm pkg mod - , ExtStg pkg mod - , FFICStub pkg mod - , FFIHStub pkg mod - , ModInfo pkg mod - ] - haskellModuleCode :: [SourceCodeDescriptor] - haskellModuleCode = - [ srcDesc - | CodeInfo{..} <- aiLiveCode - , srcDesc <- moduleCodeItems (cs ciPackageName) (cs ciModuleName) - , Set.member (getSourcePath srcDesc) rawEntriesSet - ] - - cbitsSources :: [SourceCodeDescriptor] - cbitsSources = - [ ForeignC packageName path - | path <- rawEntries - , ("cbits-source" : unitIdString : _) <- [splitDirectories path] - , Just packageName <- [Bimap.lookup (UnitId $ cs unitIdString) unitIdMap] - ] - - hsPathList <- forM aiLiveCode $ \CodeInfo{..} -> do - let extStgPath = getSourcePath $ ExtStg (cs ciPackageName) (cs ciModuleName) - (_phase, _unitId, _modName, mSrcFilePath, _stubs, _hasForeignExport, _deps) <- readModpakL fullPakPath extStgPath decodeStgbinInfo - case mSrcFilePath of - Nothing -> pure [] - Just p -> pure [(cs p, Haskell (cs ciPackageName) (cs ciModuleName))] - let hsPathMap = Bimap.fromList $ concat hsPathList - pure (haskellModuleCode ++ cbitsSources, unitIdMap, hsPathMap) - -getValidSourceRefFromSource :: Source -> Adaptor ESTG (Maybe Int) -getValidSourceRefFromSource Source{..} = do - ESTG {..} <- getDebugSession - {- - fallback chain: - 1. sourcePath - 2. sourceSourceReference - -} - let maybeSrcDesc = do - srcName <- sourcePath - Bimap.lookup srcName dapSourceNameMap - case maybeSrcDesc of - Just srcDesc -> Just <$> getSourceRef srcDesc - Nothing -> case sourceSourceReference of - Just srcRef - | Bimap.memberR srcRef dapSourceRefMap - -> pure sourceSourceReference - _ -> pure Nothing - ----------------------------------------------------------------------------- --- | Retrieves list of modules from .fullpak file -getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)], [(StgPoint, Tickish)]) -getSourceFromFullPak sourceId = do - ESTG {..} <- getDebugSession - SourceRef_SourceFileInFullpak srcDesc <- case Bimap.lookupR sourceId dapSourceRefMap of - Nothing -> do - sendError (ErrorMessage (T.pack $ "Unknown sourceId: " ++ show sourceId)) Nothing - Just value -> pure value - let sourcePath = getSourcePath srcDesc - liftIO $ - case srcDesc of - ExtStg{} -> do - m <- readModpakL fullPakPath sourcePath decodeStgbin - let (stgCode, stgLocs) = pShowWithConfig Config {cfgPrintTickish = True} $ pprModule m - tickishList = collectTickish m - pure (stgCode, stgLocs, tickishList) - _ -> do - ir <- readModpakS fullPakPath sourcePath T.decodeUtf8 - pure (ir, [], []) ----------------------------------------------------------------------------- --- | Synchronous call to Debugger, sends message and waits for response -sendAndWait :: DebugCommand -> Adaptor ESTG DebugOutput -sendAndWait cmd = do - ESTG {..} <- getDebugSession - let DebuggerChan{..} = debuggerChan - liftIO $ do - MVar.putMVar dbgSyncRequest cmd - MVar.takeMVar dbgSyncResponse - -getStgState :: Adaptor ESTG StgState -getStgState = do - sendAndWait (CmdInternal "get-stg-state") >>= \case - DbgOutStgState stgState -> - pure stgState - otherMessage -> do - let errorMsg - = concat - [ "Unexpected Message received from interpreter: " - , show otherMessage - ] - logInfo (BL8.pack errorMsg) - sendError (ErrorMessage (T.pack errorMsg)) Nothing - ----------------------------------------------------------------------------- -mkThreadLabel :: ThreadState -> String -mkThreadLabel = maybe "" (BL8.unpack . BL8.fromStrict) . tsLabel - -generateScopesForTopStackFrame - :: DapFrameIdDescriptor - -> Id - -> Env - -> Adaptor ESTG [Scope] -generateScopesForTopStackFrame frameIdDesc closureId env = do - (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint closureId (SP_RhsClosureExpr closureId) - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - varList <- forM (M.toList env) $ \(Id (Binder{..}), (_, atom)) -> do - let BinderId u = binderId - displayName = if binderScope == ModulePublic then cs binderName else cs (show u) - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - pure defaultVariable - { variableName = displayName - , variableValue = cs variableValue - , variableType = Just (cs variableType) - -- , variableEvaluateName = Just $ displayName <> " evaluate" - , variableVariablesReference = varsRef - } - setVariables scopeVarablesRef varList - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - , scopeSource = source - , scopeLine = Just line - , scopeColumn = Just column - , scopeEndLine = Just endLine - , scopeEndColumn = Just endColumn - } - ] - -getHeapObjectSummary :: HeapObject -> String -getHeapObjectSummary = \case - Con{..} -> "Con: " ++ show hoCon - Closure{..} -> if hoCloMissing == 0 - then "Thunk: " ++ show hoName - else "Closure: " ++ show hoName - BlackHole{} -> "BlackHole" - ApStack{} -> "ApStack" - RaiseException{} -> "RaiseException" - -getStgSourceLocJSON :: Id -> Adaptor ESTG (Maybe Text) -getStgSourceLocJSON i = do - (mSource, startL, startC, endL, endC) <- getSourceAndPositionForStgPoint i (SP_Binding i) - let mkPosObject line column = Aeson.object - [ ("line", Aeson.Number $ fromIntegral line) - , ("column", Aeson.Number $ fromIntegral column) - ] - srcLocJson = do - Source{..} <- mSource - path <- sourcePath - pure . cs . Aeson.encode $ Aeson.object - [ ("path", Aeson.String path) - , ("start", mkPosObject startL startC) - , ("end", mkPosObject endL endC) - ] - pure srcLocJson - -getVariablesForHeapObject :: StgState -> DapFrameIdDescriptor -> HeapObject -> Adaptor ESTG [Variable] -getVariablesForHeapObject stgState frameIdDesc = \case - Con{..} -> forM (zip [0..] hoConArgs) $ \(idx, atom) -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - pure defaultVariable - { variableName = cs $ "arg" ++ show idx - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - Closure{..} -> do - srcLocJson <- getStgSourceLocJSON hoName - let bodyVar = defaultVariable - { variableName = "code" - , variableValue = cs $ show hoName - , variableEvaluateName = srcLocJson - } - {- - TODO: - show env in subnode - show args in subnode - show missing-args-count / is thunk? - -} - argVarList <- forM (zip [0..] hoCloArgs) $ \(idx, atom) -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - pure defaultVariable - { variableName = cs $ "arg" ++ show idx - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - envVarList <- forM (M.toList hoEnv) $ \(Id (Binder{..}), (_, atom)) -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - let BinderId u = binderId - displayName = if binderScope == ModulePublic then cs binderName else cs (show u) - pure defaultVariable - { variableName = displayName - , variableValue = cs variableValue - , variableType = Just (cs variableType) - -- , variableEvaluateName = Just $ displayName <> " evaluate" - , variableVariablesReference = varsRef - } - pure $ bodyVar : argVarList ++ envVarList - BlackHole{..} -> do - (ownerVarType, ownerVarValue, ownerVarsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ ThreadId hoBHOwnerThreadId - bodyVar <- case hoBHOriginalThunk of - Closure{..} -> do - srcLocJson <- getStgSourceLocJSON hoName - pure . pure $ defaultVariable - { variableName = "code" - , variableValue = cs $ show hoName - , variableEvaluateName = cs <$> srcLocJson - } - _ -> pure [] - let onwerVar = defaultVariable - { variableName = "owner thread id" - , variableValue = cs ownerVarValue - , variableType = Just (cs ownerVarType) - , variableVariablesReference = ownerVarsRef - } - - queueVarList <- forM hoBHWaitQueue $ \tid -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ ThreadId tid - pure defaultVariable - { variableName = "waiting thread id" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - pure $ bodyVar ++ onwerVar : queueVarList - ApStack{..} -> do - resultVarList <- forM hoResult $ \atom -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - pure defaultVariable - { variableName = "latest result" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - -- TODO: hoStack - pure resultVarList - RaiseException ex -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc ex - pure $ pure defaultVariable - { variableName = "exception" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - ----------------------------------------------------------------------------- -generateScopes - :: DapFrameIdDescriptor - -> StackContinuation - -- ^ The stack instruction that we're generating Scopes for - -> Adaptor ESTG [Scope] - -- ^ List of Scopes for this StackFrame -generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do - (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint closureId (SP_RhsClosureExpr closureId) - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - varList <- forM (M.toList env) $ \(Id (Binder{..}), (_, atom)) -> do - -- DMJ: for now everything is local. - -- Inspect StaticOrigin to put things top-level, or as arguments, where applicable - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - let BinderId u = binderId - displayName = if binderScope == ModulePublic then cs binderName else cs (show u) - pure defaultVariable - { variableName = displayName - , variableValue = cs variableValue - , variableType = Just (cs variableType) - -- , variableEvaluateName = Just $ displayName <> " evaluate" - , variableVariablesReference = varsRef - } - setVariables scopeVarablesRef varList - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - , scopeSource = source - , scopeLine = Just line - , scopeColumn = Just column - , scopeEndLine = Just endLine - , scopeEndColumn = Just endColumn - } - ] -generateScopes frameIdDesc stackCont@(Update addr) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc $ HeapPtr addr - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "Thunk Address" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - ] - pure - [ defaultScope - { scopeName = "Locals: " <> T.pack (showStackCont stackCont) - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(Apply atoms) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - varList <- forM atoms $ \atom -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - pure defaultVariable - { variableName = "Closure argument" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - setVariables scopeVarablesRef varList - pure - [ defaultScope - { scopeName = "Locals: " <> T.pack (showStackCont stackCont) - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(Catch atom blockAsync interruptible) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "Exception Handler" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - , defaultVariable - { variableName = "BlockAsyncExceptions" - , variableValue = T.pack (show blockAsync) - , variableType = Just $ T.pack $ show (typeOf blockAsync) - } - , defaultVariable - { variableName = "Interruptible" - , variableValue = T.pack (show interruptible) - , variableType = Just $ T.pack $ show (typeOf interruptible) - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(RestoreExMask _ blockAsync interruptible) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "BlockAsyncExceptions" - , variableValue = T.pack (show blockAsync) - , variableType = Just $ T.pack $ show (typeOf blockAsync) - } - , defaultVariable - { variableName = "Interruptible" - , variableValue = T.pack (show interruptible) - , variableType = Just $ T.pack $ show (typeOf interruptible) - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(RunScheduler reason) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "Schedule Reason" - , variableValue = showScheduleReason reason - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] where - showScheduleReason :: ScheduleReason -> Text - showScheduleReason SR_ThreadFinished = "Thread Finished" - showScheduleReason SR_ThreadFinishedFFICallback = "Thread Finished FFI Callback" - showScheduleReason SR_ThreadBlocked = "Thread Blocked" - showScheduleReason SR_ThreadYield = "Thread Yield" - showScheduleReason SR_ThreadFinishedMain = "Thread Finished Main" - -generateScopes frameIdDesc stackCont@(Atomically atom) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "STM action" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction isRunningAlternative _tlog) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState frameIdDesc primaryAction - (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState frameIdDesc alternativeAction - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "First STM action" - , variableValue = cs variableValue1 - , variableType = Just (cs variableType1) - , variableVariablesReference = varsRef1 - } - , defaultVariable - { variableName = "Second STM action" - , variableValue = cs variableValue2 - , variableType = Just (cs variableType2) - , variableVariablesReference = varsRef2 - } - , defaultVariable - { variableName = "Is running alternative STM action" - , variableValue = T.pack (show isRunningAlternative) - , variableType = Just "Bool" - } - -- todo add tlog - ] - pure - [ defaultScope - { scopeName = "Locals: " <> T.pack (showStackCont stackCont) - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc (CatchSTM action handler) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - (variableType1, variableValue1, varsRef1) <- getAtomTypeAndValueM stgState frameIdDesc action - (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState frameIdDesc handler - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "STM action" - , variableValue = cs variableValue1 - , variableType = Just (cs variableValue1) - , variableVariablesReference = varsRef1 - } - , defaultVariable - { variableName = "Exception Handler" - , variableValue = cs variableValue2 - , variableType = Just (cs variableType2) - , variableVariablesReference = varsRef2 - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@DataToTagOp = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(RaiseOp atom) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "RaiseOp" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(KeepAlive atom) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - stgState <- getStgState - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState frameIdDesc atom - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "Managed Object" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] -generateScopes frameIdDesc stackCont@(DebugFrame (RestoreProgramPoint maybeId _)) = do - scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - setVariables scopeVarablesRef - [ defaultVariable - { variableName = "DebugFrame" - , variableValue = cs (show maybeId) - , variableType = Just "RestoreProgramPoint" - } - ] - pure - [ defaultScope - { scopeName = "Locals" - , scopePresentationHint = Just ScopePresentationHintLocals - , scopeVariablesReference = scopeVarablesRef - } - ] - -showLitNumType :: LitNumType -> String -showLitNumType LitNumInt8 = "Int8" -showLitNumType LitNumInt16 = "Int16" -showLitNumType LitNumInt32 = "Int32" -showLitNumType LitNumInt64 = "Int64" -showLitNumType LitNumWord = "Word" -showLitNumType LitNumWord8 = "Word8" -showLitNumType LitNumWord16 = "Word16" -showLitNumType LitNumWord32 = "Word32" -showLitNumType LitNumWord64 = "Word64" - -showElemRep :: PrimElemRep -> String -showElemRep Int8ElemRep = "Int8Rep" -showElemRep Int16ElemRep = "Int16Rep" -showElemRep Int32ElemRep = "Int32Rep" -showElemRep Int64ElemRep = "Int64Rep" -showElemRep Word8ElemRep = "Word8Rep" -showElemRep Word16ElemRep = "Word16Rep" -showElemRep Word32ElemRep = "Word32Rep" -showElemRep Word64ElemRep = "Word64Rep" -showElemRep FloatElemRep = "FloatRep" -showElemRep DoubleElemRep = "DoubleRep" - -showRubbishType :: Type -> String -showRubbishType (SingleValue primRep) = showPrimRep primRep - -showRubbishType (UnboxedTuple primReps) = - concat - [ "(# " - , intercalate "," (showPrimRep <$> primReps) - , " #)" - ] -showRubbishType PolymorphicRep = show PolymorphicRep - -showPrimRep :: PrimRep -> String -showPrimRep (VecRep n primElemRep) = - concat - [ "<" - , intercalate "," (replicate n (showElemRep primElemRep)) - , ">" - ] -showPrimRep rep = show rep - -getAtomTypeAndValueM - :: StgState - -> DapFrameIdDescriptor - -> Atom - -> Adaptor ESTG (String, String, Int) -getAtomTypeAndValueM ss@StgState{..} frameIdDesc = \case - HeapPtr addr - | Just o <- IntMap.lookup addr ssHeap - -> do - varsRef <- getVariablesRef $ VariablesRef_HeapObject frameIdDesc addr - pure ("HeapPtr", show addr ++ " " ++ getHeapObjectSummary o ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o), varsRef) - atom - | (t, v) <- getAtomTypeAndValue ss atom - -> pure (t, v, 0) - -getAtomTypeAndValue - :: StgState - -> Atom - -> (String, String) -getAtomTypeAndValue StgState{..} = \case - HeapPtr addr - | Just o <- IntMap.lookup addr ssHeap - -> ("HeapPtr", show addr ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o)) - Literal (LitChar char) -> ("Char", [char]) - Literal (LitString bytes) -> ("String", cs bytes) - Literal LitNullAddr -> ("Address", "0x00000000") - Literal (LitFloat float) -> ("Float", show float) - Literal (LitDouble double) -> ("Double", show double) - Literal (LitLabel labelName FunctionLabel{}) -> ("Foreign Function", cs labelName) - Literal (LitLabel labelName DataLabel) -> ("Foreign Data", cs labelName) - Literal (LitNumber num value) -> (showLitNumType num, show value) - Literal (LitRubbish rubbishType) -> ("Rubbish", showRubbishType rubbishType) - Void -> ("Void", "()") - PtrAtom _ x -> ("Ptr", show x) - IntAtom x -> ("Int", show x) - WordAtom x -> ("Word", show x) - FloatAtom x -> ("Float", show x) - DoubleAtom x -> ("Double", show x) - MVar x -> ("MVar", show x) - MutVar x -> ("MutVar", show x) - TVar x -> ("TVar", show x) - Array idx -> ("Array", show idx) - MutableArray idx -> ("MutableArray", show idx) - SmallArray idx -> ("SmallArray", show idx) - SmallMutableArray idx -> ("SmallMutableArray", show idx) - ArrayArray idx -> ("ArrayArray", show idx) - MutableArrayArray idx -> ("MutableArrayArray", show idx) - ByteArray idx -> ("ByteArray", show idx) - MutableByteArray idx -> ("MutableByteArray", show idx) - WeakPointer x -> ("WeakPoint", show x) - StableName x -> ("StableName", show x) - ThreadId x -> ("ThreadId", show x) - LiftedUndefined -> ("LiftedUndefined","undefined") - -- + on watch causes "CommandEvaluate" -- right click - set value - [127.0.0.1:49599][INFO][GOT cmd CommandSetVariable] -- right click - copy value - [127.0.0.1:49599][INFO][GOT cmd CommandEvaluate] -- save breakpoints from breakpoints request into AdaptrClient set, set them on the interpreter after configuration done (not attach) - --- resource handling - -getsApp f = f <$> getDebugSession -modifyApp = updateDebugSession - - -------------------------------------- -{- - IDEA: - pure design - use pure and unique resource descriptors to select items from StgState - maintain a bimap between the pure resource descriptors and DAP integer ids - - IMPORTANT: avoid use of counters - BENEFIT: - DAP request order independence - no resource caching is needed - stateless - use of descriptive resource identification instead of integers - - IDEA: - ResourceID ADT - structured key - idMap :: ResourceID -> Int - - DAP request argument -> estg domian idientifiers - request argument's id -> estg domain - - resource ids - threadRef = thread id - frameRef = thread id + frame index - scopeRef = thread id + frame index + argument index - variablesRef = ?? - sourceRef - - HINT: VariablesRef -> [Variable] - - DAP id types: - thread - stack frame - variable - - - Threads args: NONE - StackTrace args: threadId - Scopes args: frameId - Variables args: variablesRef - ... - Variables --} - -type StackFrameIndex = Int - -data DapFrameIdDescriptor - = FrameId_CurrentThreadTopStackFrame - | FrameId_ThreadStackFrame ThreadId StackFrameIndex - deriving (Show, Eq, Ord) - -data DapVariablesRefDescriptor - = VariablesRef_StackFrameVariables DapFrameIdDescriptor - | VariablesRef_HeapObject DapFrameIdDescriptor Int - deriving (Show, Eq, Ord) - -data SourceCodeDescriptor - = Haskell PackageName QualifiedModuleName - | GhcCore PackageName QualifiedModuleName - | GhcStg PackageName QualifiedModuleName - | Cmm PackageName QualifiedModuleName - | Asm PackageName QualifiedModuleName - | ExtStg PackageName QualifiedModuleName - | FFICStub PackageName QualifiedModuleName - | FFIHStub PackageName QualifiedModuleName - | ModInfo PackageName QualifiedModuleName - | ForeignC PackageName FilePath - deriving (Show, Read, Eq, Ord) - -data DapSourceRefDescriptor - = SourceRef_SourceFileInFullpak SourceCodeDescriptor - deriving (Show, Read, Eq, Ord) - -getSourcePath :: SourceCodeDescriptor -> FilePath -getSourcePath = \case - Haskell pkg mod -> "haskell" cs pkg cs mod "module.hs" - GhcCore pkg mod -> "haskell" cs pkg cs mod "module.ghccore" - GhcStg pkg mod -> "haskell" cs pkg cs mod "module.ghcstg" - Cmm pkg mod -> "haskell" cs pkg cs mod "module.cmm" - Asm pkg mod -> "haskell" cs pkg cs mod "module.s" - ExtStg pkg mod -> "haskell" cs pkg cs mod "module.stgbin" - FFICStub pkg mod -> "haskell" cs pkg cs mod "module_stub.c" - FFIHStub pkg mod -> "haskell" cs pkg cs mod "module_stub.h" - ModInfo pkg mod -> "haskell" cs pkg cs mod "module.info" - ForeignC _pkg path -> cs path - -getSourceName :: SourceCodeDescriptor -> String -getSourceName = \case - Haskell pkg mod -> "haskell" cs pkg cs mod <> ".hs" - GhcCore pkg mod -> "haskell" cs pkg cs mod <> ".ghccore" - GhcStg pkg mod -> "haskell" cs pkg cs mod <> ".ghcstg" - Cmm pkg mod -> "haskell" cs pkg cs mod <> ".cmm" - Asm pkg mod -> "haskell" cs pkg cs mod <> ".s" - ExtStg pkg mod -> "haskell" cs pkg cs mod <> ".stgbin.hs" - FFICStub pkg mod -> "haskell" cs pkg cs mod <> "_stub.c" - FFIHStub pkg mod -> "haskell" cs pkg cs mod <> "_stub.h" - ModInfo pkg mod -> "haskell" cs pkg cs mod <> ".info" - ForeignC _pkg path -> cs path - -getSourceFromSourceRefDescriptor :: DapSourceRefDescriptor -> Adaptor ESTG Source -getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak srcDesc) = do - srcDescSet <- getsApp sourceCodeSet - extraSources <- case srcDesc of - Haskell packageName qualModName - | cStub <- FFICStub packageName qualModName - , hStub <- FFIHStub packageName qualModName - -> Just <$> sequence ( - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ ExtStg packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcCore packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcStg packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Cmm packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Asm packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ ModInfo packageName qualModName) - ] ++ - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak cStub) - | Set.member cStub srcDescSet - ] ++ - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak hStub) - | Set.member hStub srcDescSet - ]) - - _ -> pure Nothing - - let sourceName = cs $ getSourceName srcDesc - sourceRef <- getSourceRef sourceRefDesc - ESTG {..} <- getDebugSession - pure defaultSource - { sourceName = Just $ sourceName -- used in source tree children - , sourceSourceReference = Just sourceRef - , sourcePath = Just $ sourceName -- used in code tab title - , sourceSources = extraSources - } - -getFrameId :: DapFrameIdDescriptor -> Adaptor ESTG Int -getFrameId key = do - getsApp (Bimap.lookup key . dapFrameIdMap) >>= \case - Just frameId -> pure frameId - Nothing -> do - frameId <- getsApp (succ . Bimap.size . dapFrameIdMap) - modifyApp $ \s -> s {dapFrameIdMap = Bimap.insert key frameId (dapFrameIdMap s)} - pure frameId - -getVariablesRef :: DapVariablesRefDescriptor -> Adaptor ESTG Int -getVariablesRef key = do - getsApp (Bimap.lookup key . dapVariablesRefMap) >>= \case - Just varRef -> pure varRef - Nothing -> do - varRef <- getsApp (succ . Bimap.size . dapVariablesRefMap) - modifyApp $ \s -> s {dapVariablesRefMap = Bimap.insert key varRef (dapVariablesRefMap s)} - pure varRef - -getSourceRef :: DapSourceRefDescriptor -> Adaptor ESTG Int -getSourceRef key = do - -- NOTE: Source code related db is populated at initialization - getsApp (Bimap.lookup key . dapSourceRefMap) >>= \case - Just srcRef -> pure srcRef - Nothing -> error $ "unknown source descriptor: " ++ show key - -setVariables :: Int -> [Variable] -> Adaptor ESTG () -setVariables variablesRef variableList = do - modifyApp $ \s -> s {dapVariablesRefStore = IntMap.insert variablesRef variableList (dapVariablesRefStore s)} - -getVariables :: Int -> Adaptor ESTG [Variable] -getVariables variablesRef = do - ESTG {..} <- getDebugSession - case IntMap.lookup variablesRef dapVariablesRefStore of - Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variablesRef: " ++ show variablesRef)) Nothing - Just varList -> pure varList - ----------------------------------------------------------------------------- --- | Note: this `Int` should act as if it were an unsigned 31-bit integer (0, 2^31). - -getAllVars :: Adaptor ESTG [Variable] -getAllVars = getsApp (concat . IntMap.elems . dapVariablesRefStore) - --- | Invoked when a StepEvent has occurred -resetObjectLifetimes :: Adaptor ESTG () -resetObjectLifetimes = do - modifyApp $ \s -> s - { dapFrameIdMap = Bimap.empty - , dapVariablesRefMap = Bimap.empty - , dapVariablesRefStore = mempty - } - -getFreshBreakpointId :: Adaptor ESTG BreakpointId -getFreshBreakpointId = do - bkpId <- getsApp nextFreshBreakpointId - modifyApp $ \s -> s { nextFreshBreakpointId = nextFreshBreakpointId s + 1 } - pure bkpId - -type PackageName = Text -type QualifiedModuleName = Text -type BreakpointId = Int -type SourceId = Int -type ThreadId = Int diff --git a/dap-estgi-server/src/SourceCode.hs b/dap-estgi-server/src/SourceCode.hs new file mode 100644 index 0000000..0151c84 --- /dev/null +++ b/dap-estgi-server/src/SourceCode.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module SourceCode where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad +import Data.String.Conversions (cs) +import qualified Data.Set as Set +import Data.Bimap ( Bimap ) +import qualified Data.Bimap as Bimap +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Map.Strict as Map +import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict ) +import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) +import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries) +import Data.Yaml hiding (Array) + +import Stg.Syntax hiding (sourceName, Scope) +import Stg.IRLocation +import Stg.Pretty +import Stg.Program +import Stg.IO +import Stg.Tickish ( collectTickish ) + +import DAP +import DapBase + + +---------------------------------------------------------------------------- + +getSourcePath :: SourceCodeDescriptor -> FilePath +getSourcePath = \case + Haskell pkg mod -> "haskell" cs pkg cs mod "module.hs" + GhcCore pkg mod -> "haskell" cs pkg cs mod "module.ghccore" + GhcStg pkg mod -> "haskell" cs pkg cs mod "module.ghcstg" + Cmm pkg mod -> "haskell" cs pkg cs mod "module.cmm" + Asm pkg mod -> "haskell" cs pkg cs mod "module.s" + ExtStg pkg mod -> "haskell" cs pkg cs mod "module.stgbin" + FFICStub pkg mod -> "haskell" cs pkg cs mod "module_stub.c" + FFIHStub pkg mod -> "haskell" cs pkg cs mod "module_stub.h" + ModInfo pkg mod -> "haskell" cs pkg cs mod "module.info" + ForeignC _pkg path -> cs path + +getSourceName :: SourceCodeDescriptor -> String +getSourceName = \case + Haskell pkg mod -> "haskell" cs pkg cs mod <> ".hs" + GhcCore pkg mod -> "haskell" cs pkg cs mod <> ".ghccore" + GhcStg pkg mod -> "haskell" cs pkg cs mod <> ".ghcstg" + Cmm pkg mod -> "haskell" cs pkg cs mod <> ".cmm" + Asm pkg mod -> "haskell" cs pkg cs mod <> ".s" + ExtStg pkg mod -> "haskell" cs pkg cs mod <> ".stgbin.hs" + FFICStub pkg mod -> "haskell" cs pkg cs mod <> "_stub.c" + FFIHStub pkg mod -> "haskell" cs pkg cs mod <> "_stub.h" + ModInfo pkg mod -> "haskell" cs pkg cs mod <> ".info" + ForeignC _pkg path -> cs path + +---------------------------------------------------------------------------- +-- | Retrieves list of modules from .fullpak file +getSourceCodeListFromFullPak :: FilePath -> IO ([SourceCodeDescriptor], Bimap UnitId PackageName, Bimap Name SourceCodeDescriptor) +getSourceCodeListFromFullPak fullPakPath = do + rawEntries <- fmap unEntrySelector . Map.keys <$> withArchive fullPakPath getEntries + let folderNames = Set.fromList (takeDirectory <$> rawEntries) + appInfoName = "app.info" + appInfoBytes <- readModpakL fullPakPath appInfoName id + AppInfo{..} <- decodeThrow (BL8.toStrict appInfoBytes) + let unitIdMap = Bimap.fromList + [ (UnitId $ cs ciUnitId, cs ciPackageName) + | CodeInfo{..} <- aiLiveCode + ] + {- + program source content: + haskell modules + foreign files + -} + let rawEntriesSet = Set.fromList rawEntries + moduleCodeItems pkg mod = + [ Haskell pkg mod + , GhcCore pkg mod + , GhcStg pkg mod + , Cmm pkg mod + , Asm pkg mod + , ExtStg pkg mod + , FFICStub pkg mod + , FFIHStub pkg mod + , ModInfo pkg mod + ] + haskellModuleCode :: [SourceCodeDescriptor] + haskellModuleCode = + [ srcDesc + | CodeInfo{..} <- aiLiveCode + , srcDesc <- moduleCodeItems (cs ciPackageName) (cs ciModuleName) + , Set.member (getSourcePath srcDesc) rawEntriesSet + ] + + cbitsSources :: [SourceCodeDescriptor] + cbitsSources = + [ ForeignC packageName path + | path <- rawEntries + , ("cbits-source" : unitIdString : _) <- [splitDirectories path] + , Just packageName <- [Bimap.lookup (UnitId $ cs unitIdString) unitIdMap] + ] + + hsPathList <- forM aiLiveCode $ \CodeInfo{..} -> do + let extStgPath = getSourcePath $ ExtStg (cs ciPackageName) (cs ciModuleName) + (_phase, _unitId, _modName, mSrcFilePath, _stubs, _hasForeignExport, _deps) <- readModpakL fullPakPath extStgPath decodeStgbinInfo + case mSrcFilePath of + Nothing -> pure [] + Just p -> pure [(cs p, Haskell (cs ciPackageName) (cs ciModuleName))] + let hsPathMap = Bimap.fromList $ concat hsPathList + pure (haskellModuleCode ++ cbitsSources, unitIdMap, hsPathMap) + +getValidSourceRefFromSource :: Source -> Adaptor ESTG (Maybe Int) +getValidSourceRefFromSource Source{..} = do + ESTG {..} <- getDebugSession + {- + fallback chain: + 1. sourcePath + 2. sourceSourceReference + -} + let maybeSrcDesc = do + srcName <- sourcePath + Bimap.lookup srcName dapSourceNameMap + case maybeSrcDesc of + Just srcDesc -> Just <$> getSourceRef srcDesc + Nothing -> case sourceSourceReference of + Just srcRef + | Bimap.memberR srcRef dapSourceRefMap + -> pure sourceSourceReference + _ -> pure Nothing + +---------------------------------------------------------------------------- +-- | Retrieves list of modules from .fullpak file +getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)], [(StgPoint, Tickish)]) +getSourceFromFullPak sourceId = do + ESTG {..} <- getDebugSession + SourceRef_SourceFileInFullpak srcDesc <- case Bimap.lookupR sourceId dapSourceRefMap of + Nothing -> do + sendError (ErrorMessage (T.pack $ "Unknown sourceId: " ++ show sourceId)) Nothing + Just value -> pure value + let sourcePath = getSourcePath srcDesc + liftIO $ + case srcDesc of + ExtStg{} -> do + m <- readModpakL fullPakPath sourcePath decodeStgbin + let (stgCode, stgLocs) = pShowWithConfig Config {cfgPrintTickish = True} $ pprModule m + tickishList = collectTickish m + pure (stgCode, stgLocs, tickishList) + _ -> do + ir <- readModpakS fullPakPath sourcePath T.decodeUtf8 + pure (ir, [], []) + +getSourceFromSourceRefDescriptor :: DapSourceRefDescriptor -> Adaptor ESTG Source +getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak srcDesc) = do + srcDescSet <- getsApp sourceCodeSet + extraSources <- case srcDesc of + Haskell packageName qualModName + | cStub <- FFICStub packageName qualModName + , hStub <- FFIHStub packageName qualModName + -> Just <$> sequence ( + [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ ExtStg packageName qualModName) + , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcCore packageName qualModName) + , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcStg packageName qualModName) + , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Cmm packageName qualModName) + , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Asm packageName qualModName) + , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ ModInfo packageName qualModName) + ] ++ + [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak cStub) + | Set.member cStub srcDescSet + ] ++ + [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak hStub) + | Set.member hStub srcDescSet + ]) + + _ -> pure Nothing + + let sourceName = cs $ getSourceName srcDesc + sourceRef <- getSourceRef sourceRefDesc + ESTG {..} <- getDebugSession + pure defaultSource + { sourceName = Just $ sourceName -- used in source tree children + , sourceSourceReference = Just sourceRef + , sourcePath = Just $ sourceName -- used in code tab title + , sourceSources = extraSources + } + +getSourceRef :: DapSourceRefDescriptor -> Adaptor ESTG Int +getSourceRef key = do + -- NOTE: Source code related db is populated at initialization + getsApp (Bimap.lookup key . dapSourceRefMap) >>= \case + Just srcRef -> pure srcRef + Nothing -> error $ "unknown source descriptor: " ++ show key diff --git a/dap-estgi-server/src/SourceLocation.hs b/dap-estgi-server/src/SourceLocation.hs new file mode 100644 index 0000000..73fbc1a --- /dev/null +++ b/dap-estgi-server/src/SourceLocation.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module SourceLocation where + +import Data.Maybe ( fromMaybe, maybeToList ) +import Control.Monad.IO.Class (liftIO) +import Control.Monad +import Data.String.Conversions (cs) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Aeson as Aeson +import qualified Data.Bimap as Bimap +import qualified Data.Map.Strict as Map + +import Stg.Syntax hiding (sourceName, Scope) +import Stg.IRLocation + +import DAP +import DapBase +import SourceCode +import CustomCommands + +getUnitIdAndModuleNameForStgPoint :: StgPoint -> (UnitId, ModuleName) +getUnitIdAndModuleNameForStgPoint = \case + SP_CaseScrutineeExpr StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) + SP_LetExpr stgPoint -> getUnitIdAndModuleNameForStgPoint stgPoint + SP_LetNoEscapeExpr stgPoint -> getUnitIdAndModuleNameForStgPoint stgPoint + SP_RhsClosureExpr StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) + SP_AltExpr StgId{..} _idx -> (UnitId siUnitId, ModuleName siModuleName) + SP_RhsCon StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) + SP_Binding StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) + SP_Tickish stgPoint -> getUnitIdAndModuleNameForStgPoint stgPoint + +getSourceAndPositionForStgPoint :: StgPoint -> Adaptor ESTG (Maybe Source, Int, Int, Int, Int) +getSourceAndPositionForStgPoint stgPoint = do + {- + TODO: + - remove id / binder, and use explicit package and module specification + - remove id for StgPoint + - support String -> StgPoint conversion + -} + let (unitId, moduleNameBS) = getUnitIdAndModuleNameForStgPoint stgPoint + ESTG {..} <- getDebugSession + packageName <- case Bimap.lookup unitId unitIdMap of + Nothing -> sendError (ErrorMessage (T.pack $ "Unknown unit id: " ++ show unitId)) Nothing + Just v -> pure v + let moduleName = cs $ getModuleName moduleNameBS + source <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak $ ExtStg packageName moduleName + let Just sourceRef = sourceSourceReference source + (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef + let inModule pkg mod (_, SourceNote{..}) + | RealSrcSpan'{..} <- sourceSpan + , Just hsSrcDesc <- Bimap.lookup srcSpanFile haskellSrcPathMap + = hsSrcDesc == Haskell pkg mod + inModule _ _ _ = False + + stgPointLocs = filter ((== stgPoint) . fst) hsSrcLocs + hsModLocs = filter (inModule packageName moduleName) stgPointLocs + forM_ stgPointLocs $ \(_, tickish) -> liftIO $ print tickish + {- + source location priorities: + - haskell module local + - stg + -} + case hsModLocs of + (_, SourceNote{..}) : _ + | RealSrcSpan'{..} <- sourceSpan + , Just hsSrcDesc <- Bimap.lookup srcSpanFile haskellSrcPathMap + -> do + sourceHs <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak hsSrcDesc + pure (Just sourceHs, srcSpanSLine, srcSpanSCol, srcSpanELine, srcSpanECol) + _ -> do + case filter ((== stgPoint) . fst) locations of + (_, ((line, column),(endLine, endColumn))) : _ -> do + pure (Just source, line, column, endLine, endColumn) + _ -> do + pure (Just source, 0, 0, 0, 0) + +getStgSourceLocJSONText :: StgPoint -> Adaptor ESTG (Maybe Text) +getStgSourceLocJSONText stgPoint = fmap (cs . Aeson.encode) <$> getStgSourceLocJSON stgPoint + +getStgSourceLocJSON :: StgPoint -> Adaptor ESTG (Maybe Aeson.Value) +getStgSourceLocJSON stgPoint = do + (mSource, startL, startC, endL, endC) <- getSourceAndPositionForStgPoint stgPoint + let mkPosObject line column = Aeson.object + [ ("line", Aeson.Number $ fromIntegral line) + , ("column", Aeson.Number $ fromIntegral column) + ] + srcLocJson = do + Source{..} <- mSource + path <- sourcePath + pure $ Aeson.object + [ ("path", Aeson.String path) + , ("start", mkPosObject startL startC) + , ("end", mkPosObject endL endC) + ] + pure srcLocJson + +customCommandGetSourceLinks :: Adaptor ESTG () +customCommandGetSourceLinks = do + GetSourceLinksArguments {..} <- getArguments + ESTG {..} <- getDebugSession + sourceLinks <- case Bimap.lookup getSourceLinksArgumentsPath dapSourceNameMap of + Just srcDesc@(SourceRef_SourceFileInFullpak ExtStg{}) -> do + source <- getSourceFromSourceRefDescriptor srcDesc + let Just sourceRef = sourceSourceReference source + (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef + let hsTickishLocMap = Map.unionsWith mappend [Map.singleton stgPoint [tickish] | (stgPoint, tickish) <- hsSrcLocs] + -- collect tickish locations + estgLocMap = Map.unionsWith mappend + [ Map.singleton stgPoint [range] + | (SP_Tickish stgPoint, range) <- locations + ] + liftIO $ do + print hsTickishLocMap + print estgLocMap + pure $ + [ SourceLink + { sourceLinkSourceLine = estgStartLine + , sourceLinkSourceColumn = estgStartCol + , sourceLinkSourceEndLine = estgEndLine + , sourceLinkSourceEndColumn = estgEndCol + , sourceLinkTargetLine = srcSpanSLine + , sourceLinkTargetColumn = srcSpanSCol + , sourceLinkTargetEndLine = srcSpanELine + , sourceLinkTargetEndColumn = srcSpanECol + , sourceLinkTargetPath = cs $ getSourceName hsCodeDesc + } + | (stgPoint, hsTickishList) <- Map.toList hsTickishLocMap + , estgLocList <- maybeToList $ Map.lookup stgPoint estgLocMap + , (((estgStartLine, estgStartCol),(estgEndLine, estgEndCol)), SourceNote{..}) <- zip estgLocList hsTickishList + , let RealSrcSpan'{..} = sourceSpan + , hsCodeDesc <- maybeToList $ Bimap.lookup srcSpanFile haskellSrcPathMap + ] + _ -> pure [] + sendSuccesfulResponse . setBody $ GetSourceLinksResponse + { getSourceLinksResponseSourceLinks = sourceLinks + } From d246de10012a7ceea8f2b3f46fbc20fb42495c20 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Sun, 15 Oct 2023 21:57:50 +0200 Subject: [PATCH 03/21] remove unnecessary resource handling abstraction: DapSourceRefDescriptor --- dap-estgi-server/src/Breakpoints.hs | 6 +++--- dap-estgi-server/src/DapBase.hs | 8 ++------ dap-estgi-server/src/Main.hs | 6 +++--- dap-estgi-server/src/SourceCode.hs | 26 +++++++++++++------------- dap-estgi-server/src/SourceLocation.hs | 8 ++++---- 5 files changed, 25 insertions(+), 29 deletions(-) diff --git a/dap-estgi-server/src/Breakpoints.hs b/dap-estgi-server/src/Breakpoints.hs index 3b8338d..969a70c 100644 --- a/dap-estgi-server/src/Breakpoints.hs +++ b/dap-estgi-server/src/Breakpoints.hs @@ -52,8 +52,8 @@ commandSetBreakpoints = do ESTG {..} <- getDebugSession case (setBreakpointsArgumentsBreakpoints, maybeSourceRef, maybeSourceRef >>= flip Bimap.lookupR dapSourceRefMap) of -- HINT: breakpoint on Haskell - (Just sourceBreakpoints, Just sourceRef, Just (SourceRef_SourceFileInFullpak hsCodeDesc@(Haskell pkg mod))) - | Just extStgSourceRef <- Bimap.lookup (SourceRef_SourceFileInFullpak $ ExtStg pkg mod) dapSourceRefMap + (Just sourceBreakpoints, Just sourceRef, Just hsCodeDesc@(Haskell pkg mod)) + | Just extStgSourceRef <- Bimap.lookup (ExtStg pkg mod) dapSourceRefMap , Just hsSourceFilePath <- Bimap.lookupR hsCodeDesc haskellSrcPathMap -> do (_sourceCodeText, _locations, hsSrcLocs) <- getSourceFromFullPak extStgSourceRef @@ -110,7 +110,7 @@ commandSetBreakpoints = do sendSetBreakpointsResponse breakpoints -- HINT: breakpoint on ExtStg - (Just sourceBreakpoints, Just sourceRef, Just (SourceRef_SourceFileInFullpak ExtStg{})) -> do + (Just sourceBreakpoints, Just sourceRef, Just ExtStg{}) -> do (_sourceCodeText, locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do -- filter all relevant ranges diff --git a/dap-estgi-server/src/DapBase.hs b/dap-estgi-server/src/DapBase.hs index 442fe50..faa79f5 100644 --- a/dap-estgi-server/src/DapBase.hs +++ b/dap-estgi-server/src/DapBase.hs @@ -103,10 +103,6 @@ data SourceCodeDescriptor | ForeignC PackageName FilePath deriving (Show, Read, Eq, Ord) -data DapSourceRefDescriptor - = SourceRef_SourceFileInFullpak SourceCodeDescriptor - deriving (Show, Read, Eq, Ord) - ---------------------------------------------------------------------------- -- | External STG Interpreter application internal state data ESTG @@ -117,11 +113,11 @@ data ESTG , sourceCodeSet :: Set SourceCodeDescriptor , unitIdMap :: Bimap UnitId PackageName , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor - , dapSourceNameMap :: Bimap Text DapSourceRefDescriptor + , dapSourceNameMap :: Bimap Text SourceCodeDescriptor -- application specific resource handling - , dapSourceRefMap :: !(Bimap DapSourceRefDescriptor Int) + , dapSourceRefMap :: !(Bimap SourceCodeDescriptor Int) -- ^ Used to track source reference IDs -- , dapFrameIdMap :: !(Bimap DapFrameIdDescriptor Int) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 69ec533..4c11efb 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -197,8 +197,8 @@ initESTG AttachArgs {..} = do , sourceCodeSet = Set.fromList sourceCodeList , unitIdMap = unitIdMap , haskellSrcPathMap = haskellSrcPathMap - , dapSourceNameMap = Bimap.fromList [(cs $ getSourceName d, SourceRef_SourceFileInFullpak d) | d <- sourceCodeList] - , dapSourceRefMap = Bimap.fromList $ zip (map SourceRef_SourceFileInFullpak sourceCodeList) [1..] + , dapSourceNameMap = Bimap.fromList [(cs $ getSourceName d, d) | d <- sourceCodeList] + , dapSourceRefMap = Bimap.fromList $ zip sourceCodeList [1..] , dapFrameIdMap = Bimap.empty , dapVariablesRefMap = Bimap.empty , dapStackFrameCache = mempty @@ -363,7 +363,7 @@ talk CommandLoadedSources = do ForeignC{} -> True _ -> False srcSet <- getsApp sourceCodeSet - mapM (getSourceFromSourceRefDescriptor . SourceRef_SourceFileInFullpak) $ filter shouldInclude $ Set.toList srcSet + mapM getSourceFromSourceCodeDescriptor $ filter shouldInclude $ Set.toList srcSet ---------------------------------------------------------------------------- talk (CustomCommand "getSourceLinks") = customCommandGetSourceLinks diff --git a/dap-estgi-server/src/SourceCode.hs b/dap-estgi-server/src/SourceCode.hs index 0151c84..2ded16e 100644 --- a/dap-estgi-server/src/SourceCode.hs +++ b/dap-estgi-server/src/SourceCode.hs @@ -135,7 +135,7 @@ getValidSourceRefFromSource Source{..} = do getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)], [(StgPoint, Tickish)]) getSourceFromFullPak sourceId = do ESTG {..} <- getDebugSession - SourceRef_SourceFileInFullpak srcDesc <- case Bimap.lookupR sourceId dapSourceRefMap of + srcDesc <- case Bimap.lookupR sourceId dapSourceRefMap of Nothing -> do sendError (ErrorMessage (T.pack $ "Unknown sourceId: " ++ show sourceId)) Nothing Just value -> pure value @@ -151,32 +151,32 @@ getSourceFromFullPak sourceId = do ir <- readModpakS fullPakPath sourcePath T.decodeUtf8 pure (ir, [], []) -getSourceFromSourceRefDescriptor :: DapSourceRefDescriptor -> Adaptor ESTG Source -getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak srcDesc) = do +getSourceFromSourceCodeDescriptor :: SourceCodeDescriptor -> Adaptor ESTG Source +getSourceFromSourceCodeDescriptor srcDesc = do srcDescSet <- getsApp sourceCodeSet extraSources <- case srcDesc of Haskell packageName qualModName | cStub <- FFICStub packageName qualModName , hStub <- FFIHStub packageName qualModName -> Just <$> sequence ( - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ ExtStg packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcCore packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcStg packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Cmm packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Asm packageName qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ ModInfo packageName qualModName) + [ getSourceFromSourceCodeDescriptor (ExtStg packageName qualModName) + , getSourceFromSourceCodeDescriptor (GhcCore packageName qualModName) + , getSourceFromSourceCodeDescriptor (GhcStg packageName qualModName) + , getSourceFromSourceCodeDescriptor (Cmm packageName qualModName) + , getSourceFromSourceCodeDescriptor (Asm packageName qualModName) + , getSourceFromSourceCodeDescriptor (ModInfo packageName qualModName) ] ++ - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak cStub) + [ getSourceFromSourceCodeDescriptor cStub | Set.member cStub srcDescSet ] ++ - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak hStub) + [ getSourceFromSourceCodeDescriptor hStub | Set.member hStub srcDescSet ]) _ -> pure Nothing let sourceName = cs $ getSourceName srcDesc - sourceRef <- getSourceRef sourceRefDesc + sourceRef <- getSourceRef srcDesc ESTG {..} <- getDebugSession pure defaultSource { sourceName = Just $ sourceName -- used in source tree children @@ -185,7 +185,7 @@ getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak sr , sourceSources = extraSources } -getSourceRef :: DapSourceRefDescriptor -> Adaptor ESTG Int +getSourceRef :: SourceCodeDescriptor -> Adaptor ESTG Int getSourceRef key = do -- NOTE: Source code related db is populated at initialization getsApp (Bimap.lookup key . dapSourceRefMap) >>= \case diff --git a/dap-estgi-server/src/SourceLocation.hs b/dap-estgi-server/src/SourceLocation.hs index 73fbc1a..1699b71 100644 --- a/dap-estgi-server/src/SourceLocation.hs +++ b/dap-estgi-server/src/SourceLocation.hs @@ -46,7 +46,7 @@ getSourceAndPositionForStgPoint stgPoint = do Nothing -> sendError (ErrorMessage (T.pack $ "Unknown unit id: " ++ show unitId)) Nothing Just v -> pure v let moduleName = cs $ getModuleName moduleNameBS - source <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak $ ExtStg packageName moduleName + source <- getSourceFromSourceCodeDescriptor $ ExtStg packageName moduleName let Just sourceRef = sourceSourceReference source (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef let inModule pkg mod (_, SourceNote{..}) @@ -68,7 +68,7 @@ getSourceAndPositionForStgPoint stgPoint = do | RealSrcSpan'{..} <- sourceSpan , Just hsSrcDesc <- Bimap.lookup srcSpanFile haskellSrcPathMap -> do - sourceHs <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak hsSrcDesc + sourceHs <- getSourceFromSourceCodeDescriptor hsSrcDesc pure (Just sourceHs, srcSpanSLine, srcSpanSCol, srcSpanELine, srcSpanECol) _ -> do case filter ((== stgPoint) . fst) locations of @@ -102,8 +102,8 @@ customCommandGetSourceLinks = do GetSourceLinksArguments {..} <- getArguments ESTG {..} <- getDebugSession sourceLinks <- case Bimap.lookup getSourceLinksArgumentsPath dapSourceNameMap of - Just srcDesc@(SourceRef_SourceFileInFullpak ExtStg{}) -> do - source <- getSourceFromSourceRefDescriptor srcDesc + Just srcDesc@ExtStg{} -> do + source <- getSourceFromSourceCodeDescriptor srcDesc let Just sourceRef = sourceSourceReference source (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef let hsTickishLocMap = Map.unionsWith mappend [Map.singleton stgPoint [tickish] | (stgPoint, tickish) <- hsSrcLocs] From e464aad2cb233e75cb054317dc0316d14e64bdf1 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 15:06:26 +0200 Subject: [PATCH 04/21] remove hardcoded filepaths, generate call graph --- dap-estgi-server/src/Graph.hs | 155 +++++++++++++----- .../src/GraphProtocol/Commands.hs | 7 +- 2 files changed, 114 insertions(+), 48 deletions(-) diff --git a/dap-estgi-server/src/Graph.hs b/dap-estgi-server/src/Graph.hs index 8b83249..2511107 100644 --- a/dap-estgi-server/src/Graph.hs +++ b/dap-estgi-server/src/Graph.hs @@ -5,25 +5,30 @@ module Graph where import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) import Data.String.Conversions (cs) +import Control.Monad import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import qualified Data.IntMap.Strict as IntMap import qualified Data.Bimap as Bimap +import qualified Data.Set as Set + +import qualified Data.Map.Strict as StrictMap +import Data.List (intercalate, foldl', sortOn) +import System.IO + import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) import Stg.Interpreter.GC.GCRef import Stg.Interpreter.Debugger.TraverseState -import Stg.Interpreter.Debug +import Stg.IRLocation import DAP import DapBase -import CustomCommands +import CustomCommands import GraphProtocol.Server import GraphProtocol.Commands import Inspect.Value.Atom -getValueSummary _ valueNameSpace addr = Just $ "TODO: title " ++ show (valueNameSpace, addr) - customCommandShowVariableGraphStructure :: Adaptor ESTG () customCommandShowVariableGraphStructure = do ShowVariableGraphStructureArguments {..} <- getArguments @@ -33,58 +38,118 @@ customCommandShowVariableGraphStructure = do sendSuccesfulEmptyResponse Just (VariablesRef_Value _valueRoot valueNameSpace addr) -> do stgState@StgState{..} <- getStgState - case getValueSummary stgState valueNameSpace addr of - Nothing -> sendError (ErrorMessage (T.pack $ "Unknown object: " ++ show (valueNameSpace, addr))) Nothing - Just valueSummary -> do - {- - TODO - - generate facts for transitive closure of reachable objects into file - - send to graph command service - -} - let fname = "/home/csaba/call-graphs/q3mapviewer-call-graphXXX.tsv" - {- - encodeRef :: Int -> RefNamespace -> GCSymbol - -} - liftIO $ do - --exportReachableGraph :: FilePath -> StgState -> GCSymbol -> IO () - exportReachableGraph fname stgState $ encodeRef addr valueNameSpace - liftIO $ sendGraphCommand LoadGraph - { loadGraphRequest = "loadGraph" - , loadGraphTitle = cs $ show addr ++ " " ++ valueSummary - , loadGraphFilepath = cs fname - } - sendSuccesfulEmptyResponse + valueSummary <- getValueSummary valueNameSpace addr -{- - { loadGraphRequest :: Text - , loadGraphTitle :: Text - , loadGraphFilepath :: Text - , "filepath" .= Aeson.String "/home/csaba/call-graphs/q3mapviewer-call-graph.tsv" - | Just o <- IntMap.lookup addr ssHeap - -> do - varsRef <- getVariablesRef $ VariablesRef_HeapObject frameIdDesc addr - pure ("HeapPtr", show addr ++ " " ++ getHeapObjectSummary o ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o), varsRef) - stgState <- getStgState + -- generate names ESTG {..} <- getDebugSession + let nodesFname = fullPakPath ++ "-graph-nodes.tsv" + edgesFname = fullPakPath ++ "-graph-edges.tsv" + + liftIO $ exportReachableGraph nodesFname edgesFname stgState $ encodeRef addr valueNameSpace + liftIO $ sendGraphCommand LoadGraph + { loadGraphRequest = "loadGraph" + , loadGraphTitle = cs $ show addr ++ " " ++ valueSummary + , loadGraphNodesFilepath = Just $ cs nodesFname + , loadGraphEdgesFilepath = cs edgesFname + } sendSuccesfulEmptyResponse --} + Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variables ref: " ++ show showVariableGraphStructureArgumentsVariablesReference)) Nothing customCommandShowCallGraph :: Adaptor ESTG () customCommandShowCallGraph = do - --sendAndWait (CmdInternal "gc") - {- - TODO: - - export call graph - - send command to gephi - -} - let fname = "/home/csaba/call-graphs/dap-estgi-call-graph.tsv" ESTG {..} <- getDebugSession + let nodesFname = fullPakPath ++ "-graph-nodes.tsv" + edgesFname = fullPakPath ++ "-graph-edges.tsv" StgState{..} <- getStgState liftIO $ do - writeCallGraph fname ssCallGraph + writeCallGraphEdges edgesFname ssCallGraph + writeCallGraphNodes nodesFname ssCallGraph sendGraphCommand LoadGraph { loadGraphRequest = "loadGraph" , loadGraphTitle = cs $ takeFileName fullPakPath ++ " call graph" - , loadGraphFilepath = cs fname + , loadGraphNodesFilepath = Just $ cs nodesFname + , loadGraphEdgesFilepath = cs edgesFname } sendSuccesfulEmptyResponse + +writeCallGraphEdges :: FilePath -> CallGraph -> IO () +writeCallGraphEdges fname CallGraph{..} = do + let showCallType = \case + SO_CloArg -> "unknown" + SO_Let -> "known" + SO_Scrut -> "unknown" + SO_AltArg -> "unknown" + SO_TopLevel -> "known" + SO_Builtin -> "known" + SO_ClosureResult -> "unknown" + withFile fname WriteMode $ \h -> do + hPutStrLn h $ intercalate "\t" + [ "Source" + , "Target" + , "Label" + , "count" + , "static-origin" + , "call-site-type" + ] + forM_ (sortOn (negate . snd) $ StrictMap.toList cgInterClosureCallGraph) $ \((so, from, to), count) -> do + hPutStrLn h $ intercalate "\t" + [ show from + , show to + , show count + , show count + , show so + , showCallType so + ] + forM_ (sortOn (negate . snd) $ StrictMap.toList cgIntraClosureCallGraph) $ \((from, so, to), count) -> do + hPutStrLn h $ intercalate "\t" + [ show from + , show to + , show count + , show count + , "direct" + , "known" + ] +writeCallGraphNodes :: FilePath -> CallGraph -> IO () +writeCallGraphNodes fname CallGraph{..} = do + withFile fname WriteMode $ \h -> do + hPutStrLn h $ intercalate "\t" + [ "Id" + , "Label" +-- , "package-id" +-- , "module" + , "partition2" + ] + let nodes = Set.fromList . concat $ + [[from, to] | (_so, from, to) <- StrictMap.keys cgInterClosureCallGraph] ++ + [[from, to] | (from, _so, to) <- StrictMap.keys cgIntraClosureCallGraph] + + + forM_ nodes $ \node -> + hPutStrLn h $ intercalate "\t" + [ show node + , getLabelForProgramPoint node + , case node of + PP_StgPoint{} -> "PP_StgPoint" + PP_Global{} -> "PP_Global" + PP_Apply{} -> "PP_Apply" + ] + +getLabelForProgramPoint :: ProgramPoint -> String +getLabelForProgramPoint = \case + PP_Global -> "global scope" + PP_Apply n pp -> "apply " ++ show n ++ " " ++ getLabelForProgramPoint pp + PP_StgPoint p -> getLabelForStgPoint p + +getLabelForStgPoint :: StgPoint -> String +getLabelForStgPoint = \case + SP_CaseScrutineeExpr{..} -> getLabelForStgId spScrutineeResultName + SP_LetExpr{..} -> getLabelForStgPoint spParent + SP_LetNoEscapeExpr{..} -> getLabelForStgPoint spParent + SP_RhsClosureExpr{..} -> getLabelForStgId spRhsBinderName + SP_AltExpr{..} -> "alt " ++ show spAltIndex ++ ": " ++ getLabelForStgId spScrutineeResultName + SP_RhsCon{..} -> getLabelForStgId spRhsBinderName + SP_Binding{..} -> getLabelForStgId spBinderName + SP_Tickish{..} -> getLabelForStgPoint spParent + +getLabelForStgId :: StgId -> String +getLabelForStgId StgId{..} = cs (siUnitId <> "_" <> siModuleName <> "." <> siName) <> maybe "" (\u -> "_" <> show u) siUnique diff --git a/dap-estgi-server/src/GraphProtocol/Commands.hs b/dap-estgi-server/src/GraphProtocol/Commands.hs index a3ef830..f1a2336 100644 --- a/dap-estgi-server/src/GraphProtocol/Commands.hs +++ b/dap-estgi-server/src/GraphProtocol/Commands.hs @@ -11,9 +11,10 @@ import DAP.Utils data LoadGraph = LoadGraph - { loadGraphRequest :: Text - , loadGraphTitle :: Text - , loadGraphFilepath :: Text + { loadGraphRequest :: Text + , loadGraphTitle :: Text + , loadGraphNodesFilepath :: Maybe Text + , loadGraphEdgesFilepath :: Text } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- instance ToJSON LoadGraph where From e491b5b472b96a4707ebd660832e2b3c6646796e Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 15:08:30 +0200 Subject: [PATCH 05/21] code cleanup --- dap-estgi-server/src/GraphProtocol/Server.hs | 41 ++++---------------- dap-estgi-server/src/SourceLocation.hs | 6 --- 2 files changed, 8 insertions(+), 39 deletions(-) diff --git a/dap-estgi-server/src/GraphProtocol/Server.hs b/dap-estgi-server/src/GraphProtocol/Server.hs index 61c9437..ee4f8ce 100644 --- a/dap-estgi-server/src/GraphProtocol/Server.hs +++ b/dap-estgi-server/src/GraphProtocol/Server.hs @@ -33,14 +33,8 @@ serverConfig0 = ServerConfig , debugLogging = True } -{- - TODO: - gephi - - estgi panel - - estgi listener --} data GraphEvent - = GraphEventShowCode Text + = GraphEventShowValue Text deriving (Show, Eq, Ord) data GraphChan @@ -87,51 +81,32 @@ runGraphServer = withSocketsDo $ do when debugLogging $ putStrLn ("Running GRAPH server on " <> show port <> "...") serve (Host host) (show port) $ \(socket, address) -> do when debugLogging $ do --- withGlobalLock $ do - putStrLn $ "TCP connection established from " ++ show address + putStrLn $ "TCP connection established from " ++ show address handle <- socketToHandle socket ReadWriteMode hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF } modifyIORef' graphServerStateIORef $ \s -> s {gssHandle = handle} - --request <- readPayload handle :: IO (Either String Value) - --print request - -- TODO: process request - -- TODO: send response - --adaptorStateMVar <- initAdaptorState handle address appStore serverConfig request -{- - BS.hPut handle $ encodeBaseProtocolMessage $ - Aeson.object - [ "request" .= Aeson.String "loadGraph" - , "title" .= Aeson.String "Haskell Heap" - , "filepath" .= Aeson.String "/home/csaba/call-graphs/q3mapviewer-call-graph.tsv" - ] --} serviceClient handle -- `catch` exceptionHandler handle address debugLogging serviceClient :: Handle -> IO () serviceClient handle = do {- get session id from message - lookup the communication cannel based on session id + lookup the communication channel based on session id if there is no match then report and error, or use the first session as a fallback -} nextRequest <- readPayload handle :: IO (Either String Value) print nextRequest - -- echo command case nextRequest of Left err -> do putStrLn $ "error: " ++ err Right (Aeson.Object json) - | Just "showCode" <- Aeson.lookup "event" json - , Just (Aeson.String pp) <- Aeson.lookup "programPoint" json + | Just "showValue" <- Aeson.lookup "event" json + , Just (Aeson.String nodeId) <- Aeson.lookup "nodeId" json -> do GraphServerState{..} <- readIORef graphServerStateIORef - let GraphChan{..} = head $ Map.elems gssGraphChanMap - Unagi.writeChan graphAsyncEventIn $ GraphEventShowCode pp - {- - let echo = encodeBaseProtocolMessage json - BS.putStrLn echo - BS.hPut handle echo - -} + -- TODO: handle sessions correctly, select the right session + forM_ (Map.elems gssGraphChanMap) $ \GraphChan{..} -> do + Unagi.writeChan graphAsyncEventIn $ GraphEventShowValue nodeId Right json -> do putStrLn $ "unknown event: " ++ show nextRequest -- loop: serve the next request diff --git a/dap-estgi-server/src/SourceLocation.hs b/dap-estgi-server/src/SourceLocation.hs index 1699b71..b817079 100644 --- a/dap-estgi-server/src/SourceLocation.hs +++ b/dap-estgi-server/src/SourceLocation.hs @@ -34,12 +34,6 @@ getUnitIdAndModuleNameForStgPoint = \case getSourceAndPositionForStgPoint :: StgPoint -> Adaptor ESTG (Maybe Source, Int, Int, Int, Int) getSourceAndPositionForStgPoint stgPoint = do - {- - TODO: - - remove id / binder, and use explicit package and module specification - - remove id for StgPoint - - support String -> StgPoint conversion - -} let (unitId, moduleNameBS) = getUnitIdAndModuleNameForStgPoint stgPoint ESTG {..} <- getDebugSession packageName <- case Bimap.lookup unitId unitIdMap of From 3b1fee2816d7c6de0b23c898b9670a791abcfa96 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 15:13:45 +0200 Subject: [PATCH 06/21] show value graph event now supports call graphs and heap graphs also --- dap-estgi-server/src/Main.hs | 78 ++++++++++++------------------------ 1 file changed, 25 insertions(+), 53 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 4c11efb..acfff19 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -91,6 +91,7 @@ import GraphProtocol.Server import SourceCode import SourceLocation import Breakpoints +import Inspect.Value.Atom import Inspect.Value import Inspect.Stack import Graph @@ -212,74 +213,45 @@ initESTG AttachArgs {..} = do ] liftIO $ registerGraphChan __sessionId graphChan -{- - Q: do we need sync I/O only between graph server and estgi-dap? - - graph server - map: session id -> graph channel - - esgi-dap - registers sessions to graph server --} - ---------------------------------------------------------------------------- -- | Graph Event Handler handleGraphEvents :: GraphChan -> (Adaptor ESTG () -> IO ()) -> IO () handleGraphEvents GraphChan{..} withAdaptor = forever $ do graphEvent <- liftIO (Unagi.readChan graphAsyncEventOut) - withAdaptor $ do + withAdaptor . flip catch handleDebuggerExceptions $ do let sendEvent ev = sendSuccesfulEvent ev . setBody case graphEvent of - -- show heap value implementation - GraphEventShowCode gcsymbol -> do - let root@(ns, idx) = decodeRef . GCSymbol $ cs gcsymbol - {- - TODO: - - create variables references - - send variables references to vscode - -} - varsRef <- getVariablesRef $ VariablesRef_Value (ValueRoot_Value root) ns idx - sendEvent (EventTypeCustom "showValues") $ object - [ "variablesReferences" .= (Aeson.Array . pure . Number $ fromIntegral varsRef) - ] - - -- show code implementation - GraphEventShowCode gcsymbol -> do - {- - TODO: - lookup source loc just like in 'code:' like variable source range encoding - Q: how to convert Text to Id/Binder? - done - generalize source location encodin to program points - - TODO: - done - read GCSymbol - done - lookup stgpoint for GCSymbol when possible - done - get source location for stg point - done - send event, with document name, and source location - -} - StgState{..} <- getStgState - let (ns, idx) = decodeRef . GCSymbol $ cs gcsymbol - case ns of - NS_HeapPtr - | Just Closure{..} <- IntMap.lookup idx ssHeap - -> do - srcLocJson <- getStgSourceLocJSON . SP_Binding . binderToStgId $ unId hoName - sendEvent (EventTypeCustom "showCode") srcLocJson + GraphEventShowValue nodeId + | Just programPoint <- readMaybe $ cs nodeId + -> do + let getStgPointFromProgramPoint = \case + PP_Global -> Nothing + PP_Apply _ pp -> getStgPointFromProgramPoint pp + PP_StgPoint p -> Just p + case getStgPointFromProgramPoint programPoint of + Nothing -> pure () + Just stgPoint -> do + srcLocJson <- getStgSourceLocJSON stgPoint + sendEvent (EventTypeCustom "showCode") srcLocJson - | Just BlackHole{..} <- IntMap.lookup idx ssHeap - , Closure{..} <- hoBHOriginalThunk - -> do - srcLocJson <- getStgSourceLocJSON . SP_Binding . binderToStgId $ unId hoName - sendEvent (EventTypeCustom "showCode") srcLocJson + GraphEventShowValue nodeId + | Just root@(ns, idx) <- readMaybe $ cs nodeId + -> do + atom <- valueToAtom ns idx + var <- getVariableForAtom "" (ValueRoot_Value root) atom + sendEvent (EventTypeCustom "showValue") $ object + [ "variable" .= var + ] - _ -> logInfo $ BL8.pack ("not program point for " <> show gcsymbol) + GraphEventShowValue nodeId -> do + logError $ BL8.pack ("invalid node id format: " <> cs nodeId) ---------------------------------------------------------------------------- -- | Debug Event Handler handleDebugEvents :: DebuggerChan -> (Adaptor ESTG () -> IO ()) -> IO () handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do dbgEvent <- liftIO (Unagi.readChan dbgAsyncEventOut) - withAdaptor $ do + withAdaptor . flip catch handleDebuggerExceptions $ do ESTG {..} <- getDebugSession let sendEvent ev = sendSuccesfulEvent ev . setBody case dbgEvent of From 2dbf501af367cbc35bfb7d26f34a649167d012b4 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 15:15:34 +0200 Subject: [PATCH 07/21] adjust atom visualization to be more descriptive --- dap-estgi-server/src/Inspect/Value/Atom.hs | 70 ++++++++++++++++------ 1 file changed, 53 insertions(+), 17 deletions(-) diff --git a/dap-estgi-server/src/Inspect/Value/Atom.hs b/dap-estgi-server/src/Inspect/Value/Atom.hs index 94535ad..e0a1332 100644 --- a/dap-estgi-server/src/Inspect/Value/Atom.hs +++ b/dap-estgi-server/src/Inspect/Value/Atom.hs @@ -9,6 +9,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.Text ( Text ) import qualified Data.Text.Lazy as LazyText import qualified Text.Pretty.Simple as PP +import Foreign.Ptr import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) import Stg.Interpreter.GC.GCRef @@ -82,12 +83,12 @@ getAtomTypeAndValue :: StgState -> Atom -> (String, String) -getAtomTypeAndValue StgState{..} = \case +getAtomTypeAndValue StgState{..} atom = case atom of HeapPtr addr | Just o <- IntMap.lookup addr ssHeap -> ("HeapPtr", show addr ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o)) - Literal (LitChar char) -> ("Char", [char]) - Literal (LitString bytes) -> ("String", cs bytes) + Literal (LitChar char) -> ("Char", show char) + Literal (LitString bytes) -> ("String", cs $ show bytes) Literal LitNullAddr -> ("Address", "0x00000000") Literal (LitFloat float) -> ("Float", show float) Literal (LitDouble double) -> ("Double", show double) @@ -101,20 +102,20 @@ getAtomTypeAndValue StgState{..} = \case WordAtom x -> ("Word", show x) FloatAtom x -> ("Float", show x) DoubleAtom x -> ("Double", show x) - MVar x -> ("MVar", show x) - MutVar x -> ("MutVar", show x) - TVar x -> ("TVar", show x) - Array idx -> ("Array", show idx) - MutableArray idx -> ("MutableArray", show idx) - SmallArray idx -> ("SmallArray", show idx) - SmallMutableArray idx -> ("SmallMutableArray", show idx) - ArrayArray idx -> ("ArrayArray", show idx) - MutableArrayArray idx -> ("MutableArrayArray", show idx) - ByteArray idx -> ("ByteArray", show idx) - MutableByteArray idx -> ("MutableByteArray", show idx) - WeakPointer x -> ("WeakPoint", show x) - StableName x -> ("StableName", show x) - ThreadId x -> ("ThreadId", show x) + MVar x -> ("MVar", show atom) + MutVar x -> ("MutVar", show atom) + TVar x -> ("TVar", show atom) + Array idx -> ("Array", show atom) + MutableArray idx -> ("MutableArray", show atom) + SmallArray idx -> ("SmallArray", show atom) + SmallMutableArray idx -> ("SmallMutableArray", show atom) + ArrayArray idx -> ("ArrayArray", show atom) + MutableArrayArray idx -> ("MutableArrayArray", show atom) + ByteArray idx -> ("ByteArray", show atom) + MutableByteArray idx -> ("MutableByteArray", show atom) + WeakPointer x -> ("WeakPoint", show atom) + StableName x -> ("StableName", show atom) + ThreadId x -> ("ThreadId", show atom) LiftedUndefined -> ("LiftedUndefined","undefined") getHeapObjectSummary :: HeapObject -> String @@ -136,3 +137,38 @@ getVariableForAtom name valueRoot atom = do , variableType = Just (cs variableType) , variableVariablesReference = varsRef } + +valueToAtom :: RefNamespace -> Int -> Adaptor ESTG Atom +valueToAtom ns i = do + StgState{..} <- getStgState + pure $ case ns of + NS_HeapPtr -> HeapPtr i + NS_StablePointer -> PtrAtom (StablePtr i) (intPtrToPtr $ IntPtr i) + NS_MVar -> MVar i + NS_MutVar -> MutVar i + NS_TVar -> TVar i + NS_Array -> Array $ ArrIdx i + NS_MutableArray -> MutableArray $ MutArrIdx i + NS_SmallArray -> SmallArray $ SmallArrIdx i + NS_SmallMutableArray -> SmallMutableArray $ SmallMutArrIdx i + NS_ArrayArray -> ArrayArray $ ArrayArrIdx i + NS_MutableArrayArray -> MutableArrayArray $ ArrayMutArrIdx i + NS_MutableByteArray + | Just ByteArrayDescriptor{..} <- IntMap.lookup i ssMutableByteArrays + -> MutableByteArray $ ByteArrayIdx + { baId = i + , baPinned = baaPinned + , baAlignment = baaAlignment + } + NS_WeakPointer -> WeakPointer i + NS_StableName -> StableName i + NS_Thread -> ThreadId i + +getValueSummary :: RefNamespace -> Int -> Adaptor ESTG String +getValueSummary ns i = do + StgState{..} <- getStgState + pure $ case ns of + NS_HeapPtr + | Just o <- IntMap.lookup i ssHeap + -> "HeapPtr " ++ getHeapObjectSummary o + _ -> show (ns, i) From 812cf3829b939e30722cbef213631e68dd218381 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 15:16:09 +0200 Subject: [PATCH 08/21] fix scope name --- dap-estgi-server/src/Inspect/Stack.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dap-estgi-server/src/Inspect/Stack.hs b/dap-estgi-server/src/Inspect/Stack.hs index c027cdd..7ad1bc9 100644 --- a/dap-estgi-server/src/Inspect/Stack.hs +++ b/dap-estgi-server/src/Inspect/Stack.hs @@ -55,7 +55,7 @@ getScopesForStackContinuation getScopesForStackContinuation frameIdDesc stackCont = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc let scope = defaultScope - { scopeName = "Locals: " <> T.pack (showStackCont stackCont) + { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef } From 59564d8a9781f19f3079ca10fc82bed7844e49c6 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 15:17:12 +0200 Subject: [PATCH 09/21] work in progress value inspector --- dap-estgi-server/src/Inspect/Value.hs | 30 +++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/dap-estgi-server/src/Inspect/Value.hs b/dap-estgi-server/src/Inspect/Value.hs index 434f53e..064da6d 100644 --- a/dap-estgi-server/src/Inspect/Value.hs +++ b/dap-estgi-server/src/Inspect/Value.hs @@ -3,12 +3,38 @@ module Inspect.Value where import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) import Stg.Interpreter.GC.GCRef +import qualified Data.IntMap as IntMap import DAP import DapBase +import Inspect.Value.HeapObject getVariablesForValue :: ValueRoot -> RefNamespace -> Int -> Adaptor ESTG [Variable] getVariablesForValue valueRoot valueNS idx = do StgState{..} <- getStgState - --case valueNS of - pure [] + case valueNS of + NS_HeapPtr + | Just v <- IntMap.lookup idx ssHeap + -> getVariablesForHeapObject valueRoot v + + _ -> pure [] + +{- + +data RefNamespace + = NS_Array + | NS_ArrayArray + | NS_HeapPtr + | NS_MutableArray + | NS_MutableArrayArray + | NS_MutableByteArray + | NS_MutVar + | NS_TVar + | NS_MVar + | NS_SmallArray + | NS_SmallMutableArray + | NS_StableName + | NS_StablePointer + | NS_WeakPointer + | NS_Thread +-} \ No newline at end of file From b9415e7ab809c5318a7ce4fa0d5011284a364d66 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 15:39:27 +0200 Subject: [PATCH 10/21] update dependencies --- stack.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index e0d8b26..806c5c5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,10 +12,10 @@ extra-deps: commit: ac9616b94cb8c4a9e07188d19979a6225ebd5a10 - git: https://github.com/haskell-debugger/dap - commit: 1f8ed2f97e9d41f037274791d66f1e0984c1ed17 + commit: 31c114964e30b8c96279ddef6fbe8d6549b52e9e - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project - commit: 81c142ab40c6757904d873d4dd1db4a7786b186c + commit: 59aacc82f1d15e1534cbdd52cdce781cbd6c81dc subdirs: - external-stg - external-stg-syntax From 5b7d627b08a10fce42903aac5a0616260416909d Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 16:29:32 +0200 Subject: [PATCH 11/21] remove dead code --- dap-estgi-server/src/DapBase.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/dap-estgi-server/src/DapBase.hs b/dap-estgi-server/src/DapBase.hs index faa79f5..a238ac0 100644 --- a/dap-estgi-server/src/DapBase.hs +++ b/dap-estgi-server/src/DapBase.hs @@ -86,7 +86,6 @@ data ValueRoot data DapVariablesRefDescriptor = VariablesRef_StackFrameVariables DapFrameIdDescriptor --- | VariablesRef_HeapObject DapFrameIdDescriptor Int | VariablesRef_Value ValueRoot RefNamespace Int deriving (Show, Eq, Ord) From 592222fbfb512505fcc8d2a570b72de0aebc53c6 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 17 Oct 2023 16:44:56 +0200 Subject: [PATCH 12/21] remove unused channels --- dap-estgi-server/src/GraphProtocol/Server.hs | 4 +--- dap-estgi-server/src/Main.hs | 6 +----- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/dap-estgi-server/src/GraphProtocol/Server.hs b/dap-estgi-server/src/GraphProtocol/Server.hs index ee4f8ce..0ea13c7 100644 --- a/dap-estgi-server/src/GraphProtocol/Server.hs +++ b/dap-estgi-server/src/GraphProtocol/Server.hs @@ -39,9 +39,7 @@ data GraphEvent data GraphChan = GraphChan - { graphSyncRequest :: MVar () - , graphSyncResponse :: MVar () - , graphAsyncEventIn :: InChan GraphEvent + { graphAsyncEventIn :: InChan GraphEvent , graphAsyncEventOut :: OutChan GraphEvent } deriving Eq diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index acfff19..1a4d010 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -183,12 +183,8 @@ initESTG AttachArgs {..} = do , dbgAsyncEventOut = dbgAsyncO } (graphAsyncI, graphAsyncO) <- liftIO (Unagi.newChan 100) - graphRequestMVar <- liftIO MVar.newEmptyMVar - graphResponseMVar <- liftIO MVar.newEmptyMVar let graphChan = GraphChan - { graphSyncRequest = graphRequestMVar - , graphSyncResponse = graphResponseMVar - , graphAsyncEventIn = graphAsyncI + { graphAsyncEventIn = graphAsyncI , graphAsyncEventOut = graphAsyncO } estg = ESTG From 11b85ea417df73d61b2c44fd0b1378d20df6ec6f Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 18 Oct 2023 11:21:57 +0200 Subject: [PATCH 13/21] add select graph node custom command --- dap-estgi-server/src/CustomCommands.hs | 11 +++++++++++ dap-estgi-server/src/Graph.hs | 14 ++++++++++++++ dap-estgi-server/src/GraphProtocol/Commands.hs | 11 +++++++++++ 3 files changed, 36 insertions(+) diff --git a/dap-estgi-server/src/CustomCommands.hs b/dap-estgi-server/src/CustomCommands.hs index cc4b294..4d972f4 100644 --- a/dap-estgi-server/src/CustomCommands.hs +++ b/dap-estgi-server/src/CustomCommands.hs @@ -52,3 +52,14 @@ instance FromJSON ShowVariableGraphStructureArguments where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- +data SelectVariableGraphNodeArguments + = SelectVariableGraphNodeArguments + { selectVariableGraphNodeArgumentsVariablesReference :: Int + } deriving stock (Show, Eq, Generic) + +instance FromJSON SelectVariableGraphNodeArguments where + parseJSON = genericParseJSONWithModifier + +---------------------------------------------------------------------------- diff --git a/dap-estgi-server/src/Graph.hs b/dap-estgi-server/src/Graph.hs index 2511107..e680fb5 100644 --- a/dap-estgi-server/src/Graph.hs +++ b/dap-estgi-server/src/Graph.hs @@ -29,6 +29,20 @@ import GraphProtocol.Server import GraphProtocol.Commands import Inspect.Value.Atom +customCommandSelectVariableGraphNode :: Adaptor ESTG () +customCommandSelectVariableGraphNode = do + SelectVariableGraphNodeArguments {..} <- getArguments + getsApp (Bimap.lookupR selectVariableGraphNodeArgumentsVariablesReference . dapVariablesRefMap) >>= \case + Just VariablesRef_StackFrameVariables{} -> do + sendSuccesfulEmptyResponse + Just (VariablesRef_Value _valueRoot valueNameSpace addr) -> do + liftIO $ sendGraphCommand SelectNode + { selectNodeRequest = "selectNode" + , selectNodeNodeId = cs $ show (valueNameSpace, addr) + } + sendSuccesfulEmptyResponse + Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variables ref: " ++ show selectVariableGraphNodeArgumentsVariablesReference)) Nothing + customCommandShowVariableGraphStructure :: Adaptor ESTG () customCommandShowVariableGraphStructure = do ShowVariableGraphStructureArguments {..} <- getArguments diff --git a/dap-estgi-server/src/GraphProtocol/Commands.hs b/dap-estgi-server/src/GraphProtocol/Commands.hs index f1a2336..fc8277a 100644 --- a/dap-estgi-server/src/GraphProtocol/Commands.hs +++ b/dap-estgi-server/src/GraphProtocol/Commands.hs @@ -21,3 +21,14 @@ instance ToJSON LoadGraph where toJSON = genericToJSONWithModifier ---------------------------------------------------------------------------- + +data SelectNode + = SelectNode + { selectNodeRequest :: Text + , selectNodeNodeId :: Text + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON SelectNode where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- + From 423915177daac8158fc17ad499419219f654e2cb Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 18 Oct 2023 11:24:13 +0200 Subject: [PATCH 14/21] simplify design to support only single graph and dap session (for now) ; cleanup graph server setup ; read override graph port and host values from ENV variables --- dap-estgi-server/src/GraphProtocol/Server.hs | 97 +++++++++++--------- dap-estgi-server/src/Main.hs | 21 +++-- 2 files changed, 69 insertions(+), 49 deletions(-) diff --git a/dap-estgi-server/src/GraphProtocol/Server.hs b/dap-estgi-server/src/GraphProtocol/Server.hs index 0ea13c7..fa12b62 100644 --- a/dap-estgi-server/src/GraphProtocol/Server.hs +++ b/dap-estgi-server/src/GraphProtocol/Server.hs @@ -26,11 +26,11 @@ import System.IO.Unsafe import Control.Concurrent.MVar import Control.Concurrent.Chan.Unagi.Bounded as Unagi -serverConfig0 = ServerConfig - { host = "0.0.0.0" - , port = 4721 - , serverCapabilities = defaultCapabilities - , debugLogging = True +data GraphServerConfig + = GraphServerConfig + { graphServerHost :: String + , graphServerPort :: Int + , graphServerDebugLogging :: Bool } data GraphEvent @@ -49,49 +49,72 @@ instance Show GraphChan where data GraphServerState = GraphServerState - { gssHandle :: Handle - , gssGraphChanMap :: Map Text GraphChan + { gssHandle :: Maybe Handle + , gssGraphChan :: Maybe GraphChan + , gssConfig :: GraphServerConfig } -emptyGraphServerState :: GraphServerState -emptyGraphServerState = GraphServerState - { gssHandle = error "missing gssHandle" - , gssGraphChanMap = mempty - } +{- + DESIGN: + currently only one dap session and one gephi session is supported + i.e. vscode --- estgi-dap --- gephi + multi session dap or multi session gephi is not supported + + use cases: + debug one program + 1 vscode + 1 gephi + 1 estgi dap session / program + debug multiple programs - not supported yet +-} {-# NOINLINE graphServerStateIORef #-} graphServerStateIORef :: IORef GraphServerState -graphServerStateIORef = unsafePerformIO $ newIORef emptyGraphServerState +graphServerStateIORef = unsafePerformIO $ newIORef $ error "uninitialized graph server" registerGraphChan :: Text -> GraphChan -> IO () -registerGraphChan sessionId graphChan = do - modifyIORef' graphServerStateIORef $ \s@GraphServerState{..} -> s {gssGraphChanMap = Map.insert sessionId graphChan gssGraphChanMap} +registerGraphChan _sessionId graphChan = do + ------------------------------------------- + -- NOTE: only one dap session is supported + ------------------------------------------- + modifyIORef' graphServerStateIORef $ \s@GraphServerState{..} -> s {gssGraphChan = Just graphChan} sendGraphCommand :: ToJSON a => a -> IO () sendGraphCommand msg = do GraphServerState{..} <- readIORef graphServerStateIORef - BS.hPut gssHandle $ encodeBaseProtocolMessage msg - -runGraphServer :: IO () -runGraphServer = withSocketsDo $ do - let ServerConfig{..} = serverConfig0 - serverConfig = serverConfig0 - when debugLogging $ putStrLn ("Running GRAPH server on " <> show port <> "...") - serve (Host host) (show port) $ \(socket, address) -> do - when debugLogging $ do + case gssHandle of + Nothing -> when (graphServerDebugLogging gssConfig) $ putStrLn $ "no graph client, can not send graph command: " ++ show (Aeson.encode msg) + Just h -> BS.hPut h $ encodeBaseProtocolMessage msg + +sendGraphEvent :: GraphEvent -> IO () +sendGraphEvent ev = do + GraphServerState{..} <- readIORef graphServerStateIORef + case gssGraphChan of + Nothing -> when (graphServerDebugLogging gssConfig) $ putStrLn $ "no dap session, can not send graph event: " ++ show ev + Just GraphChan{..} -> Unagi.writeChan graphAsyncEventIn ev + +runGraphServer :: GraphServerConfig -> IO () +runGraphServer serverConfig = withSocketsDo $ do + let GraphServerConfig{..} = serverConfig + writeIORef graphServerStateIORef GraphServerState + { gssHandle = Nothing + , gssGraphChan = Nothing + , gssConfig = serverConfig + } + when graphServerDebugLogging $ putStrLn ("Running GRAPH server on " <> show graphServerPort <> "...") + serve (Host graphServerHost) (show graphServerPort) $ \(socket, address) -> do + when graphServerDebugLogging $ do putStrLn $ "TCP connection established from " ++ show address handle <- socketToHandle socket ReadWriteMode hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF } - modifyIORef' graphServerStateIORef $ \s -> s {gssHandle = handle} + ------------------------------------------- + -- NOTE: only one gephi client is supported + ------------------------------------------- + modifyIORef' graphServerStateIORef $ \s -> s {gssHandle = Just handle} serviceClient handle -- `catch` exceptionHandler handle address debugLogging serviceClient :: Handle -> IO () serviceClient handle = do - {- - get session id from message - lookup the communication channel based on session id - if there is no match then report and error, or use the first session as a fallback - -} nextRequest <- readPayload handle :: IO (Either String Value) print nextRequest case nextRequest of @@ -101,20 +124,8 @@ serviceClient handle = do | Just "showValue" <- Aeson.lookup "event" json , Just (Aeson.String nodeId) <- Aeson.lookup "nodeId" json -> do - GraphServerState{..} <- readIORef graphServerStateIORef - -- TODO: handle sessions correctly, select the right session - forM_ (Map.elems gssGraphChanMap) $ \GraphChan{..} -> do - Unagi.writeChan graphAsyncEventIn $ GraphEventShowValue nodeId + sendGraphEvent $ GraphEventShowValue nodeId Right json -> do putStrLn $ "unknown event: " ++ show nextRequest -- loop: serve the next request serviceClient handle - -{- - use cases: - debug one program - 1 vscode - 1 gephi - 1 estgi dap session / program - debug multiple programs --} \ No newline at end of file diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 1a4d010..878f3b2 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -102,18 +102,19 @@ import Graph -- Converts the 'Socket' to a 'Handle' for convenience main :: IO () main = do - config <- getConfig - forkIO runGraphServer + (config, graphConfig) <- getConfig + forkIO $ runGraphServer graphConfig finally (runDAPServer config talk) $ do putStrLn "dap finished, bye!" ---------------------------------------------------------------------------- -- | Fetch config from environment, fallback to sane defaults -getConfig :: IO ServerConfig +getConfig :: IO (ServerConfig, GraphServerConfig) getConfig = do let - hostDefault = "0.0.0.0" - portDefault = 4711 + hostDefault = "0.0.0.0" + portDefault = 4711 + graphPortDefault = 4721 capabilities = defaultCapabilities { supportsConfigurationDoneRequest = True , supportsHitConditionalBreakpoints = True @@ -128,12 +129,18 @@ getConfig = do , supportTerminateDebuggee = True , supportsLoadedSourcesRequest = True } - ServerConfig + config <- ServerConfig <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST" <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT" <*> pure capabilities <*> pure True + graphConfig <- GraphServerConfig + <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST" + <*> do fromMaybe graphPortDefault . (readMaybe =<<) <$> do lookupEnv "DAP_GRAPH_PORT" + <*> pure True + + pure (config, graphConfig) findProgram :: String -> IO [FilePath] findProgram globPattern = do @@ -336,6 +343,8 @@ talk CommandLoadedSources = do ---------------------------------------------------------------------------- talk (CustomCommand "getSourceLinks") = customCommandGetSourceLinks ---------------------------------------------------------------------------- +talk (CustomCommand "selectVariableGraphNode") = customCommandSelectVariableGraphNode +---------------------------------------------------------------------------- talk (CustomCommand "showVariableGraphStructure") = customCommandShowVariableGraphStructure ---------------------------------------------------------------------------- talk (CustomCommand "showCallGraph") = customCommandShowCallGraph From 29a168fadfc4fdfddc27cfb42ad937786ad25f34 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 18 Oct 2023 12:25:48 +0200 Subject: [PATCH 15/21] dap-estgi now can handle both .fullpak and .ghc_stgapp as input --- dap-estgi-server/src/Main.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 878f3b2..e4a1d00 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -173,12 +173,20 @@ data AttachArgs ---------------------------------------------------------------------------- initESTG :: AttachArgs -> Adaptor ESTG () initESTG AttachArgs {..} = do - ghcstgappPath <- (liftIO $ findProgram program) >>= \case + programPath <- (liftIO $ findProgram program) >>= \case [fname] -> pure fname - [] -> sendError (ErrorMessage (T.pack $ unlines ["No .ghc_stgapp program found at:", program])) Nothing + [] -> sendError (ErrorMessage (T.pack $ unlines ["No program found at:", program])) Nothing names -> sendError (ErrorMessage (T.pack $ unlines $ ["Ambiguous program path:", program, "Use more specific path pattern to fix the issue.", "Multiple matches:"] ++ names)) Nothing - let fullpakPath = ghcstgappPath -<.> ".fullpak" - liftIO $ mkFullpak ghcstgappPath False False fullpakPath + fullpakPath <- case takeExtension programPath of + ".fullpak" -> do + -- handle .fullpak + pure programPath + _ -> do + -- handle .ghc_stgapp + let fname = programPath -<.> ".fullpak" + liftIO $ mkFullpak programPath False False fname + pure fname + (sourceCodeList, unitIdMap, haskellSrcPathMap) <- liftIO $ getSourceCodeListFromFullPak fullpakPath (dbgAsyncI, dbgAsyncO) <- liftIO (Unagi.newChan 100) dbgRequestMVar <- liftIO MVar.newEmptyMVar From c8ce0c28d65718fdfe1129d8603fe843b6f8c9fa Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 3 Nov 2023 16:17:36 +0100 Subject: [PATCH 16/21] fix: significant speedup: open zip one time --- dap-estgi-server/src/SourceCode.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/dap-estgi-server/src/SourceCode.hs b/dap-estgi-server/src/SourceCode.hs index 2ded16e..0de88c7 100644 --- a/dap-estgi-server/src/SourceCode.hs +++ b/dap-estgi-server/src/SourceCode.hs @@ -14,7 +14,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Map.Strict as Map import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict ) import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) -import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries) +import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries, mkEntrySelector, getEntry) import Data.Yaml hiding (Array) import Stg.Syntax hiding (sourceName, Scope) @@ -59,12 +59,15 @@ getSourceName = \case ---------------------------------------------------------------------------- -- | Retrieves list of modules from .fullpak file getSourceCodeListFromFullPak :: FilePath -> IO ([SourceCodeDescriptor], Bimap UnitId PackageName, Bimap Name SourceCodeDescriptor) -getSourceCodeListFromFullPak fullPakPath = do - rawEntries <- fmap unEntrySelector . Map.keys <$> withArchive fullPakPath getEntries +getSourceCodeListFromFullPak fullPakPath = withArchive fullPakPath $ do + liftIO $ putStrLn "getSourceCodeListFromFullPak 1" + rawEntries <- fmap unEntrySelector . Map.keys <$> getEntries + liftIO $ putStrLn "getSourceCodeListFromFullPak 2" let folderNames = Set.fromList (takeDirectory <$> rawEntries) appInfoName = "app.info" - appInfoBytes <- readModpakL fullPakPath appInfoName id - AppInfo{..} <- decodeThrow (BL8.toStrict appInfoBytes) + readFromZip fname = mkEntrySelector fname >>= getEntry + appInfoBytes <- readFromZip appInfoName + AppInfo{..} <- liftIO $ decodeThrow (cs appInfoBytes) let unitIdMap = Bimap.fromList [ (UnitId $ cs ciUnitId, cs ciPackageName) | CodeInfo{..} <- aiLiveCode @@ -104,7 +107,8 @@ getSourceCodeListFromFullPak fullPakPath = do hsPathList <- forM aiLiveCode $ \CodeInfo{..} -> do let extStgPath = getSourcePath $ ExtStg (cs ciPackageName) (cs ciModuleName) - (_phase, _unitId, _modName, mSrcFilePath, _stubs, _hasForeignExport, _deps) <- readModpakL fullPakPath extStgPath decodeStgbinInfo + liftIO $ putStrLn $ "getSourceCodeListFromFullPak " ++ extStgPath + (_phase, _unitId, _modName, mSrcFilePath, _stubs, _hasForeignExport, _deps) <- decodeStgbinInfo . cs <$> readFromZip extStgPath case mSrcFilePath of Nothing -> pure [] Just p -> pure [(cs p, Haskell (cs ciPackageName) (cs ciModuleName))] @@ -132,6 +136,7 @@ getValidSourceRefFromSource Source{..} = do ---------------------------------------------------------------------------- -- | Retrieves list of modules from .fullpak file +-- TODO: precalc in a map getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)], [(StgPoint, Tickish)]) getSourceFromFullPak sourceId = do ESTG {..} <- getDebugSession From 351ef301b9335c91ff3cd8d0a1be9389164bed7f Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 3 Nov 2023 16:19:27 +0100 Subject: [PATCH 17/21] add progress event to get source links request --- dap-estgi-server/src/SourceLocation.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/dap-estgi-server/src/SourceLocation.hs b/dap-estgi-server/src/SourceLocation.hs index b817079..d33d340 100644 --- a/dap-estgi-server/src/SourceLocation.hs +++ b/dap-estgi-server/src/SourceLocation.hs @@ -32,6 +32,7 @@ getUnitIdAndModuleNameForStgPoint = \case SP_Binding StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) SP_Tickish stgPoint -> getUnitIdAndModuleNameForStgPoint stgPoint +-- TODO: precalc in a map getSourceAndPositionForStgPoint :: StgPoint -> Adaptor ESTG (Maybe Source, Int, Int, Int, Int) getSourceAndPositionForStgPoint stgPoint = do let (unitId, moduleNameBS) = getUnitIdAndModuleNameForStgPoint stgPoint @@ -91,8 +92,14 @@ getStgSourceLocJSON stgPoint = do ] pure srcLocJson +-- TODO: precalc in a map customCommandGetSourceLinks :: Adaptor ESTG () customCommandGetSourceLinks = do + let progressId = "estgi-get-source-links" + sendProgressStartEvent $ defaultProgressStartEvent + { progressStartEventProgressId = progressId + , progressStartEventTitle = "Running get source links..." + } GetSourceLinksArguments {..} <- getArguments ESTG {..} <- getDebugSession sourceLinks <- case Bimap.lookup getSourceLinksArgumentsPath dapSourceNameMap of @@ -131,3 +138,7 @@ customCommandGetSourceLinks = do sendSuccesfulResponse . setBody $ GetSourceLinksResponse { getSourceLinksResponseSourceLinks = sourceLinks } + sendProgressEndEvent $ defaultProgressEndEvent + { progressEndEventProgressId = progressId + , progressEndEventMessage = Just "Get source links finished." + } From 62d77745cb91cd6d9b30919e001f6f7658521ef4 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 3 Nov 2023 16:20:53 +0100 Subject: [PATCH 18/21] fix debug log json message formatting --- dap-estgi-server/src/GraphProtocol/Server.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/dap-estgi-server/src/GraphProtocol/Server.hs b/dap-estgi-server/src/GraphProtocol/Server.hs index fa12b62..b430f68 100644 --- a/dap-estgi-server/src/GraphProtocol/Server.hs +++ b/dap-estgi-server/src/GraphProtocol/Server.hs @@ -14,6 +14,7 @@ import qualified Data.Aeson.KeyMap as Aeson import qualified Data.ByteString.Char8 as BS +import Data.String.Conversions (cs) import Data.Text ( Text ) import qualified Data.Map.Strict as Map import Data.Map.Strict ( Map ) @@ -83,7 +84,7 @@ sendGraphCommand :: ToJSON a => a -> IO () sendGraphCommand msg = do GraphServerState{..} <- readIORef graphServerStateIORef case gssHandle of - Nothing -> when (graphServerDebugLogging gssConfig) $ putStrLn $ "no graph client, can not send graph command: " ++ show (Aeson.encode msg) + Nothing -> when (graphServerDebugLogging gssConfig) $ putStrLn $ "no graph client, can not send graph command: " ++ cs (Aeson.encode msg) Just h -> BS.hPut h $ encodeBaseProtocolMessage msg sendGraphEvent :: GraphEvent -> IO () From ac6bbf95ff2c15fd805804041b51b9dedf93713b Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 3 Nov 2023 16:22:29 +0100 Subject: [PATCH 19/21] add comments ; mark scope computation expensive --- dap-estgi-server/src/Inspect/Stack.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/dap-estgi-server/src/Inspect/Stack.hs b/dap-estgi-server/src/Inspect/Stack.hs index 7ad1bc9..3958af5 100644 --- a/dap-estgi-server/src/Inspect/Stack.hs +++ b/dap-estgi-server/src/Inspect/Stack.hs @@ -56,11 +56,13 @@ getScopesForStackContinuation frameIdDesc stackCont = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc let scope = defaultScope { scopeName = "Locals" + , scopeExpensive = True , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef } scopeWithSourceLoc <- case stackCont of CaseOf _ closureId _ _ _ _ -> do + -- Q: do we need scope source positions? (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr (binderToStgId . unId $ closureId)) pure scope { scopeSource = source @@ -78,10 +80,12 @@ getScopesForTopStackFrame -> Adaptor ESTG [Scope] getScopesForTopStackFrame frameIdDesc closureId = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc + -- Q: do we need scope source positions? (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr . binderToStgId $ unId closureId) pure [ defaultScope { scopeName = "Locals" + , scopeExpensive = True , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef , scopeSource = source @@ -129,6 +133,7 @@ commandStackTrace = do Just currentClosureId | ssCurrentThreadId == stackTraceArgumentsThreadId -> do + -- Q: do we need stack source positions? (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr . binderToStgId $ unId currentClosureId) frameId <- getFrameId FrameId_CurrentThreadTopStackFrame pure [ defaultStackFrame @@ -151,6 +156,7 @@ commandStackTrace = do case stackCont of CaseOf _ closureId _ scrutResultId _ _ -> do -- HINT: use the case scrutinee result's unique binder id to lookup source location info + -- Q: do we need stack source positions? (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_CaseScrutineeExpr . binderToStgId $ unId scrutResultId) pure $ defaultStackFrame { stackFrameId = frameId From 8317457dfad7da7dfc3993e62506cdfb166082e6 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 3 Nov 2023 16:29:33 +0100 Subject: [PATCH 20/21] add docker shared folder estgi app configuration ; add region custom requests ; report GC progress ; add retainer graph request --- dap-estgi-server/dap-estgi-server.cabal | 4 + dap-estgi-server/src/CustomCommands.hs | 37 +++++ dap-estgi-server/src/CustomDapTypes.hs | 31 +++++ dap-estgi-server/src/DapBase.hs | 16 ++- dap-estgi-server/src/Graph.hs | 74 +++++++++- dap-estgi-server/src/Main.hs | 98 +++++++++---- dap-estgi-server/src/Region.hs | 176 ++++++++++++++++++++++++ dap-estgi-server/src/SharedFolder.hs | 18 +++ 8 files changed, 418 insertions(+), 36 deletions(-) create mode 100644 dap-estgi-server/src/CustomDapTypes.hs create mode 100644 dap-estgi-server/src/Region.hs create mode 100644 dap-estgi-server/src/SharedFolder.hs diff --git a/dap-estgi-server/dap-estgi-server.cabal b/dap-estgi-server/dap-estgi-server.cabal index f7cc4f0..8a30376 100644 --- a/dap-estgi-server/dap-estgi-server.cabal +++ b/dap-estgi-server/dap-estgi-server.cabal @@ -24,6 +24,7 @@ executable dap-estgi Inspect.Value.HeapObject Inspect.Value.StackContinuation CustomCommands + CustomDapTypes GraphProtocol.Commands GraphProtocol.Server Graph @@ -31,6 +32,8 @@ executable dap-estgi DapBase SourceCode SourceLocation + SharedFolder + Region main-is: Main.hs @@ -45,6 +48,7 @@ executable dap-estgi , external-stg-interpreter , external-stg-syntax , external-stg + , directory , filepath , filemanip , lifted-base diff --git a/dap-estgi-server/src/CustomCommands.hs b/dap-estgi-server/src/CustomCommands.hs index 4d972f4..a5fd048 100644 --- a/dap-estgi-server/src/CustomCommands.hs +++ b/dap-estgi-server/src/CustomCommands.hs @@ -7,6 +7,7 @@ import GHC.Generics ( Generic ) import Data.Text import Data.Aeson import DAP.Utils +import CustomDapTypes data GetSourceLinksArguments = GetSourceLinksArguments @@ -53,6 +54,16 @@ instance FromJSON ShowVariableGraphStructureArguments where ---------------------------------------------------------------------------- +data ShowRetainerGraphArguments + = ShowRetainerGraphArguments + { showRetainerGraphArgumentsVariablesReference :: Int + } deriving stock (Show, Eq, Generic) + +instance FromJSON ShowRetainerGraphArguments where + parseJSON = genericParseJSONWithModifier + +---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- data SelectVariableGraphNodeArguments = SelectVariableGraphNodeArguments @@ -63,3 +74,29 @@ instance FromJSON SelectVariableGraphNodeArguments where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- +data RegionsResponse + = RegionsResponse + { regionsResponseRegions :: [Region] + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON RegionsResponse where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- + +data RegionInstancesArguments + = RegionInstancesArguments + { regionInstancesArgumentsRegionName :: Text + } deriving stock (Show, Eq, Generic) + +instance FromJSON RegionInstancesArguments where + parseJSON = genericParseJSONWithModifier + +---------------------------------------------------------------------------- +data RegionInstancesResponse + = RegionInstancesResponse + { regionInstancesResponseRegionInstances :: [RegionInstance] + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON RegionInstancesResponse where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- diff --git a/dap-estgi-server/src/CustomDapTypes.hs b/dap-estgi-server/src/CustomDapTypes.hs new file mode 100644 index 0000000..75da6c3 --- /dev/null +++ b/dap-estgi-server/src/CustomDapTypes.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +module CustomDapTypes where + +import GHC.Generics ( Generic ) + +import Data.Text +import Data.Aeson +import DAP.Utils + +---------------------------------------------------------------------------- +data Region + = Region + { regionName :: Text + , regionInstanceCount :: Int + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON Region where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- + +data RegionInstance + = RegionInstance + { regionInstanceInstanceId :: Int + , regionInstanceObjectCount :: Int + , regionInstanceVariablesReference :: Int + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON RegionInstance where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- diff --git a/dap-estgi-server/src/DapBase.hs b/dap-estgi-server/src/DapBase.hs index a238ac0..93ef0a7 100644 --- a/dap-estgi-server/src/DapBase.hs +++ b/dap-estgi-server/src/DapBase.hs @@ -87,6 +87,7 @@ data ValueRoot data DapVariablesRefDescriptor = VariablesRef_StackFrameVariables DapFrameIdDescriptor | VariablesRef_Value ValueRoot RefNamespace Int + | VariablesRef_RegionInstance Stg.Region Int deriving (Show, Eq, Ord) data SourceCodeDescriptor @@ -106,13 +107,14 @@ data SourceCodeDescriptor -- | External STG Interpreter application internal state data ESTG = ESTG - { debuggerChan :: DebuggerChan - , fullPakPath :: String - , breakpointMap :: Map Stg.Breakpoint IntSet - , sourceCodeSet :: Set SourceCodeDescriptor - , unitIdMap :: Bimap UnitId PackageName - , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor - , dapSourceNameMap :: Bimap Text SourceCodeDescriptor + { debuggerChan :: DebuggerChan + , fullPakPath :: String + , sharedFolderMapping :: Maybe (FilePath, FilePath) -- host absolute path, container absolute path + , breakpointMap :: Map Stg.Breakpoint IntSet + , sourceCodeSet :: Set SourceCodeDescriptor + , unitIdMap :: Bimap UnitId PackageName + , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor + , dapSourceNameMap :: Bimap Text SourceCodeDescriptor -- application specific resource handling diff --git a/dap-estgi-server/src/Graph.hs b/dap-estgi-server/src/Graph.hs index e680fb5..086cfe1 100644 --- a/dap-estgi-server/src/Graph.hs +++ b/dap-estgi-server/src/Graph.hs @@ -8,6 +8,7 @@ import Data.String.Conversions (cs) import Control.Monad import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T +import qualified Data.Map.Strict as Map import qualified Data.IntMap.Strict as IntMap import qualified Data.Bimap as Bimap import qualified Data.Set as Set @@ -20,6 +21,7 @@ import System.IO import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) import Stg.Interpreter.GC.GCRef import Stg.Interpreter.Debugger.TraverseState +import Stg.Interpreter.Debugger.Retainer import Stg.IRLocation import DAP @@ -28,6 +30,8 @@ import CustomCommands import GraphProtocol.Server import GraphProtocol.Commands import Inspect.Value.Atom +import SharedFolder +import Region customCommandSelectVariableGraphNode :: Adaptor ESTG () customCommandSelectVariableGraphNode = do @@ -43,10 +47,68 @@ customCommandSelectVariableGraphNode = do sendSuccesfulEmptyResponse Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variables ref: " ++ show selectVariableGraphNodeArgumentsVariablesReference)) Nothing +customCommandShowRetainerGraph :: Adaptor ESTG () +customCommandShowRetainerGraph = do + ShowRetainerGraphArguments {..} <- getArguments +{- + = ShowRetainerGraphArguments + { showRetainerGraphArgumentsVariablesReference :: Int +-} + getsApp (Bimap.lookupR showRetainerGraphArgumentsVariablesReference . dapVariablesRefMap) >>= \case + Just (VariablesRef_Value _valueRoot valueNameSpace addr) -> do + stgState@StgState{..} <- getStgState + valueSummary <- getValueSummary valueNameSpace addr + + -- generate names + ESTG {..} <- getDebugSession + let nodesFname = fullPakPath ++ "-graph-nodes.tsv" + edgesFname = fullPakPath ++ "-graph-edges.tsv" + hostNodesFname <- mapFilePathToHost nodesFname + hostEdgesFname <- mapFilePathToHost edgesFname + + liftIO $ exportRetainerGraph nodesFname edgesFname stgState $ encodeRef addr valueNameSpace + liftIO $ sendGraphCommand LoadGraph + { loadGraphRequest = "loadGraph" + , loadGraphTitle = cs $ show addr ++ " " ++ valueSummary + , loadGraphNodesFilepath = Just $ cs hostNodesFname + , loadGraphEdgesFilepath = cs hostEdgesFname + } + sendSuccesfulEmptyResponse + Just v -> sendError (ErrorMessage (T.pack $ "Visualization is not yet supported for: " ++ show v)) Nothing + Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variables ref: " ++ show showRetainerGraphArgumentsVariablesReference)) Nothing + customCommandShowVariableGraphStructure :: Adaptor ESTG () customCommandShowVariableGraphStructure = do ShowVariableGraphStructureArguments {..} <- getArguments getsApp (Bimap.lookupR showVariableGraphStructureArgumentsVariablesReference . dapVariablesRefMap) >>= \case + Just r@(VariablesRef_RegionInstance region idx) -> do + stgState@StgState{..} <- getStgState + case Map.lookup region ssRegionInstances of + Just instanceMap + | Just (start, end) <- IntMap.lookup idx instanceMap + -> do + -- generate names + ESTG {..} <- getDebugSession + let nodesFname = fullPakPath ++ "-graph-nodes.tsv" + edgesFname = fullPakPath ++ "-graph-edges.tsv" + hostNodesFname <- mapFilePathToHost nodesFname + hostEdgesFname <- mapFilePathToHost edgesFname + + let heap = getRegionHeap (asNextHeapAddr start) (asNextHeapAddr end) ssHeap + title = case region of + IRRegion{} -> "region instance " ++ show idx + EventRegion{..} -> cs regionName ++ " instance " ++ show idx + liftIO $ exportHeapGraph nodesFname edgesFname heap + liftIO $ sendGraphCommand LoadGraph + { loadGraphRequest = "loadGraph" + , loadGraphTitle = cs title + , loadGraphNodesFilepath = Just $ cs hostNodesFname + , loadGraphEdgesFilepath = cs hostEdgesFname + } + sendSuccesfulEmptyResponse + + _ -> sendError (ErrorMessage (T.pack $ "Unknown region instance: " ++ show r)) Nothing + Just VariablesRef_StackFrameVariables{} -> do -- TODO: create graph from the full stack frame sendSuccesfulEmptyResponse @@ -58,13 +120,15 @@ customCommandShowVariableGraphStructure = do ESTG {..} <- getDebugSession let nodesFname = fullPakPath ++ "-graph-nodes.tsv" edgesFname = fullPakPath ++ "-graph-edges.tsv" + hostNodesFname <- mapFilePathToHost nodesFname + hostEdgesFname <- mapFilePathToHost edgesFname liftIO $ exportReachableGraph nodesFname edgesFname stgState $ encodeRef addr valueNameSpace liftIO $ sendGraphCommand LoadGraph { loadGraphRequest = "loadGraph" , loadGraphTitle = cs $ show addr ++ " " ++ valueSummary - , loadGraphNodesFilepath = Just $ cs nodesFname - , loadGraphEdgesFilepath = cs edgesFname + , loadGraphNodesFilepath = Just $ cs hostNodesFname + , loadGraphEdgesFilepath = cs hostEdgesFname } sendSuccesfulEmptyResponse Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variables ref: " ++ show showVariableGraphStructureArgumentsVariablesReference)) Nothing @@ -74,6 +138,8 @@ customCommandShowCallGraph = do ESTG {..} <- getDebugSession let nodesFname = fullPakPath ++ "-graph-nodes.tsv" edgesFname = fullPakPath ++ "-graph-edges.tsv" + hostNodesFname <- mapFilePathToHost nodesFname + hostEdgesFname <- mapFilePathToHost edgesFname StgState{..} <- getStgState liftIO $ do writeCallGraphEdges edgesFname ssCallGraph @@ -81,8 +147,8 @@ customCommandShowCallGraph = do sendGraphCommand LoadGraph { loadGraphRequest = "loadGraph" , loadGraphTitle = cs $ takeFileName fullPakPath ++ " call graph" - , loadGraphNodesFilepath = Just $ cs nodesFname - , loadGraphEdgesFilepath = cs edgesFname + , loadGraphNodesFilepath = Just $ cs hostNodesFname + , loadGraphEdgesFilepath = cs hostEdgesFname } sendSuccesfulEmptyResponse diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index e4a1d00..a6d9301 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -25,7 +25,6 @@ module Main (main) where import Data.List import Data.String.Conversions (cs) import Text.PrettyPrint.ANSI.Leijen (pretty, plain) -import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries) import Data.IntSet ( IntSet ) import qualified Data.IntSet as IntSet import Data.Set ( Set ) @@ -61,8 +60,10 @@ import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fr import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi import Control.Concurrent.MVar ( MVar ) import qualified Control.Concurrent.MVar as MVar -import Control.Concurrent ( forkIO ) +import Control.Concurrent ( forkIO, ThreadId ) import qualified System.FilePath.Find as Glob +import System.IO.Unsafe ( unsafePerformIO ) +import System.IO ---------------------------------------------------------------------------- import Stg.Syntax hiding (sourceName, Scope) import Stg.IRLocation @@ -76,7 +77,6 @@ import Stg.Interpreter.Debugger import Stg.Interpreter.Debugger.UI import Stg.Interpreter.Debugger.TraverseState import Stg.Interpreter.GC.GCRef -import Stg.IO import Stg.Program import Stg.Fullpak import Data.Yaml hiding (Array) @@ -84,7 +84,7 @@ import qualified Text.Pretty.Simple as PP ---------------------------------------------------------------------------- import DAP hiding (send) ---------------------------------------------------------------------------- -import DapBase +import DapBase hiding (ThreadId) import CustomCommands import GraphProtocol.Commands import GraphProtocol.Server @@ -95,6 +95,7 @@ import Inspect.Value.Atom import Inspect.Value import Inspect.Stack import Graph +import Region ---------------------------------------------------------------------------- -- | DAP entry point -- Extracts configuration information from the environment @@ -102,6 +103,7 @@ import Graph -- Converts the 'Socket' to a 'Handle' for convenience main :: IO () main = do + hSetBuffering stdout LineBuffering (config, graphConfig) <- getConfig forkIO $ runGraphServer graphConfig finally (runDAPServer config talk) $ do @@ -155,6 +157,7 @@ findProgram globPattern = do -- > "__sessionId": "6c0ba6f8-e478-4698-821e-356fc4a72c3d", -- > "name": "thing", -- > "program": "/home/dmjio/Desktop/stg-dap/test.ghc_stgapp", +-- > "programArguments": [], -- > "request": "attach", -- > "type": "dap-estgi-extension" -- > } @@ -165,9 +168,20 @@ data AttachArgs -- ^ SessionID from VSCode , program :: String -- ^ Path or glob pattern to .ghc_stgapp file + , programArguments :: [String] + -- ^ Arguments that ESTGi will pass to the interpreted program + , sharedFolderHostPath :: Maybe String + -- ^ Shared folder path on the host machine when the program is running in a VM container (i.e. Docker) + , sharedFolderContainerPath :: Maybe String + -- ^ Shared folder path in the container when the program is running in a VM container (i.e. Docker) } deriving stock (Show, Eq, Generic) deriving anyclass FromJSON +{- + TODO: + implement launch / attach mode +-} + ---------------------------------------------------------------------------- -- | Intialize ESTG interpreter ---------------------------------------------------------------------------- @@ -187,17 +201,35 @@ initESTG AttachArgs {..} = do liftIO $ mkFullpak programPath False False fname pure fname - (sourceCodeList, unitIdMap, haskellSrcPathMap) <- liftIO $ getSourceCodeListFromFullPak fullpakPath - (dbgAsyncI, dbgAsyncO) <- liftIO (Unagi.newChan 100) - dbgRequestMVar <- liftIO MVar.newEmptyMVar - dbgResponseMVar <- liftIO MVar.newEmptyMVar - let dbgChan = DebuggerChan - { dbgSyncRequest = dbgRequestMVar - , dbgSyncResponse = dbgResponseMVar - , dbgAsyncEventIn = dbgAsyncI - , dbgAsyncEventOut = dbgAsyncO - } - (graphAsyncI, graphAsyncO) <- liftIO (Unagi.newChan 100) + let shaderFolder = (,) <$> sharedFolderHostPath <*> sharedFolderContainerPath + dbgChan <- liftIO $ newDebuggerChan + (graphChan, estg) <- liftIO $ prepareESTG shaderFolder dbgChan fullpakPath + flip catch handleDebuggerExceptions $ do + registerNewDebugSession __sessionId estg + [ \_withAdaptor -> loadAndRunProgram True True fullpakPath programArguments dbgChan DbgStepByStep False defaultDebugSettings + , handleDebugEvents dbgChan + , handleGraphEvents graphChan + ] + liftIO $ registerGraphChan __sessionId graphChan + +newDebuggerChan :: IO DebuggerChan +newDebuggerChan = do + (dbgAsyncI, dbgAsyncO) <- Unagi.newChan 100 + dbgRequestMVar <- MVar.newEmptyMVar + dbgResponseMVar <- MVar.newEmptyMVar + pure DebuggerChan + { dbgSyncRequest = dbgRequestMVar + , dbgSyncResponse = dbgResponseMVar + , dbgAsyncEventIn = dbgAsyncI + , dbgAsyncEventOut = dbgAsyncO + } + +prepareESTG :: Maybe (FilePath, FilePath) -> DebuggerChan -> String -> IO (GraphChan, ESTG) +prepareESTG shaderFolder dbgChan fullpakPath = do + liftIO $ putStrLn "prepareESTG [start]" + (sourceCodeList, unitIdMap, haskellSrcPathMap) <- getSourceCodeListFromFullPak fullpakPath + liftIO $ putStrLn "prepareESTG [end]" + (graphAsyncI, graphAsyncO) <- Unagi.newChan 100 let graphChan = GraphChan { graphAsyncEventIn = graphAsyncI , graphAsyncEventOut = graphAsyncO @@ -205,6 +237,7 @@ initESTG AttachArgs {..} = do estg = ESTG { debuggerChan = dbgChan , fullPakPath = fullpakPath + , sharedFolderMapping = shaderFolder , breakpointMap = mempty , sourceCodeSet = Set.fromList sourceCodeList , unitIdMap = unitIdMap @@ -216,13 +249,10 @@ initESTG AttachArgs {..} = do , dapStackFrameCache = mempty , nextFreshBreakpointId = 1 } - flip catch handleDebuggerExceptions $ do - registerNewDebugSession __sessionId estg - [ \_withAdaptor -> loadAndRunProgram True True fullpakPath [] dbgChan DbgStepByStep False defaultDebugSettings - , handleDebugEvents dbgChan - , handleGraphEvents graphChan - ] - liftIO $ registerGraphChan __sessionId graphChan + pure (graphChan, estg) + +sendEvent :: ToJSON a => EventType -> a -> Adaptor ESTG () +sendEvent ev = sendSuccesfulEvent ev . setBody ---------------------------------------------------------------------------- -- | Graph Event Handler @@ -230,7 +260,6 @@ handleGraphEvents :: GraphChan -> (Adaptor ESTG () -> IO ()) -> IO () handleGraphEvents GraphChan{..} withAdaptor = forever $ do graphEvent <- liftIO (Unagi.readChan graphAsyncEventOut) withAdaptor . flip catch handleDebuggerExceptions $ do - let sendEvent ev = sendSuccesfulEvent ev . setBody case graphEvent of GraphEventShowValue nodeId | Just programPoint <- readMaybe $ cs nodeId @@ -264,7 +293,6 @@ handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do dbgEvent <- liftIO (Unagi.readChan dbgAsyncEventOut) withAdaptor . flip catch handleDebuggerExceptions $ do ESTG {..} <- getDebugSession - let sendEvent ev = sendSuccesfulEvent ev . setBody case dbgEvent of DbgEventStopped -> do resetObjectLifetimes @@ -274,6 +302,7 @@ handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do , "allThreadsStopped" .= True , "threadId" .= Number (fromIntegral ssCurrentThreadId) ] + sendEvent (EventTypeCustom "refreshCustomViews") Null DbgEventHitBreakpoint bkpName -> do resetObjectLifetimes @@ -286,6 +315,7 @@ handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do [ "hitBreakpointIds" .= idSet | Just idSet <- pure $ M.lookup bkpName breakpointMap ] + sendEvent (EventTypeCustom "refreshCustomViews") Null ---------------------------------------------------------------------------- -- | Exception Handler @@ -315,8 +345,20 @@ talk CommandAttach = do ---------------------------------------------------------------------------- talk (CustomCommand "garbageCollect") = do logInfo "Running garbage collection..." + let progressId = "estgi-gc" + sendProgressStartEvent $ defaultProgressStartEvent + { progressStartEventProgressId = progressId + , progressStartEventTitle = "Running garbage collection..." + } sendAndWait (CmdInternal "gc") + logInfo "Running garbage collection...done" + reportRegions sendSuccesfulEmptyResponse + sendProgressEndEvent $ defaultProgressEndEvent + { progressEndEventProgressId = progressId + , progressEndEventMessage = Just "Garbage collection finished." + } + sendEvent (EventTypeCustom "refreshCustomViews") Null ---------------------------------------------------------------------------- talk CommandContinue = do ESTG {..} <- getDebugSession @@ -353,10 +395,16 @@ talk (CustomCommand "getSourceLinks") = customCommandGetSourceLinks ---------------------------------------------------------------------------- talk (CustomCommand "selectVariableGraphNode") = customCommandSelectVariableGraphNode ---------------------------------------------------------------------------- +talk (CustomCommand "showRetainerGraph") = customCommandShowRetainerGraph +---------------------------------------------------------------------------- talk (CustomCommand "showVariableGraphStructure") = customCommandShowVariableGraphStructure ---------------------------------------------------------------------------- talk (CustomCommand "showCallGraph") = customCommandShowCallGraph ---------------------------------------------------------------------------- +talk (CustomCommand "regions") = customCommandRegions +---------------------------------------------------------------------------- +talk (CustomCommand "regionInstances") = customCommandRegionInstances +---------------------------------------------------------------------------- talk CommandModules = do sendModulesResponse (ModulesResponse [] Nothing) ---------------------------------------------------------------------------- @@ -403,7 +451,7 @@ talk CommandVariables = do | otherwise = v {variableName = variableName v <> " "} sendVariablesResponse (VariablesResponse $ map markLoop variables) - Nothing -> do + _ -> do sendVariablesResponse (VariablesResponse []) ---------------------------------------------------------------------------- talk CommandNext = do diff --git a/dap-estgi-server/src/Region.hs b/dap-estgi-server/src/Region.hs new file mode 100644 index 0000000..2cad442 --- /dev/null +++ b/dap-estgi-server/src/Region.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module Region + ( reportRegions + , customCommandRegions + , customCommandRegionInstances + , getRegionHeap + ) where + +import Text.Printf +import Control.Monad.IO.Class +import Control.Monad.State + +import Data.String.Conversions (cs) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import Data.Map.Strict ( Map ) + +import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint, Region) + +import DAP +import DapBase +import CustomDapTypes +import CustomCommands + +customCommandRegions :: Adaptor ESTG () +customCommandRegions = do + {- + region instance map + - calc region name + - calc region heap size + -} + StgState{..} <- getStgState + regions <- forM (Map.toList ssRegionInstances) $ \(r, instances) -> do + let name = case r of + IRRegion{} -> cs $ show r + EventRegion{..} -> cs regionName + pure Region + { regionName = name + , regionInstanceCount = length instances + } + sendSuccesfulResponse . setBody $ RegionsResponse + { regionsResponseRegions = regions + } + +customCommandRegionInstances :: Adaptor ESTG () +customCommandRegionInstances = do + RegionInstancesArguments {..} <- getArguments + StgState{..} <- getStgState + let region = EventRegion $ cs regionInstancesArgumentsRegionName + regionInstances <- case Map.lookup region ssRegionInstances of + Nothing -> pure [] + Just instances -> forM (IntMap.toList instances) $ \(idx, (start, end)) -> do + let heap = getRegionHeap (asNextHeapAddr start) (asNextHeapAddr end) ssHeap + varsRef <- getVariablesRef $ VariablesRef_RegionInstance region idx + pure RegionInstance + { regionInstanceInstanceId = idx + , regionInstanceObjectCount = IntMap.size heap + , regionInstanceVariablesReference = varsRef + } + sendSuccesfulResponse . setBody $ RegionInstancesResponse + { regionInstancesResponseRegionInstances = regionInstances + } + +--------------------- +reportRegions :: Adaptor ESTG () +reportRegions = do + stgState@StgState{..} <- getStgState + evalStateT (mapM_ parseRegion $ reverse ssTraceMarkers) $ RegionState Map.empty stgState Map.empty + +{- + estgi.debug.region.start + + logInfo "Running garbage collection...done" + , ssTraceMarkers :: ![(String, Int, AddressState)] + +getRegionHeap :: Int -> Int -> M Heap +getRegionHeap start end = do + heap <- gets ssHeap + let ltEnd = fst $ IntMap.split end heap + geStart = snd $ IntMap.split (start-1) ltEnd + pure geStart + +showRegion :: Bool -> String -> String -> M () +showRegion doHeapDump start end = do + regions <- gets ssRegions + let r = Region (BS8.pack start) (BS8.pack end) + printDelimiter = when doHeapDump $ liftIO $ putStrLn "\n==============================================================================\n" + case Map.lookup r regions of + Nothing -> pure () + Just (cur, _curCallGraph, l) -> do + liftIO $ putStrLn $ "region data count: " ++ show (length l) + liftIO $ putStrLn $ "order: OLD -> NEW" + forM_ (reverse l) $ \(s, e) -> do + printDelimiter + let sAddr = asNextHeapAddr s + eAddr = asNextHeapAddr e + rHeap <- getRegionHeap sAddr eAddr + liftIO $ printf "heap start: %-10d end: %-10d object count: %d\n" sAddr eAddr (IntMap.size rHeap) + when doHeapDump $ do + liftIO $ putStrLn "" + dumpHeapM rHeap + liftIO $ putStrLn "" + printDelimiter +-} + +data RegionInstanceData + = RegionInstanceData + { ridStart :: AddressState + , ridEnd :: AddressState + , ridHeap :: Heap + } + +type R = StateT RegionState (Adaptor ESTG) + +data RegionState + = RegionState + { rsRegionStack :: Map (Int, String) [AddressState] + , rsStgState :: StgState + , rsInstances :: Map String [RegionInstanceData] + } + + {- + TODO: + parse region stack + report on the fly + -} +parseRegion :: (String, Int, AddressState) -> R () +parseRegion (msg, tid, addrState) = do + case words msg of + ["estgi.debug.region.start", regionName] -> do + pushRegion tid regionName addrState + + ["estgi.debug.region.end", regionName] -> do + popRegion tid regionName >>= \case + Nothing -> lift .logError . cs $ "missing region start for: " ++ show (tid, regionName) + Just startAddrState -> do + reportRegion regionName startAddrState addrState + + _ -> pure () + +pushRegion :: Int -> String -> AddressState -> R () +pushRegion tid regionName addrState = modify' $ \s@RegionState{..} -> s {rsRegionStack = Map.insertWith (++) (tid, regionName) [addrState] rsRegionStack} + +popRegion :: Int -> String -> R (Maybe AddressState) +popRegion tid regionName = do + Map.lookup (tid, regionName) <$> gets rsRegionStack >>= \case + Nothing -> pure Nothing + Just (x : xs) -> do + modify' $ \s@RegionState{..} -> s {rsRegionStack = Map.insert (tid, regionName) xs rsRegionStack} + pure $ Just x + +reportRegion :: String -> AddressState -> AddressState -> R () +reportRegion regionName start end = do + let sAddr = asNextHeapAddr start + eAddr = asNextHeapAddr end + rHeap <- getRegionHeapM sAddr eAddr + let instanceData = RegionInstanceData + { ridStart = start + , ridEnd = end + , ridHeap = rHeap + } + modify' $ \s@RegionState{..} -> s {rsInstances = Map.insertWith (++) regionName [instanceData] rsInstances} + let str :: String + str = printf "region: %-10s heap start: %-10d end: %-10d object count: %d\n" regionName sAddr eAddr (IntMap.size rHeap) + lift . logInfo $ cs str + +getRegionHeap :: Int -> Int -> Heap -> Heap +getRegionHeap start end heap = geStart + where + ltEnd = fst $ IntMap.split end heap + geStart = snd $ IntMap.split (start-1) ltEnd + +getRegionHeapM :: Int -> Int -> R Heap +getRegionHeapM start end = gets $ getRegionHeap start end . ssHeap . rsStgState diff --git a/dap-estgi-server/src/SharedFolder.hs b/dap-estgi-server/src/SharedFolder.hs new file mode 100644 index 0000000..70a1918 --- /dev/null +++ b/dap-estgi-server/src/SharedFolder.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE RecordWildCards #-} +module SharedFolder where + +import Control.Monad.IO.Class +import System.Directory +import System.FilePath + +import DAP +import DapBase + +mapFilePathToHost :: FilePath -> Adaptor ESTG FilePath +mapFilePathToHost path = do + ESTG {..} <- getDebugSession + case sharedFolderMapping of + Nothing -> pure path + Just (hostAbsPath, containerAbsPath) -> do + absPath <- liftIO $ makeAbsolute path + pure $ hostAbsPath makeRelative containerAbsPath absPath From 3e4d0a5c65f7dba1f91472f801b73107c98fd6a5 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 3 Nov 2023 16:36:30 +0100 Subject: [PATCH 21/21] update deps --- stack.yaml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 806c5c5..9e1bf97 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,6 +4,7 @@ packages: - dap-estgi-server extra-deps: + - dom-lt-0.2.3 - souffle-haskell-3.5.1 - type-errors-pretty-0.0.1.2@sha256:9042b64d1ac2f69aa55690576504a2397ebea8a6a55332242c88f54027c7eb57,2781 - async-pool-0.9.1@sha256:4015140f896c3f1652b06a679b0ade2717d05557970c283ea2c372a71be2a6a1,1605 @@ -12,10 +13,10 @@ extra-deps: commit: ac9616b94cb8c4a9e07188d19979a6225ebd5a10 - git: https://github.com/haskell-debugger/dap - commit: 31c114964e30b8c96279ddef6fbe8d6549b52e9e + commit: 0990087985da0bc14388fd2d394f8aff1bcf7d7a - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project - commit: 59aacc82f1d15e1534cbdd52cdce781cbd6c81dc + commit: a4b0c92cdf5dfb204be314e5f47d71fc8e5bc06b subdirs: - external-stg - external-stg-syntax