[Git][ghc/ghc][wip/romes/graph-compact-easy] 4 commits: fixup! fixup! A start on module graphs
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Nov 18 17:49:18 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/graph-compact-easy at Glasgow Haskell Compiler / GHC
Commits:
103ba572 by Rodrigo Mesquita at 2024-11-18T15:20:51+00:00
fixup! fixup! A start on module graphs
- - - - -
f117c422 by Matthew Pickering at 2024-11-18T16:40:18+00:00
Add support for ghc-debug to ghc executable
- - - - -
ed48da52 by Fendor at 2024-11-18T16:40:25+00:00
Bump ghc-debug submodule
- - - - -
3476ec0c by Rodrigo Mesquita at 2024-11-18T17:48:59+00:00
Better getLinkDeps
- - - - -
13 changed files:
- .gitmodules
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/Data/Graph/Directed.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Unit/Module/Graph.hs
- + ghc-debug
- ghc/Main.hs
- ghc/ghc-bin.cabal.in
- hadrian/src/Packages.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- + instructions.md
Changes:
=====================================
.gitmodules
=====================================
@@ -118,3 +118,6 @@
[submodule "libraries/file-io"]
path = libraries/file-io
url = https://gitlab.haskell.org/ghc/packages/file-io.git
+[submodule "ghc-debug"]
+ path = ghc-debug
+ url = git at gitlab.haskell.org:ghc/ghc-debug.git
=====================================
compiler/GHC/CmmToAsm/Reg/Linear.hs
=====================================
@@ -843,7 +843,7 @@ allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr _fmt)
Just (InMem slot) | reading -> doSpill (ReadMem slot)
| otherwise -> doSpill WriteMem
Nothing | reading ->
- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr <+> ppr assig)
+ pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr)
-- NOTE: if the input to the NCG contains some
-- unreachable blocks with junk code, this panic
-- might be triggered. Make sure you only feed
=====================================
compiler/GHC/Data/Graph/Directed.hs
=====================================
@@ -29,7 +29,8 @@ module GHC.Data.Graph.Directed (
-- Simple way to classify edges
EdgeType(..), classifyEdges,
- ReachabilityIndex, reachabilityIndex, emptyGraph, nodeLookupByIx, reachable
+ ReachabilityIndex, reachabilityIndex, emptyGraph, nodeLookupByIx, ixLookupByNode,
+ reachable
) where
------------------------------------------------------------------------------
@@ -577,6 +578,9 @@ reachabilityIndex = gr_reachability
nodeLookupByIx :: Graph node -> Vertex -> node
nodeLookupByIx (Graph _ from _ _) v = from v
+ixLookupByNode :: Graph node -> node -> Maybe Vertex
+ixLookupByNode (Graph _ _ to _) v = to v
+
-- | Reachability query. On graph @g@ and nodes @a@ and @b@, @reachable(g, a,
-- b)@ asks whether @b@ can be reached starting from @a at .
reachable :: Graph node -- ^ @g@
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1840,8 +1840,7 @@ checkHomeUnitsClosed ue
inverse_closure = transposeG downwards_closure
- upwards_closure =
- Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
+ upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
all_unit_direct_deps
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -164,17 +164,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
make_deps_loop found [] = found
make_deps_loop found@(found_units, found_mods) (nk:nexts)
| NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
- | otherwise =
- case mkNodeKey <$> mgReachable mod_graph (NodeKey_Module nk) of
- [] ->
- let (ModNodeKeyWithUid _ uid) = nk
- in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
- trans_deps ->
- let deps = Set.insert (NodeKey_Module nk) (Set.fromList trans_deps)
- -- See #936 and the ghci.prog007 test for why we have to continue traversing through
- -- boot modules.
- todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- trans_deps]
- in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
+
+ | mgMember mod_graph (NodeKey_Module nk)
+ , let (ModNodeKeyWithUid _ uid) = nk
+ = make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
+
+ | otherwise
+ , let trans_deps = mkNodeKey <$> mgReachable mod_graph (NodeKey_Module nk)
+ deps = Set.insert (NodeKey_Module nk) (Set.fromList trans_deps)
+ -- See #936 and the ghci.prog007 test for why we have to continue traversing through
+ -- boot modules.
+ todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- trans_deps]
+ = make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
(init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.Unit.Module.Graph
, moduleGraphModulesBelow
, mgReachable
, mgQuery
+ , mgMember
, moduleGraphNodes
, SummaryNode
@@ -411,7 +412,9 @@ mgReachable mg nk = map summaryNodeSummary modules_below where
modules_below = expectJust "mgReachable" $
reachableG' td_map <$> lookup_node nk
--- | Reachability Query. @mgQuery(g, a, b)@ asks: Can we reach @b@ from @a@ in graph @g@?
+-- | Reachability Query. @mgQuery(g, a, b)@ asks: Can we reach @b@ from @a@ in
+-- graph @g@?
+-- INVARIANT: Both @a@ and @b@ must be in @g at .
mgQuery :: ModuleGraph -- ^ @g@
-> NodeKey -- ^ @a@
-> NodeKey -- ^ @b@
@@ -421,3 +424,10 @@ mgQuery mg nka nkb = reachable td_map na nb where
na = expectJust "mgQuery:a" $ lookup_node nka
nb = expectJust "mgQuery:b" $ lookup_node nkb
+-- | Is @k@ in @g@?
+mgMember :: ModuleGraph -- ^ @g@
+ -> NodeKey -- ^ @k@
+ -> Bool
+mgMember mg nk = isJust $ ixLookupByNode td_map =<< k where
+ (td_map, lookup_node) = mg_graph mg
+ k = lookup_node nk
=====================================
ghc-debug
=====================================
@@ -0,0 +1 @@
+Subproject commit 2541e77d2687b8b3b0c1a52bb4790a602ce17d7d
=====================================
ghc/Main.hs
=====================================
@@ -33,6 +33,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
@@ -101,6 +102,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:
@@ -113,6 +118,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
@@ -161,8 +173,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 ()
=====================================
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.15
else
=====================================
hadrian/src/Packages.hs
=====================================
@@ -12,7 +12,7 @@ module Packages (
runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout,
transformers, unlit, unix, win32, xhtml,
lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
- ghcPackages, isGhcPackage,
+ ghcPackages, isGhcPackage, ghc_debug_convention, ghc_debug_stub,
-- * Package information
crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath,
@@ -43,7 +43,9 @@ ghcPackages =
, terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio
, timeout
, lintersCommon
- , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
+ , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
+ , ghc_debug_convention
+ , ghc_debug_stub ]
-- TODO: Optimise by switching to sets of packages.
isGhcPackage :: Package -> Bool
@@ -134,6 +136,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"
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -171,6 +171,8 @@ stage1Packages = do
, unlit
, xhtml
, if winTarget then win32 else unix
+ , ghc_debug_convention
+ , ghc_debug_stub
]
, when (not cross)
[ haddock
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -117,6 +117,7 @@ packageArgs = do
ifM (expr cross)
(arg "internal-interpreter")
(notStage0 `cabalFlag` "internal-interpreter")
+ , notStage0 `cabalFlag` "ghc-debug"
, ifM stage0
-- We build a threaded stage 1 if the bootstrapping compiler
-- supports it.
=====================================
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.
+
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc510042fbb87cbed53891ffdad6a8f16a16702b...3476ec0cd8ec85693ff241daaf467b6972510201
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc510042fbb87cbed53891ffdad6a8f16a16702b...3476ec0cd8ec85693ff241daaf467b6972510201
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241118/e875ea42/attachment-0001.html>
More information about the ghc-commits
mailing list