For `-fkeep-going` do not duplicate dependency edge code

We now compute the deps for `-fkeep-going` 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 recaluclated
consistently now.

1 files changed, 47 insertions, 45 deletions

diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index e59a78904d..0344c5ed97 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -953,6 +953,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'.
@@ -1391,20 +1397,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')
 
@@ -1429,7 +1435,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)
 
@@ -1483,7 +1489,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
@@ -1919,7 +1925,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)
 
 -- ---------------------------------------------------------------------------
 --
@@ -1962,7 +1968,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
@@ -1977,60 +1983,56 @@ 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
-                                  { gwib_mod = moduleName $ ms_mod s
-                                  , gwib_isBoot = hscSourceToIsBoot $ ms_hsc_src s
-                                  }
-                              , node
-                              )
+    node_map = Map.fromList [ (mkHomeBuildModule s, 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