Fix recompilation checking for multiple home units

The key part of this change is to store a UnitId in the
`UsageHomeModule` and `UsageHomeModuleInterface`.

* Fine-grained dependency tracking is used if the dependency comes from
  any home unit.
* We actually look up the right module when checking whether we need to
  recompile in the `UsageHomeModuleInterface` case.

These scenarios are both checked by the new tests (
multipleHomeUnits_recomp and multipleHomeUnits_recomp_th )

Fixes #22675

16 files changed, 84 insertions, 21 deletions

diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index 498fe888b8..e2ac533ba8 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -40,6 +40,7 @@ import Data.IORef
 import Data.List (sortBy)
 import Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import GHC.Linker.Types
 import GHC.Unit.Finder
@@ -82,7 +83,8 @@ mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods used_names dependent_fi
         hug = ue_home_unit_graph unit_env
     -- Dependencies on object files due to TH and plugins
     object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs
-    mod_usages <- mk_mod_usage_info uc hu this_mod
+    let all_home_ids = ue_all_home_unit_ids unit_env
+    mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod
                                        dir_imp_mods used_names
     let usages = mod_usages ++ [ UsageFile { usg_file_path = f
                                            , usg_file_hash = hash
@@ -184,7 +186,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
           case miface of
             Nothing -> pprPanic "mkObjectUsage" (ppr m)
             Just iface ->
-              return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface))
+              return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash (mi_final_exts iface))
 
     librarySpecToUsage :: LibrarySpec -> IO [Usage]
     librarySpecToUsage (Objects os) = traverse (fing Nothing) os
@@ -194,11 +196,12 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
 
 mk_mod_usage_info :: UsageConfig
               -> HomeUnit
+              -> Set.Set UnitId
               -> Module
               -> ImportedMods
               -> NameSet
               -> IfG [Usage]
-mk_mod_usage_info uc home_unit this_mod direct_imports used_names
+mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names
   = mapMaybeM mkUsageM usage_mods
   where
     safe_implicit_imps_req = uc_safe_implicit_imps_req uc
@@ -252,7 +255,7 @@ mk_mod_usage_info uc home_unit this_mod direct_imports used_names
     --     (need to recompile if its export list changes: export_fprint)
     mkUsage :: Module -> ModIface -> Maybe Usage
     mkUsage mod iface
-      | not (isHomeModule home_unit mod)
+      | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids
       = Just $ UsagePackageModule{ usg_mod      = mod,
                                    usg_mod_hash = mod_hash,
                                    usg_safe     = imp_safe }
@@ -270,6 +273,7 @@ mk_mod_usage_info uc home_unit this_mod direct_imports used_names
       | otherwise
       = Just UsageHomeModule {
                       usg_mod_name = moduleName mod,
+                      usg_unit_id  = toUnitId (moduleUnit mod),
                       usg_mod_hash = mod_hash,
                       usg_exports  = export_hash,
                       usg_entities = Map.toList ent_hashs,
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index bf7ae8e005..0786505e3a 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -1172,7 +1172,7 @@ pprUsage :: Usage -> SDoc
 pprUsage usage@UsagePackageModule{}
   = pprUsageImport usage usg_mod
 pprUsage usage@UsageHomeModule{}
-  = pprUsageImport usage usg_mod_name $$
+  = pprUsageImport usage (\u -> mkModule (usg_unit_id u) (usg_mod_name u)) $$
     nest 2 (
         maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
         vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
@@ -1184,7 +1184,9 @@ pprUsage usage@UsageFile{}
 pprUsage usage@UsageMergedRequirement{}
   = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
 pprUsage usage@UsageHomeModuleInterface{}
-  = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)]
+  = hsep [text "implementation", ppr (usg_mod_name usage)
+                               , ppr (usg_unit_id usage)
+                               , ppr (usg_iface_hash usage)]
 
 pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
 pprUsageImport usage usg_mod'
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 886bc12192..0f8748e536 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -403,7 +403,7 @@ checkVersions hsc_env mod_summary iface
        when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {
           ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }
        }
