gistfile1.txt

commit fff55592a7b9c9487c043d055f2d0d77fa549f4e
Author: Torsten Schmits <[email protected]>
Date:   Thu Aug 22 15:58:09 2024 +0200

    finder: Add `IsBootInterface` to finder cache keys

diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 3fe26820651..bd4dae294ff 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -781,7 +781,7 @@ summariseRequirement pn mod_name = do
     let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
 
     let fc = hsc_FC hsc_env
-    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location
+    mod <- liftIO $ addHomeModuleToFinder fc home_unit (notBoot mod_name) location
 
     extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
 
@@ -893,7 +893,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
     this_mod <- liftIO $ do
       let home_unit = hsc_home_unit hsc_env
       let fc        = hsc_FC hsc_env
-      addHomeModuleToFinder fc home_unit modname location
+      addHomeModuleToFinder fc home_unit (GWIB modname (hscSourceToIsBoot hsc_src)) location
     let ms = ModSummary {
             ms_mod = this_mod,
             ms_hsc_src = hsc_src,
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 3d92ee5da7d..f710dd7404d 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -2044,25 +2044,43 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
             <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
 
         let fopts = initFinderOpts (hsc_dflags hsc_env)
-
-        -- Make a ModLocation for this file
-        let location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf src_fn)
+            src_path = unsafeEncodeUtf src_fn
+
+            is_boot = case takeExtension src_fn of
+              ".hs-boot" -> IsBoot
+              ".lhs-boot" -> IsBoot
+              _ -> NotBoot
+
+            (path_without_boot, hsc_src)
+              | isHaskellSigFilename src_fn = (src_path, HsigFile)
+              | IsBoot <- is_boot = (removeBootSuffix src_path, HsBootFile)
+              | otherwise = (src_path, HsSrcFile)
+
+            -- Make a ModLocation for the Finder, who only has one entry for
+            -- each @ModuleName@, and therefore needs to use the locations for
+            -- the non-boot files.
+            location_without_boot =
+              mkHomeModLocation fopts pi_mod_name path_without_boot
+
+            -- Make a ModLocation for this file, adding the @-boot@ suffix to
+            -- all paths if the original was a boot file.
+            location
+              | IsBoot <- is_boot
+              = addBootSuffixLocn location_without_boot
+              | otherwise
+              = location_without_boot
 
         -- Tell the Finder cache where it is, so that subsequent calls
         -- to findModule will find it, even if it's not on any search path
         mod <- liftIO $ do
           let home_unit = hsc_home_unit hsc_env
           let fc        = hsc_FC hsc_env
-          addHomeModuleToFinder fc home_unit pi_mod_name location
+          addHomeModuleToFinder fc home_unit (GWIB pi_mod_name is_boot) location
 
         liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
             { nms_src_fn = src_fn
             , nms_src_hash = src_hash
-            , nms_is_boot = NotBoot
-            , nms_hsc_src =
-                if isHaskellSigFilename src_fn
-                   then HsigFile
-                   else HsSrcFile
+            , nms_hsc_src = hsc_src
             , nms_location = location
             , nms_mod = mod
             , nms_preimps = preimps
@@ -2090,9 +2108,10 @@ checkSummaryHash
            -- Also, only add to finder cache for non-boot modules as the finder cache
            -- makes sure to add a boot suffix for boot files.
            _ <- do
-              let fc        = hsc_FC hsc_env
+              let fc = hsc_FC hsc_env
+                  gwib = GWIB (ms_mod old_summary) (isBootSummary old_summary)
               case ms_hsc_src old_summary of
-                HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location
+                HsSrcFile -> addModuleToFinder fc gwib location
                 _ -> return ()
 
            hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
@@ -2230,7 +2249,6 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
         liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
             { nms_src_fn = src_fn
             , nms_src_hash = src_hash
-            , nms_is_boot = is_boot
             , nms_hsc_src = hsc_src
             , nms_location = location
             , nms_mod = mod
@@ -2243,7 +2261,6 @@ data MakeNewModSummary
   = MakeNewModSummary
       { nms_src_fn :: FilePath
       , nms_src_hash :: Fingerprint
-      , nms_is_boot :: IsBootInterface
       , nms_hsc_src :: HscSource
       , nms_location :: ModLocation
       , nms_mod :: Module
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 2d8d5f2fae4..c47e6003c33 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -734,7 +734,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
   mod <- do
     let home_unit = hsc_home_unit hsc_env
     let fc        = hsc_FC hsc_env
-    addHomeModuleToFinder fc home_unit mod_name location
+    addHomeModuleToFinder fc home_unit (GWIB mod_name (hscSourceToIsBoot src_flavour)) location
 
   -- Make the ModSummary to hand to hscMain
   let
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
index a99fda06216..f1695e5d837 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ b/compiler/GHC/Unit/Finder.hs
@@ -89,23 +89,23 @@ type BaseName = OsPath  -- Basename of file
 
 initFinderCache :: IO FinderCache
 initFinderCache = do
-  mod_cache <- newIORef emptyInstalledModuleEnv
+  mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv
   file_cache <- newIORef M.empty
   let flushFinderCaches :: UnitEnv -> IO ()
       flushFinderCaches ue = do
-        atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
+        atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())
         atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
        where
-        is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
+        is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod))
 
