System tests

.gitignore

@@ -1,2 +1,3 @@
 .ghc.environment.*
 dist-newstyle/
+cabal.project.local

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

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)

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
 -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h>
 --
@@ -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

stub/cbits/stub.cpp

@@ -15,32 +15,16 @@
 
 #include <Rts.h>
 #include "socket.h"
+#include "trace.h"
 #include "parser.h"
 #include <stdarg.h>
 #include <stdio.h>
 
 #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;
 

stub/cbits/trace.cpp

@@ -0,0 +1,16 @@
+#include <stdarg.h>
+#include <stdio.h>
+
+#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
+

stub/cbits/trace.h

@@ -0,0 +1,3 @@
+#pragma once
+
+void trace(const char *fmt, ...);

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++

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

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
+

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

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

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