[Git][ghc/ghc][wip/sv/T25246-a] 5 commits: Add a missing tidy in UnivCo
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Mon Oct 28 12:42:20 UTC 2024
Sjoerd Visscher pushed to branch wip/sv/T25246-a at Glasgow Haskell Compiler / GHC
Commits:
9f02dfb5 by Simon Peyton Jones at 2024-10-27T15:10:08-04:00
Add a missing tidy in UnivCo
We were failing to tidy the argument coercions of a UnivCo, which
led directly to #25391.
The fix is, happily, trivial.
I don't have a small repro case (it came up when building horde-ad,
which uses typechecker plugins). It should be possible to make a
repro case, by using a plugin (which builds a UnivCo) but I decided
it was not worth the bother. The bug is egregious and easily fixed.
- - - - -
853050c3 by Andrew Lelechenko at 2024-10-27T15:10:44-04:00
Bump text submodule to 2.1.2
- - - - -
90746a59 by Andrew Lelechenko at 2024-10-27T15:10:44-04:00
hadrian: allow -Wunused-imports for text package
- - - - -
324162fa by Sjoerd Visscher at 2024-10-28T13:42:07+01:00
Don't store boot locations in finder cache
Partially reverts commit fff55592a7b
Amends add(Home)ModuleToFinder so that locations for boot files are not stored in the finder cache.
Removes InstalledModule field from InstalledFound constructor since it's the same as the key that was searched for.
- - - - -
36659cf2 by Sjoerd Visscher at 2024-10-28T13:42:08+01:00
Concentrate boot extension logic in Finder
With new mkHomeModLocation that takes an extra HscSource to add boot extensions if required.
- - - - -
14 changed files:
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Env.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Types.hs
- hadrian/src/Settings/Warnings.hs
- libraries/text
Changes:
=====================================
compiler/GHC/Core/TyCo/Tidy.hs
=====================================
@@ -336,16 +336,18 @@ tidyCo env co
go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
go (ForAllCo tv visL visR h co)
= ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co)
- where (envp, tvp) = tidyVarBndr env tv
+ where (envp, tvp) = tidyVarBndr env tv
-- the case above duplicates a bit of work in tidying h and the kind
-- of tv. But the alternative is to use coercionKind, which seems worse.
go (FunCo r afl afr w co1 co2) = ((FunCo r afl afr $! go w) $! go co1) $! go co2
go (CoVarCo cv) = CoVarCo $! go_cv cv
go (HoleCo h) = HoleCo $! go_hole h
go (AxiomCo ax cos) = AxiomCo ax $ strictMap go cos
- go co@(UnivCo { uco_lty = t1, uco_rty = t2 })
- = co { uco_lty = tidyType env t1, uco_rty = tidyType env t2 }
- -- Don't bother to tidy the uco_deps field
+ go (UnivCo prov role t1 t2 cos)
+ = ((UnivCo prov role
+ $! tidyType env t1)
+ $! tidyType env t2)
+ $! strictMap go cos
go (SymCo co) = SymCo $! go co
go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
go (SelCo d co) = SelCo d $! go co
=====================================
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 (notBoot mod_name) location
+ mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location HsigFile
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
@@ -854,17 +854,14 @@ hsModuleToModSummary home_keys pn hsc_src modname
-- To add insult to injury, we don't even actually use
-- these filenames to figure out where the hi files go.
-- A travesty!
- let location0 = mkHomeModLocation2 fopts modname
+ let location = mkHomeModLocation fopts modname
(unsafeEncodeUtf $ unpackFS unit_fs </>
moduleNameSlashes modname)
- (case hsc_src of
+ (case hsc_src of
HsigFile -> os "hsig"
HsBootFile -> os "hs-boot"
HsSrcFile -> os "hs")
- -- DANGEROUS: bootifying can POISON the module finder cache
- let location = case hsc_src of
- HsBootFile -> addBootSuffixLocnOut location0
- _ -> location0
+ hsc_src
-- This duplicates a pile of logic in GHC.Driver.Make
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
@@ -893,7 +890,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 (GWIB modname (hscSourceToIsBoot hsc_src)) location
+ addHomeModuleToFinder fc home_unit modname location hsc_src
let ms = ModSummary {
ms_mod = this_mod,
ms_hsc_src = hsc_src,
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2123,38 +2123,23 @@ 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)
- src_path = unsafeEncodeUtf src_fn
+ (basename, extension) = splitExtension 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
+ hsc_src
+ | isHaskellSigSuffix (drop 1 extension) = HsigFile
+ | isHaskellBootSuffix (drop 1 extension) = HsBootFile
+ | otherwise = HsSrcFile
-- 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
+ location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src
-- 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 (GWIB pi_mod_name is_boot) location
+ addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
@@ -2184,14 +2169,10 @@ checkSummaryHash
-- and it was likely flushed in depanal. This is not technically
-- needed when we're called from sumariseModule but it shouldn't
-- hurt.
- -- 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
- gwib = GWIB (ms_mod old_summary) (isBootSummary old_summary)
- case ms_hsc_src old_summary of
- HsSrcFile -> addModuleToFinder fc gwib location
- _ -> return ()
+ let fc = hsc_FC hsc_env
+ mod = ms_mod old_summary
+ hsc_src = ms_hsc_src old_summary
+ addModuleToFinder fc mod location hsc_src
hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
@@ -2243,7 +2224,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
find_it :: IO SummariseResult
find_it = do
- found <- findImportedModule hsc_env wanted_mod mb_pkg
+ found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg
case found of
Found location mod
| isJust (ml_hs_file location) ->
@@ -2261,10 +2242,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
just_found location mod = do
-- Adjust location to point to the hs-boot source file,
-- hi file, object file, when is_boot says so
- let location' = case is_boot of
- IsBoot -> addBootSuffixLocn location
- NotBoot -> location
- src_fn = expectJust "summarise2" (ml_hs_file location')
+ let src_fn = expectJust "summarise2" (ml_hs_file location)
-- Check that it exists
-- It might have been deleted since the Finder last found it
@@ -2274,7 +2252,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
-- .hs-boot file doesn't exist.
Nothing -> return NotThere
Just h -> do
- fresult <- new_summary_cache_check location' mod src_fn h
+ fresult <- new_summary_cache_check location mod src_fn h
return $ case fresult of
Left err -> FoundHomeWithError (moduleUnitId mod, err)
Right ms -> FoundHome ms
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -292,12 +292,12 @@ findDependency :: HscEnv
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
-- Find the module; this will be fast because
-- we've done it once during downsweep
- r <- findImportedModule hsc_env imp pkg
+ r <- findImportedModuleWithIsBoot hsc_env imp is_boot pkg
case r of
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (unsafeDecodeUtf $ addBootSuffix_maybe is_boot (ml_hi_file_ospath loc)))
+ -> return (Just (unsafeDecodeUtf $ ml_hi_file_ospath loc))
-- Not in this package: we don't need a dependency
| otherwise
=====================================
compiler/GHC/Driver/Phases.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.Driver.Phases (
isDynLibSuffix,
isHaskellUserSrcSuffix,
isHaskellSigSuffix,
+ isHaskellBootSuffix,
isSourceSuffix,
isHaskellishTarget,
@@ -234,7 +235,7 @@ phaseInputExt Js = "js"
phaseInputExt StopLn = "o"
haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,
- js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes
+ js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes
:: [String]
-- When a file with an extension in the haskellish_src_suffixes group is
-- loaded in --make mode, its imports will be loaded too.
@@ -247,7 +248,8 @@ js_suffixes = [ "js" ]
-- Will not be deleted as temp files:
haskellish_user_src_suffixes =
- haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]
+ haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ]
+haskellish_boot_suffixes = [ "hs-boot", "lhs-boot" ]
haskellish_sig_suffixes = [ "hsig", "lhsig" ]
backpackish_suffixes = [ "bkp" ]
@@ -265,11 +267,12 @@ dynlib_suffixes platform = case platformOS platform of
_ -> ["so"]
isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,
- isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix
+ isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix
:: String -> Bool
isHaskellishSuffix s = s `elem` haskellish_suffixes
isBackpackishSuffix s = s `elem` backpackish_suffixes
isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes
+isHaskellBootSuffix s = s `elem` haskellish_boot_suffixes
isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
isCishSuffix s = s `elem` cish_suffixes
isJsSuffix s = s `elem` js_suffixes
=====================================
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 (GWIB mod_name (hscSourceToIsBoot src_flavour)) location
+ addHomeModuleToFinder fc home_unit mod_name location src_flavour
-- Make the ModSummary to hand to hscMain
let
@@ -777,24 +777,18 @@ mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO Mod
mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
let PipeEnv{ src_basename=basename,
src_suffix=suff } = pipe_env
- let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)
-
- -- Boot-ify it if necessary
- let location2
- | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
- | otherwise = location1
-
+ let location1 = mkHomeModLocation fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff) src_flavour
-- Take -ohi into account if present
-- This can't be done in mkHomeModuleLocation because
-- it only applies to the module being compiles
let ohi = outputHi dflags
- location3 | Just fn <- ohi = location2{ ml_hi_file_ospath = unsafeEncodeUtf fn }
- | otherwise = location2
+ location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn }
+ | otherwise = location1
let dynohi = dynOutputHi dflags
- location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
- | otherwise = location3
+ location3 | Just fn <- dynohi = location2{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
+ | otherwise = location2
-- Take -o into account if present
-- Very like -ohi, but we must *only* do this if we aren't linking
@@ -807,11 +801,11 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
location5 | Just ofile <- expl_o_file
, let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
, isNoLink (ghcLink dflags)
- = location4 { ml_obj_file_ospath = unsafeEncodeUtf ofile
+ = location3 { ml_obj_file_ospath = unsafeEncodeUtf ofile
, ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
| Just dyn_ofile <- expl_dyn_o_file
- = location4 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
- | otherwise = location4
+ = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
+ | otherwise = location3
return location5
where
fopts = initFinderOpts dflags
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -896,9 +896,9 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
else do
let fopts = initFinderOpts dflags
-- Look for the file
- mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)
+ mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod hi_boot_file)
case mb_found of
- InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do
+ InstalledFound loc -> do
-- See Note [Home module load error]
case mhome_unit of
Just home_unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -15,6 +15,7 @@ module GHC.Unit.Finder (
FinderCache(..),
initFinderCache,
findImportedModule,
+ findImportedModuleWithIsBoot,
findPluginModule,
findExactModule,
findHomeModule,
@@ -55,6 +56,7 @@ import GHC.Utils.Panic
import GHC.Linker.Types
import GHC.Types.PkgQual
+import GHC.Types.SourceFile
import GHC.Fingerprint
import Data.IORef
@@ -103,28 +105,28 @@ InstalledNotFound.
initFinderCache :: IO FinderCache
initFinderCache = do
- mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv
+ mod_cache <- newIORef emptyInstalledModuleEnv
file_cache <- newIORef M.empty
let flushFinderCaches :: UnitEnv -> IO ()
flushFinderCaches ue = do
- atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())
+ atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
where
- is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod))
+ is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
- addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+ addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache key val =
atomicModifyIORef' mod_cache $ \c ->
- case (lookupInstalledModuleWithIsBootEnv c key, val) of
+ case (lookupInstalledModuleEnv c key, val) of
-- Don't overwrite an InstalledFound with an InstalledNotFound
-- See [Note Monotonic addToFinderCache]
(Just InstalledFound{}, InstalledNotFound{}) -> (c, ())
- _ -> (extendInstalledModuleWithIsBootEnv c key val, ())
+ _ -> (extendInstalledModuleEnv c key val, ())
- lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+ lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
lookupFinderCache key = do
c <- readIORef mod_cache
- return $! lookupInstalledModuleWithIsBootEnv c key
+ return $! lookupInstalledModuleEnv c key
lookupFileCache :: FilePath -> IO Fingerprint
lookupFileCache key = do
@@ -156,6 +158,13 @@ findImportedModule hsc_env mod pkg_qual =
in do
findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
+findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do
+ res <- findImportedModule hsc_env mod pkg_qual
+ case (res, is_boot) of
+ (Found loc mod, IsBoot) -> return (Found (addBootSuffixLocn loc) mod)
+ _ -> return res
+
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
@@ -228,15 +237,19 @@ findPluginModule fc fopts units Nothing mod_name =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult
-findExactModule fc fopts other_fopts unit_state mhome_unit mod = do
- case mhome_unit of
+findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
+findExactModule fc fopts other_fopts unit_state mhome_unit mod is_boot = do
+ res <- case mhome_unit of
Just home_unit
| isHomeInstalledModule home_unit mod
-> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)
| Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts
-> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)
_ -> findPackageModule fc unit_state fopts mod
+ case (res, is_boot) of
+ (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc))
+ _ -> return res
+
-- -----------------------------------------------------------------------------
-- Helpers
@@ -274,7 +287,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 (notBoot mod) do_this
+ modLocationCache fc mod do_this
findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
findExposedPackageModule fc fopts units mod_name mb_pkg =
@@ -296,7 +309,7 @@ findLookupResult fc fopts r = case r of
-- with just the location of the thing that was
-- instantiated; you probably also need all of the
-- implicit locations from the instances
- InstalledFound loc _ -> return (Found loc m)
+ InstalledFound loc -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
@@ -331,7 +344,7 @@ findLookupResult fc fopts r = case r of
, fr_unusables = []
, fr_suggestions = suggest' })
-modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
modLocationCache fc mod do_this = do
m <- lookupFinderCache fc mod
case m of
@@ -341,17 +354,19 @@ modLocationCache fc mod do_this = do
addToFinderCache fc mod result
return result
-addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()
-addModuleToFinder fc mod loc = do
- let imod = fmap toUnitId <$> mod
- addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))
+addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO ()
+addModuleToFinder fc mod loc src_flavour = do
+ let imod = toUnitId <$> mod
+ unless (src_flavour == HsBootFile) $
+ addToFinderCache fc imod (InstalledFound loc)
-- This returns a module because it's more convenient for users
-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 (gwib_mod mod))
- return (mkHomeModule home_unit (gwib_mod mod_name))
+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module
+addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do
+ let mod = mkHomeInstalledModule home_unit mod_name
+ unless (src_flavour == HsBootFile) $
+ addToFinderCache fc mod (InstalledFound loc)
+ return (mkHomeModule home_unit mod_name)
-- -----------------------------------------------------------------------------
-- The internal workers
@@ -361,7 +376,7 @@ findHomeModule fc fopts home_unit mod_name = do
let uid = homeUnitAsUnit home_unit
r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name
return $ case r of
- InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
+ InstalledFound loc -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fmap unsafeDecodeUtf fps,
@@ -386,7 +401,7 @@ findHomePackageModule fc fopts home_unit mod_name = do
let uid = RealUnit (Definite home_unit)
r <- findInstalledHomeModule fc fopts home_unit mod_name
return $ case r of
- InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+ InstalledFound loc -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fmap unsafeDecodeUtf fps,
@@ -456,7 +471,7 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
-- This is important only when compiling the base package (where GHC.Prim
-- is a home module).
if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ then return (InstalledFound (error "GHC.Prim ModLocation"))
else searchPathExts search_dirs mod exts
-- | Prepend the working directory to the search path.
@@ -485,11 +500,11 @@ 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 (notBoot mod) $
+ modLocationCache fc mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ then return (InstalledFound (error "GHC.Prim ModLocation"))
else
let
@@ -513,7 +528,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
-- don't bother looking for it.
let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
loc = mk_hi_loc one basename
- in return $ InstalledFound loc mod
+ in return $ InstalledFound loc
_otherwise ->
searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
@@ -547,7 +562,7 @@ searchPathExts paths mod exts = search to_search
search ((file, loc) : rest) = do
b <- doesFileExist file
if b
- then return $ InstalledFound loc mod
+ then return $ InstalledFound loc
else search rest
mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
@@ -589,10 +604,12 @@ mkHomeModLocationSearched fopts mod suff path basename =
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
-mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation
-mkHomeModLocation dflags mod src_filename =
- let (basename,extension) = OsPath.splitExtension src_filename
- in mkHomeModLocation2 dflags mod basename extension
+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> FileExt -> HscSource -> ModLocation
+mkHomeModLocation dflags mod src_basename ext hsc_src =
+ let loc = mkHomeModLocation2 dflags mod src_basename ext
+ in case hsc_src of
+ HsBootFile -> addBootSuffixLocnOut loc
+ _ -> loc
mkHomeModLocation2 :: FinderOpts
-> ModuleName
=====================================
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 :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+ , addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
-- ^ Add a found location to the cache for the module.
- , lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+ , lookupFinderCache :: InstalledModule -> 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
@@ -40,7 +40,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
}
data InstalledFindResult
- = InstalledFound ModLocation InstalledModule
+ = InstalledFound ModLocation
| InstalledNoPackage UnitId
| InstalledNotFound [OsPath] (Maybe UnitId)
=====================================
compiler/GHC/Unit/Module/Env.hs
=====================================
@@ -33,17 +33,6 @@ module GHC.Unit.Module.Env
, mergeInstalledModuleEnv
, plusInstalledModuleEnv
, installedModuleEnvElts
-
- -- * InstalledModuleWithIsBootEnv
- , InstalledModuleWithIsBootEnv
- , emptyInstalledModuleWithIsBootEnv
- , lookupInstalledModuleWithIsBootEnv
- , extendInstalledModuleWithIsBootEnv
- , filterInstalledModuleWithIsBootEnv
- , delInstalledModuleWithIsBootEnv
- , mergeInstalledModuleWithIsBootEnv
- , plusInstalledModuleWithIsBootEnv
- , installedModuleWithIsBootEnvElts
)
where
@@ -294,56 +283,3 @@ 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
-
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -13,8 +13,6 @@ module GHC.Unit.Module.Location
)
, pattern ModLocation
, addBootSuffix
- , addBootSuffix_maybe
- , addBootSuffixLocn_maybe
, addBootSuffixLocn
, addBootSuffixLocnOut
, removeBootSuffix
@@ -25,7 +23,6 @@ where
import GHC.Prelude
import GHC.Data.OsPath
-import GHC.Unit.Types
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString (mkFastString)
@@ -99,26 +96,10 @@ removeBootSuffix pathWithBootSuffix =
Just path -> path
Nothing -> error "removeBootSuffix: no -boot suffix"
--- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath
-addBootSuffix_maybe is_boot path = case is_boot of
- IsBoot -> addBootSuffix path
- NotBoot -> path
-
-addBootSuffixLocn_maybe :: IsBootInterface -> ModLocation -> ModLocation
-addBootSuffixLocn_maybe is_boot locn = case is_boot of
- IsBoot -> addBootSuffixLocn locn
- _ -> locn
-
-- | Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
- = locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn)
- , ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn)
- , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
- , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
- , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
- , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) }
+ = addBootSuffixLocnOut locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn) }
-- | Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -84,8 +84,6 @@ module GHC.Unit.Types
, GenWithIsBoot (..)
, ModuleNameWithIsBoot
, ModuleWithIsBoot
- , InstalledModuleWithIsBoot
- , notBoot
)
where
@@ -720,8 +718,6 @@ 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
@@ -735,6 +731,3 @@ 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}
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -66,7 +66,9 @@ ghcWarningsArgs = do
, package primitive ? pure [ "-Wno-unused-imports"
, "-Wno-deprecations" ]
, package rts ? pure [ "-Wcpp-undef" ]
- , package text ? pure [ "-Wno-deprecations", "-Wno-deriving-typeable" ]
+ , package text ? pure [ "-Wno-deprecations"
+ , "-Wno-deriving-typeable"
+ , "-Wno-unused-imports" ]
, package terminfo ? pure [ "-Wno-unused-imports", "-Wno-deriving-typeable" ]
, package stm ? pure [ "-Wno-deriving-typeable" ]
, package osString ? pure [ "-Wno-deriving-typeable" ]
=====================================
libraries/text
=====================================
@@ -1 +1 @@
-Subproject commit cdb9e13b39079904eed9d75cd332b66ee0cad0c0
+Subproject commit ee0a8f8b9a4bd3fdad23e9ac0db56e7f08ce35cd
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c046b1e58181d8f5edf62efc7f8ca0c8ccc46e2...36659cf2d0aab2df73c56441e4610f63c5275fff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c046b1e58181d8f5edf62efc7f8ca0c8ccc46e2...36659cf2d0aab2df73c56441e4610f63c5275fff
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/20241028/9e745ec8/attachment-0001.html>
More information about the ghc-commits
mailing list