-      addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
+      addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
       addToFinderCache key val =
-        atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c key val, ())
+        atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleWithIsBootEnv c key val, ())
 
-      lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
+      lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
       lookupFinderCache key = do
          c <- readIORef mod_cache
-         return $! lookupInstalledModuleEnv c key
+         return $! lookupInstalledModuleWithIsBootEnv c key
 
       lookupFileCache :: FilePath -> IO Fingerprint
       lookupFileCache key = do
@@ -255,7 +255,7 @@ orIfNotFound this or_this = do
 homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
 homeSearchCache fc home_unit mod_name do_this = do
   let mod = mkModule home_unit mod_name
-  modLocationCache fc mod do_this
+  modLocationCache fc (notBoot mod) do_this
 
 findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
 findExposedPackageModule fc fopts units mod_name mb_pkg =
@@ -312,7 +312,7 @@ findLookupResult fc fopts r = case r of
                        , fr_unusables = []
                        , fr_suggestions = suggest' })
 
-modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult
 modLocationCache fc mod do_this = do
   m <- lookupFinderCache fc mod
   case m of
@@ -322,17 +322,17 @@ modLocationCache fc mod do_this = do
         addToFinderCache fc mod result
         return result
 
-addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()
+addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()
 addModuleToFinder fc mod loc = do
-  let imod = toUnitId <$> mod
-  addToFinderCache fc imod (InstalledFound loc imod)
+  let imod = fmap toUnitId <$> mod
+  addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))
 
 -- This returns a module because it's more convenient for users
-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleNameWithIsBoot -> ModLocation -> IO Module
 addHomeModuleToFinder fc home_unit mod_name loc = do
-  let mod = mkHomeInstalledModule home_unit mod_name
-  addToFinderCache fc mod (InstalledFound loc mod)
-  return (mkHomeModule home_unit mod_name)
+  let mod = mkHomeInstalledModule home_unit <$> mod_name
+  addToFinderCache fc mod (InstalledFound loc (gwib_mod mod))
+  return (mkHomeModule home_unit (gwib_mod mod_name))
 
 -- -----------------------------------------------------------------------------
 --      The internal workers
@@ -466,7 +466,7 @@ findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -
 findPackageModule_ fc fopts mod pkg_conf = do
   massertPpr (moduleUnit mod == unitId pkg_conf)
              (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))
-  modLocationCache fc mod $
+  modLocationCache fc (notBoot mod) $
 
     -- special case for GHC.Prim; we won't find it in the filesystem.
     if mod `installedModuleEq` gHC_PRIM
diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs
index 7955f3c07b4..7315c8c1cc2 100644
--- a/compiler/GHC/Unit/Finder/Types.hs
+++ b/compiler/GHC/Unit/Finder/Types.hs
@@ -30,9 +30,9 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
                                -- ^ remove all the home modules from the cache; package modules are
                                -- assumed to not move around during a session; also flush the file hash
                                -- cache.
-                               , addToFinderCache  :: InstalledModule -> InstalledFindResult -> IO ()
+                               , addToFinderCache  :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
                                -- ^ Add a found location to the cache for the module.
-                               , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
+                               , lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
                                -- ^ Look for a location in the cache.
                                , lookupFileCache   :: FilePath -> IO Fingerprint
                                -- ^ Look for the hash of a file in the cache. This should add it to the
diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs
index c9825396882..6b16a7c3fed 100644
--- a/compiler/GHC/Unit/Module/Env.hs
+++ b/compiler/GHC/Unit/Module/Env.hs
@@ -33,6 +33,17 @@ module GHC.Unit.Module.Env
    , mergeInstalledModuleEnv
    , plusInstalledModuleEnv
    , installedModuleEnvElts
+
+     -- * InstalledModuleWithIsBootEnv
+   , InstalledModuleWithIsBootEnv
+   , emptyInstalledModuleWithIsBootEnv
+   , lookupInstalledModuleWithIsBootEnv
+   , extendInstalledModuleWithIsBootEnv
+   , filterInstalledModuleWithIsBootEnv
+   , delInstalledModuleWithIsBootEnv
+   , mergeInstalledModuleWithIsBootEnv
+   , plusInstalledModuleWithIsBootEnv
+   , installedModuleWithIsBootEnvElts
    )
 where
 
@@ -283,3 +294,56 @@ plusInstalledModuleEnv :: (elt -> elt -> elt)
 plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) =
   InstalledModuleEnv $ Map.unionWith f xm ym
 
+
+
+--------------------------------------------------------------------
+-- InstalledModuleWithIsBootEnv
+--------------------------------------------------------------------
+
+-- | A map keyed off of 'InstalledModuleWithIsBoot'
+newtype InstalledModuleWithIsBootEnv elt = InstalledModuleWithIsBootEnv (Map InstalledModuleWithIsBoot elt)
+
+instance Outputable elt => Outputable (InstalledModuleWithIsBootEnv elt) where
+  ppr (InstalledModuleWithIsBootEnv env) = ppr env
+
+
+emptyInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a
+emptyInstalledModuleWithIsBootEnv = InstalledModuleWithIsBootEnv Map.empty
+
+lookupInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> Maybe a
+lookupInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = Map.lookup m e
+
+extendInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> a -> InstalledModuleWithIsBootEnv a
+extendInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m x = InstalledModuleWithIsBootEnv (Map.insert m x e)
+
+filterInstalledModuleWithIsBootEnv :: (InstalledModuleWithIsBoot -> a -> Bool) -> InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBootEnv a
+filterInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv e) =
+  InstalledModuleWithIsBootEnv (Map.filterWithKey f e)
+
+delInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> InstalledModuleWithIsBootEnv a
+delInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = InstalledModuleWithIsBootEnv (Map.delete m e)
+
+installedModuleWithIsBootEnvElts :: InstalledModuleWithIsBootEnv a -> [(InstalledModuleWithIsBoot, a)]
+installedModuleWithIsBootEnvElts (InstalledModuleWithIsBootEnv e) = Map.assocs e
+
+mergeInstalledModuleWithIsBootEnv
+  :: (elta -> eltb -> Maybe eltc)
+  -> (InstalledModuleWithIsBootEnv elta -> InstalledModuleWithIsBootEnv eltc)  -- map X
+  -> (InstalledModuleWithIsBootEnv eltb -> InstalledModuleWithIsBootEnv eltc) -- map Y
+  -> InstalledModuleWithIsBootEnv elta
+  -> InstalledModuleWithIsBootEnv eltb
+  -> InstalledModuleWithIsBootEnv eltc
+mergeInstalledModuleWithIsBootEnv f g h (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym)
+  = InstalledModuleWithIsBootEnv $ Map.mergeWithKey
+      (\_ x y -> (x `f` y))
+      (coerce g)
+      (coerce h)
+      xm ym
+
+plusInstalledModuleWithIsBootEnv :: (elt -> elt -> elt)
+  -> InstalledModuleWithIsBootEnv elt
+  -> InstalledModuleWithIsBootEnv elt
+  -> InstalledModuleWithIsBootEnv elt
+plusInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym) =
+  InstalledModuleWithIsBootEnv $ Map.unionWith f xm ym
+
diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs
index 7c72ebc6438..69e5277dd2a 100644
--- a/compiler/GHC/Unit/Types.hs
+++ b/compiler/GHC/Unit/Types.hs
@@ -86,6 +86,8 @@ module GHC.Unit.Types
    , GenWithIsBoot (..)
    , ModuleNameWithIsBoot
    , ModuleWithIsBoot
