Torsten Schmits pushed to branch wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps_ospath at Glasgow Haskell Compiler / GHC Commits: 4d6ffa22 by Torsten Schmits at 2025-11-06T16:10:01+01:00 remove redundant core bindings typecheck in initWholeCoreBindings - - - - - 75206a24 by Georgios Karachalias at 2025-11-19T13:58:58+01:00 Use OsPath in PkgDbRef and UnitDatabase, not FilePath - - - - - 8 changed files: - + compiler/GHC/Data/OsPath.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Data/OsPath.hs ===================================== @@ -0,0 +1,45 @@ +module GHC.Data.OsPath + ( + -- * OsPath initialisation and transformation + OsPath + , OsString + , encodeUtf + , decodeUtf + , unsafeDecodeUtf + , unsafeEncodeUtf + , os + -- * Common utility functions + , () + , (<.>) + , splitSearchPath + , isRelative + , dropTrailingPathSeparator + , takeDirectory + , isSuffixOf + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , createDirectoryIfMissing + , pprOsPath + ) + where + +import GHC.Prelude + +import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Outputable qualified as Outputable +import GHC.Utils.Panic (panic) + +import System.OsPath +import System.OsString (isSuffixOf) +import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing) +import System.Directory.Internal (os) + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf p = + either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p) + +pprOsPath :: HasCallStack => OsPath -> Outputable.SDoc +pprOsPath = Outputable.text . unsafeDecodeUtf ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -76,6 +76,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import GHC.Data.StringBuffer import GHC.Data.FastString +import qualified GHC.Data.OsPath as OsPath import qualified GHC.Data.EnumSet as EnumSet import qualified GHC.Data.ShortText as ST @@ -433,7 +434,7 @@ addUnit u = do Nothing -> panic "addUnit: called too early" Just dbs -> let newdb = UnitDatabase - { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" + { unitDatabasePath = OsPath.unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -96,6 +96,7 @@ import GHC.Core.Unfold import GHC.Data.Bool import GHC.Data.EnumSet (EnumSet) import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) import GHC.Builtin.Names ( mAIN_NAME ) import GHC.Driver.Backend import GHC.Driver.Flags @@ -948,7 +949,7 @@ setDynamicNow dflags0 = data PkgDbRef = GlobalPkgDb | UserPkgDb - | PkgDbPath FilePath + | PkgDbPath OsPath deriving Eq -- | Used to differentiate the scope an include needs to apply to. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1009,11 +1009,6 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do types_var <- newIORef (md_types details) let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv } - core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi - -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do - -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone - -- reports a bug. - let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing [] -- The bytecode generation itself is lazy because otherwise even when doing -- recompilation checking the bytecode will be generated (which slows things down a lot) -- the laziness is OK because generateByteCode just depends on things already loaded ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -255,6 +255,7 @@ import GHC.Types.SrcLoc import GHC.Types.SafeHaskell import GHC.Types.Basic ( treatZeroAsInf ) import GHC.Data.FastString +import qualified GHC.Data.OsPath as OsPath import GHC.Utils.TmpFs import GHC.Utils.Fingerprint import GHC.Utils.Outputable @@ -1962,7 +1963,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] package_flags_deps = [ ------- Packages ---------------------------------------------------- make_ord_flag defFlag "package-db" - (HasArg (addPkgDbRef . PkgDbPath)) + (HasArg (addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf)) , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) @@ -1972,7 +1973,7 @@ package_flags_deps = [ (NoArg (addPkgDbRef UserPkgDb)) -- backwards compat with GHC<=7.4 : , make_dep_flag defFlag "package-conf" - (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + (HasArg $ addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf) "Use -package-db instead" , make_dep_flag defFlag "no-user-package-conf" (NoArg removeUserPkgDb) "Use -no-user-package-db instead" , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> @@ -3377,7 +3378,7 @@ parseEnvFile :: FilePath -> String -> DynP () parseEnvFile envfile = mapM_ parseEntry . lines where parseEntry str = case words str of - ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir db)) + ("package-db": _) -> addPkgDbRef (PkgDbPath (OsPath.unsafeEncodeUtf (envdir db))) -- relative package dbs are interpreted relative to the env file where envdir = takeDirectory envfile db = drop 11 str ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -54,8 +54,6 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import qualified Data.Set as Set -import qualified Data.Map as M -import Data.List (isSuffixOf) import System.FilePath import System.Directory ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -103,6 +103,8 @@ import GHC.Data.Maybe import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST +import GHC.Data.OsPath (OsPath) +import qualified GHC.Data.OsPath as OsPath import GHC.Utils.Logger import GHC.Utils.Error import GHC.Utils.Exception @@ -112,7 +114,7 @@ import System.FilePath as FilePath import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn ) +import Data.List ( intersperse, partition, sortBy, sortOn ) import Data.Set (Set) import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup @@ -405,7 +407,7 @@ initUnitConfig dflags cached_dbs home_units = where offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag - offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset p)) + offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath. p)) offsetPackageDb _ p = p @@ -500,12 +502,12 @@ emptyUnitState = UnitState { -- | Unit database data UnitDatabase unit = UnitDatabase - { unitDatabasePath :: FilePath + { unitDatabasePath :: OsPath , unitDatabaseUnits :: [GenUnitInfo unit] } instance Outputable u => Outputable (UnitDatabase u) where - ppr (UnitDatabase fp _u) = text "DB:" <+> text fp + ppr (UnitDatabase fp _u) = text "DB:" <+> OsPath.pprOsPath fp type UnitInfoMap = UniqMap UnitId UnitInfo @@ -720,9 +722,9 @@ getUnitDbRefs cfg = do Left _ -> system_conf_refs Right path | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs | otherwise - -> map PkgDbPath (splitSearchPath path) + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) -- Apply the package DB-related flags from the command line to get the -- final list of package DBs. @@ -751,24 +753,24 @@ getUnitDbRefs cfg = do -- NB: This logic is reimplemented in Cabal, so if you change it, -- make sure you update Cabal. (Or, better yet, dump it in the -- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg) +resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) let pkgconf = dir unitConfigDBName cfg exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return pkgconf else mzero + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero resolveUnitDatabase _ (PkgDbPath name) = return $ Just name -readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) +readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) readUnitDatabase logger cfg conf_file = do - isdir <- doesDirectoryExist conf_file + isdir <- OsPath.doesDirectoryExist conf_file proto_pkg_configs <- if isdir then readDirStyleUnitInfo conf_file else do - isfile <- doesFileExist conf_file + isfile <- OsPath.doesFileExist conf_file if isfile then do mpkgs <- tryReadOldFileStyleUnitInfo @@ -776,48 +778,49 @@ readUnitDatabase logger cfg conf_file = do Just pkgs -> return pkgs Nothing -> throwGhcExceptionIO $ InstallationError $ "ghc no longer supports single-file style package " ++ - "databases (" ++ conf_file ++ + "databases (" ++ show conf_file ++ ") use 'ghc-pkg init' to create the database with " ++ "the correct format." else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ conf_file + "can't find a package database at " ++ show conf_file let -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = dropTrailingPathSeparator conf_file - top_dir = unitConfigGHCDir cfg - pkgroot = takeDirectory conf_file' + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) -- TODO: hm. + pkgroot = OsPath.takeDirectory conf_file' pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- return $ UnitDatabase conf_file' pkg_configs1 where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] readDirStyleUnitInfo conf_dir = do - let filename = conf_dir "package.cache" - cache_exists <- doesFileExist filename + let filename = conf_dir OsPath. (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename if cache_exists then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename - readPackageDbForGhc filename + debugTraceMsg logger 2 $ text "Using binary package database:" <+> OsPath.pprOsPath filename + readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) -- TODO: Can we help it with this one? it comes from the ghc-boot package else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it -- does, something is wrong and we fail. Otherwise we assume that the -- database is empty. debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> text conf_dir + <+> OsPath.pprOsPath conf_dir <> text ", checking if the database is empty" - db_empty <- all (not . isSuffixOf ".conf") - <$> getDirectoryContents conf_dir + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir if db_empty then do debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> text conf_dir <> text ", treating" + <+> OsPath.pprOsPath conf_dir <> text ", treating" <+> text "package database as empty" return [] else throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ conf_dir ++ + "there is no package.cache in " ++ show conf_dir ++ " even though package database is not empty" @@ -830,13 +833,13 @@ readUnitDatabase logger cfg conf_file = do -- assumes it's a file and tries to overwrite with 'writeFile'. -- ghc-pkg also cooperates with this workaround. tryReadOldFileStyleUnitInfo = do - content <- readFile conf_file `catchIO` \_ -> return "" + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" if take 2 content == "[]" then do - let conf_dir = conf_file <.> "d" - direxists <- doesDirectoryExist conf_dir + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> OsPath.pprOsPath conf_dir) liftM Just (readDirStyleUnitInfo conf_dir) else return (Just []) -- ghc-pkg will create it when it's updated else return Nothing @@ -846,11 +849,12 @@ distrustAllUnits pkgs = map distrust pkgs where distrust pkg = pkg{ unitIsTrusted = False } -mungeUnitInfo :: FilePath -> FilePath +-- TODO: Can we help it with this one? it comes from the ghc-boot package +mungeUnitInfo :: OsPath -> OsPath -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot = mungeDynLibFields - . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot) + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) mungeDynLibFields :: UnitInfo -> UnitInfo mungeDynLibFields pkg = @@ -1388,7 +1392,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] where merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ - text "loading package database" <+> text db_path + text "loading package database" <+> OsPath.pprOsPath db_path forM_ (Set.toList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> ===================================== compiler/ghc.cabal.in ===================================== @@ -115,6 +115,7 @@ Library containers >= 0.6.2.1 && < 0.8, array >= 0.1 && < 0.6, filepath >= 1 && < 1.6, + os-string >= 2.0.1 && < 2.1, template-haskell == 2.22.*, hpc >= 0.6 && < 0.8, transformers >= 0.5 && < 0.7, @@ -430,6 +431,7 @@ Library GHC.Data.List.SetOps GHC.Data.Maybe GHC.Data.OrdList + GHC.Data.OsPath GHC.Data.Pair GHC.Data.SmallArray GHC.Data.Stream View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f166735f14fcdbbe054d15ccdd03ec3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f166735f14fcdbbe054d15ccdd03ec3... You're receiving this email because of your account on gitlab.haskell.org.