[Git][ghc/ghc][wip/mpickering/get-link-deps] 2 commits: WIP: Use a stable scc algorithm
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Jan 2 17:34:57 UTC 2025
Matthew Pickering pushed to branch wip/mpickering/get-link-deps at Glasgow Haskell Compiler / GHC
Commits:
c1f36074 by Matthew Pickering at 2025-01-02T17:33:50+00:00
WIP: Use a stable scc algorithm
- - - - -
c220dfed by Matthew Pickering at 2025-01-02T17:34:02+00:00
MP cleanup
- - - - -
4 changed files:
- compiler/GHC/Data/Graph/Directed/Internal.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
Changes:
=====================================
compiler/GHC/Data/Graph/Directed/Internal.hs
=====================================
@@ -7,6 +7,10 @@ import Data.Array
import qualified Data.Graph as G
import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation
import Data.Tree
+import Data.Array.ST.Safe (STUArray)
+import Control.Monad.ST
+import Data.Array.ST.Safe (newArray, readArray, writeArray)
+import Data.List (sort)
data Graph node = Graph {
gr_int_graph :: IntGraph,
@@ -69,7 +73,7 @@ reachable g vs = preorderF (G.dfs g vs)
scc :: IntGraph -> [SCC Vertex]
scc graph = map decode forest
where
- forest = {-# SCC "Digraph.scc" #-} G.scc graph
+ forest = {-# SCC "Digraph.scc" #-} scc2 graph
decode (Node v []) | mentions_itself v = CyclicSCC [v]
| otherwise = AcyclicSCC v
@@ -77,3 +81,68 @@ scc graph = map decode forest
where dec (Node v ts) vs = v : foldr dec vs ts
mentions_itself v = v `elem` (graph ! v)
+
+
+newtype SetM s a = SetM { runSetM :: STUArray s Vertex Bool -> ST s a }
+
+instance Monad (SetM s) where
+ return = pure
+ {-# INLINE return #-}
+ SetM v >>= f = SetM $ \s -> do { x <- v s; runSetM (f x) s }
+ {-# INLINE (>>=) #-}
+
+instance Functor (SetM s) where
+ f `fmap` SetM v = SetM $ \s -> f `fmap` v s
+ {-# INLINE fmap #-}
+
+instance Applicative (SetM s) where
+ pure x = SetM $ const (return x)
+ {-# INLINE pure #-}
+ SetM f <*> SetM v = SetM $ \s -> f s >>= (`fmap` v s)
+ -- We could also use the following definition
+ -- SetM f <*> SetM v = SetM $ \s -> f s <*> v s
+ -- but Applicative (ST s) instance is present only in GHC 7.2+
+ {-# INLINE (<*>) #-}
+
+run :: G.Bounds -> (forall s. SetM s a) -> a
+run bnds act = runST (newArray bnds False >>= runSetM act)
+
+contains :: Vertex -> SetM s Bool
+contains v = SetM $ \ m -> readArray m v
+
+include :: Vertex -> SetM s ()
+include v = SetM $ \ m -> writeArray m v True
+
+scc2 :: G.Graph -> [Tree Vertex]
+scc2 g = dfs g (reverse (postOrd (G.transposeG g)))
+
+postorder :: Tree a -> [a] -> [a]
+postorder (Node a ts) = postorderF ts . (a :)
+
+postorderF :: [Tree a] -> [a] -> [a]
+postorderF ts = foldr (.) id $ map postorder ts
+
+postOrd :: G.Graph -> [Vertex]
+postOrd g = postorderF (dff g) []
+
+dff :: G.Graph -> [Tree Vertex]
+dff g = dfs g (G.vertices g)
+
+
+-- This dfs provides stability under transposition.
+dfs :: G.Graph -> [Vertex] -> [Tree Vertex]
+dfs g vs0 = run (bounds g) $ go vs0
+ where
+ go :: [Vertex] -> SetM s [Tree Vertex]
+ go [] = pure []
+ go (k: is') = do
+ visited <- contains k
+ if visited
+ then go is'
+ else do
+ include k
+ as <- go (sort (g!k))
+ bs <- go is'
+ pure $ Node k as : bs
+
+
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1751,7 +1751,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
Just {} -> loopUnit cache uxs
Nothing -> case unitDepends <$> lookupUnitId (hsc_units hsc_env) u of
Just us -> loopUnit (loopUnit (Map.insert nk (PackageNode us u) cache) us) uxs
- Nothing -> panic "bad"
+ Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
getRootSummary ::
[ModuleName] ->
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -417,11 +417,6 @@ loadInterfaceWithException doc mod_name where_from
--
-- This operation is used just before TH splices are run (in 'getLinkDeps').
--
--- TODO: SHOULD WE ASSERT THIS IS ONLY CALLED ON ONESHOT MODE? WE SHOULD NEVER
--- WANT TO LOAD HOME MODULE PACKAGES INTO THE EPS ANY OTHER WAY.
---
--- The first time this is run...??
---
-- A field in the EPS tracks which home modules are already fully loaded, which we use
-- here to avoid trying to load them a second time.
--
@@ -430,7 +425,7 @@ loadInterfaceWithException doc mod_name where_from
-- graph in 'getLinkDeps' another way.
loadHomePackageInterfacesBelow :: (Module -> SDoc) -> Maybe HomeUnit {-^ The current home unit -}
-> [Module] -> IfM lcl ()
-loadHomePackageInterfacesBelow _ Nothing _ = error "No home unit, what to do?"
+loadHomePackageInterfacesBelow _ Nothing _ = panic "loadHomePackageInterfacesBelow: No home unit"
loadHomePackageInterfacesBelow msg (Just home_unit) mods = do
dflags <- getDynFlags
let ctx = initSDocContext dflags defaultUserStyle
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -118,7 +118,6 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- 1. Find the dependent home-pkg-modules/packages from each iface
-- (omitting modules from the interactive package, which is already linked)
(mods_s, pkgs_s) <- get_reachable_nodes opts relevant_mods
- pprTraceM "Linkable deps:" (ppr relevant_mods $$ ppr mods_s $$ ppr pkgs_s)
let
-- 2. Exclude ones already linked
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/19367100257652a203c4cb1de61f1da0a9936845...c220dfed4f7279e19aec4ae68624590f5e051083
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/19367100257652a203c4cb1de61f1da0a9936845...c220dfed4f7279e19aec4ae68624590f5e051083
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/20250102/92e7aae0/attachment-0001.html>
More information about the ghc-commits
mailing list