-       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u
+       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u
                              | u <- mi_usages iface]
        ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {
        ; return $ UpToDateItem iface
@@ -682,7 +682,7 @@ tryGetModIface doc_msg mod
   = do  -- Load the imported interface if possible
     logger <- getLogger
     let doc_str = sep [text doc_msg, ppr mod]
-    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod)
+    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod))
 
     mb_iface <- loadInterface doc_str mod ImportBySystem
         -- Load the interface, but don't complain on failure;
@@ -701,8 +701,8 @@ tryGetModIface doc_msg mod
 -- | Given the usage information extracted from the old
 -- M.hi file for the module being compiled, figure out
 -- whether M needs to be recompiled.
-checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired
-checkModUsage _ _this_pkg UsagePackageModule{
+checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired
+checkModUsage _ UsagePackageModule{
                                 usg_mod = mod,
                                 usg_mod_hash = old_mod_hash } = do
   logger <- getLogger
@@ -714,25 +714,28 @@ checkModUsage _ _this_pkg UsagePackageModule{
         -- recompile.  This is safe but may entail more recompilation when
         -- a dependent package has changed.
 
-checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
+checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
   logger <- getLogger
   needInterface mod $ \iface -> do
     let reason = ModuleChangedRaw (moduleName mod)
     checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
-checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do
-  let mod = mkModule this_pkg mod_name
+checkModUsage _  UsageHomeModuleInterface{ usg_mod_name = mod_name
+                                                 , usg_unit_id = uid
+                                                 , usg_iface_hash = old_mod_hash } = do
+  let mod = mkModule (RealUnit (Definite uid)) mod_name
   logger <- getLogger
   needInterface mod $ \iface -> do
     let reason = ModuleChangedIface mod_name
     checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface))
 