+   , InstalledModuleWithIsBoot
+   , notBoot
    )
 where
 
@@ -723,6 +725,8 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
 
 type ModuleWithIsBoot = GenWithIsBoot Module
 
+type InstalledModuleWithIsBoot = GenWithIsBoot InstalledModule
+
 instance Binary a => Binary (GenWithIsBoot a) where
   put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
     put_ bh gwib_mod
@@ -736,3 +740,6 @@ instance Outputable a => Outputable (GenWithIsBoot a) where
   ppr (GWIB  { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of
     IsBoot -> [ text "{-# SOURCE #-}" ]
     NotBoot -> []
+
+notBoot :: mod -> GenWithIsBoot mod
+notBoot gwib_mod = GWIB {gwib_mod, gwib_isBoot = NotBoot}
diff --git a/testsuite/tests/driver/boot-target/A.hs b/testsuite/tests/driver/boot-target/A.hs
new file mode 100644
index 00000000000..0a2f230d1fe
--- /dev/null
+++ b/testsuite/tests/driver/boot-target/A.hs
@@ -0,0 +1,5 @@
+module A where
+
+import B
+
+data A = A B
diff --git a/testsuite/tests/driver/boot-target/A.hs-boot b/testsuite/tests/driver/boot-target/A.hs-boot
new file mode 100644
index 00000000000..fb541bf67e8
--- /dev/null
+++ b/testsuite/tests/driver/boot-target/A.hs-boot
@@ -0,0 +1,3 @@
+module A where
+
+data A
diff --git a/testsuite/tests/driver/boot-target/B.hs b/testsuite/tests/driver/boot-target/B.hs
new file mode 100644
index 00000000000..024ed67b718
--- /dev/null
+++ b/testsuite/tests/driver/boot-target/B.hs
@@ -0,0 +1,5 @@
+module B where
+
+import {-# source #-} A
+
+data B = B A
diff --git a/testsuite/tests/driver/boot-target/Makefile b/testsuite/tests/driver/boot-target/Makefile
new file mode 100644
index 00000000000..d9404ccc8c1
--- /dev/null
+++ b/testsuite/tests/driver/boot-target/Makefile
@@ -0,0 +1,8 @@
+boot1:
+	$(TEST_HC) -c A.hs-boot B.hs
+
+boot2:
+	$(TEST_HC) A.hs-boot A.hs B.hs -v0
+
+boot3:
+	$(TEST_HC) A.hs-boot B.hs -v0
\ No newline at end of file
diff --git a/testsuite/tests/driver/boot-target/all.T b/testsuite/tests/driver/boot-target/all.T
new file mode 100644
index 00000000000..5995bfb2827
--- /dev/null
+++ b/testsuite/tests/driver/boot-target/all.T
@@ -0,0 +1,10 @@
+def test_boot(name):
+    return test(name,
+     [extra_files(['A.hs', 'A.hs-boot', 'B.hs']),
+      ],
+     makefile_test,
+     [])
+
+test_boot('boot1')
+test_boot('boot2')
+test_boot('boot3')