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 diff --git a/client/src/GHC/Debug/Client.hs b/client/src/GHC/Debug/Client.hs index c1b4d7e..0d931bc 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 @@ -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) diff --git a/common/src/GHC/Debug/Types/Closures.hs b/common/src/GHC/Debug/Types/Closures.hs index fe70714..242e4c3 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 -- -- @@ -308,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/stub/cbits/stub.cpp b/stub/cbits/stub.cpp index 649e9d9..34922b0 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: * @@ -546,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/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++ diff --git a/test/Test.hs b/test/Test.hs index f0fd3f9..805cd05 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -10,13 +10,30 @@ 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" +import Data.List.Extra (trim) +import System.Process -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" +saveOnePath :: IO FilePath +saveOnePath = testProgPath "save-one" ---main = withDebuggeeSocket "/tmp/ghc-debug" Nothing p14 -main = withDebuggee prog2 p12 ---main = withDebuggee 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 = do + prog <- debugTestPath -- Or @dyePackTestPath@ + print prog + withDebuggee prog "/tmp/ghc-debug" p12 -- Test pause/resume p1 d = pauseDebuggee d (void $ getChar) @@ -119,7 +136,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 ec7d232..8a18307 100644 --- a/test/ghc-debugger.cabal +++ b/test/ghc-debugger.cabal @@ -16,6 +16,66 @@ 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 + main-is: TestSetup.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base + , hspec ==2.* + , process + , ghc-debug-client + , ghc-debug-common + , ghc-vis + , directory + , async + , extra + , dwarfadt + , text + other-modules: + SystemTest + , Server + default-language: Haskell2010 + ghc-options: -threaded -debug -g3 + build-tool-depends: ghc-debug-stub:debug-test + , ghc-debugger:save-one-pause + , ghc-debugger:clock + +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 + +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/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-progs/SaveOnePause.hs b/test/test-progs/SaveOnePause.hs new file mode 100644 index 0000000..1801d87 --- /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/Server.hs b/test/test/Server.hs new file mode 100644 index 0000000..632ec2b --- /dev/null +++ b/test/test/Server.hs @@ -0,0 +1,73 @@ +module Server + ( withServer + , withStartedDebuggee + , withStartedDebuggeeAndHandles + , Handles(..) + ) where + +import Control.Concurrent.Async +import Control.Monad +import System.IO +import System.Process +import Data.List.Extra (trim) +import System.IO.Extra + +import GHC.Debug.Client + +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, + std_out = CreatePipe, + std_err = CreatePipe, + env = Just [("GHC_DEBUG_SOCKET",socketName)] + } + 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 $ \serverIn serverOut serverProc -> do + prog <- readCreateProcess serverExePathCmd [] + withDebuggee (trim prog) socketName action + where + serverExePathCmd = shell $ "which " ++ exeName + +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 $ \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 new file mode 100644 index 0000000..4139d84 --- /dev/null +++ b/test/test/SystemTest.hs @@ -0,0 +1,175 @@ +module SystemTest where + +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 +import Data.Dwarf.ADT + +import Server + +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 + +spec :: SpecWith () +spec = do + 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" $ + 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 `shouldSatisfy` notNull + + 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 `shouldSatisfy` notNull + + describe "RequestSavedObjects" $ + it "should return saved object" $ + withStartedDebuggeeAndHandles "save-one-pause" $ \ h d -> do + waitForSync $ Server.stdout h + withAsync (pipeStreamThread (Server.stdout h)) $ \_ -> do + request d RequestPoll + os@(o:_) <- request d RequestSavedObjects + length os `shouldBe` 1 + 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 "RequestConstrDesc" $ + it "should return ConstrDesc of saved value (I# 1)" $ + 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 "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` notNull + + 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 + + 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 + result <- timeout fiveSecondsInMicros $ whileM $ do + threadDelay 5000 + (t:_) <- readIORef ref + return $ t < now + + result `shouldBe` Just () + +fiveSecondsInMicros :: Int +fiveSecondsInMicros = 5000000 + +waitForSync :: Handle -> IO () +waitForSync h = do + 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 + 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 = read . trim + +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