Add support for ghc-debug to ghc executablewip/ghc-with-debug

8 files changed, 82 insertions, 4 deletions

diff --git a/.gitmodules b/.gitmodules
index 2994d6e31f..4cc97daa75 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -113,3 +113,6 @@
 [submodule "utils/hpc"]
 	path = utils/hpc
 	url = https://gitlab.haskell.org/hpc/hpc-bin.git
+[submodule "ghc-debug"]
+	path = ghc-debug
+	url = git@gitlab.haskell.org:ghc/ghc-debug.git
diff --git a/ghc-debug b/ghc-debug
new file mode 160000
+Subproject 537e462a5c987537725d95caa10fa6d7b30abf3
diff --git a/ghc/Main.hs b/ghc/Main.hs
index ae862a7014..5f854b6565 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -32,6 +32,7 @@ import GHC.Driver.Backpack  ( doBackpack )
 import GHC.Driver.Plugins
 import GHC.Driver.Config.Logger (initLogFlags)
 import GHC.Driver.Config.Diagnostic
+import GHC.Driver.Monad
 
 import GHC.Platform
 import GHC.Platform.Ways
@@ -99,6 +100,10 @@ import Data.Bifunctor
 import GHC.Data.Graph.Directed
 import qualified Data.List.NonEmpty as NE
 
+#if defined(GHC_DEBUG)
+import GHC.Debug.Stub
+#endif
+
 -----------------------------------------------------------------------------
 -- ToDo:
 
@@ -111,6 +116,13 @@ import qualified Data.List.NonEmpty as NE
 -----------------------------------------------------------------------------
 -- GHC's command-line interface
 
+debugWrapper :: IO a -> IO a
+#if defined(GHC_DEBUG)
+debugWrapper = withGhcDebug
+#else
+debugWrapper = id
+#endif
+
 main :: IO ()
 main = do
    hSetBuffering stdout LineBuffering
@@ -159,8 +171,10 @@ main = do
                             ShowGhcUsage           -> showGhcUsage  dflags
                             ShowGhciUsage          -> showGhciUsage dflags
                             PrintWithDynFlags f    -> putStrLn (f dflags)
-                Right postLoadMode ->
-                    main' postLoadMode units dflags argv3 flagWarnings
+                Right postLoadMode -> do
+                    reifyGhc $ \session -> debugWrapper $
+                      reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session
+
 
 main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]
       -> Ghc ()
diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in
index 88e559048c..5cde07bc6a 100644
--- a/ghc/ghc-bin.cabal.in
+++ b/ghc/ghc-bin.cabal.in
@@ -22,6 +22,11 @@ Flag internal-interpreter
     Default: False
     Manual: True
 
+Flag ghc-debug
+    Description: Build with support for ghc-debug.
+    Default: False
+    Manual: True
+
 Flag threaded
     Description: Link the ghc executable against the threaded RTS
     Default: True
@@ -42,6 +47,10 @@ Executable ghc
                    ghc-boot      == @ProjectVersionMunged@,
                    ghc           == @ProjectVersionMunged@
 
+    if flag(ghc-debug)
+        build-depends: ghc-debug-stub
+        CPP-OPTIONS: -DGHC_DEBUG
+
     if os(windows)
         Build-Depends: Win32  >= 2.3 && < 2.14
     else
diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs
index 6dbeb6ed14..5df998e6a1 100644
--- a/hadrian/src/Packages.hs
+++ b/hadrian/src/Packages.hs
@@ -11,7 +11,7 @@ module Packages (
     runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy,
     transformers, unlit, unix, win32, xhtml,
     lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
-    ghcPackages, isGhcPackage,
+    ghcPackages, isGhcPackage, ghc_debug_convention, ghc_debug_stub,
 
     -- * Package information
     crossPrefix, programName, nonHsMainPackage, autogenPath, programPath, timeoutPath,
@@ -43,7 +43,9 @@ ghcPackages =
     , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
     , timeout
     , lintersCommon
-    , lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
+    , lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
+    , ghc_debug_convention
+    , ghc_debug_stub ]
 
 -- TODO: Optimise by switching to sets of packages.
 isGhcPackage :: Package -> Bool
@@ -122,6 +124,8 @@ unlit               = util "unlit"
 unix                = lib  "unix"
 win32               = lib  "Win32"
 xhtml               = lib  "xhtml"
+ghc_debug_convention = lib "ghc-debug-convention" `setPath` "ghc-debug/convention"
+ghc_debug_stub       = lib "ghc-debug-stub" `setPath` "ghc-debug/stub"
 
 lintersCommon       = lib     "linters-common"      `setPath` "linters/linters-common"
 lintNotes           = linter  "lint-notes"
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 5996924096..54ec6cfb8b 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -146,6 +146,8 @@ stage1Packages = do
         , unlit
         , xhtml
         , if winTarget then win32 else unix
+        , ghc_debug_convention
+        , ghc_debug_stub
         ]
       , when (not cross)
         [ haddock
diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs
index e2afd72ee5..2d34ab4f43 100644
--- a/hadrian/src/Settings/Packages.hs
+++ b/hadrian/src/Settings/Packages.hs
@@ -89,6 +89,7 @@ packageArgs = do
 
           , builder (Cabal Flags) ? mconcat
             [ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter"
+            , notStage0 `cabalFlag` "ghc-debug"
             , ifM stage0
                   -- We build a threaded stage 1 if the bootstrapping compiler
                   -- supports it.
diff --git a/instructions.md b/instructions.md
new file mode 100644
index 0000000000..6c8c4c6796
--- /dev/null
+++ b/instructions.md
@@ -0,0 +1,45 @@
+# Building GHC
+
+* Add the following to _build/hadrian.settings
+
+```
+stage1.*.ghc.hs.opts += -finfo-table-map -fdistinct-constructor-tables
+```
+
+* Build GHC as normal
+
+```
+./hadrian/build -j8
+```
+
+* The result is a ghc-debug enabled compiler
+
+# Building a debugger
+
+* Use the compiler you just built to build ghc-debug
+
+```
+cd ghc-debug
+cabal update
+cabal new-build debugger -w ../_build/stage1/bin/ghc
+```
+
+# Running the debugger
+
+Modify `test/Test.hs` to implement the debugging thing you want to do. Perhaps
+start with `p30`, which is a program to generate a profile.
+
+
+* Start the process you want to debug
+```
+GHC_DEBUG_SOCKET=/tmp/ghc-debug build-cabal
+```
+
+* Start the debugger
+```
+cabal new-run debugger -w ...
+```
+
+* Open a ticket about the memory issue you find.
+
+