[Git][ghc/ghc][wip/keep-going-hs-boot] For -fkeep-failed do not duplicate dependency edge code
cgibbard
gitlab at gitlab.haskell.org
Fri Jun 26 08:43:38 UTC 2020
cgibbard pushed to branch wip/keep-going-hs-boot at Glasgow Haskell Compiler / GHC
Commits:
03bca452 by John Ericson at 2020-06-26T04:43:27-04:00
For -fkeep-failed do not duplicate dependency edge code
We now compute the deps for -fkeep-failed the same way that the original
graph calculates them, so the edges are correct. Upsweep really ought to
take the graph rather than a topological sort so we are never
recalculating anything, but at least things are done consistently now.
- - - - -
1 changed file:
- compiler/GHC/Driver/Make.hs
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -952,6 +952,12 @@ mkBuildModule ms = GWIB
, gwib_isBoot = isBootSummary ms
}
+mkHomeBuildModule :: ModSummary -> ModuleNameWithIsBoot
+mkHomeBuildModule ms = GWIB
+ { gwib_mod = moduleName $ ms_mod ms
+ , gwib_isBoot = isBootSummary ms
+ }
+
-- | The entry point to the parallel upsweep.
--
-- See also the simpler, sequential 'upsweep'.
@@ -1390,20 +1396,20 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do
let sum_deps ms (AcyclicSCC mod) =
- if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms
- then ms_mod_name mod:ms
+ if any (flip elem $ unfilteredEdges False mod) ms
+ then mkHomeBuildModule mod:ms
else ms
sum_deps ms _ = ms
dep_closure = foldl' sum_deps this_mods mods
dropped_ms = drop (length this_mods) (reverse dep_closure)
- prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure
+ prunable (AcyclicSCC mod) = elem (mkHomeBuildModule mod) dep_closure
prunable _ = False
mods' = filter (not . prunable) mods
nmods' = nmods - length dropped_ms
when (not $ null dropped_ms) $ do
dflags <- getSessionDynFlags
- liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms)
+ liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ gwib_mod <$> dropped_ms)
(_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes
return (Failed, done')
@@ -1428,7 +1434,7 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
= do dflags <- getSessionDynFlags
liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
if gopt Opt_KeepGoing dflags
- then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods
+ then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods
uids_to_check done_holes
else return (Failed, done)
@@ -1482,7 +1488,7 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
Nothing -> do
dflags <- getSessionDynFlags
if gopt Opt_KeepGoing dflags
- then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods
+ then keep_going [mkHomeBuildModule mod] old_hpt done mods mod_index nmods
uids_to_check done_holes
else return (Failed, done)
Just mod_info -> do
@@ -1917,7 +1923,7 @@ reachableBackwards mod summaries
= [ node_payload node | node <- reachableG (transposeG graph) root ]
where -- the rest just sets up the graph:
(graph, lookup_node) = moduleGraphNodes False summaries
- root = expectJust "reachableBackwards" (lookup_node IsBoot mod)
+ root = expectJust "reachableBackwards" (lookup_node $ GWIB mod IsBoot)
-- ---------------------------------------------------------------------------
--
@@ -1960,7 +1966,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
-- the specified module. We do this by building a graph with
-- the full set of nodes, and determining the reachable set from
-- the specified node.
- let root | Just node <- lookup_node NotBoot root_mod
+ let root | Just node <- lookup_node $ GWIB root_mod NotBoot
, graph `hasVertexG` node
= node
| otherwise
@@ -1975,20 +1981,39 @@ summaryNodeKey = node_key
summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary = node_payload
+unfilteredEdges :: Bool -> ModSummary -> [ModuleNameWithIsBoot]
+unfilteredEdges drop_hs_boot_nodes ms =
+ (flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++
+ (flip GWIB NotBoot . unLoc <$> ms_home_imps ms) ++
+ [ GWIB (ms_mod_name ms) IsBoot
+ | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile
+ -- see [boot-edges] below
+ ]
+ where
+ -- [boot-edges] if this is a .hs and there is an equivalent
+ -- .hs-boot, add a link from the former to the latter. This
+ -- has the effect of detecting bogus cases where the .hs-boot
+ -- depends on the .hs, by introducing a cycle. Additionally,
+ -- it ensures that we will always process the .hs-boot before
+ -- the .hs, and so the HomePackageTable will always have the
+ -- most up to date information.
+
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
+ | otherwise = IsBoot
+
moduleGraphNodes :: Bool -> [ModSummary]
- -> (Graph SummaryNode, IsBootInterface -> ModuleName -> Maybe SummaryNode)
+ -> (Graph SummaryNode, ModuleNameWithIsBoot -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
numbered_summaries = zip summaries [1..]
- lookup_node :: IsBootInterface -> ModuleName -> Maybe SummaryNode
- lookup_node hs_src mod = Map.lookup
- (GWIB { gwib_mod = mod, gwib_isBoot = hs_src })
- node_map
+ lookup_node :: ModuleNameWithIsBoot -> Maybe SummaryNode
+ lookup_node mnwib = Map.lookup mnwib node_map
- lookup_key :: IsBootInterface -> ModuleName -> Maybe Int
- lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+ lookup_key :: ModuleNameWithIsBoot -> Maybe Int
+ lookup_key = fmap summaryNodeKey . lookup_node
node_map :: NodeMap SummaryNode
node_map = Map.fromList [ ( GWIB
@@ -1998,37 +2023,19 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
, node
)
| node <- nodes
- , let s = summaryNodeSummary node ]
+ , let s = summaryNodeSummary node
+ ]
-- We use integers as the keys for the SCC algorithm
nodes :: [SummaryNode]
- nodes = [ DigraphNode s key out_keys
+ nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
, not (isBootSummary s == IsBoot && drop_hs_boot_nodes)
- , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
- out_edge_keys NotBoot (map unLoc (ms_home_imps s)) ++
- (-- see [boot-edges] below
- if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
- then []
- else case lookup_key IsBoot (ms_mod_name s) of
- Nothing -> []
- Just k -> [k]) ]
-
- -- [boot-edges] if this is a .hs and there is an equivalent
- -- .hs-boot, add a link from the former to the latter. This
- -- has the effect of detecting bogus cases where the .hs-boot
- -- depends on the .hs, by introducing a cycle. Additionally,
- -- it ensures that we will always process the .hs-boot before
- -- the .hs, and so the HomePackageTable will always have the
- -- most up to date information.
-
- -- Drop hs-boot nodes by using HsSrcFile as the key
- hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
- | otherwise = IsBoot
+ ]
- out_edge_keys :: IsBootInterface -> [ModuleName] -> [Int]
- out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
+ out_edge_keys :: [ModuleNameWithIsBoot] -> [Int]
+ out_edge_keys = mapMaybe lookup_key
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- IsBoot; else False
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03bca4528a6c603eb89a9ab50f08060d923db67a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03bca4528a6c603eb89a9ab50f08060d923db67a
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/20200626/f7913039/attachment-0001.html>
More information about the ghc-commits
mailing list