From c03b2281ce8c03c42a67d2a069724226aa242da1 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Mon, 11 Sep 2023 15:19:52 +0200 Subject: [PATCH 01/10] update estgi ; replace ModuleInfo with more precise SourceCodeDescriptor set --- dap-estgi-server/src/Main.hs | 244 +++++++++++++++++++---------------- stack.yaml | 2 +- 2 files changed, 132 insertions(+), 114 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 00230d9..916aab8 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -18,6 +18,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} ---------------------------------------------------------------------------- module Main (main) where ---------------------------------------------------------------------------- @@ -27,6 +28,7 @@ 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 ) import qualified Data.Set as Set import Control.Arrow import Data.IORef @@ -51,7 +53,7 @@ import Data.Maybe ( fromMaybe ) import Data.List ( sortOn ) import GHC.Generics ( Generic ) import System.Environment ( lookupEnv ) -import System.FilePath ( (-<.>), (), takeDirectory, takeExtension, dropExtension, splitFileName, splitPath, joinPath) +import System.FilePath ( (-<.>), (), takeDirectory, 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 @@ -109,6 +111,7 @@ getConfig = do <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT" <*> pure capabilities <*> pure True + ---------------------------------------------------------------------------- -- | VSCode arguments are custom for attach -- > "arguments": { @@ -134,8 +137,9 @@ data ESTG = ESTG { debuggerChan :: DebuggerChan , fullPakPath :: String - , moduleInfoMap :: Map Text ModuleInfo , breakpointMap :: Map Stg.Breakpoint IntSet + , sourceCodeSet :: Set SourceCodeDescriptor + , unitIdMap :: Bimap UnitId PackageName -- application specific resource handling @@ -173,7 +177,7 @@ initESTG AttachArgs {..} = do 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 - moduleInfos <- liftIO $ getModuleListFromFullPak fullpakPath + (sourceCodeList, unitIdMap) <- liftIO $ getSourceCodeListFromFullPak fullpakPath (dbgAsyncI, dbgAsyncO) <- liftIO (Unagi.newChan 100) dbgRequestMVar <- liftIO MVar.newEmptyMVar dbgResponseMVar <- liftIO MVar.newEmptyMVar @@ -186,8 +190,9 @@ initESTG AttachArgs {..} = do estg = ESTG { debuggerChan = dbgChan , fullPakPath = fullpakPath - , moduleInfoMap = M.fromList [(cs $ qualifiedModuleName mi, mi) | mi <- moduleInfos] , breakpointMap = mempty + , sourceCodeSet = Set.fromList sourceCodeList + , unitIdMap = unitIdMap , dapSourceRefMap = Bimap.empty , dapFrameIdMap = Bimap.empty , dapVariablesRefMap = Bimap.empty @@ -294,10 +299,15 @@ talk CommandInitialize = do talk CommandLoadedSources = do sendLoadedSourcesResponse =<< do - moduleInfos <- getsApp $ M.elems . moduleInfoMap - forM moduleInfos $ \ModuleInfo {..} -> case isCSource of - True -> getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak ForeignC qualifiedModuleName - False -> getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak ExtStg qualifiedModuleName + {- + list only Haskell ExtStg and ForeignC files + -} + let shouldInclude = \case + ExtStg{} -> True + ForeignC{} -> True + _ -> False + srcSet <- getsApp sourceCodeSet + mapM (getSourceFromSourceRefDescriptor . SourceRef_SourceFileInFullpak) $ filter shouldInclude $ Set.toList srcSet ---------------------------------------------------------------------------- talk CommandModules = do @@ -518,7 +528,9 @@ 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 - source <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak ExtStg (cs $ getModuleName binderModule) + ESTG {..} <- getDebugSession + let Just packageName = Bimap.lookup binderUnitId unitIdMap + source <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak $ ExtStg packageName (cs $ getModuleName binderModule) let Just sourceRef = sourceSourceReference source (_sourceCodeText, locations) <- getSourceFromFullPak sourceRef case filter ((== stgPoint) . fst) locations of @@ -529,54 +541,52 @@ getSourceAndPositionForStgPoint (Id Binder{..}) stgPoint = do ---------------------------------------------------------------------------- -data ModuleInfo - = ModuleInfo - { cStub :: Bool - -- ^ If stubs.c is included in the .fullpak for this module - , hStub :: Bool - -- ^ If stubs.h is included in the .fullpak for this module - , isCSource :: Bool - -- ^ Is a C source file located in c-sources - , qualifiedModuleName :: Text - -- ^ Fully qualified module name - } ---------------------------------------------------------------------------- -- | Retrieves list of modules from .fullpak file --- TODO: Check if stubs file exists, if so, return it. -getModuleListFromFullPak :: FilePath -> IO [ModuleInfo] -getModuleListFromFullPak fullPakPath = do - let appName = "app.ghc_stgapp" - bytes <- readModpakL fullPakPath appName id +getSourceCodeListFromFullPak :: FilePath -> IO ([SourceCodeDescriptor], Bimap UnitId PackageName) +getSourceCodeListFromFullPak fullPakPath = do rawEntries <- fmap unEntrySelector . M.keys <$> withArchive fullPakPath getEntries let folderNames = Set.fromList (takeDirectory <$> rawEntries) - GhcStgApp {..} <- decodeThrow (BL8.toStrict bytes) - let - unitModules :: [String] - unitModules = concat - [ unitExposedModules ++ unitHiddenModules - | UnitLinkerInfo {..} <- appLibDeps - ] - - cbitsSources :: [String] - cbitsSources = - [ entry - | entry <- rawEntries - , "cbits-source" `isPrefixOf` entry - ] - + appInfoName = "app.info" + appInfoBytes <- readModpakL fullPakPath appInfoName id + AppInfo{..} <- decodeThrow (BL8.toStrict appInfoBytes) + let unitIdMap = Bimap.fromList + [ (UnitId $ cs ciUnitId, cs ciPackageName) + | CodeInfo{..} <- aiLiveCode + ] + {- + content: + haskell modules + foreign files + -} let rawEntriesSet = Set.fromList rawEntries - - pure - [ ModuleInfo - { cStub = (moduleName "module_stub.c") `Set.member` rawEntriesSet - , hStub = (moduleName "module_stub.h") `Set.member` rawEntriesSet - , qualifiedModuleName = cs moduleName - , .. - } - | moduleName <- unitModules <> appModules <> cbitsSources - , let isCSource = "cbits-source" `isPrefixOf` moduleName - , moduleName `Set.member` folderNames || isCSource - ] + moduleCode 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 + ] + haskellModuleCode :: [SourceCodeDescriptor] + haskellModuleCode = + [ srcDesc + | CodeInfo{..} <- aiLiveCode + , srcDesc <- moduleCode (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] + ] + + pure (haskellModuleCode ++ cbitsSources, unitIdMap) getValidSourceRefFromSource :: Source -> Adaptor ESTG (Maybe Int) getValidSourceRefFromSource Source{..} = do @@ -604,14 +614,14 @@ getValidSourceRefFromSource Source{..} = do getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)]) getSourceFromFullPak sourceId = do ESTG {..} <- getDebugSession - SourceRef_SourceFileInFullpak srcLang qualifiedModuleName <- case Bimap.lookupR sourceId dapSourceRefMap of + 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 qualifiedModuleName srcLang + let sourcePath = getSourcePath srcDesc liftIO $ - case srcLang of - ExtStg -> do + case srcDesc of + ExtStg{} -> do m <- readModpakL fullPakPath sourcePath decodeStgbin pure . pShow $ pprModule m _ -> do @@ -780,7 +790,7 @@ generateScopes frameIdDesc stackCont@(Catch atom blockAsync interruptible) = do , scopeNamedVariables = Just 3 } ] -generateScopes frameIdDesc stackCont@(RestoreExMask blockAsync interruptible) = do +generateScopes frameIdDesc stackCont@(RestoreExMask _ blockAsync interruptible) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc setVariables scopeVarablesRef [ defaultVariable @@ -843,10 +853,10 @@ generateScopes frameIdDesc stackCont@(Atomically atom) = do , scopeNamedVariables = Just 1 } ] -generateScopes frameIdDesc stackCont@(CatchRetry atom1 atom2 interruptible) = do +generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction isRunningAlternative _tlog) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - let (variableType1, variableValue1) = getAtomTypeAndValue atom1 - let (variableType2, variableValue2) = getAtomTypeAndValue atom2 + let (variableType1, variableValue1) = getAtomTypeAndValue primaryAction + let (variableType2, variableValue2) = getAtomTypeAndValue alternativeAction setVariables scopeVarablesRef [ defaultVariable { variableName = "First STM action" @@ -855,14 +865,15 @@ generateScopes frameIdDesc stackCont@(CatchRetry atom1 atom2 interruptible) = do } , defaultVariable { variableName = "Second STM action" - , variableValue = T.pack (show atom2) - , variableType = Just (T.pack (show (typeOf atom2))) + , variableValue = cs variableValue2 + , variableType = Just (cs variableType2) } , defaultVariable - { variableName = "Interruptible" - , variableValue = T.pack (show interruptible) + { variableName = "Is running alternativbe STM action" + , variableValue = T.pack (show isRunningAlternative) , variableType = Just "Bool" } + -- todo add tlog ] pure [ defaultScope @@ -1105,65 +1116,71 @@ data DapVariablesRefDescriptor = VariablesRef_StackFrameVariables DapFrameIdDescriptor deriving (Show, Eq, Ord) -data SourceLanguage - = Haskell - | GhcCore - | GhcStg - | Cmm - | Asm - | ExtStg - | FFICStub - | FFIHStub - | ForeignC +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 + | ForeignC PackageName FilePath deriving (Show, Read, Eq, Ord) data DapSourceRefDescriptor - = SourceRef_SourceFileInFullpak SourceLanguage QualifiedModuleName + = SourceRef_SourceFileInFullpak SourceCodeDescriptor deriving (Show, Read, Eq, Ord) -getSourcePath :: QualifiedModuleName -> SourceLanguage -> FilePath -getSourcePath qualifiedModuleName = \case - Haskell -> cs qualifiedModuleName "module.hs" - GhcCore -> cs qualifiedModuleName "module.ghccore" - GhcStg -> cs qualifiedModuleName "module.ghcstg" - Cmm -> cs qualifiedModuleName "module.cmm" - Asm -> cs qualifiedModuleName "module.s" - ExtStg -> cs qualifiedModuleName "module.stgbin" - FFICStub -> cs qualifiedModuleName "module_stub.c" - FFIHStub -> cs qualifiedModuleName "module_stub.h" - ForeignC -> cs qualifiedModuleName - -getSourceName :: QualifiedModuleName -> SourceLanguage -> String -getSourceName qualifiedModuleName = \case - Haskell -> cs qualifiedModuleName <> ".hs" - GhcCore -> cs qualifiedModuleName <> ".ghccore" - GhcStg -> cs qualifiedModuleName <> ".ghcstg" - Cmm -> cs qualifiedModuleName <> ".cmm" - Asm -> cs qualifiedModuleName <> ".s" - ExtStg -> cs qualifiedModuleName <> ".stgbin.hs" - FFICStub -> cs qualifiedModuleName <> "_stub.c" - FFIHStub -> cs qualifiedModuleName <> "_stub.h" - ForeignC -> cs qualifiedModuleName +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" + ForeignC _pkg path -> cs path + +getSourceName :: SourceCodeDescriptor -> String +getSourceName = \case + Haskell pkg mod -> cs mod <> ".hs" + GhcCore pkg mod -> cs mod <> ".ghccore" + GhcStg pkg mod -> cs mod <> ".ghcstg" + Cmm pkg mod -> cs mod <> ".cmm" + Asm pkg mod -> cs mod <> ".s" + ExtStg pkg mod -> cs mod <> ".stgbin.hs" + FFICStub pkg mod -> cs mod <> "_stub.c" + FFIHStub pkg mod -> cs mod <> "_stub.h" + ForeignC _pkg path -> cs path getSourceFromSourceRefDescriptor :: DapSourceRefDescriptor -> Adaptor ESTG Source -getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak sourceLanguage qualModName) = do - sources <- if sourceLanguage /= ExtStg then pure Nothing else do - ModuleInfo{..} <- getsApp $ (M.! qualModName) . moduleInfoMap - Just <$> sequence ( - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak Haskell qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak GhcCore qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak GhcStg qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak Cmm qualModName) - , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak Asm qualModName) +getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak srcDesc) = do + srcDescSet <- getsApp sourceCodeSet + sources <- case srcDesc of + ExtStg packageName qualModName + | cStub <- FFICStub packageName qualModName + , hStub <- FFIHStub packageName qualModName + -> Just <$> sequence ( + [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Haskell 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 FFICStub qualModName) - | cStub + [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak cStub) + | Set.member cStub srcDescSet ] ++ - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak FFIHStub qualModName) - | hStub + [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak hStub) + | Set.member hStub srcDescSet ]) - let --sourcePath = cs $ getSourcePath qualModName sourceLanguage - sourceName = cs $ getSourceName qualModName sourceLanguage + + _ -> pure Nothing + + let --sourcePath = cs $ getSourcePath srcDesc + sourceName = cs $ getSourceName srcDesc sourceRef <- getSourceRef sourceRefDesc ESTG {..} <- getDebugSession pure defaultSource @@ -1237,6 +1254,7 @@ getFreshBreakpointId = do modifyApp $ \s -> s { nextFreshBreakpointId = nextFreshBreakpointId s + 1 } pure bkpId +type PackageName = Text type QualifiedModuleName = Text type BreakpointId = Int type SourceId = Int diff --git a/stack.yaml b/stack.yaml index 6c900fd..72b1f3f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ extra-deps: commit: 1f8ed2f97e9d41f037274791d66f1e0984c1ed17 - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project - commit: 80e408ebdeaf5c1cea72bfbf86823c32d4fdafbe + commit: 5ceaa4505bdaac4b6ca5ce9e2fc2e82483052f8b subdirs: - external-stg - external-stg-syntax From 6910682d1764dc98a158781da75940bdf3aa1054 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 13 Sep 2023 16:41:19 +0200 Subject: [PATCH 02/10] add support for Haskell breakpoint placing ; show current program point on Haskell or STG as a fallback ; include module compile info file in module's metadata set --- dap-estgi-server/src/Main.hs | 142 ++++++++++++++++++++++++++++++----- 1 file changed, 122 insertions(+), 20 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 916aab8..7ba9382 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -63,6 +63,7 @@ import qualified System.FilePath.Find as Glob ---------------------------------------------------------------------------- import Stg.Syntax hiding (sourceName, Scope) import Stg.IRLocation +import Stg.Tickish ( collectTickish ) import Stg.Pretty import Stg.Interpreter import Stg.Interpreter.Debug @@ -140,6 +141,7 @@ data ESTG , breakpointMap :: Map Stg.Breakpoint IntSet , sourceCodeSet :: Set SourceCodeDescriptor , unitIdMap :: Bimap UnitId PackageName + , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor -- application specific resource handling @@ -177,7 +179,7 @@ initESTG AttachArgs {..} = do 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) <- liftIO $ getSourceCodeListFromFullPak fullpakPath + (sourceCodeList, unitIdMap, haskellSrcPathMap) <- liftIO $ getSourceCodeListFromFullPak fullpakPath (dbgAsyncI, dbgAsyncO) <- liftIO (Unagi.newChan 100) dbgRequestMVar <- liftIO MVar.newEmptyMVar dbgResponseMVar <- liftIO MVar.newEmptyMVar @@ -193,6 +195,7 @@ initESTG AttachArgs {..} = do , breakpointMap = mempty , sourceCodeSet = Set.fromList sourceCodeList , unitIdMap = unitIdMap + , haskellSrcPathMap = haskellSrcPathMap , dapSourceRefMap = Bimap.empty , dapFrameIdMap = Bimap.empty , dapVariablesRefMap = Bimap.empty @@ -321,13 +324,75 @@ talk CommandSetBreakpoints = do SetBreakpointsArguments {..} <- getArguments maybeSourceRef <- getValidSourceRefFromSource setBreakpointsArgumentsSource - -- the input SourceRef might be a remain of a previous DAP session, update it wit the new valid one + -- 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 - case (setBreakpointsArgumentsBreakpoints, maybeSourceRef) of - (Just sourceBreakpoints, Just sourceRef) -> do - (_sourceCodeText, locations) <- getSourceFromFullPak sourceRef + {- + 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, (srcSpanELine - srcSpanSLine, maxBound)) + | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs + , srcSpanFile == hsSourceFilePath + , srcSpanSLine <= sourceBreakpointLine + , srcSpanELine >= sourceBreakpointLine + ] + Just col -> + [ (p, (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol)) + | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs + , srcSpanFile == hsSourceFilePath + , srcSpanSLine <= sourceBreakpointLine + , srcSpanELine >= sourceBreakpointLine + , srcSpanSCol <= col + , srcSpanECol >= col + ] + liftIO $ putStrLn . unlines $ "relevant haskell locations:" : map show relevantLocations + -- use the first location found + 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 {- @@ -457,7 +522,7 @@ talk CommandSource = do Just source -> getValidSourceRefFromSource source Nothing -> pure Nothing - (source, _locations) <- getSourceFromFullPak sourceRef + (source, _locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef sendSourceResponse (SourceResponse source Nothing) ---------------------------------------------------------------------------- talk CommandThreads = do @@ -530,20 +595,43 @@ getSourceAndPositionForStgPoint :: Id -> StgPoint -> Adaptor ESTG (Maybe Source, getSourceAndPositionForStgPoint (Id Binder{..}) stgPoint = do ESTG {..} <- getDebugSession let Just packageName = Bimap.lookup binderUnitId unitIdMap - source <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak $ ExtStg packageName (cs $ getModuleName binderModule) + moduleName = cs $ getModuleName binderModule + source <- getSourceFromSourceRefDescriptor $ SourceRef_SourceFileInFullpak $ ExtStg packageName moduleName let Just sourceRef = sourceSourceReference source - (_sourceCodeText, locations) <- getSourceFromFullPak sourceRef - case filter ((== stgPoint) . fst) locations of - (_, ((line, column),(endLine, endColumn))) : _ -> do - pure (Just source, line, column, endLine, endColumn) + (_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 - pure (Just source, 0, 0, 0, 0) + 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) +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) @@ -555,12 +643,12 @@ getSourceCodeListFromFullPak fullPakPath = do | CodeInfo{..} <- aiLiveCode ] {- - content: + program source content: haskell modules foreign files -} let rawEntriesSet = Set.fromList rawEntries - moduleCode pkg mod = + moduleCodeItems pkg mod = [ Haskell pkg mod , GhcCore pkg mod , GhcStg pkg mod @@ -569,12 +657,13 @@ getSourceCodeListFromFullPak fullPakPath = do , ExtStg pkg mod , FFICStub pkg mod , FFIHStub pkg mod + , ModInfo pkg mod ] haskellModuleCode :: [SourceCodeDescriptor] haskellModuleCode = [ srcDesc | CodeInfo{..} <- aiLiveCode - , srcDesc <- moduleCode (cs ciPackageName) (cs ciModuleName) + , srcDesc <- moduleCodeItems (cs ciPackageName) (cs ciModuleName) , Set.member (getSourcePath srcDesc) rawEntriesSet ] @@ -586,7 +675,14 @@ getSourceCodeListFromFullPak fullPakPath = do , Just packageName <- [Bimap.lookup (UnitId $ cs unitIdString) unitIdMap] ] - pure (haskellModuleCode ++ cbitsSources, 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 @@ -611,7 +707,7 @@ getValidSourceRefFromSource Source{..} = do ---------------------------------------------------------------------------- -- | Retrieves list of modules from .fullpak file -getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)]) +getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)], [(StgPoint, Tickish)]) getSourceFromFullPak sourceId = do ESTG {..} <- getDebugSession SourceRef_SourceFileInFullpak srcDesc <- case Bimap.lookupR sourceId dapSourceRefMap of @@ -623,10 +719,12 @@ getSourceFromFullPak sourceId = do case srcDesc of ExtStg{} -> do m <- readModpakL fullPakPath sourcePath decodeStgbin - pure . pShow $ pprModule m + 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, []) + pure (ir, [], []) ---------------------------------------------------------------------------- -- | Synchronous call to Debugger, sends message and waits for response sendAndWait :: DebugCommand -> Adaptor ESTG DebugOutput @@ -1125,6 +1223,7 @@ data SourceCodeDescriptor | ExtStg PackageName QualifiedModuleName | FFICStub PackageName QualifiedModuleName | FFIHStub PackageName QualifiedModuleName + | ModInfo PackageName QualifiedModuleName | ForeignC PackageName FilePath deriving (Show, Read, Eq, Ord) @@ -1142,6 +1241,7 @@ getSourcePath = \case 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 @@ -1154,6 +1254,7 @@ getSourceName = \case ExtStg pkg mod -> cs mod <> ".stgbin.hs" FFICStub pkg mod -> cs mod <> "_stub.c" FFIHStub pkg mod -> cs mod <> "_stub.h" + ModInfo pkg mod -> cs mod <> ".info" ForeignC _pkg path -> cs path getSourceFromSourceRefDescriptor :: DapSourceRefDescriptor -> Adaptor ESTG Source @@ -1169,6 +1270,7 @@ getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak sr , 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 From d5d3baf203cb8e3fefcf08f2ba61053a862dca73 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 20 Sep 2023 14:42:49 +0200 Subject: [PATCH 03/10] allow to explore variables in arbitrary depth ; include language origin and package name in source names, this allows vscode grouping in tree views --- dap-estgi-server/dap-estgi-server.cabal | 1 + dap-estgi-server/src/Main.hs | 244 ++++++++++++++++++------ 2 files changed, 184 insertions(+), 61 deletions(-) diff --git a/dap-estgi-server/dap-estgi-server.cabal b/dap-estgi-server/dap-estgi-server.cabal index 7193d1a..c1030b4 100644 --- a/dap-estgi-server/dap-estgi-server.cabal +++ b/dap-estgi-server/dap-estgi-server.cabal @@ -44,6 +44,7 @@ executable dap-estgi , yaml , zip , bimap + , pretty-simple hs-source-dirs: src default-language: diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 7ba9382..f20b971 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -48,6 +48,7 @@ import Data.Map.Strict ( Map ) import qualified Data.Text.Encoding as T 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.List ( sortOn ) @@ -75,6 +76,7 @@ import Stg.IO import Stg.Program import Stg.Fullpak import Data.Yaml hiding (Array) +import qualified Text.Pretty.Simple as PP ---------------------------------------------------------------------------- import DAP hiding (send) ---------------------------------------------------------------------------- @@ -561,8 +563,15 @@ talk CommandScopes = do ---------------------------------------------------------------------------- talk CommandVariables = do VariablesArguments {..} <- getArguments - variables <- getVariables variablesArgumentsVariablesReference - sendVariablesResponse (VariablesResponse variables) + getsApp (Bimap.lookupR variablesArgumentsVariablesReference . dapVariablesRefMap) >>= \case + Just VariablesRef_StackFrameVariables{} -> do + variables <- getVariables variablesArgumentsVariablesReference + sendVariablesResponse (VariablesResponse variables) + Just (VariablesRef_HeapObject addr) -> do + stgState <- getStgState + let Just ho = IntMap.lookup addr $ ssHeap stgState + variables <- getVariablesForHeapObject stgState ho + sendVariablesResponse (VariablesResponse variables) ---------------------------------------------------------------------------- talk CommandNext = do NextArguments {..} <- getArguments @@ -761,24 +770,24 @@ generateScopesForTopStackFrame generateScopesForTopStackFrame frameIdDesc closureId env = do (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint closureId (SP_RhsClosureExpr closureId) scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - setVariables scopeVarablesRef - [ defaultVariable + 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 } - | (Id (Binder{..}), (_, atom)) <- M.toList env - , let (variableType, variableValue) = getAtomTypeAndValue atom - BinderId u = binderId - displayName = if binderScope == ModulePublic then cs binderName else cs (show u) - ] + setVariables scopeVarablesRef varList pure [ defaultScope { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just (M.size env) , scopeSource = source , scopeLine = Just line , scopeColumn = Just column @@ -787,6 +796,95 @@ generateScopesForTopStackFrame frameIdDesc closureId env = do } ] +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 @@ -797,26 +895,26 @@ generateScopes generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint closureId (SP_RhsClosureExpr closureId) scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - setVariables scopeVarablesRef + 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 - [ defaultVariable + (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 } - | (Id (Binder{..}), (_, atom)) <- M.toList env - , let (variableType, variableValue) = getAtomTypeAndValue atom - BinderId u = binderId - displayName = if binderScope == ModulePublic then cs binderName else cs (show u) - ] + setVariables scopeVarablesRef varList pure [ defaultScope { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just (M.size env) , scopeSource = source , scopeLine = Just line , scopeColumn = Just column @@ -826,11 +924,14 @@ generateScopes frameIdDesc stackCont@(CaseOf _ closureId env _ _ _) = do ] generateScopes frameIdDesc stackCont@(Update addr) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc + stgState <- getStgState + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState $ HeapPtr addr setVariables scopeVarablesRef [ defaultVariable - { variableName = "Address" - , variableValue = T.pack (show addr) - , variableType = Just "Ptr" + { variableName = "Thunk Address" + , variableValue = cs variableValue + , variableType = Just (cs variableType) + , variableVariablesReference = varsRef } ] pure @@ -838,36 +939,37 @@ generateScopes frameIdDesc stackCont@(Update addr) = do { scopeName = "Locals: " <> T.pack (showStackCont stackCont) , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 1 } ] generateScopes frameIdDesc stackCont@(Apply atoms) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - setVariables scopeVarablesRef - [ defaultVariable + 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 } - | atom <- atoms - , let (variableType, variableValue) = getAtomTypeAndValue atom - ] + setVariables scopeVarablesRef varList pure [ defaultScope { scopeName = "Locals: " <> T.pack (showStackCont stackCont) , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just (length atoms) } ] generateScopes frameIdDesc stackCont@(Catch atom blockAsync interruptible) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - let (variableType, variableValue) = getAtomTypeAndValue atom + 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" @@ -885,7 +987,6 @@ generateScopes frameIdDesc stackCont@(Catch atom blockAsync interruptible) = do { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 3 } ] generateScopes frameIdDesc stackCont@(RestoreExMask _ blockAsync interruptible) = do @@ -907,7 +1008,6 @@ generateScopes frameIdDesc stackCont@(RestoreExMask _ blockAsync interruptible) { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 2 } ] generateScopes frameIdDesc stackCont@(RunScheduler reason) = do @@ -923,7 +1023,6 @@ generateScopes frameIdDesc stackCont@(RunScheduler reason) = do { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 1 } ] where showScheduleReason :: ScheduleReason -> Text @@ -935,12 +1034,14 @@ generateScopes frameIdDesc stackCont@(RunScheduler reason) = do generateScopes frameIdDesc stackCont@(Atomically atom) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - let (variableType, variableValue) = getAtomTypeAndValue atom + stgState <- getStgState + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom setVariables scopeVarablesRef [ defaultVariable { variableName = "STM action" , variableValue = cs variableValue , variableType = Just (cs variableType) + , variableVariablesReference = varsRef } ] pure @@ -948,26 +1049,28 @@ generateScopes frameIdDesc stackCont@(Atomically atom) = do { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 1 } ] generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction isRunningAlternative _tlog) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - let (variableType1, variableValue1) = getAtomTypeAndValue primaryAction - let (variableType2, variableValue2) = getAtomTypeAndValue alternativeAction + 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 alternativbe STM action" + { variableName = "Is running alternative STM action" , variableValue = T.pack (show isRunningAlternative) , variableType = Just "Bool" } @@ -978,23 +1081,25 @@ generateScopes frameIdDesc stackCont@(CatchRetry primaryAction alternativeAction { scopeName = "Locals: " <> T.pack (showStackCont stackCont) , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 3 } ] -generateScopes frameIdDesc (CatchSTM atom1 atom2) = do +generateScopes frameIdDesc (CatchSTM action handler) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - let (variableType1, variableValue1) = getAtomTypeAndValue atom1 - (variableType2, variableValue2) = getAtomTypeAndValue atom2 + 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 @@ -1002,7 +1107,6 @@ generateScopes frameIdDesc (CatchSTM atom1 atom2) = do { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 2 } ] generateScopes frameIdDesc stackCont@DataToTagOp = do @@ -1012,17 +1116,18 @@ generateScopes frameIdDesc stackCont@DataToTagOp = do { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 0 } ] generateScopes frameIdDesc stackCont@(RaiseOp atom) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - let (variableType, variableValue) = getAtomTypeAndValue atom + stgState <- getStgState + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom setVariables scopeVarablesRef [ defaultVariable { variableName = "RaiseOp" , variableValue = cs variableValue , variableType = Just (cs variableType) + , variableVariablesReference = varsRef } ] pure @@ -1030,17 +1135,18 @@ generateScopes frameIdDesc stackCont@(RaiseOp atom) = do { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 1 } ] generateScopes frameIdDesc stackCont@(KeepAlive atom) = do scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc - let (variableType, variableValue) = getAtomTypeAndValue atom + stgState <- getStgState + (variableType, variableValue, varsRef) <- getAtomTypeAndValueM stgState atom setVariables scopeVarablesRef [ defaultVariable { variableName = "Managed Object" , variableValue = cs variableValue , variableType = Just (cs variableType) + , variableVariablesReference = varsRef } ] pure @@ -1048,7 +1154,6 @@ generateScopes frameIdDesc stackCont@(KeepAlive atom) = do { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 1 } ] generateScopes frameIdDesc stackCont@(DebugFrame (RestoreProgramPoint maybeId _)) = do @@ -1065,7 +1170,6 @@ generateScopes frameIdDesc stackCont@(DebugFrame (RestoreProgramPoint maybeId _) { scopeName = "Locals" , scopePresentationHint = Just ScopePresentationHintLocals , scopeVariablesReference = scopeVarablesRef - , scopeNamedVariables = Just 1 } ] @@ -1112,11 +1216,28 @@ showPrimRep (VecRep n 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 - :: Atom + :: StgState + -> Atom -> (String, String) -getAtomTypeAndValue = \case - HeapPtr addr -> ("HeapPtr", show addr) +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") @@ -1211,7 +1332,8 @@ data DapFrameIdDescriptor deriving (Show, Eq, Ord) data DapVariablesRefDescriptor - = VariablesRef_StackFrameVariables DapFrameIdDescriptor + = VariablesRef_StackFrameVariables DapFrameIdDescriptor + | VariablesRef_HeapObject Int deriving (Show, Eq, Ord) data SourceCodeDescriptor @@ -1246,15 +1368,15 @@ getSourcePath = \case getSourceName :: SourceCodeDescriptor -> String getSourceName = \case - Haskell pkg mod -> cs mod <> ".hs" - GhcCore pkg mod -> cs mod <> ".ghccore" - GhcStg pkg mod -> cs mod <> ".ghcstg" - Cmm pkg mod -> cs mod <> ".cmm" - Asm pkg mod -> cs mod <> ".s" - ExtStg pkg mod -> cs mod <> ".stgbin.hs" - FFICStub pkg mod -> cs mod <> "_stub.c" - FFIHStub pkg mod -> cs mod <> "_stub.h" - ModInfo pkg mod -> cs mod <> ".info" + 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 From a3d6f069290cc54c93b041d3a470ad2b94b2a3a0 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 20 Sep 2023 14:48:03 +0200 Subject: [PATCH 04/10] update estgi dep --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 72b1f3f..fa23dba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ extra-deps: commit: 1f8ed2f97e9d41f037274791d66f1e0984c1ed17 - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project - commit: 5ceaa4505bdaac4b6ca5ce9e2fc2e82483052f8b + commit: 9de6064478bbd66e95edcd9b89770e32eeebf641 subdirs: - external-stg - external-stg-syntax From ef24ad341f0d214ea94fb75157db890b5a7d546f Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 20 Sep 2023 15:21:34 +0200 Subject: [PATCH 05/10] mark loops during value structure unfolding --- dap-estgi-server/src/Main.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index f20b971..ab76ff6 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -571,7 +571,15 @@ talk CommandVariables = do stgState <- getStgState let Just ho = IntMap.lookup addr $ ssHeap stgState variables <- getVariablesForHeapObject stgState ho - sendVariablesResponse (VariablesResponse variables) + -- detect and annotate loops + let markLoop v + | variableVariablesReference v == 0 + = v + | variableVariablesReference v > variablesArgumentsVariablesReference + = v + | otherwise + = v {variableName = variableName v <> " "} + sendVariablesResponse (VariablesResponse $ map markLoop variables) ---------------------------------------------------------------------------- talk CommandNext = do NextArguments {..} <- getArguments From 8611ff2eea2a4196d8afca2bf5e095303a5f45c6 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 20 Sep 2023 15:38:25 +0200 Subject: [PATCH 06/10] use haskell source files by deafult in loaded sources --- dap-estgi-server/src/Main.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index ab76ff6..59e2167 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -308,7 +308,7 @@ talk CommandLoadedSources = do list only Haskell ExtStg and ForeignC files -} let shouldInclude = \case - ExtStg{} -> True + Haskell{} -> True ForeignC{} -> True _ -> False srcSet <- getsApp sourceCodeSet @@ -1390,12 +1390,12 @@ getSourceName = \case getSourceFromSourceRefDescriptor :: DapSourceRefDescriptor -> Adaptor ESTG Source getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak srcDesc) = do srcDescSet <- getsApp sourceCodeSet - sources <- case srcDesc of - ExtStg packageName qualModName + extraSources <- case srcDesc of + Haskell packageName qualModName | cStub <- FFICStub packageName qualModName , hStub <- FFIHStub packageName qualModName -> Just <$> sequence ( - [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Haskell packageName qualModName) + [ getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ ExtStg packageName qualModName) , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcCore packageName qualModName) , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ GhcStg packageName qualModName) , getSourceFromSourceRefDescriptor (SourceRef_SourceFileInFullpak $ Cmm packageName qualModName) @@ -1419,7 +1419,7 @@ getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak sr { sourceName = Just $ sourceName -- used in source tree children , sourceSourceReference = Just sourceRef , sourcePath = Just $ sourceName -- used in code tab title - , sourceSources = sources + , sourceSources = extraSources {- use fingerprint to identify sources between debug sessions this allows to set pre-existing breakpoints coming from client (e.g. VSCode) From 9a053773e8fd2031e4a5f33e7a029a0e92d42dd6 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 20 Sep 2023 15:39:11 +0200 Subject: [PATCH 07/10] update estgi dep --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index fa23dba..e0d8b26 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ extra-deps: commit: 1f8ed2f97e9d41f037274791d66f1e0984c1ed17 - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project - commit: 9de6064478bbd66e95edcd9b89770e32eeebf641 + commit: 81c142ab40c6757904d873d4dd1db4a7786b186c subdirs: - external-stg - external-stg-syntax From 5c6d3a9f10cd820f2d3e66854d57aedc37241b63 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 20 Sep 2023 15:45:56 +0200 Subject: [PATCH 08/10] improve thread name reporting --- dap-estgi-server/src/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 59e2167..864948e 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -532,7 +532,7 @@ talk CommandThreads = do sendThreadsResponse [ Thread { threadId = threadId - , threadName = T.pack (show threadId <> " " <> threadLabel) + , threadName = T.pack ("thread id: " <> show threadId <> " " <> threadLabel) } | (threadId, threadState) <- allThreads , isThreadLive $ tsStatus threadState @@ -768,7 +768,7 @@ getStgState = do ---------------------------------------------------------------------------- mkThreadLabel :: ThreadState -> String -mkThreadLabel = maybe "" (BL8.unpack . BL8.fromStrict) . tsLabel +mkThreadLabel = maybe "" (BL8.unpack . BL8.fromStrict) . tsLabel generateScopesForTopStackFrame :: DapFrameIdDescriptor From 1f9fdf892869b4c9602cd181ccc62ce346976978 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Thu, 21 Sep 2023 12:45:38 +0200 Subject: [PATCH 09/10] use sourcePath instead of sourceAdapterData for source file identification, it is more robust across dap sessions --- dap-estgi-server/src/Main.hs | 30 +++++++++++------------------- 1 file changed, 11 insertions(+), 19 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index 864948e..afb7e73 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -144,6 +144,7 @@ data ESTG , sourceCodeSet :: Set SourceCodeDescriptor , unitIdMap :: Bimap UnitId PackageName , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor + , dapSourceNameMap :: Bimap Text DapSourceRefDescriptor -- application specific resource handling @@ -198,7 +199,8 @@ initESTG AttachArgs {..} = do , sourceCodeSet = Set.fromList sourceCodeList , unitIdMap = unitIdMap , haskellSrcPathMap = haskellSrcPathMap - , dapSourceRefMap = Bimap.empty + , dapSourceNameMap = Bimap.fromList [(cs $ getSourceName d, SourceRef_SourceFileInFullpak d) | d <- sourceCodeList] + , dapSourceRefMap = Bimap.fromList $ zip (map SourceRef_SourceFileInFullpak sourceCodeList) [1..] , dapFrameIdMap = Bimap.empty , dapVariablesRefMap = Bimap.empty , dapVariablesRefStore = mempty @@ -441,7 +443,7 @@ talk CommandSetBreakpoints = do , breakpointMessage = Just "no code found" } sendSetBreakpointsResponse breakpoints - _ -> + v -> do sendSetBreakpointsResponse [] ---------------------------------------------------------------------------- talk CommandStackTrace = do @@ -706,14 +708,12 @@ getValidSourceRefFromSource Source{..} = do ESTG {..} <- getDebugSession {- fallback chain: - read sourceAdapterData if fullpak path matches to create SourceRef - use sourceSourceReference + 1. sourcePath + 2. sourceSourceReference -} let maybeSrcDesc = do - String fingerprint <- sourceAdapterData - (srcFullpakPath, srcDesc) <- readMaybe (cs fingerprint) - guard (srcFullpakPath == fullPakPath) - pure srcDesc + srcName <- sourcePath + Bimap.lookup srcName dapSourceNameMap case maybeSrcDesc of Just srcDesc -> Just <$> getSourceRef srcDesc Nothing -> case sourceSourceReference of @@ -1411,8 +1411,7 @@ getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak sr _ -> pure Nothing - let --sourcePath = cs $ getSourcePath srcDesc - sourceName = cs $ getSourceName srcDesc + let sourceName = cs $ getSourceName srcDesc sourceRef <- getSourceRef sourceRefDesc ESTG {..} <- getDebugSession pure defaultSource @@ -1420,11 +1419,6 @@ getSourceFromSourceRefDescriptor sourceRefDesc@(SourceRef_SourceFileInFullpak sr , sourceSourceReference = Just sourceRef , sourcePath = Just $ sourceName -- used in code tab title , sourceSources = extraSources - {- - use fingerprint to identify sources between debug sessions - this allows to set pre-existing breakpoints coming from client (e.g. VSCode) - -} - , sourceAdapterData = Just . String . cs $ show (fullPakPath, sourceRefDesc) } getFrameId :: DapFrameIdDescriptor -> Adaptor ESTG Int @@ -1447,12 +1441,10 @@ getVariablesRef key = do 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 -> do - srcRef <- getsApp (succ . Bimap.size . dapSourceRefMap) - modifyApp $ \s -> s {dapSourceRefMap = Bimap.insert key srcRef (dapSourceRefMap s)} - pure srcRef + Nothing -> error $ "unknown source descriptor: " ++ show key setVariables :: Int -> [Variable] -> Adaptor ESTG () setVariables variablesRef variableList = do From 9cf59b1cf81e69f42a3e57bb457a4fc0277721c4 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Tue, 26 Sep 2023 12:19:13 +0200 Subject: [PATCH 10/10] add more comments ; use debug logging ; add more error handling ; improve names --- dap-estgi-server/src/Main.hs | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/dap-estgi-server/src/Main.hs b/dap-estgi-server/src/Main.hs index afb7e73..8f20377 100644 --- a/dap-estgi-server/src/Main.hs +++ b/dap-estgi-server/src/Main.hs @@ -355,23 +355,26 @@ talk CommandSetBreakpoints = do _ -> True -- TODO let relevantLocations = filter (onlySupported . fst . fst) $ case sourceBreakpointColumn of Nothing -> - [ (p, (srcSpanELine - srcSpanSLine, maxBound)) + [ (p, spanSize) | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs , srcSpanFile == hsSourceFilePath , srcSpanSLine <= sourceBreakpointLine , srcSpanELine >= sourceBreakpointLine + , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) ] Just col -> - [ (p, (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol)) + [ (p, spanSize) | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs , srcSpanFile == hsSourceFilePath , srcSpanSLine <= sourceBreakpointLine , srcSpanELine >= sourceBreakpointLine , srcSpanSCol <= col , srcSpanECol >= col + , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) ] - liftIO $ putStrLn . unlines $ "relevant haskell locations:" : map show relevantLocations + 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 @@ -420,7 +423,7 @@ talk CommandSetBreakpoints = do , startCol <= col , endCol >= col ] - liftIO $ putStrLn $ "relevantLocations: " ++ show relevantLocations + debugMessage . cs $ "relevantLocations: " ++ show relevantLocations -- use the first location found case sortOn snd relevantLocations of (stgPoint@(SP_RhsClosureExpr closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do @@ -571,7 +574,9 @@ talk CommandVariables = do sendVariablesResponse (VariablesResponse variables) Just (VariablesRef_HeapObject addr) -> do stgState <- getStgState - let Just ho = IntMap.lookup addr $ ssHeap stgState + 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 -- detect and annotate loops let markLoop v @@ -580,7 +585,7 @@ talk CommandVariables = do | variableVariablesReference v > variablesArgumentsVariablesReference = v | otherwise - = v {variableName = variableName v <> " "} + = v {variableName = variableName v <> " "} sendVariablesResponse (VariablesResponse $ map markLoop variables) ---------------------------------------------------------------------------- talk CommandNext = do @@ -613,8 +618,10 @@ 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 - let Just packageName = Bimap.lookup binderUnitId unitIdMap - moduleName = cs $ getModuleName binderModule + 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