diff --git a/dap-estgi-server/dap-estgi-server.cabal b/dap-estgi-server/dap-estgi-server.cabal index c1030b4..8a30376 100644 --- a/dap-estgi-server/dap-estgi-server.cabal +++ b/dap-estgi-server/dap-estgi-server.cabal @@ -17,6 +17,24 @@ extra-source-files: CHANGELOG.md executable dap-estgi + other-modules: + Inspect.Stack + Inspect.Value + Inspect.Value.Atom + Inspect.Value.HeapObject + Inspect.Value.StackContinuation + CustomCommands + CustomDapTypes + GraphProtocol.Commands + GraphProtocol.Server + Graph + Breakpoints + DapBase + SourceCode + SourceLocation + SharedFolder + Region + main-is: Main.hs ghc-options: @@ -30,6 +48,7 @@ executable dap-estgi , external-stg-interpreter , external-stg-syntax , external-stg + , directory , filepath , filemanip , lifted-base @@ -45,6 +64,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..969a70c --- /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 hsCodeDesc@(Haskell pkg mod)) + | Just extStgSourceRef <- Bimap.lookup (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 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 new file mode 100644 index 0000000..a5fd048 --- /dev/null +++ b/dap-estgi-server/src/CustomCommands.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +module CustomCommands where + +import GHC.Generics ( Generic ) + +import Data.Text +import Data.Aeson +import DAP.Utils +import CustomDapTypes + +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 + +---------------------------------------------------------------------------- +data ShowVariableGraphStructureArguments + = ShowVariableGraphStructureArguments + { showVariableGraphStructureArgumentsVariablesReference :: Int + } deriving stock (Show, Eq, Generic) + +instance FromJSON ShowVariableGraphStructureArguments where + parseJSON = genericParseJSONWithModifier + +---------------------------------------------------------------------------- + +data ShowRetainerGraphArguments + = ShowRetainerGraphArguments + { showRetainerGraphArgumentsVariablesReference :: Int + } deriving stock (Show, Eq, Generic) + +instance FromJSON ShowRetainerGraphArguments where + parseJSON = genericParseJSONWithModifier + +---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- +data SelectVariableGraphNodeArguments + = SelectVariableGraphNodeArguments + { selectVariableGraphNodeArgumentsVariablesReference :: Int + } deriving stock (Show, Eq, Generic) + +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 new file mode 100644 index 0000000..93ef0a7 --- /dev/null +++ b/dap-estgi-server/src/DapBase.hs @@ -0,0 +1,213 @@ +{-# 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_Value ValueRoot RefNamespace Int + | VariablesRef_RegionInstance Stg.Region 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) + +---------------------------------------------------------------------------- +-- | External STG Interpreter application internal state +data ESTG + = ESTG + { 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 + + , dapSourceRefMap :: !(Bimap SourceCodeDescriptor 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..086cfe1 --- /dev/null +++ b/dap-estgi-server/src/Graph.hs @@ -0,0 +1,235 @@ +{-# 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 +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 + +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.Debugger.Retainer +import Stg.IRLocation + +import DAP +import DapBase +import CustomCommands +import GraphProtocol.Server +import GraphProtocol.Commands +import Inspect.Value.Atom +import SharedFolder +import Region + +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 + +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 + 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 $ exportReachableGraph nodesFname edgesFname stgState $ encodeRef addr valueNameSpace + liftIO $ sendGraphCommand LoadGraph + { loadGraphRequest = "loadGraph" + , loadGraphTitle = cs $ show addr ++ " " ++ valueSummary + , loadGraphNodesFilepath = Just $ cs hostNodesFname + , loadGraphEdgesFilepath = cs hostEdgesFname + } + sendSuccesfulEmptyResponse + Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variables ref: " ++ show showVariableGraphStructureArgumentsVariablesReference)) Nothing + +customCommandShowCallGraph :: Adaptor ESTG () +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 + writeCallGraphNodes nodesFname ssCallGraph + sendGraphCommand LoadGraph + { loadGraphRequest = "loadGraph" + , loadGraphTitle = cs $ takeFileName fullPakPath ++ " call graph" + , loadGraphNodesFilepath = Just $ cs hostNodesFname + , loadGraphEdgesFilepath = cs hostEdgesFname + } + 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 new file mode 100644 index 0000000..fc8277a --- /dev/null +++ b/dap-estgi-server/src/GraphProtocol/Commands.hs @@ -0,0 +1,34 @@ +{-# 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 + , loadGraphNodesFilepath :: Maybe Text + , loadGraphEdgesFilepath :: Text + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON LoadGraph where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- + + +data SelectNode + = SelectNode + { selectNodeRequest :: Text + , selectNodeNodeId :: Text + } deriving stock (Show, Eq, Generic) +---------------------------------------------------------------------------- +instance ToJSON SelectNode 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..b430f68 --- /dev/null +++ b/dap-estgi-server/src/GraphProtocol/Server.hs @@ -0,0 +1,132 @@ +{-# 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.String.Conversions (cs) +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 + +data GraphServerConfig + = GraphServerConfig + { graphServerHost :: String + , graphServerPort :: Int + , graphServerDebugLogging :: Bool + } + +data GraphEvent + = GraphEventShowValue Text + deriving (Show, Eq, Ord) + +data GraphChan + = GraphChan + { graphAsyncEventIn :: InChan GraphEvent + , graphAsyncEventOut :: OutChan GraphEvent + } + deriving Eq + +instance Show GraphChan where + show _ = "GraphChan" + +data GraphServerState + = GraphServerState + { gssHandle :: Maybe Handle + , gssGraphChan :: Maybe GraphChan + , gssConfig :: GraphServerConfig + } + +{- + 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 $ error "uninitialized graph server" + +registerGraphChan :: Text -> GraphChan -> IO () +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 + case gssHandle of + 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 () +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 } + ------------------------------------------- + -- 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 + nextRequest <- readPayload handle :: IO (Either String Value) + print nextRequest + case nextRequest of + Left err -> do + putStrLn $ "error: " ++ err + Right (Aeson.Object json) + | Just "showValue" <- Aeson.lookup "event" json + , Just (Aeson.String nodeId) <- Aeson.lookup "nodeId" json + -> do + sendGraphEvent $ GraphEventShowValue nodeId + Right json -> do + putStrLn $ "unknown event: " ++ show nextRequest + -- loop: serve the next request + serviceClient handle diff --git a/dap-estgi-server/src/Inspect/Stack.hs b/dap-estgi-server/src/Inspect/Stack.hs new file mode 100644 index 0000000..3958af5 --- /dev/null +++ b/dap-estgi-server/src/Inspect/Stack.hs @@ -0,0 +1,205 @@ +{-# 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" + , 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 + , 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 + -- 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 + , 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 + -- Q: do we need stack source positions? + (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 + -- Q: do we need stack source positions? + (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..064da6d --- /dev/null +++ b/dap-estgi-server/src/Inspect/Value.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +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 + 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 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..e0a1332 --- /dev/null +++ b/dap-estgi-server/src/Inspect/Value/Atom.hs @@ -0,0 +1,174 @@ +{-# 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 Foreign.Ptr + +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{..} 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", 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) + 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 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 +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 + } + +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) 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 8f20377..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 ) @@ -39,6 +38,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,17 +50,20 @@ 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 ) -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, 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 @@ -72,7 +75,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.IO +import Stg.Interpreter.Debugger.TraverseState +import Stg.Interpreter.GC.GCRef import Stg.Program import Stg.Fullpak import Data.Yaml hiding (Array) @@ -80,21 +84,39 @@ import qualified Text.Pretty.Simple as PP ---------------------------------------------------------------------------- import DAP hiding (send) ---------------------------------------------------------------------------- +import DapBase hiding (ThreadId) +import CustomCommands +import GraphProtocol.Commands +import GraphProtocol.Server +import SourceCode +import SourceLocation +import Breakpoints +import Inspect.Value.Atom +import Inspect.Value +import Inspect.Stack +import Graph +import Region +---------------------------------------------------------------------------- -- | DAP entry point -- Extracts configuration information from the environment -- Opens a listen socket on a port (defaulting to '4711') -- Converts the 'Socket' to a 'Handle' for convenience main :: IO () main = do - config <- getConfig - runDAPServer config talk + hSetBuffering stdout LineBuffering + (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 @@ -109,12 +131,25 @@ 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 + 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": { @@ -122,6 +157,7 @@ getConfig = 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" -- > } @@ -132,93 +168,131 @@ 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 ----------------------------------------------------------------------------- --- | 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 +{- + TODO: + implement launch / attach mode +-} ---------------------------------------------------------------------------- -- | Intialize ESTG interpreter ---------------------------------------------------------------------------- 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 - (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 + 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 + + 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 } estg = ESTG { debuggerChan = dbgChan , fullPakPath = fullpakPath + , sharedFolderMapping = shaderFolder , breakpointMap = mempty , 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 - , dapVariablesRefStore = mempty + , dapStackFrameCache = mempty , nextFreshBreakpointId = 1 } - flip catch handleDebuggerExceptions - $ registerNewDebugSession __sessionId estg - (loadAndRunProgram True True fullpakPath [] dbgChan DbgStepByStep False defaultDebugSettings) - (handleDebugEvents dbgChan) + pure (graphChan, estg) + +sendEvent :: ToJSON a => EventType -> a -> Adaptor ESTG () +sendEvent ev = sendSuccesfulEvent ev . setBody + +---------------------------------------------------------------------------- +-- | Graph Event Handler +handleGraphEvents :: GraphChan -> (Adaptor ESTG () -> IO ()) -> IO () +handleGraphEvents GraphChan{..} withAdaptor = forever $ do + graphEvent <- liftIO (Unagi.readChan graphAsyncEventOut) + withAdaptor . flip catch handleDebuggerExceptions $ do + case graphEvent of + 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 + + 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 + ] + + 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 DbgEventStopped -> do resetObjectLifetimes @@ -228,6 +302,7 @@ handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do , "allThreadsStopped" .= True , "threadId" .= Number (fromIntegral ssCurrentThreadId) ] + sendEvent (EventTypeCustom "refreshCustomViews") Null DbgEventHitBreakpoint bkpName -> do resetObjectLifetimes @@ -240,6 +315,7 @@ handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do [ "hitBreakpointIds" .= idSet | Just idSet <- pure $ M.lookup bkpName breakpointMap ] + sendEvent (EventTypeCustom "refreshCustomViews") Null ---------------------------------------------------------------------------- -- | Exception Handler @@ -252,20 +328,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 @@ -283,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 @@ -314,8 +388,22 @@ 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 +---------------------------------------------------------------------------- +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) @@ -324,199 +412,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 @@ -532,52 +430,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 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 + Just (VariablesRef_Value valueRoot valueNameSpace addr) -> do + variables <- getVariablesForValue valueRoot valueNameSpace addr -- detect and annotate loops let markLoop v | variableVariablesReference v == 0 @@ -587,6 +451,8 @@ talk CommandVariables = do | otherwise = v {variableName = variableName v <> " "} sendVariablesResponse (VariablesResponse $ map markLoop variables) + _ -> do + sendVariablesResponse (VariablesResponse []) ---------------------------------------------------------------------------- talk CommandNext = do NextArguments {..} <- getArguments @@ -615,878 +481,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 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" - -getVariablesForHeapObject :: StgState -> HeapObject -> Adaptor ESTG [Variable] -getVariablesForHeapObject stgState = \case - Con{..} -> forM (zip [0..] hoConArgs) $ \(idx, atom) -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom - pure defaultVariable - { variableName = cs $ "arg" ++ show idx - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - Closure{..} -> do - let bodyVar = defaultVariable - { variableName = "code" - , variableValue = cs $ show hoName - } - {- - 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 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 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 $ ThreadId hoBHOwnerThreadId - 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 $ ThreadId tid - pure defaultVariable - { variableName = "waiting thread id" - , variableValue = cs variableValue - , variableType = Just (cs variableType) - , variableVariablesReference = varsRef - } - pure $ onwerVar : queueVarList - ApStack{..} -> do - resultVarList <- forM hoResult $ \atom -> do - (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState 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 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 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 $ 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 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 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 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 primaryAction - (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState 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 action - (variableType2, variableValue2, varsRef2) <- getAtomTypeAndValueM stgState 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 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 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 - -> Atom - -> Adaptor ESTG (String, String, Int) -getAtomTypeAndValueM ss@StgState{..} = \case - HeapPtr addr - | Just o <- IntMap.lookup addr ssHeap - -> do - varsRef <- getVariablesRef $ VariablesRef_HeapObject 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 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/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 diff --git a/dap-estgi-server/src/SourceCode.hs b/dap-estgi-server/src/SourceCode.hs new file mode 100644 index 0000000..0de88c7 --- /dev/null +++ b/dap-estgi-server/src/SourceCode.hs @@ -0,0 +1,198 @@ +{-# 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, mkEntrySelector, getEntry) +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 = 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" + readFromZip fname = mkEntrySelector fname >>= getEntry + appInfoBytes <- readFromZip appInfoName + AppInfo{..} <- liftIO $ decodeThrow (cs 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) + 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))] + 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 +-- TODO: precalc in a map +getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)], [(StgPoint, Tickish)]) +getSourceFromFullPak sourceId = do + ESTG {..} <- getDebugSession + 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, [], []) + +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 ( + [ getSourceFromSourceCodeDescriptor (ExtStg packageName qualModName) + , getSourceFromSourceCodeDescriptor (GhcCore packageName qualModName) + , getSourceFromSourceCodeDescriptor (GhcStg packageName qualModName) + , getSourceFromSourceCodeDescriptor (Cmm packageName qualModName) + , getSourceFromSourceCodeDescriptor (Asm packageName qualModName) + , getSourceFromSourceCodeDescriptor (ModInfo packageName qualModName) + ] ++ + [ getSourceFromSourceCodeDescriptor cStub + | Set.member cStub srcDescSet + ] ++ + [ getSourceFromSourceCodeDescriptor hStub + | Set.member hStub srcDescSet + ]) + + _ -> pure Nothing + + let sourceName = cs $ getSourceName srcDesc + sourceRef <- getSourceRef srcDesc + 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 :: SourceCodeDescriptor -> 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..d33d340 --- /dev/null +++ b/dap-estgi-server/src/SourceLocation.hs @@ -0,0 +1,144 @@ +{-# 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 + +-- TODO: precalc in a map +getSourceAndPositionForStgPoint :: StgPoint -> Adaptor ESTG (Maybe Source, Int, Int, Int, Int) +getSourceAndPositionForStgPoint stgPoint = do + 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 <- getSourceFromSourceCodeDescriptor $ 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 <- getSourceFromSourceCodeDescriptor 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 + +-- 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 + 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] + -- 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 + } + sendProgressEndEvent $ defaultProgressEndEvent + { progressEndEventProgressId = progressId + , progressEndEventMessage = Just "Get source links finished." + } diff --git a/stack.yaml b/stack.yaml index e0d8b26..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: 1f8ed2f97e9d41f037274791d66f1e0984c1ed17 + commit: 0990087985da0bc14388fd2d394f8aff1bcf7d7a - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project - commit: 81c142ab40c6757904d873d4dd1db4a7786b186c + commit: a4b0c92cdf5dfb204be314e5f47d71fc8e5bc06b subdirs: - external-stg - external-stg-syntax