driver: Fix issue with module loops and multiple home units

We were attempting to rehydrate all dependencies of a particular module,
but we actually only needed to rehydrate those of the current package
(as those are the ones participating in the loop).

This fixes loading GHC into a multi-unit session.

Fixes #21814

(cherry picked from commit 665fa5a73e385bdfce13180048701a179ec3f36a)

8 files changed, 40 insertions, 4 deletions

diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index dfc0af7e38..2b8c2a734d 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -591,11 +591,18 @@ createBuildPlan mod_graph maybe_top_mod =
 
         (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)
         trans_deps_map = allReachable mg (mkNodeKey . node_payload)
+        -- Compute the intermediate modules between a file and its hs-boot file.
+        -- See Step 2a in Note [Upsweep]
         boot_path mn uid =
           map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $
+          -- Don't include the boot module itself
           Set.delete (NodeKey_Module (key IsBoot))  $
-          expectJust "boot_path" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)
-            `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (key IsBoot)) trans_deps_map))
+          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are
+          -- the transitive dependencies of the non-boot file which transitively depend
+          -- on the boot file.
+          Set.filter (\nk -> nodeKeyUnitId nk == uid  -- Cheap test
+                              && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $
+          expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)
           where
             key ib = ModNodeKeyWithUid (GWIB mn ib) uid
 
@@ -894,8 +901,13 @@ Step 1:  Topologically sort the module graph without hs-boot files. This returns
 Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should
          result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.
 Step 2a: For each module in the cycle, if the module has a boot file then compute the
-         modules on the path between it and the hs-boot file. This information is
-         stored in ModuleGraphNodeWithBoot.
+         modules on the path between it and the hs-boot file.
+         These are the intermediate modules which:
+            (1) are (transitive) dependencies of the non-boot module, and
+            (2) have the boot module as a (transitive) dependency.
+         In particular, all such intermediate modules must appear in the same unit as
+         the module under consideration, as module cycles cannot cross unit boundaries.
+         This information is stored in ModuleGraphNodeWithBoot.
 
 The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.
 
diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs
index 42d3e068b4..ceae3683ea 100644
--- a/compiler/GHC/Unit/Module/Graph.hs
+++ b/compiler/GHC/Unit/Module/Graph.hs
@@ -28,6 +28,7 @@ module GHC.Unit.Module.Graph
    , summaryNodeSummary
 
    , NodeKey(..)
+   , nodeKeyUnitId
    , ModNodeKey
    , mkNodeKey
    , msKey
@@ -120,6 +121,11 @@ pprNodeKey (NodeKey_Unit iu) = ppr iu
 pprNodeKey (NodeKey_Module mk) = ppr mk
 pprNodeKey (NodeKey_Link uid)  = ppr uid
 
+nodeKeyUnitId :: NodeKey -> UnitId
+nodeKeyUnitId (NodeKey_Unit iu)   = instUnitInstanceOf iu
+nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk
+nodeKeyUnitId (NodeKey_Link uid)  = uid
+
 data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot
                                            , mnkUnitId     :: UnitId } deriving (Eq, Ord)
 
diff --git a/testsuite/tests/driver/multipleHomeUnits/all.T b/testsuite/tests/driver/multipleHomeUnits/all.T
index c2bbf0f368..53090f2e68 100644
--- a/testsuite/tests/driver/multipleHomeUnits/all.T
+++ b/testsuite/tests/driver/multipleHomeUnits/all.T
@@ -55,3 +55,5 @@ test('multipleHomeUnitsPackageImports',
     ], multiunit_compile, [['unitB', 'unitB2', 'unitPI'], '-fhide-source-paths'])
 
 test('MHU_OptionsGHC', normal, compile_fail, [''])
+
+test('multipleHomeUnits_loop', [extra_files([ 'a/', 'unitA', 'loop', 'unitLoop'])], multiunit_compile, [['unitA', 'unitLoop'], '-fhide-source-paths'])
diff --git a/testsuite/tests/driver/multipleHomeUnits/loop/Loop.hs b/testsuite/tests/driver/multipleHomeUnits/loop/Loop.hs
new file mode 100644
index 0000000000..c4c3de9a5d
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/loop/Loop.hs
@@ -0,0 +1,5 @@
+module Loop where
+
+import Loop1
+
+import A
diff --git a/testsuite/tests/driver/multipleHomeUnits/loop/Loop.hs-boot b/testsuite/tests/driver/multipleHomeUnits/loop/Loop.hs-boot
new file mode 100644
index 0000000000..aa7d4f4ac5
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/loop/Loop.hs-boot
@@ -0,0 +1 @@
+module Loop where
diff --git a/testsuite/tests/driver/multipleHomeUnits/loop/Loop1.hs b/testsuite/tests/driver/multipleHomeUnits/loop/Loop1.hs
new file mode 100644
index 0000000000..140c34b6f5
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/loop/Loop1.hs
@@ -0,0 +1,5 @@
+module Loop1 where
+
+import {-# SOURCE #-} Loop
+
+import A
diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_loop.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_loop.stderr
new file mode 100644
index 0000000000..7045bacb64
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_loop.stderr
@@ -0,0 +1,4 @@
+[1 of 4] Compiling A[a]
+[2 of 4] Compiling Loop[boot][loop]
+[3 of 4] Compiling Loop1[loop]
+[4 of 4] Compiling Loop[loop]
diff --git a/testsuite/tests/driver/multipleHomeUnits/unitLoop b/testsuite/tests/driver/multipleHomeUnits/unitLoop
new file mode 100644
index 0000000000..baddcf0220
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/unitLoop
@@ -0,0 +1 @@
+-i -i./loop Loop Loop1 -package-id a -this-unit-id loop