From bf00a58fab3719fa5502f125f357b1a990d76871 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 13:06:17 +0100 Subject: [PATCH 01/24] system-tests: Add simple system test --- client/src/GHC/Debug/Client.hs | 10 +++++----- test/Test.hs | 9 ++++----- test/ghc-debugger.cabal | 22 ++++++++++++++++++++++ 3 files changed, 31 insertions(+), 10 deletions(-) diff --git a/client/src/GHC/Debug/Client.hs b/client/src/GHC/Debug/Client.hs index c1b4d7e..8b45c76 100644 --- a/client/src/GHC/Debug/Client.hs +++ b/client/src/GHC/Debug/Client.hs @@ -1,5 +1,5 @@ module GHC.Debug.Client - ( Debuggee + ( Debuggee(..) , withDebuggee , withDebuggeeSocket , pauseDebuggee @@ -69,17 +69,17 @@ debuggeeProcess exe sockName = do -- | Open a debuggee, this will also read the DWARF information withDebuggee :: FilePath -- ^ path to executable + -> FilePath -- ^ filename of socket (e.g. @"/tmp/ghc-debug"@) -> (Debuggee -> IO a) -> IO a -withDebuggee exeName action = do - let sockName = "/tmp/ghc-debug2" +withDebuggee exeName socketName action = do -- Read DWARF information from the executable -- Start the process we want to debug - cp <- debuggeeProcess exeName sockName + cp <- debuggeeProcess exeName socketName withCreateProcess cp $ \_ _ _ _ -> do dwarf <- getDwarfInfo exeName -- Now connect to the socket the debuggeeProcess just started - withDebuggeeSocket exeName sockName (Just dwarf) action + withDebuggeeSocket exeName socketName (Just dwarf) action -- | Open a debuggee's socket directly diff --git a/test/Test.hs b/test/Test.hs index f0fd3f9..4c7c94d 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -10,13 +10,12 @@ import Control.Concurrent import Data.Bitraversable import GHC.Vis -prog = "/home/matt/ghc-debug/dist-newstyle/build/x86_64-linux/ghc-8.9.0.20190806/ghc-debug-stub-0.1.0.0/x/debug-test/build/debug-test/debug-test" - -prog2 = "/home/matt/ghc-debug/dist-newstyle/build/x86_64-linux/ghc-8.9.0.20190806/dyepack-test-0.1.0.0/x/dyepack-test/build/dyepack-test/dyepack-test" +prog = "/home/sven/src/ghc-debug/dist-newstyle/build/x86_64-linux/ghc-8.11.0/ghc-debug-stub-0.1.0.0/x/debug-test/build/debug-test/debug-test" +prog2 = "/home/sven/src/ghc-debug/dist-newstyle/build/x86_64-linux/ghc-8.11.0.20200126/dyepack-test-0.1.0.0/x/dyepack-test/build/dyepack-test/dyepack-test" --main = withDebuggeeSocket "/tmp/ghc-debug" Nothing p14 -main = withDebuggee prog2 p12 ---main = withDebuggee prog p15 +main = withDebuggee prog "/tmp/ghc-debug" p11 +--main = withDebuggee "/tmp/ghc-debug" prog p15 -- Test pause/resume p1 d = pauseDebuggee d (void $ getChar) diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal index ec7d232..d07aebc 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -19,3 +19,25 @@ executable debugger build-depends: base, ghc-debug-client, ghc-debug-common, ghc-heap, ghc-vis, containers default-language: Haskell2010 +test-suite system-test + type: exitcode-stdio-1.0 + main-is: TestSetup.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base + , hspec ==2.* + , process + , ghc-debug-client + , directory + , async + , extra + , dwarfadt + , text + other-modules: + SystemTest + , Server + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -debug -g3 + build-tool-depends: ghc-debug-stub:debug-test \ No newline at end of file From 2c52e974915a5952f83c1321ab2cf9dbf0246ab0 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 13:12:50 +0100 Subject: [PATCH 02/24] system-tests: Add tests --- test/test/Server.hs | 27 +++++++++++++++++++++++++ test/test/SystemTest.hs | 44 +++++++++++++++++++++++++++++++++++++++++ test/test/TestSetup.hs | 7 +++++++ 3 files changed, 78 insertions(+) create mode 100644 test/test/Server.hs create mode 100644 test/test/SystemTest.hs create mode 100644 test/test/TestSetup.hs diff --git a/test/test/Server.hs b/test/test/Server.hs new file mode 100644 index 0000000..59da6eb --- /dev/null +++ b/test/test/Server.hs @@ -0,0 +1,27 @@ +module Server (withServer) where + +import Control.Concurrent.Async +import Control.Monad +import System.IO +import System.Process +import Control.Concurrent + +withServer :: String -> FilePath -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a +withServer serverExe socketName logStdErr f = do + -- TODO Probably should just change runServer to accept + -- separate command and arguments + let cmd:args = words serverExe + let p = (proc cmd args) { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + env = Just [("GHC_DEBUG_SOCKET",socketName)] + } + withCreateProcess p $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do + -- Need to continuously consume to stderr else it gets blocked + -- Can't pass NoStream either to std_err + hSetBuffering serverErr NoBuffering + hSetBinaryMode serverErr True + let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn + withAsync errSinkThread $ \_ -> do + f serverIn serverOut serverProc diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs new file mode 100644 index 0000000..b353615 --- /dev/null +++ b/test/test/SystemTest.hs @@ -0,0 +1,44 @@ +module SystemTest where + +import Test.Hspec + +import System.Process +import GHC.IO.Handle + +import GHC.Debug.Client + +import Control.Monad +import Debug.Trace +import Control.Exception +import Control.Concurrent +import Data.Bitraversable + +import System.Directory +import System.IO.Extra hiding (map) +import Data.List.Extra hiding (map) +import Data.Text hiding (map) + +import Data.Dwarf.ADT + +import Server + +spec = do + describe "debuggeeDwarf" $ do + it "should return Dwarf of the executeable" $ do + withTempDir $ \ tempDirPath -> do + let socketName = tempDirPath ++ "/ghc-debug" + withServer "debug-test" socketName True $ \serverIn serverOut serverProc -> do + prog <- readCreateProcess (shell "which debug-test") [] + withDebuggee (trim prog) socketName $ \ d -> do + case debuggeeDwarf d of + Just dwarf -> dwarf `shouldContainCuName` "Test.hs" + Nothing -> error "No Dwarf" + +shouldContainCuName :: Dwarf -> String -> Expectation +shouldContainCuName dwarf name = allCuNames `shouldContain` [name] + where + allCuNames :: [String] + allCuNames = map (unpack . cuName . bData) boxedCompilationUnits + + boxedCompilationUnits :: [Boxed CompilationUnit] + boxedCompilationUnits = dwarfCompilationUnits dwarf diff --git a/test/test/TestSetup.hs b/test/test/TestSetup.hs new file mode 100644 index 0000000..d6e90a0 --- /dev/null +++ b/test/test/TestSetup.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.Hspec +import SystemTest + +main :: IO () +main = hspec spec From a2df96e909a4fd1004f3cb0d2603e6b23ff4272c Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 13:21:59 +0100 Subject: [PATCH 03/24] system-tests: Cleanup --- test/test/Server.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/test/test/Server.hs b/test/test/Server.hs index 59da6eb..27e62fd 100644 --- a/test/test/Server.hs +++ b/test/test/Server.hs @@ -8,8 +8,6 @@ import Control.Concurrent withServer :: String -> FilePath -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a withServer serverExe socketName logStdErr f = do - -- TODO Probably should just change runServer to accept - -- separate command and arguments let cmd:args = words serverExe let p = (proc cmd args) { std_in = CreatePipe, From c5377c02b4d201d5775f188315ccd7a1638cda7e Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 15:21:43 +0100 Subject: [PATCH 04/24] system-tests: Cleanup --- test/test/SystemTest.hs | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index b353615..b597983 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -3,25 +3,16 @@ module SystemTest where import Test.Hspec import System.Process -import GHC.IO.Handle - import GHC.Debug.Client - -import Control.Monad -import Debug.Trace -import Control.Exception -import Control.Concurrent -import Data.Bitraversable - -import System.Directory -import System.IO.Extra hiding (map) -import Data.List.Extra hiding (map) -import Data.Text hiding (map) +import System.IO.Extra +import Data.List.Extra (trim) +import Data.Text (unpack) import Data.Dwarf.ADT import Server +spec :: SpecWith () spec = do describe "debuggeeDwarf" $ do it "should return Dwarf of the executeable" $ do From f15710c26835ed90e0a17ef028a394ee866425bc Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 15:25:09 +0100 Subject: [PATCH 05/24] system-tests: Do not depend on fixed file paths --- test/Test.hs | 28 ++++++++++++++++++++++------ test/ghc-debugger.cabal | 10 +++++++++- 2 files changed, 31 insertions(+), 7 deletions(-) diff --git a/test/Test.hs b/test/Test.hs index 4c7c94d..8c4b0d7 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -10,12 +10,28 @@ import Control.Concurrent import Data.Bitraversable import GHC.Vis -prog = "/home/sven/src/ghc-debug/dist-newstyle/build/x86_64-linux/ghc-8.11.0/ghc-debug-stub-0.1.0.0/x/debug-test/build/debug-test/debug-test" -prog2 = "/home/sven/src/ghc-debug/dist-newstyle/build/x86_64-linux/ghc-8.11.0.20200126/dyepack-test-0.1.0.0/x/dyepack-test/build/dyepack-test/dyepack-test" +import Data.List.Extra (trim) +import System.Process ---main = withDebuggeeSocket "/tmp/ghc-debug" Nothing p14 -main = withDebuggee prog "/tmp/ghc-debug" p11 ---main = withDebuggee "/tmp/ghc-debug" prog p15 +debugTestPath :: IO FilePath +debugTestPath = testProgPath "debug-test" + +dyePackTestPath :: IO FilePath +dyePackTestPath = testProgPath "dyepack-test" + +testProgPath :: String -> IO FilePath +testProgPath progName = do + path <- readCreateProcess shellCmd [] + return $ trim path + where + shellCmd = shell $ "which " ++ progName + +---main = withDebuggeeSocket "/tmp/ghc-debug" Nothing p14 +main :: IO () +main = do + prog <- debugTestPath -- Or @dyePackTestPath@ + print prog + withDebuggee prog "/tmp/ghc-debug" p12 -- Test pause/resume p1 d = pauseDebuggee d (void $ getChar) @@ -118,7 +134,7 @@ p11 d = do let itb = getInfoTblPtr c case lookupDwarf d itb of Just r -> showFileSnippet d r - Nothing -> return () + Nothing -> print "No Dwarf!" p12 d = do request d RequestPoll diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal index d07aebc..25ddeef 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -16,8 +16,16 @@ cabal-version: >=1.10 executable debugger main-is: Test.hs ghc-options: -threaded -debug -g3 - build-depends: base, ghc-debug-client, ghc-debug-common, ghc-heap, ghc-vis, containers + build-depends: base + , ghc-debug-client + , ghc-debug-common + , ghc-heap + , ghc-vis + , containers + , extra + , process default-language: Haskell2010 + build-tool-depends: ghc-debug-stub:debug-test, dyepack-test:dyepack-test test-suite system-test type: exitcode-stdio-1.0 From d1f2f980f2c402d9c558e58d79865b0003d80d2d Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 16:15:02 +0100 Subject: [PATCH 06/24] system-tests: Add test for RequestVersion --- test/test/SystemTest.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index b597983..33f625d 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -25,6 +25,19 @@ spec = do Just dwarf -> dwarf `shouldContainCuName` "Test.hs" Nothing -> error "No Dwarf" + describe "request" $ do + describe "version" $ do + it "should return the correct version" $ do + withTempDir $ \ tempDirPath -> do + let socketName = tempDirPath ++ "/ghc-debug" + withServer "debug-test" socketName True $ \serverIn serverOut serverProc -> do + prog <- readCreateProcess (shell "which debug-test") [] + withDebuggee (trim prog) socketName $ \ d -> do + version <- request d RequestVersion + request d RequestPause + request d RequestResume + version `shouldBe` 0 + shouldContainCuName :: Dwarf -> String -> Expectation shouldContainCuName dwarf name = allCuNames `shouldContain` [name] where From 06c7862b305ad2866b0945a36f8dd340d9d69791 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 16:24:24 +0100 Subject: [PATCH 07/24] system-tests: Add test for RequestRoots --- test/test/SystemTest.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 33f625d..756d59c 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -26,7 +26,7 @@ spec = do Nothing -> error "No Dwarf" describe "request" $ do - describe "version" $ do + describe "RequestVersion" $ do it "should return the correct version" $ do withTempDir $ \ tempDirPath -> do let socketName = tempDirPath ++ "/ghc-debug" @@ -34,10 +34,19 @@ spec = do prog <- readCreateProcess (shell "which debug-test") [] withDebuggee (trim prog) socketName $ \ d -> do version <- request d RequestVersion - request d RequestPause - request d RequestResume version `shouldBe` 0 + describe "RequestRoots" $ do + it "should return a non-empty result" $ do + withTempDir $ \ tempDirPath -> do + let socketName = tempDirPath ++ "/ghc-debug" + withServer "debug-test" socketName True $ \serverIn serverOut serverProc -> do + prog <- readCreateProcess (shell "which debug-test") [] + withDebuggee (trim prog) socketName $ \ d -> do + request d RequestPause + roots <- request d RequestRoots + roots `shouldNotBe` [] + shouldContainCuName :: Dwarf -> String -> Expectation shouldContainCuName dwarf name = allCuNames `shouldContain` [name] where From e354df66f7bcd4e19fc6a13fecd0123ee4ca5e55 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 22 Mar 2020 17:22:39 +0100 Subject: [PATCH 08/24] system-tests: Simplify test setup --- test/test/Server.hs | 20 +++++++++++++++++--- test/test/SystemTest.hs | 41 +++++++++++++---------------------------- 2 files changed, 30 insertions(+), 31 deletions(-) diff --git a/test/test/Server.hs b/test/test/Server.hs index 27e62fd..7de8cf7 100644 --- a/test/test/Server.hs +++ b/test/test/Server.hs @@ -1,10 +1,14 @@ -module Server (withServer) where +module Server (withServer, withStartedDebuggee) where import Control.Concurrent.Async import Control.Monad import System.IO import System.Process import Control.Concurrent +import Data.List.Extra (trim) +import System.IO.Extra + +import GHC.Debug.Client withServer :: String -> FilePath -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a withServer serverExe socketName logStdErr f = do @@ -21,5 +25,15 @@ withServer serverExe socketName logStdErr f = do hSetBuffering serverErr NoBuffering hSetBinaryMode serverErr True let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn - withAsync errSinkThread $ \_ -> do - f serverIn serverOut serverProc + withAsync errSinkThread $ \_ -> f serverIn serverOut serverProc + +withStartedDebuggee :: String -- ^ executable name + -> (Debuggee -> IO a) -- ^ action + -> IO a +withStartedDebuggee exeName action = withTempDir $ \ tempDirPath -> do + let socketName = tempDirPath ++ "/ghc-debug" + withServer exeName socketName True $ \serverIn serverOut serverProc -> do + prog <- readCreateProcess serverExePathCmd [] + withDebuggee (trim prog) socketName action + where + serverExePathCmd = shell $ "which " ++ exeName diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 756d59c..1f27f8a 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -2,10 +2,7 @@ module SystemTest where import Test.Hspec -import System.Process import GHC.Debug.Client -import System.IO.Extra -import Data.List.Extra (trim) import Data.Text (unpack) import Data.Dwarf.ADT @@ -14,35 +11,23 @@ import Server spec :: SpecWith () spec = do - describe "debuggeeDwarf" $ do - it "should return Dwarf of the executeable" $ do - withTempDir $ \ tempDirPath -> do - let socketName = tempDirPath ++ "/ghc-debug" - withServer "debug-test" socketName True $ \serverIn serverOut serverProc -> do - prog <- readCreateProcess (shell "which debug-test") [] - withDebuggee (trim prog) socketName $ \ d -> do - case debuggeeDwarf d of + describe "debuggeeDwarf" $ + it "should return Dwarf of the executeable" $ + withStartedDebuggee "debug-test" $ \ d -> + case debuggeeDwarf d of Just dwarf -> dwarf `shouldContainCuName` "Test.hs" Nothing -> error "No Dwarf" describe "request" $ do - describe "RequestVersion" $ do - it "should return the correct version" $ do - withTempDir $ \ tempDirPath -> do - let socketName = tempDirPath ++ "/ghc-debug" - withServer "debug-test" socketName True $ \serverIn serverOut serverProc -> do - prog <- readCreateProcess (shell "which debug-test") [] - withDebuggee (trim prog) socketName $ \ d -> do - version <- request d RequestVersion - version `shouldBe` 0 - - describe "RequestRoots" $ do - it "should return a non-empty result" $ do - withTempDir $ \ tempDirPath -> do - let socketName = tempDirPath ++ "/ghc-debug" - withServer "debug-test" socketName True $ \serverIn serverOut serverProc -> do - prog <- readCreateProcess (shell "which debug-test") [] - withDebuggee (trim prog) socketName $ \ d -> do + describe "RequestVersion" $ + it "should return the correct version" $ + withStartedDebuggee "debug-test" $ \ d -> do + version <- request d RequestVersion + version `shouldBe` 0 + + describe "RequestRoots" $ + it "should return a non-empty result" $ + withStartedDebuggee "debug-test" $ \ d -> do request d RequestPause roots <- request d RequestRoots roots `shouldNotBe` [] From 9a112d7861ba5cf980a785f1ef7f853aa8adc4f0 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 5 Apr 2020 18:52:04 +0200 Subject: [PATCH 09/24] system-tests: Add cabal.project.local to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 108832a..39c80c7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .ghc.environment.* dist-newstyle/ +cabal.project.local \ No newline at end of file From 191429fdeb0651aad55116a224db1ed787dd99f6 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 5 Apr 2020 19:01:14 +0200 Subject: [PATCH 10/24] system-tests: Remove `unsafePerformIO` `decodeClosure` works without it. --- client/src/GHC/Debug/Client.hs | 2 +- common/src/GHC/Debug/Decode.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/client/src/GHC/Debug/Client.hs b/client/src/GHC/Debug/Client.hs index 8b45c76..0d931bc 100644 --- a/client/src/GHC/Debug/Client.hs +++ b/client/src/GHC/Debug/Client.hs @@ -185,7 +185,7 @@ dereferenceClosures d cs = do let its = map getInfoTblPtr raw_cs --print $ map (lookupDwarf d) its raw_its <- request d (RequestInfoTables its) - return $ map (uncurry decodeClosure) (zip raw_its (zip cs raw_cs)) + mapM (uncurry decodeClosure) (zip raw_its (zip cs raw_cs)) dereferenceStack :: Debuggee -> StackCont -> IO Stack dereferenceStack d (StackCont stack) = do diff --git a/common/src/GHC/Debug/Decode.hs b/common/src/GHC/Debug/Decode.hs index 077d537..c2321f7 100644 --- a/common/src/GHC/Debug/Decode.hs +++ b/common/src/GHC/Debug/Decode.hs @@ -82,8 +82,8 @@ data Ptr' a = Ptr' a aToWord# :: Any -> Word# aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr -decodeClosure :: RawInfoTable -> (ClosurePtr, RawClosure) -> Closure -decodeClosure (RawInfoTable itbl) (ptr, rc@(RawClosure clos)) = unsafePerformIO $ do +decodeClosure :: RawInfoTable -> (ClosurePtr, RawClosure) -> IO Closure +decodeClosure (RawInfoTable itbl) (ptr, rc@(RawClosure clos)) = do allocate itbl $ \itblPtr -> do allocate clos $ \closPtr -> do let ptr_to_itbl_ptr :: Ptr (Ptr StgInfoTable) From 67100257be90ce02eeba450149bbfea499f1edf8 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 5 Apr 2020 19:11:07 +0200 Subject: [PATCH 11/24] system-tests: Extract C++ `trace` into separate file Makes `stub.cpp` smaller and `trace` can be easier reused for debugging purposes. --- stub/cbits/stub.cpp | 18 +----------------- stub/cbits/trace.cpp | 16 ++++++++++++++++ stub/cbits/trace.h | 3 +++ stub/ghc-debug-stub.cabal | 2 +- 4 files changed, 21 insertions(+), 18 deletions(-) create mode 100644 stub/cbits/trace.cpp create mode 100644 stub/cbits/trace.h diff --git a/stub/cbits/stub.cpp b/stub/cbits/stub.cpp index 649e9d9..6df7eff 100644 --- a/stub/cbits/stub.cpp +++ b/stub/cbits/stub.cpp @@ -15,32 +15,16 @@ #include #include "socket.h" +#include "trace.h" #include "parser.h" #include #include #define MAX_CMD_SIZE 4096 - #define WORD_SIZE sizeof(unsigned long) #define INFO_TABLE_SIZE sizeof(StgInfoTable) -#ifdef TRACE -void trace(const char *fmt, ...) { - va_list args; - va_start(args, fmt); - vprintf(fmt, args); - va_end(args); -} -#else -void trace(const char * fmt, ...){ - (void) fmt; -} -#endif - - - - /* * Wire format: * diff --git a/stub/cbits/trace.cpp b/stub/cbits/trace.cpp new file mode 100644 index 0000000..e22a584 --- /dev/null +++ b/stub/cbits/trace.cpp @@ -0,0 +1,16 @@ +#include +#include + +#ifdef TRACE +void trace(const char *fmt, ...) { + va_list args; + va_start(args, fmt); + vprintf(fmt, args); + va_end(args); +} +#else +void trace(const char * fmt, ...){ + (void) fmt; +} +#endif + diff --git a/stub/cbits/trace.h b/stub/cbits/trace.h new file mode 100644 index 0000000..28a3fa9 --- /dev/null +++ b/stub/cbits/trace.h @@ -0,0 +1,3 @@ +#pragma once + +void trace(const char *fmt, ...); diff --git a/stub/ghc-debug-stub.cabal b/stub/ghc-debug-stub.cabal index a954a1d..874e069 100644 --- a/stub/ghc-debug-stub.cabal +++ b/stub/ghc-debug-stub.cabal @@ -23,7 +23,7 @@ library hs-source-dirs: src build-depends: base >=4.12 && <4.14, ghc-prim default-language: Haskell2010 - cxx-sources: cbits/stub.cpp, cbits/socket.cpp + cxx-sources: cbits/stub.cpp, cbits/socket.cpp, cbits/trace.cpp cxx-options: -std=gnu++11 ghc-options: -threaded extra-libraries: stdc++ From 5bca1aeb027bf60f10ed30639059a58e4501a7fe Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 5 Apr 2020 19:17:34 +0200 Subject: [PATCH 12/24] system-tests: Add `save-one` path to `Test.hs` One more option to play around... --- test/Test.hs | 4 +++- test/ghc-debugger.cabal | 21 +++++++++++++++++++-- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/test/Test.hs b/test/Test.hs index 8c4b0d7..805cd05 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -13,6 +13,9 @@ import GHC.Vis import Data.List.Extra (trim) import System.Process +saveOnePath :: IO FilePath +saveOnePath = testProgPath "save-one" + debugTestPath :: IO FilePath debugTestPath = testProgPath "debug-test" @@ -27,7 +30,6 @@ testProgPath progName = do shellCmd = shell $ "which " ++ progName ---main = withDebuggeeSocket "/tmp/ghc-debug" Nothing p14 -main :: IO () main = do prog <- debugTestPath -- Or @dyePackTestPath@ print prog diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal index 25ddeef..ed83050 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -47,5 +47,22 @@ test-suite system-test SystemTest , Server default-language: Haskell2010 - ghc-options: -threaded -rtsopts -debug -g3 - build-tool-depends: ghc-debug-stub:debug-test \ No newline at end of file + ghc-options: -threaded -debug -g3 + build-tool-depends: ghc-debug-stub:debug-test, ghc-debugger:save-one + +executable save-one + main-is: SaveOne.hs + hs-source-dirs: + test-progs + ghc-options: -threaded -debug -g3 -O0 + build-depends: base + , ghc-debug-client + , ghc-debug-common + , ghc-heap + , ghc-vis + , containers + , extra + , process + , ghc-debug-stub + default-language: Haskell2010 + From ed5833bba3ace60aa7ef943cc4343ea284026ba2 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 5 Apr 2020 19:27:37 +0200 Subject: [PATCH 13/24] system-tests: Add test for RequestSavedObjects --- test/test/Server.hs | 22 +++++++++++++++++++- test/test/SystemTest.hs | 46 +++++++++++++++++++++++++++++++++++++---- 2 files changed, 63 insertions(+), 5 deletions(-) diff --git a/test/test/Server.hs b/test/test/Server.hs index 7de8cf7..da6a149 100644 --- a/test/test/Server.hs +++ b/test/test/Server.hs @@ -1,4 +1,4 @@ -module Server (withServer, withStartedDebuggee) where +module Server (withServer, withStartedDebuggee, withStartedDebuggeeAndHandles, Handles(..)) where import Control.Concurrent.Async import Control.Monad @@ -19,6 +19,7 @@ withServer serverExe socketName logStdErr f = do std_err = CreatePipe, env = Just [("GHC_DEBUG_SOCKET",socketName)] } +-- TODO pattern match case where one or more handles are not available (-> error with message) withCreateProcess p $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do -- Need to continuously consume to stderr else it gets blocked -- Can't pass NoStream either to std_err @@ -27,6 +28,7 @@ withServer serverExe socketName logStdErr f = do let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn withAsync errSinkThread $ \_ -> f serverIn serverOut serverProc + withStartedDebuggee :: String -- ^ executable name -> (Debuggee -> IO a) -- ^ action -> IO a @@ -37,3 +39,21 @@ withStartedDebuggee exeName action = withTempDir $ \ tempDirPath -> do withDebuggee (trim prog) socketName action where serverExePathCmd = shell $ "which " ++ exeName + +data Handles = Handles { + stdin :: Handle, + stdout :: Handle, + process :: ProcessHandle + } + +withStartedDebuggeeAndHandles :: String -- ^ executable name + -> (Handles -> Debuggee -> IO a) -- ^ action + -> IO a +withStartedDebuggeeAndHandles exeName action = withTempDir $ \ tempDirPath -> do + let socketName = tempDirPath ++ "/ghc-debug" + withServer exeName socketName True $ \serverIn serverOut serverProc -> do + prog <- readCreateProcess serverExePathCmd [] + let handles = Handles serverIn serverOut serverProc + withDebuggee (trim prog) socketName (action handles) + where + serverExePathCmd = shell $ "which " ++ exeName diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 1f27f8a..339fb2c 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -4,11 +4,17 @@ import Test.Hspec import GHC.Debug.Client import Data.Text (unpack) - +import System.IO import Data.Dwarf.ADT import Server +import Debug.Trace +import Control.Monad + +import Control.Concurrent.Async +import Control.Concurrent + spec :: SpecWith () spec = do describe "debuggeeDwarf" $ @@ -28,9 +34,41 @@ spec = do describe "RequestRoots" $ it "should return a non-empty result" $ withStartedDebuggee "debug-test" $ \ d -> do - request d RequestPause - roots <- request d RequestRoots - roots `shouldNotBe` [] + request d RequestPause + roots <- request d RequestRoots + roots `shouldNotBe` [] + + describe "RequestSavedObjects" $ + it "should return saved object" $ + withStartedDebuggeeAndHandles "save-one" $ \ h d -> do + waitForSync $ Server.stdout h + let errSinkThread = forever $ do + l <- hGetLine (Server.stdout h) + print l + withAsync errSinkThread $ \_ -> do + -- TODO Get rid of the `threadDelay`. `save-one` should signal that the GC has finished. + threadDelay 5000000 + request d RequestPause + ss@(s:_) <- request d RequestSavedObjects + length ss `shouldBe` 1 + sos <- request d (RequestFindPtr s) + print $ "sos : " ++ show sos + length sos `shouldBe` 1 + dcs <- dereferenceClosures d sos + mapM_ print dcs + length dcs `shouldBe` 1 + +waitForSync :: Handle -> IO () +waitForSync h = do + hSetBuffering h LineBuffering + l <- hGetLine h + traceIO $ "line " ++ l + if l == "\"sync\"" then + return () + else + waitForSync h +-- TODO There should be some exit condition. +-- error "Can not sync!" shouldContainCuName :: Dwarf -> String -> Expectation shouldContainCuName dwarf name = allCuNames `shouldContain` [name] From a188a19189ff6b0a311d45c7dcf165e2e80d24fc Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 12 Apr 2020 12:13:42 +0200 Subject: [PATCH 14/24] system-tests: Check result in test for RequestSavedObjects --- common/src/GHC/Debug/Types/Closures.hs | 2 ++ stub/cbits/stub.cpp | 1 + test/ghc-debugger.cabal | 2 ++ test/test-progs/SaveOne.hs | 22 +++++++++++++++++++++ test/test/SystemTest.hs | 27 +++++++++++++------------- 5 files changed, 41 insertions(+), 13 deletions(-) create mode 100644 test/test-progs/SaveOne.hs diff --git a/common/src/GHC/Debug/Types/Closures.hs b/common/src/GHC/Debug/Types/Closures.hs index fe70714..b23ab61 100644 --- a/common/src/GHC/Debug/Types/Closures.hs +++ b/common/src/GHC/Debug/Types/Closures.hs @@ -70,6 +70,8 @@ type Closure = DebugClosure ClosurePtr StackCont ClosurePtr type Stack = DebugStackFrame ClosurePtr +-- TODO looks like a copy of ghc-lib-parser:GHC.Exts.Heap + -- | This is the representation of a Haskell value on the heap. It reflects -- -- diff --git a/stub/cbits/stub.cpp b/stub/cbits/stub.cpp index 6df7eff..34922b0 100644 --- a/stub/cbits/stub.cpp +++ b/stub/cbits/stub.cpp @@ -530,6 +530,7 @@ StgWord saveClosures(StgWord n, HsStablePtr *sps) struct savedObjectsState *ps = &g_savedObjectState; StgWord i; + // TODO Use a constant to communicate relationship with size(savedObjectsState.objects) if(n > 20) return 20; diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal index ed83050..d0095b0 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -38,6 +38,8 @@ test-suite system-test , hspec ==2.* , process , ghc-debug-client + , ghc-debug-common + , ghc-vis , directory , async , extra diff --git a/test/test-progs/SaveOne.hs b/test/test-progs/SaveOne.hs new file mode 100644 index 0000000..488cc04 --- /dev/null +++ b/test/test-progs/SaveOne.hs @@ -0,0 +1,22 @@ +import GHC.Debug.Stub +import System.Mem +import Control.Concurrent +import System.IO +import Data.Word +import GHC.Stats + +loop :: IO () +loop = go 0 + where + go x = hFlush stdout >> print x >> threadDelay 1000000 >> go (x + 1) + +main :: IO () +main = do + start + let v = 1 :: Int + performGC + saveClosures [Box v] + print "sync" + hFlush stdout + loop + print $ v diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 339fb2c..eb0242c 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -3,6 +3,8 @@ module SystemTest where import Test.Hspec import GHC.Debug.Client +import GHC.Debug.Types.Graph +import GHC.Vis import Data.Text (unpack) import System.IO import Data.Dwarf.ADT @@ -42,21 +44,15 @@ spec = do it "should return saved object" $ withStartedDebuggeeAndHandles "save-one" $ \ h d -> do waitForSync $ Server.stdout h - let errSinkThread = forever $ do - l <- hGetLine (Server.stdout h) - print l - withAsync errSinkThread $ \_ -> do - -- TODO Get rid of the `threadDelay`. `save-one` should signal that the GC has finished. + withAsync (pipeStreamThread (Server.stdout h)) $ \_ -> do + -- TODO Get rid of the `threadDelay`. + -- `save-one` should signal that the GC has finished. threadDelay 5000000 request d RequestPause - ss@(s:_) <- request d RequestSavedObjects - length ss `shouldBe` 1 - sos <- request d (RequestFindPtr s) - print $ "sos : " ++ show sos - length sos `shouldBe` 1 - dcs <- dereferenceClosures d sos - mapM_ print dcs - length dcs `shouldBe` 1 + os@(o:_) <- request d RequestSavedObjects + length os `shouldBe` 1 + hg <- buildHeapGraph (derefBox d) 20 () o + ppHeapGraph hg `shouldBe` "I# 1" waitForSync :: Handle -> IO () waitForSync h = do @@ -70,6 +66,11 @@ waitForSync h = do -- TODO There should be some exit condition. -- error "Can not sync!" +pipeStreamThread :: Handle -> IO () +pipeStreamThread h = forever $ do + l <- hGetLine h + print l + shouldContainCuName :: Dwarf -> String -> Expectation shouldContainCuName dwarf name = allCuNames `shouldContain` [name] where From c90d926b203f88f30c90847c0813ffa665bb8567 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 12 Apr 2020 20:11:45 +0200 Subject: [PATCH 15/24] system-tests: Add test for RequestResume --- test/ghc-debugger.cabal | 13 ++++++++- test/test-progs/Clock.hs | 24 +++++++++++++++++ test/test/SystemTest.hs | 57 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 93 insertions(+), 1 deletion(-) create mode 100644 test/test-progs/Clock.hs diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal index d0095b0..df276e6 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -50,7 +50,9 @@ test-suite system-test , Server default-language: Haskell2010 ghc-options: -threaded -debug -g3 - build-tool-depends: ghc-debug-stub:debug-test, ghc-debugger:save-one + build-tool-depends: ghc-debug-stub:debug-test + , ghc-debugger:save-one + , ghc-debugger:clock executable save-one main-is: SaveOne.hs @@ -68,3 +70,12 @@ executable save-one , ghc-debug-stub default-language: Haskell2010 +executable clock + main-is: Clock.hs + hs-source-dirs: + test-progs + ghc-options: -threaded -debug -g3 -O0 + build-depends: base + , ghc-debug-stub + default-language: Haskell2010 + diff --git a/test/test-progs/Clock.hs b/test/test-progs/Clock.hs new file mode 100644 index 0000000..31238fe --- /dev/null +++ b/test/test-progs/Clock.hs @@ -0,0 +1,24 @@ +import GHC.Debug.Stub +import System.Mem +import Control.Concurrent +import System.IO +import Data.Word +import GHC.Stats +import GHC.Clock + +loop :: IO () +loop = do + time <- getMonotonicTimeNSec + print time + hFlush stdout + threadDelay oneSecond + loop + where + oneSecond = 1000000 + +main :: IO () +main = do + start + print "sync" + hFlush stdout + loop diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index eb0242c..ec7f907 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -16,7 +16,15 @@ import Control.Monad import Control.Concurrent.Async import Control.Concurrent +import Control.Monad.Extra +import Data.Word +import Data.IORef +import GHC.Clock +import System.Timeout +import Data.List.Extra + +-- TODO use timeout for tests spec :: SpecWith () spec = do describe "debuggeeDwarf" $ @@ -54,6 +62,44 @@ spec = do hg <- buildHeapGraph (derefBox d) 20 () o ppHeapGraph hg `shouldBe` "I# 1" + describe "RequestResume" $ + it "should resume a paused debugee" $ + withStartedDebuggeeAndHandles "clock" $ \ h d -> do + waitForSync $ Server.stdout h + ref <- newIORef [] + withAsync (pipeStreamToListThread ref (Server.stdout h)) $ \_ -> do + request d RequestPause + (t:_) <- readIORef ref + assertNoNewClockTimes ref t + + request d RequestResume + + assertNewClockTime ref + where + oneSecondInMicros = 1000000 + fiveSecondsInMicros = 5000000 + + assertNoNewClockTimes :: IORef [ClockTime] -> ClockTime -> Expectation + assertNoNewClockTimes ref t0 = do + result <- timeout fiveSecondsInMicros $ whileM $ do + threadDelay oneSecondInMicros + (t1:_) <- readIORef ref + return $ t0 == t1 + + result `shouldBe` Nothing + + assertNewClockTime :: IORef [ClockTime] -> Expectation + assertNewClockTime ref = do + now <- getMonotonicTimeNSec + print $ "now2 : " ++ show now + result <- timeout fiveSecondsInMicros $ whileM $ do + threadDelay 5000 + (t:_) <- readIORef ref + return $ t < now + + result `shouldBe` Just () + + waitForSync :: Handle -> IO () waitForSync h = do hSetBuffering h LineBuffering @@ -71,6 +117,17 @@ pipeStreamThread h = forever $ do l <- hGetLine h print l +type ClockTime = Word64 + +pipeStreamToListThread :: IORef [ClockTime] -> Handle -> IO () +pipeStreamToListThread ref h = forever $ do + l <- hGetLine h + timesList <- readIORef ref + writeIORef ref $ (toClockTime l) : timesList + where + toClockTime :: String -> ClockTime + toClockTime s = read . trim $ s + shouldContainCuName :: Dwarf -> String -> Expectation shouldContainCuName dwarf name = allCuNames `shouldContain` [name] where From b469b8575776e82202ae7ecfaa892f7284c790a4 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 12:33:23 +0200 Subject: [PATCH 16/24] system-tests: Add test for RequestClosures --- test/test/SystemTest.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index ec7f907..2aab133 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -48,6 +48,14 @@ spec = do roots <- request d RequestRoots roots `shouldNotBe` [] + describe "RequestClosures" $ + it "should return a non-empty result" $ + withStartedDebuggee "debug-test" $ \ d -> do + request d RequestPause + roots <- request d RequestRoots + closures <- request d $ RequestClosures roots + closures `shouldNotBe` [] + describe "RequestSavedObjects" $ it "should return saved object" $ withStartedDebuggeeAndHandles "save-one" $ \ h d -> do From b5e03c2c53e6d31ba4e9a73db797ee46a7ffe0b0 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 13:59:55 +0200 Subject: [PATCH 17/24] system-tests: Add test for RequestInfoTables --- test/ghc-debugger.cabal | 17 +++++++++++++++++ test/test-progs/SaveOnePause.hs | 25 +++++++++++++++++++++++++ test/test/SystemTest.hs | 14 ++++++++++++-- 3 files changed, 54 insertions(+), 2 deletions(-) create mode 100644 test/test-progs/SaveOnePause.hs diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal index df276e6..765383c 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -52,6 +52,7 @@ test-suite system-test ghc-options: -threaded -debug -g3 build-tool-depends: ghc-debug-stub:debug-test , ghc-debugger:save-one + , ghc-debugger:save-one-pause , ghc-debugger:clock executable save-one @@ -79,3 +80,19 @@ executable clock , ghc-debug-stub default-language: Haskell2010 +executable save-one-pause + main-is: SaveOnePause.hs + hs-source-dirs: + test-progs + ghc-options: -threaded -debug -g3 -O0 + build-depends: base + , ghc-debug-client + , ghc-debug-common + , ghc-heap + , ghc-vis + , containers + , extra + , process + , ghc-debug-stub + default-language: Haskell2010 + diff --git a/test/test-progs/SaveOnePause.hs b/test/test-progs/SaveOnePause.hs new file mode 100644 index 0000000..34ad468 --- /dev/null +++ b/test/test-progs/SaveOnePause.hs @@ -0,0 +1,25 @@ +import GHC.Debug.Stub +import System.Mem +import Control.Concurrent +import System.IO +import Data.Word +import GHC.Stats + +loop :: IO () +loop = go 0 + where + go 0 = threadDelay 500000 >> pause >> go 1 + go x = threadDelay 500000 >> go (x + 1) + +main :: IO () +main = do + start + + print "sync" + hFlush stdout + + let v = 1 :: Int + performGC + saveClosures [Box v] + loop + print $ v diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 2aab133..b55fda8 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -70,6 +70,18 @@ spec = do hg <- buildHeapGraph (derefBox d) 20 () o ppHeapGraph hg `shouldBe` "I# 1" + describe "RequestInfoTables" $ + it "should return decodable RawInfoTables" $ + withStartedDebuggeeAndHandles "save-one-pause" $ \ h d -> do + waitForSync $ Server.stdout h + request d RequestPoll + sos <- request d RequestSavedObjects + closures <- request d $ RequestClosures sos + let itptrs = map getInfoTblPtr closures + its <- request d $ RequestInfoTables itptrs + let stgits = map decodeInfoTable its + length stgits `shouldBe` 1 + describe "RequestResume" $ it "should resume a paused debugee" $ withStartedDebuggeeAndHandles "clock" $ \ h d -> do @@ -99,7 +111,6 @@ spec = do assertNewClockTime :: IORef [ClockTime] -> Expectation assertNewClockTime ref = do now <- getMonotonicTimeNSec - print $ "now2 : " ++ show now result <- timeout fiveSecondsInMicros $ whileM $ do threadDelay 5000 (t:_) <- readIORef ref @@ -107,7 +118,6 @@ spec = do result `shouldBe` Just () - waitForSync :: Handle -> IO () waitForSync h = do hSetBuffering h LineBuffering From 06e59bd0cdf5fcd2259a0e607c5d2ecbb2aedbed Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 14:12:45 +0200 Subject: [PATCH 18/24] system-tests: Add test for RequestConstrDesc --- common/src/GHC/Debug/Types/Closures.hs | 2 +- test/test/SystemTest.hs | 10 ++++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/common/src/GHC/Debug/Types/Closures.hs b/common/src/GHC/Debug/Types/Closures.hs index b23ab61..242e4c3 100644 --- a/common/src/GHC/Debug/Types/Closures.hs +++ b/common/src/GHC/Debug/Types/Closures.hs @@ -310,7 +310,7 @@ data ConstrDesc = ConstrDesc { pkg :: !String -- ^ Package name , modl :: !String -- ^ Module name , name :: !String -- ^ Constructor name - } deriving Show + } deriving (Show, Eq) -- Copied from ghc-heap diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index b55fda8..8ee5465 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -4,6 +4,7 @@ import Test.Hspec import GHC.Debug.Client import GHC.Debug.Types.Graph +import GHC.Debug.Types.Closures import GHC.Vis import Data.Text (unpack) import System.IO @@ -82,6 +83,15 @@ spec = do let stgits = map decodeInfoTable its length stgits `shouldBe` 1 + describe "RequestConstrDesc" $ + it "should return decodable RawInfoTables" $ + withStartedDebuggeeAndHandles "save-one-pause" $ \ h d -> do + waitForSync $ Server.stdout h + request d RequestPoll + (s:_) <- request d RequestSavedObjects + cd <- request d $ RequestConstrDesc s + cd `shouldBe` ConstrDesc {pkg = "ghc-prim", modl = "GHC.Types", name = "I#"} + describe "RequestResume" $ it "should resume a paused debugee" $ withStartedDebuggeeAndHandles "clock" $ \ h d -> do From 54e505f2b32320bf8a3211e560cc2bc860b99a2a Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 15:35:45 +0200 Subject: [PATCH 19/24] system-tests: Cleanup --- test/test/SystemTest.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 8ee5465..054706f 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -84,7 +84,7 @@ spec = do length stgits `shouldBe` 1 describe "RequestConstrDesc" $ - it "should return decodable RawInfoTables" $ + it "should return ConstrDesc of saved value (I# 1)" $ withStartedDebuggeeAndHandles "save-one-pause" $ \ h d -> do waitForSync $ Server.stdout h request d RequestPoll @@ -132,7 +132,6 @@ waitForSync :: Handle -> IO () waitForSync h = do hSetBuffering h LineBuffering l <- hGetLine h - traceIO $ "line " ++ l if l == "\"sync\"" then return () else From 298a38f5ba46db8001171abe161511c42a9a5e6a Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 16:03:25 +0200 Subject: [PATCH 20/24] system-tests: Add test for RequestFindPtr --- test/test/SystemTest.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 054706f..3d6b437 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -92,6 +92,16 @@ spec = do cd <- request d $ RequestConstrDesc s cd `shouldBe` ConstrDesc {pkg = "ghc-prim", modl = "GHC.Types", name = "I#"} + describe "RequestFindPtr" $ + it "should return ClosurePtrs that can be dereferenced" $ + withStartedDebuggeeAndHandles "save-one-pause" $ \ h d -> do + waitForSync $ Server.stdout h + request d RequestPoll + (s:_) <- request d RequestSavedObjects + ptrs <- request d $ RequestFindPtr s + closures <- dereferenceClosures d ptrs + closures `shouldSatisfy` (\ cs -> notNull cs) + describe "RequestResume" $ it "should resume a paused debugee" $ withStartedDebuggeeAndHandles "clock" $ \ h d -> do From 5779dabba140244555957a397a0a01e75bc11883 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 17:43:51 +0200 Subject: [PATCH 21/24] system-tests: Cleanup - Use RequestPoll where possible - Better assertion for empty list - Fail if synchronization times out --- test/test/SystemTest.hs | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index 3d6b437..b5628ff 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -25,7 +25,6 @@ import GHC.Clock import System.Timeout import Data.List.Extra --- TODO use timeout for tests spec :: SpecWith () spec = do describe "debuggeeDwarf" $ @@ -47,7 +46,7 @@ spec = do withStartedDebuggee "debug-test" $ \ d -> do request d RequestPause roots <- request d RequestRoots - roots `shouldNotBe` [] + roots `shouldSatisfy` (\ cs -> notNull cs) describe "RequestClosures" $ it "should return a non-empty result" $ @@ -55,17 +54,14 @@ spec = do request d RequestPause roots <- request d RequestRoots closures <- request d $ RequestClosures roots - closures `shouldNotBe` [] + closures `shouldSatisfy` (\ cs -> notNull cs) describe "RequestSavedObjects" $ it "should return saved object" $ - withStartedDebuggeeAndHandles "save-one" $ \ h d -> do + withStartedDebuggeeAndHandles "save-one-pause" $ \ h d -> do waitForSync $ Server.stdout h withAsync (pipeStreamThread (Server.stdout h)) $ \_ -> do - -- TODO Get rid of the `threadDelay`. - -- `save-one` should signal that the GC has finished. - threadDelay 5000000 - request d RequestPause + request d RequestPoll os@(o:_) <- request d RequestSavedObjects length os `shouldBe` 1 hg <- buildHeapGraph (derefBox d) 20 () o @@ -117,7 +113,6 @@ spec = do assertNewClockTime ref where oneSecondInMicros = 1000000 - fiveSecondsInMicros = 5000000 assertNoNewClockTimes :: IORef [ClockTime] -> ClockTime -> Expectation assertNoNewClockTimes ref t0 = do @@ -138,16 +133,22 @@ spec = do result `shouldBe` Just () +fiveSecondsInMicros :: Int +fiveSecondsInMicros = 5000000 + waitForSync :: Handle -> IO () waitForSync h = do - hSetBuffering h LineBuffering - l <- hGetLine h - if l == "\"sync\"" then - return () - else - waitForSync h --- TODO There should be some exit condition. --- error "Can not sync!" + result <- (timeout fiveSecondsInMicros $ do + hSetBuffering h LineBuffering + l <- hGetLine h + if l == "\"sync\"" then + return () + else + waitForSync h) + + case result of + Nothing -> error "Can not sync!" + _ -> return () pipeStreamThread :: Handle -> IO () pipeStreamThread h = forever $ do From ef1e5313bafcbdf80d71166795d3d521a8c0135b Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 17:47:55 +0200 Subject: [PATCH 22/24] system-tests: Remove unused test program (save-one) --- test/ghc-debugger.cabal | 17 ----------------- test/test-progs/SaveOne.hs | 22 ---------------------- 2 files changed, 39 deletions(-) delete mode 100644 test/test-progs/SaveOne.hs diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal index 765383c..8a18307 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -51,26 +51,9 @@ test-suite system-test default-language: Haskell2010 ghc-options: -threaded -debug -g3 build-tool-depends: ghc-debug-stub:debug-test - , ghc-debugger:save-one , ghc-debugger:save-one-pause , ghc-debugger:clock -executable save-one - main-is: SaveOne.hs - hs-source-dirs: - test-progs - ghc-options: -threaded -debug -g3 -O0 - build-depends: base - , ghc-debug-client - , ghc-debug-common - , ghc-heap - , ghc-vis - , containers - , extra - , process - , ghc-debug-stub - default-language: Haskell2010 - executable clock main-is: Clock.hs hs-source-dirs: diff --git a/test/test-progs/SaveOne.hs b/test/test-progs/SaveOne.hs deleted file mode 100644 index 488cc04..0000000 --- a/test/test-progs/SaveOne.hs +++ /dev/null @@ -1,22 +0,0 @@ -import GHC.Debug.Stub -import System.Mem -import Control.Concurrent -import System.IO -import Data.Word -import GHC.Stats - -loop :: IO () -loop = go 0 - where - go x = hFlush stdout >> print x >> threadDelay 1000000 >> go (x + 1) - -main :: IO () -main = do - start - let v = 1 :: Int - performGC - saveClosures [Box v] - print "sync" - hFlush stdout - loop - print $ v From 48daea3afc090b6b81b0b3c0da71f37860b65a2a Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 18:13:25 +0200 Subject: [PATCH 23/24] system-tests: Cleanup Server --- test/test/Server.hs | 46 +++++++++++++++++++++++++++------------------ 1 file changed, 28 insertions(+), 18 deletions(-) diff --git a/test/test/Server.hs b/test/test/Server.hs index da6a149..584ecc3 100644 --- a/test/test/Server.hs +++ b/test/test/Server.hs @@ -10,8 +10,19 @@ import System.IO.Extra import GHC.Debug.Client -withServer :: String -> FilePath -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a -withServer serverExe socketName logStdErr f = do +data Handles = Handles { + stdin :: Handle, + stdout :: Handle, + process :: ProcessHandle +} + +type TestFunction a = (Handle -> Handle -> ProcessHandle -> IO a) + +withServer :: String -- ^ executable name + -> FilePath -- ^ socket name + -> TestFunction a -- ^ test code + -> IO a +withServer serverExe socketName f = do let cmd:args = words serverExe let p = (proc cmd args) { std_in = CreatePipe, @@ -19,39 +30,38 @@ withServer serverExe socketName logStdErr f = do std_err = CreatePipe, env = Just [("GHC_DEBUG_SOCKET",socketName)] } --- TODO pattern match case where one or more handles are not available (-> error with message) - withCreateProcess p $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do - -- Need to continuously consume to stderr else it gets blocked - -- Can't pass NoStream either to std_err - hSetBuffering serverErr NoBuffering - hSetBinaryMode serverErr True - let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn - withAsync errSinkThread $ \_ -> f serverIn serverOut serverProc + withCreateProcess p $ runTestFunction f +runTestFunction :: TestFunction a -- ^ test code + -> Maybe Handle -- ^ stdin + -> Maybe Handle -- ^ stdout + -> Maybe Handle -- ^ stderr + -> ProcessHandle + -> IO a +runTestFunction f (Just serverIn) (Just serverOut) (Just serverErr) serverProc = do + hSetBuffering serverErr NoBuffering + hSetBinaryMode serverErr True + let errSinkThread = forever $ hGetLine serverErr >>= putStrLn + withAsync errSinkThread $ \_ -> f serverIn serverOut serverProc +runTestFunction _ _ _ _ _ = error "Starting the process failed" withStartedDebuggee :: String -- ^ executable name -> (Debuggee -> IO a) -- ^ action -> IO a withStartedDebuggee exeName action = withTempDir $ \ tempDirPath -> do let socketName = tempDirPath ++ "/ghc-debug" - withServer exeName socketName True $ \serverIn serverOut serverProc -> do + withServer exeName socketName $ \serverIn serverOut serverProc -> do prog <- readCreateProcess serverExePathCmd [] withDebuggee (trim prog) socketName action where serverExePathCmd = shell $ "which " ++ exeName -data Handles = Handles { - stdin :: Handle, - stdout :: Handle, - process :: ProcessHandle - } - withStartedDebuggeeAndHandles :: String -- ^ executable name -> (Handles -> Debuggee -> IO a) -- ^ action -> IO a withStartedDebuggeeAndHandles exeName action = withTempDir $ \ tempDirPath -> do let socketName = tempDirPath ++ "/ghc-debug" - withServer exeName socketName True $ \serverIn serverOut serverProc -> do + withServer exeName socketName $ \serverIn serverOut serverProc -> do prog <- readCreateProcess serverExePathCmd [] let handles = Handles serverIn serverOut serverProc withDebuggee (trim prog) socketName (action handles) From 37c94c57a3789605099d3f08d5e479177b1f7c4b Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 13 Apr 2020 18:33:55 +0200 Subject: [PATCH 24/24] system-tests: HLint --- test/test-progs/SaveOnePause.hs | 2 +- test/test/Server.hs | 8 ++++++-- test/test/SystemTest.hs | 15 +++++++-------- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/test/test-progs/SaveOnePause.hs b/test/test-progs/SaveOnePause.hs index 34ad468..1801d87 100644 --- a/test/test-progs/SaveOnePause.hs +++ b/test/test-progs/SaveOnePause.hs @@ -22,4 +22,4 @@ main = do performGC saveClosures [Box v] loop - print $ v + print v diff --git a/test/test/Server.hs b/test/test/Server.hs index 584ecc3..632ec2b 100644 --- a/test/test/Server.hs +++ b/test/test/Server.hs @@ -1,10 +1,14 @@ -module Server (withServer, withStartedDebuggee, withStartedDebuggeeAndHandles, Handles(..)) where +module Server + ( withServer + , withStartedDebuggee + , withStartedDebuggeeAndHandles + , Handles(..) + ) where import Control.Concurrent.Async import Control.Monad import System.IO import System.Process -import Control.Concurrent import Data.List.Extra (trim) import System.IO.Extra diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs index b5628ff..4139d84 100644 --- a/test/test/SystemTest.hs +++ b/test/test/SystemTest.hs @@ -12,7 +12,6 @@ import Data.Dwarf.ADT import Server -import Debug.Trace import Control.Monad import Control.Concurrent.Async @@ -46,7 +45,7 @@ spec = do withStartedDebuggee "debug-test" $ \ d -> do request d RequestPause roots <- request d RequestRoots - roots `shouldSatisfy` (\ cs -> notNull cs) + roots `shouldSatisfy` notNull describe "RequestClosures" $ it "should return a non-empty result" $ @@ -54,7 +53,7 @@ spec = do request d RequestPause roots <- request d RequestRoots closures <- request d $ RequestClosures roots - closures `shouldSatisfy` (\ cs -> notNull cs) + closures `shouldSatisfy` notNull describe "RequestSavedObjects" $ it "should return saved object" $ @@ -96,7 +95,7 @@ spec = do (s:_) <- request d RequestSavedObjects ptrs <- request d $ RequestFindPtr s closures <- dereferenceClosures d ptrs - closures `shouldSatisfy` (\ cs -> notNull cs) + closures `shouldSatisfy` notNull describe "RequestResume" $ it "should resume a paused debugee" $ @@ -138,13 +137,13 @@ fiveSecondsInMicros = 5000000 waitForSync :: Handle -> IO () waitForSync h = do - result <- (timeout fiveSecondsInMicros $ do + result <- timeout fiveSecondsInMicros $ do hSetBuffering h LineBuffering l <- hGetLine h if l == "\"sync\"" then return () else - waitForSync h) + waitForSync h case result of Nothing -> error "Can not sync!" @@ -161,10 +160,10 @@ pipeStreamToListThread :: IORef [ClockTime] -> Handle -> IO () pipeStreamToListThread ref h = forever $ do l <- hGetLine h timesList <- readIORef ref - writeIORef ref $ (toClockTime l) : timesList + writeIORef ref $ toClockTime l : timesList where toClockTime :: String -> ClockTime - toClockTime s = read . trim $ s + toClockTime = read . trim shouldContainCuName :: Dwarf -> String -> Expectation shouldContainCuName dwarf name = allCuNames `shouldContain` [name]