Matthew Pickering pushed to branch wip/gbc-files at Glasgow Haskell Compiler / GHC Commits: 1b95e960 by Matthew Pickering at 2025-10-01T12:28:59+01:00 Don't get so many uniques - - - - - 33dc1d21 by Matthew Pickering at 2025-10-01T14:34:55+01:00 Use 'OsPath' in getModificationTimeIfExists This part of the compiler is quite hot during recompilation checking in particular since the filepaths will be translated to a string. It is better to use the 'OsPath' native function, which turns out to be easy to do. - - - - - 8 changed files: - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Utils/Misc.hs Changes: ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -34,6 +34,7 @@ import qualified Data.ByteString as BS import Data.Traversable import GHC.Utils.Logger import GHC.Linker.Types +import System.IO.Unsafe (unsafeInterleaveIO) -- | The on-disk representation of a bytecode object data OnDiskByteCodeObject = OnDiskByteCodeObject { odbco_module :: Module @@ -242,12 +243,15 @@ addBinNameReader HscEnv {..} bh' = do pure $ BinName nm 1 -> do occ <- mkVarOccFS <$> get bh - u <- takeUniqFromNameCache hsc_NC - nm' <- evaluate $ mkInternalName u occ noSrcSpan + -- We don't want to get a new unique from the NameCache each time we + -- see a name. + nm' <- unsafeInterleaveIO $ do + u <- takeUniqFromNameCache hsc_NC + evaluate $ mkInternalName u occ noSrcSpan fmap BinName $ atomicModifyIORef' env_ref $ \env -> case lookupOccEnv env occ of Just nm -> (env, nm) - _ -> (extendOccEnv env occ nm', nm') + _ -> nm' `seq` (extendOccEnv env occ nm', nm') _ -> panic "Binary BinName: invalid byte" -- Note [Serializing Names in bytecode] ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -786,8 +786,8 @@ summariseRequirement pn mod_name = do env <- getBkpEnv src_hash <- liftIO $ getFileHash (bkp_filename env) - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location) let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) let fc = hsc_FC hsc_env @@ -872,8 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname HsSrcFile -> os "hs") 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) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location) -- Also copied from 'getImports' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -1264,7 +1264,7 @@ checkSummaryHash | ms_hs_hash old_summary == src_hash && not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do -- update the object-file timestamp - obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + obj_timestamp <- modificationTimeIfExists (ml_obj_file_ospath location) -- We have to repopulate the Finder's cache for file targets -- because the file might not even be on the regular search path @@ -1276,8 +1276,8 @@ checkSummaryHash 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) + hi_timestamp <- modificationTimeIfExists (ml_hi_file_ospath location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file_ospath location) return $ Right ( old_summary @@ -1481,11 +1481,11 @@ data MakeNewModSummary makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary makeNewModSummary hsc_env MakeNewModSummary{..} = do let PreprocessedImports{..} = nms_preimps - obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) - dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location) - hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) - hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) - bytecode_timestamp <- modificationTimeIfExists (ml_bytecode_file nms_location) + obj_timestamp <- modificationTimeIfExists (ml_obj_file_ospath nms_location) + dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file_ospath nms_location) + hi_timestamp <- modificationTimeIfExists (ml_hi_file_ospath nms_location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file_ospath nms_location) + bytecode_timestamp <- modificationTimeIfExists (ml_bytecode_file_ospath nms_location) extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1088,7 +1088,7 @@ loadIfaceByteCode hsc_env iface location type_env = linkable $ pure $ BCOs $ (ByteCodeObject (mi_module iface) bcos fos) linkable parts = do - if_time <- modificationTimeIfExists (ml_hi_file location) + if_time <- modificationTimeIfExists (ml_hi_file_ospath location) time <- maybe getCurrentTime pure if_time return $! Linkable time (mi_module iface) parts @@ -1109,7 +1109,7 @@ loadIfaceByteCodeLazy hsc_env iface location type_env = linkable $ NE.singleton (BCOs (ByteCodeObject (mi_module iface) bcos fos)) linkable parts = do - if_time <- modificationTimeIfExists (ml_hi_file location) + if_time <- modificationTimeIfExists (ml_hi_file_ospath location) time <- maybe getCurrentTime pure if_time return $!Linkable time (mi_module iface) parts @@ -2230,7 +2230,7 @@ generateAndWriteByteCodeLinkable hsc_env cgguts mod_location = do -- Either, get the same time as the .gbc file if it exists, or just the current time. -- It's important the time of the linkable matches the time of the .gbc file for recompilation -- checking. - bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file mod_location) + bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file_ospath mod_location) loadByteCodeObjectLinkable bco_time bco_object mkByteCodeObject :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ByteCodeObject ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -722,17 +722,18 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name - let o_file = ml_obj_file location -- The real object file - hi_file = ml_hi_file location - hie_file = ml_hie_file location - dyn_o_file = ml_dyn_obj_file location + let o_file = ml_obj_file_ospath location -- The real object file + hi_file = ml_hi_file_ospath location + hie_file = ml_hie_file_ospath location + dyn_o_file = ml_dyn_obj_file_ospath location + bytecode_file = ml_bytecode_file_ospath location src_hash <- getFileHash (basename <.> suff) hi_date <- modificationTimeIfExists hi_file hie_date <- modificationTimeIfExists hie_file o_mod <- modificationTimeIfExists o_file dyn_o_mod <- modificationTimeIfExists dyn_o_file - bytecode_date <- modificationTimeIfExists (ml_bytecode_file location) + bytecode_date <- modificationTimeIfExists bytecode_file -- Tell the finder cache about this module mod <- do ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -658,7 +658,7 @@ findWholeCoreBindings hsc_env mod = do findBytecodeLinkableMaybe :: HscEnv -> Module -> ModLocation -> IO (Maybe Linkable) findBytecodeLinkableMaybe hsc_env mod locn = do - let bytecode_fn = ml_bytecode_file locn + let bytecode_fn = ml_bytecode_file_ospath locn maybe_bytecode_time <- modificationTimeIfExists bytecode_fn case maybe_bytecode_time of Nothing -> return Nothing @@ -668,7 +668,7 @@ findBytecodeLinkableMaybe hsc_env mod locn = do _ <- initIfaceLoad hsc_env $ loadInterface (text "get_reachable_nodes" <+> parens (ppr mod)) mod ImportBySystem - bco <- readBinByteCode hsc_env bytecode_fn + bco <- readBinByteCode hsc_env (ml_bytecode_file locn) Just <$> loadByteCodeObjectLinkable bytecode_time bco get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -826,7 +826,7 @@ mkStubPaths fopts mod location = do findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) findObjectLinkableMaybe mod locn = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn + maybe_obj_time <- modificationTimeIfExists (ml_obj_file_ospath locn) case maybe_obj_time of Nothing -> return Nothing Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -137,6 +137,8 @@ import Control.Monad ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) +import qualified System.Directory.OsPath as OsPath +import System.OsPath (OsPath) import System.FilePath import Data.Bifunctor ( first, second ) @@ -1248,9 +1250,9 @@ getModificationUTCTime = getModificationTime -- -------------------------------------------------------------- -- check existence & modification time at the same time -modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +modificationTimeIfExists :: OsPath -> IO (Maybe UTCTime) modificationTimeIfExists f = - (do t <- getModificationUTCTime f; return (Just t)) + (do t <- OsPath.getModificationTime f; return (Just t)) `catchIO` \e -> if isDoesNotExistError e then return Nothing else ioError e View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2172b324ade01d9c8127e3a6b1b1c69... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2172b324ade01d9c8127e3a6b1b1c69... You're receiving this email because of your account on gitlab.haskell.org.