-checkModUsage _ this_pkg UsageHomeModule{
+checkModUsage _ UsageHomeModule{
                                 usg_mod_name = mod_name,
+                                usg_unit_id  = uid,
                                 usg_mod_hash = old_mod_hash,
                                 usg_exports = maybe_old_export_hash,
                                 usg_entities = old_decl_hash }
   = do
-    let mod = mkModule this_pkg mod_name
+    let mod = mkModule (RealUnit (Definite uid)) mod_name
     logger <- getLogger
     needInterface mod $ \iface -> do
      let
@@ -757,9 +760,9 @@ checkModUsage _ this_pkg UsageHomeModule{
            , up_to_date logger (text "  Great!  The bits I use are up to date")
            ]
 
-checkModUsage fc _this_pkg UsageFile{ usg_file_path = file,
-                                   usg_file_hash = old_hash,
-                                   usg_file_label = mlabel } =
+checkModUsage fc UsageFile{ usg_file_path = file,
+                            usg_file_hash = old_hash,
+                            usg_file_label = mlabel } =
   liftIO $
     handleIO handler $ do
       new_hash <- lookupFileCache fc file
diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs
index ade158ddad..a34ae550e0 100644
--- a/compiler/GHC/Unit/Env.hs
+++ b/compiler/GHC/Unit/Env.hs
@@ -14,6 +14,7 @@ module GHC.Unit.Env
     , ue_setUnits
     , ue_setUnitFlags
     , ue_unit_dbs
+    , ue_all_home_unit_ids
     , ue_setUnitDbs
     , ue_hpt
     , ue_homeUnit
@@ -442,7 +443,8 @@ ue_unitHomeUnit_maybe uid ue_env =
 ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit
 ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env
 
-
+ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId
+ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph
 -- -------------------------------------------------------
 -- Query and modify the currently active unit
 -- -------------------------------------------------------
@@ -462,6 +464,7 @@ ue_setActiveUnit u ue_env = assertUnitEnvInvariant $ ue_env
 ue_currentUnit :: UnitEnv -> UnitId
 ue_currentUnit = ue_current_unit
 
+
 -- -------------------------------------------------------
 -- Operations on arbitrary elements of the home unit graph
 -- -------------------------------------------------------
diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs
index 9099ee2f0d..583b7fdaaa 100644
--- a/compiler/GHC/Unit/Module/Deps.hs
+++ b/compiler/GHC/Unit/Module/Deps.hs
@@ -255,6 +255,8 @@ data Usage
   | UsageHomeModule {
         usg_mod_name :: ModuleName,
             -- ^ Name of the module
+        usg_unit_id :: UnitId,
+        -- ^ UnitId of the HomeUnit the module is from
         usg_mod_hash :: Fingerprint,
             -- ^ Cached module ABI fingerprint (corresponds to mi_mod_hash).
             -- This may be out dated after recompilation was avoided, but is
@@ -291,6 +293,8 @@ data Usage
   | UsageHomeModuleInterface {
         usg_mod_name :: ModuleName
         -- ^ Name of the module
+        , usg_unit_id :: UnitId
+        -- ^ UnitId of the HomeUnit the module is from
         , usg_iface_hash :: Fingerprint
         -- ^ The *interface* hash of the module, not the ABI hash.
         -- This changes when anything about the interface (and hence the
@@ -330,6 +334,7 @@ instance Binary Usage where
     put_ bh usg@UsageHomeModule{} = do
         putByte bh 1
         put_ bh (usg_mod_name usg)
+        put_ bh (usg_unit_id  usg)
         put_ bh (usg_mod_hash usg)
         put_ bh (usg_exports  usg)
         put_ bh (usg_entities usg)
@@ -349,6 +354,7 @@ instance Binary Usage where
     put_ bh usg@UsageHomeModuleInterface{} = do
         putByte bh 4
         put_ bh (usg_mod_name usg)
+        put_ bh (usg_unit_id  usg)
         put_ bh (usg_iface_hash usg)
 
     get bh = do
@@ -361,11 +367,12 @@ instance Binary Usage where
             return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
           1 -> do
             nm    <- get bh
+            uid    <- get bh
             mod   <- get bh
             exps  <- get bh
             ents  <- get bh
             safe  <- get bh
-            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
+            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, usg_unit_id = uid,
                      usg_exports = exps, usg_entities = ents, usg_safe = safe }
           2 -> do
             fp   <- get bh
@@ -378,8 +385,9 @@ instance Binary Usage where
             return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }
           4 -> do
             mod <- get bh
+            uid <- get bh
             hash <- get bh
-            return UsageHomeModuleInterface { usg_mod_name = mod, usg_iface_hash = hash }
+            return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }
           i -> error ("Binary.get(Usage): " ++ show i)
 
 
diff --git a/testsuite/tests/driver/multipleHomeUnits/Dep.hs b/testsuite/tests/driver/multipleHomeUnits/Dep.hs
new file mode 100644
index 0000000000..8f9b621e15
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/Dep.hs
@@ -0,0 +1,3 @@
+module Dep (foo) where
+
+foo = ()
diff --git a/testsuite/tests/driver/multipleHomeUnits/Makefile b/testsuite/tests/driver/multipleHomeUnits/Makefile
index d244bc6834..bd5805207a 100644
--- a/testsuite/tests/driver/multipleHomeUnits/Makefile
+++ b/testsuite/tests/driver/multipleHomeUnits/Makefile
@@ -30,4 +30,9 @@ multipleHomeUnits004_recomp: clean
 multipleHomeUnitsModuleVisibility: clean
 	! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitMV -unit @unitMV-import
 
+multipleHomeUnits_recomp: clean
+	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitRecomp -unit @unitDep
+	# Doesn't cause recomp when TH is not involved
+	echo "recomp=()" >> Dep.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitRecomp -unit @unitDep
 
diff --git a/testsuite/tests/driver/multipleHomeUnits/Recomp.hs b/testsuite/tests/driver/multipleHomeUnits/Recomp.hs
new file mode 100644
index 0000000000..42b93f81d5
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/Recomp.hs
@@ -0,0 +1,5 @@
+module Recomp where
+
+import Dep
+
+qux = foo
diff --git a/testsuite/tests/driver/multipleHomeUnits/RecompTH.hs b/testsuite/tests/driver/multipleHomeUnits/RecompTH.hs
new file mode 100644
index 0000000000..ee7ee96a78
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/RecompTH.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module RecompTH where
+
+import Dep
+
+qux = $(const [| () |] foo)
diff --git a/testsuite/tests/driver/multipleHomeUnits/all.T b/testsuite/tests/driver/multipleHomeUnits/all.T
index 97974e19e2..a21459d74f 100644
--- a/testsuite/tests/driver/multipleHomeUnits/all.T
+++ b/testsuite/tests/driver/multipleHomeUnits/all.T
@@ -59,3 +59,10 @@ test('multipleHomeUnitsPackageImports',
 test('MHU_OptionsGHC', normal, compile_fail, [''])
 
 test('multipleHomeUnits_loop', [extra_files([ 'a/', 'unitA', 'loop', 'unitLoop'])], multiunit_compile, [['unitA', 'unitLoop'], '-fhide-source-paths'])
+
+test('multipleHomeUnits_recomp', [copy_files,extra_files([ 'Recomp.hs', 'unitRecomp', 'unitDep', 'Dep.hs'])], makefile_test, [])
+
+test('multipleHomeUnits_recomp_th', [filter_stdout_lines(r'.*Compiling.*'), copy_files, extra_files(['thRecomp.script', 'unitRecompTH', 'unitDep', 'RecompTH.hs', 'Dep.hs', '../../ghci/shell.hs'])  , extra_run_opts('-v1 -unit @unitRecompTH -unit @unitDep')], ghci_script, ['thRecomp.script'])
+
+
+
diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp.stdout
new file mode 100644
index 0000000000..1fbd0c9e1e
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp.stdout
@@ -0,0 +1,3 @@
+[1 of 2] Compiling Dep[dep]
+[2 of 2] Compiling Recomp[recomp]
+[1 of 2] Compiling Dep[dep] [Source file changed]
diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout
new file mode 100644
index 0000000000..4e57668849
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout
@@ -0,0 +1,8 @@
+GHCi, version 9.7.20230119: https://www.haskell.org/ghc/  :? for help
+[1 of 2] Compiling Dep              ( Dep.hs, interpreted )[dep]
+[2 of 2] Compiling RecompTH         ( RecompTH.hs, interpreted )[recomp]
+Ok, two modules loaded.
+ghci> ghci> ghci> [1 of 2] Compiling Dep              ( Dep.hs, interpreted )[dep] [Source file changed]
+[2 of 2] Compiling RecompTH         ( RecompTH.hs, interpreted )[recomp] [Dep changed (interface)]
+Ok, two modules loaded.
+ghci> Leaving GHCi.
diff --git a/testsuite/tests/driver/multipleHomeUnits/thRecomp.script b/testsuite/tests/driver/multipleHomeUnits/thRecomp.script
new file mode 100644
index 0000000000..d16ddc4a16
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/thRecomp.script
@@ -0,0 +1,3 @@
+shell s = System.Process.rawSystem "sh" ["-c", s] >> return ()
+shell "echo \"recomp=()\" >> Dep.hs"
+:r
diff --git a/testsuite/tests/driver/multipleHomeUnits/unitDep b/testsuite/tests/driver/multipleHomeUnits/unitDep
new file mode 100644
index 0000000000..b11a7baaf0
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/unitDep
@@ -0,0 +1 @@
+-i Dep -outputdir=dep -this-unit-id dep
diff --git a/testsuite/tests/driver/multipleHomeUnits/unitRecomp b/testsuite/tests/driver/multipleHomeUnits/unitRecomp
new file mode 100644
index 0000000000..f30b19fa5c
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/unitRecomp
@@ -0,0 +1 @@
+-i Recomp -outputdir=recomp -this-unit-id recomp -package-id dep
diff --git a/testsuite/tests/driver/multipleHomeUnits/unitRecompTH b/testsuite/tests/driver/multipleHomeUnits/unitRecompTH
new file mode 100644
index 0000000000..867e522ec4
--- /dev/null
+++ b/testsuite/tests/driver/multipleHomeUnits/unitRecompTH
@@ -0,0 +1 @@
+-i RecompTH -outputdir=recomp -this-unit-id recomp -package-id dep