Zubin pushed to branch wip/linkable-hashes at Glasgow Haskell Compiler / GHC Commits: 8eea219f by Zubin Duggal at 2026-08-25T14:52:54+05:30 linker: refactor loader so that object suffixes get passed through in a sane way - - - - - e1c8030b by Zubin Duggal at 2026-08-25T14:52:54+05:30 Identify Linkable with fingerprints of their contents rather than modtimes - - - - - afdb51c2 by Zubin Duggal at 2026-08-25T14:52:54+05:30 Linker cleanup delete a bunch of unused functions - - - - - c7f64e7d by Zubin Duggal at 2026-08-25T14:52:54+05:30 Record constituent hashes for bytecode libraries A bytecode library now records the combined hash of its constituents, so relinking can be skipped when they haven't changed. - - - - - 15 changed files: - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Unit/Finder.hs - + testsuite/tests/driver/recomp023/M.hs - + testsuite/tests/driver/recomp023/Makefile - + testsuite/tests/driver/recomp023/all.T - + testsuite/tests/driver/recomp023/recomp023.stdout Changes: ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -6,7 +6,7 @@ {- | This module implements the serialization of bytecode objects to and from disk. -} module GHC.ByteCode.Serialize - ( writeBinByteCode, readBinByteCode, readOnDiskModuleByteCode + ( writeBinByteCode, readBinByteCode, readBinByteCodeHash, readOnDiskModuleByteCode , ModuleByteCode(..) , BytecodeLibX(..) , BytecodeLib @@ -15,6 +15,7 @@ module GHC.ByteCode.Serialize , InterpreterLibraryContents(..) , writeBytecodeLib , readBytecodeLib + , readBytecodeLibInputsHash , mkModuleByteCode , fingerprintModuleByteCodeContents , decodeOnDiskModuleByteCode @@ -84,6 +85,7 @@ The ticket where bytecode objects were dicussed is #26298 See Note [-fwrite-byte-code is not the default] See Note [Recompilation avoidance with bytecode objects] See Note [Persistent bytecode file headers] +See Note [Hash of bytecode libs] Note [Persistent bytecode file headers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -96,15 +98,28 @@ To make these failures explicit, we write a file-kind-specific magic word and the current `hiVersion` ahead of the binary payload. Readers validate this header before setting up the normal `Name`/`FastString` deserialisation machinery. This follows the same approach as normal interface files. + +Note [Hash of bytecode libs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bytecode library records the combined hash of its constituents, so +that relinking can be skipped when they haven't changed. + +We can't hash the library file itself: we would have to build the +library to know which hash to expect. So we compare the inputs. + +The hash is written right after the file header. The constituent hashes +are sorted before they are combined, so the order of the modules +doesn't matter. -} -writeBytecodeLib :: BytecodeLib -> FilePath -> IO () -writeBytecodeLib lib path = do +writeBytecodeLib :: Fingerprint -> BytecodeLib -> FilePath -> IO () +writeBytecodeLib inputs_hash lib path = do odbco <- encodeBytecodeLib lib createDirectoryIfMissing True (takeDirectory path) bh' <- openBinMem initBinMemSize bh <- addBinNameWriter bh' writePersistentBytecodeHeader BytecodeLibraryFile bh + put_ bh inputs_hash putWithUserData QuietBinIFace NormalCompression bh odbco writeBinMem bh path @@ -112,10 +127,18 @@ readBytecodeLib :: HscEnv -> FilePath -> IO OnDiskBytecodeLib readBytecodeLib hsc_env path = do bh' <- readBinMem path readPersistentBytecodeHeader BytecodeLibraryFile path bh' + _inputs_hash <- get bh' :: IO Fingerprint bh <- addBinNameReader (hsc_NC hsc_env) bh' res <- getWithUserData (hsc_NC hsc_env) bh pure res +-- See Note [Hash of bytecode libs] +readBytecodeLibInputsHash :: FilePath -> IO Fingerprint +readBytecodeLibInputsHash path = do + bh <- readBinMem path + readPersistentBytecodeHeader BytecodeLibraryFile path bh + get bh + -- | Convert an 'OnDiskModuleByteCode' to an 'ModuleByteCode'. -- 'OnDiskModuleByteCode' is the representation which we read from a file, -- the 'ModuleByteCode' is the representation which is manipulated by program logic. @@ -200,6 +223,10 @@ readBinByteCode hsc_env f = do odbco <- readOnDiskModuleByteCode hsc_env f decodeOnDiskModuleByteCode hsc_env odbco +-- | Read only the hash from the start of a bytecode file +readBinByteCodeHash :: HscEnv -> FilePath -> IO Fingerprint +readBinByteCodeHash hsc_env f = odgbc_hash <$> readOnDiskModuleByteCode hsc_env f + readOnDiskModuleByteCode :: HscEnv -> FilePath -> IO OnDiskModuleByteCode readOnDiskModuleByteCode hsc_env f = do bh' <- readBinMem f ===================================== compiler/GHC/Driver/Main/Compile.hs ===================================== @@ -132,7 +132,6 @@ import GHC.Data.OsPath (unsafeEncodeUtf) import qualified GHC.Data.Stream as Stream -import Data.Traversable (for) import Control.Monad import Data.IORef import System.Directory @@ -141,7 +140,6 @@ import Data.Map (Map) import qualified Data.Set as S import GHC.Unit.Module.WholeCoreBindings import GHC.Types.TypeEnv -import Data.Time import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) @@ -218,12 +216,7 @@ loadIfaceByteCode hsc_env iface location type_env = where compile decls = do bco <- compileWholeCoreBindings hsc_env type_env decls - linkable $ pure $ DotGBC bco - - linkable parts = do - if_time <- modificationTimeIfExists (ml_hi_file_ospath location) - time <- maybe getCurrentTime pure if_time - return $! Linkable time (mi_module iface) parts + return $! Linkable (gbc_hash bco) (mi_module iface) (pure (DotGBC bco)) loadIfaceByteCodeLazy :: HscEnv -> @@ -240,12 +233,7 @@ loadIfaceByteCodeLazy hsc_env iface location type_env = compile decls = do bco <- unsafeInterleaveIO $ do compileWholeCoreBindings hsc_env type_env decls - linkable bco - - linkable parts = do - if_time <- modificationTimeIfExists (ml_hi_file_ospath location) - time <- maybe getCurrentTime pure if_time - return $!Linkable time (mi_module iface) parts + return $! Linkable (gbc_hash bco) (mi_module iface) bco -- | If the 'Linkable' contains Core bindings loaded from an interface, replace -- them with a lazy IO thunk that compiles them to bytecode and foreign objects, @@ -283,12 +271,13 @@ initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do go :: RecompBytecodeLinkable -> IO (Maybe (LinkableWith ModuleByteCode)) go (NormalLinkable l) = pure l - go (WholeCoreBindingsLinkable wcbl) = - fmap Just $ for wcbl $ \wcb -> do - add_iface_to_hpt iface details hsc_env - bco <- unsafeInterleaveIO $ do - compileWholeCoreBindings hsc_env type_env wcb - pure bco + go (WholeCoreBindingsLinkable wcbl) = do + add_iface_to_hpt iface details hsc_env + bco <- unsafeInterleaveIO $ do + compileWholeCoreBindings hsc_env type_env (linkableParts wcbl) + -- We need to fill in the hash over here, replacing the panic + -- because WholeCoreBindingsLinkable doesn't have a hash. + pure $ Just $ Linkable (gbc_hash bco) (linkableModule wcbl) bco -- | Hydrate interface Core bindings and compile them to bytecode. -- @@ -842,11 +831,7 @@ make user's opt into writing the files. generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO (LinkableWith ModuleByteCode) generateAndWriteByteCodeLinkable hsc_env cgguts mod_location = do bco_object <- generateAndWriteByteCode hsc_env cgguts mod_location - -- 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_ospath mod_location) - return $ mkOnlyModuleByteCodeLinkable bco_time bco_object + return $ mkOnlyModuleByteCodeLinkable bco_object mkModuleByteCode :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ModuleByteCode mkModuleByteCode hsc_env mod mod_location cgguts = do @@ -861,9 +846,8 @@ generateFreshByteCodeLinkable :: HscEnv -> ModLocation -> IO Linkable generateFreshByteCodeLinkable hsc_env mod_name cgguts mod_location = do - bco_time <- getCurrentTime bco_object <- mkModuleByteCode hsc_env (mkHomeModule (hsc_home_unit hsc_env) mod_name) mod_location cgguts - return $ mkModuleByteCodeLinkable bco_time bco_object + return $ mkModuleByteCodeLinkable bco_object ------------------------------ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath) ===================================== compiler/GHC/Driver/Main/Passes.hs ===================================== @@ -153,7 +153,7 @@ import GHC.Types.Unique.Set import GHC.Types.Var.Env ( mkEmptyTidyEnv ) import GHC.Types.Var.Set -import GHC.Utils.Fingerprint ( Fingerprint ) +import GHC.Utils.Fingerprint ( Fingerprint, getFileHash ) import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Outputable @@ -168,8 +168,8 @@ import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict import qualified Data.Array as A -import Data.List ( nub, isPrefixOf, partition ) import qualified Data.List.NonEmpty as NE +import Data.List ( nub, isPrefixOf, partition ) import Control.Monad import Data.IORef import System.FilePath as FilePath @@ -180,7 +180,6 @@ import Data.Set (Set) import Control.DeepSeq (force) import Control.Exception as E (mask_, finally) import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Time import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) @@ -707,15 +706,24 @@ checkObjects dflags mb_old_linkable summary = do -- Not in dynamic-too mode else k + -- We check by date first, even though we have the hash + -- If a compilation is interupted after writing the .hi + -- but before writing the .o, then we catch this through + -- modtimes. + -- If the object file is newer than the .hi file, and the + -- .hi file is up to date, we also assume the object file + -- is up to date. checkDynamicObj $ case (,) <$> mb_obj_date <*> mb_if_date of Just (obj_date, if_date) - | obj_date >= if_date -> + | obj_date >= if_date -> do + disk_hash <- getFileHash obj_fn case mb_old_linkable of Just old_linkable - | linkableIsNativeCodeOnly old_linkable, linkableTime old_linkable == obj_date + | linkableIsNativeCodeOnly old_linkable + , linkableHash old_linkable == disk_hash -> return $ UpToDateItem old_linkable - _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date + _ -> return $ UpToDateItem (findObjectLinkable this_mod obj_fn disk_hash) _ -> return $ outOfDateItemBecause MissingObjectFile Nothing -- | Check to see if we can reuse the old linkable, by this point we will @@ -724,15 +732,22 @@ checkObjects dflags mb_old_linkable summary = do checkByteCodeInMemory :: HscEnv -> ModSummary -> Maybe (LinkableWith ModuleByteCode) -> IO (MaybeValidated (LinkableWith ModuleByteCode)) checkByteCodeInMemory hsc_env mod_sum mb_old_linkable = case mb_old_linkable of - Just old_linkable + Just old_linkable -> do -- If `-fwrite-byte-code` is enabled, then check that the .gbc file is -- up-to-date with the linkable we have in our hand. -- If ms_bytecode_date is Nothing, then the .gbc file does not exist yet. - -- Otherwise, check that the date matches the linkable date exactly. - | if gopt Opt_WriteByteCode (hsc_dflags hsc_env) - then maybe False (linkableTime old_linkable ==) (ms_bytecode_date mod_sum) - else True - -> return $ (UpToDateItem old_linkable) + -- Otherwise, check that the hash matches the disk. + ok <- if gopt Opt_WriteByteCode (hsc_dflags hsc_env) + then case ms_bytecode_date mod_sum of + Nothing -> pure False + Just _ -> do + disk_hash <- ByteCode.readBinByteCodeHash hsc_env + (ml_bytecode_file (ms_location mod_sum)) + pure (disk_hash == linkableHash old_linkable) + else pure True + if ok + then return (UpToDateItem old_linkable) + else return $ outOfDateItemBecause MissingBytecode Nothing _ -> return $ outOfDateItemBecause MissingBytecode Nothing -- | Load bytecode from a ".gbc" object file if it exists and is up-to-date @@ -749,7 +764,7 @@ checkByteCodeFromObject hsc_env mod_sum = do -- that the one we have on disk would be suitable as well. linkable <- unsafeInterleaveIO $ do bco <- ByteCode.readBinByteCode hsc_env obj_fn - return $ mkOnlyModuleByteCodeLinkable obj_date bco + return $ mkOnlyModuleByteCodeLinkable bco return $ UpToDateItem linkable _ -> return $ outOfDateItemBecause MissingBytecode Nothing @@ -759,9 +774,11 @@ checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (Ma checkByteCodeFromIfaceCoreBindings _hsc_env iface mod_sum = do let this_mod = ms_mod mod_sum - if_date = fromJust $ ms_iface_date mod_sum + -- This hash isn't used, initWholeCoreBindings will replace it + -- with a real linkable with bytecode that has a hash. + wcb_hash = panic "linkableHash: WholeCoreBindingsLinkable" case iface_core_bindings iface (ms_location mod_sum) of - Just fi -> return $ UpToDateItem (Linkable if_date this_mod fi) + Just fi -> return $ UpToDateItem (Linkable wcb_hash this_mod fi) _ -> return $ outOfDateItemBecause MissingBytecode Nothing @@ -1621,10 +1638,9 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do Strict.Nothing -- no hpc info {- load it -} - bco_time <- getCurrentTime mbc <- ByteCode.mkModuleByteCode this_mod bcos [] (mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $ - Linkable bco_time this_mod $ NE.singleton (DotGBC mbc) + mkModuleByteCodeLinkable mbc -- Get the foreign reference to the name we should have just loaded. mhvs <- lookupFromLoadedEnv interp (idName binding_id) {- Get the HValue for the root -} @@ -1683,7 +1699,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do -- state independently to load new objects here. let objs = mapMaybe linkableFilterNative (ldNeededLinkables deps) - (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs + (objs_loaded', _new_objs) = rmDupLinkables Nothing (objs_loaded pls) objs -- Compute LoadedPkgInfo metadata for recompilation avoidance. -- We don't call loadPackages' because the JS interpreter doesn't load ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -126,9 +126,11 @@ import qualified Control.Monad.Catch as MC (handle, mask, onException) import Data.Maybe import qualified Data.Set as Set import qualified Data.List.NonEmpty as NE +import Data.List (sort) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Time ( getCurrentTime ) +import GHC.Utils.Fingerprint ( fingerprintFingerprints, getFileHash ) +import GHC.ByteCode.Serialize ( readBytecodeLibInputsHash ) import GHC.Tc.Utils.Monad (shutdownTcMPluginsIO, FrontendResult (..), tcg_plugins) @@ -547,11 +549,13 @@ checkBytecodeLibraryLinkingNeeded _logger dflags unit_env linkables _pkg_deps = e_bytecode_lib_time <- modificationTimeIfExists exe_file_os case e_bytecode_lib_time of Nothing -> return $ NeedsRecompile MustCompile - Just t -> do - let bytecode_times = map linkableTime linkables - if any (t <) bytecode_times - then return $ needsRecompileBecause ObjectsChanged - else return UpToDate + Just _ -> do + -- See Note [Hash of bytecode libs] in GHC.ByteCode.Serialize + e_recorded <- tryIO (readBytecodeLibInputsHash exe_file) + let current = fingerprintFingerprints (sort (map linkableHash linkables)) + case e_recorded of + Right recorded | recorded == current -> return UpToDate + _ -> return $ needsRecompileBecause ObjectsChanged checkNativeLibraryLinkingNeeded :: Bool -> Logger -> DynFlags -> UnitEnv -> [Linkable] -> [UnitId] -> IO RecompileRequired checkNativeLibraryLinkingNeeded staticLink _ dflags unit_env linkables pkg_deps = do @@ -576,8 +580,9 @@ checkNativeLibraryLinkingNeeded staticLink _ dflags unit_env linkables pkg_deps Just t -> do -- first check object files and extra_ld_inputs let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] - (errs,extra_times) <- partitionWithM (tryIO . getModificationUTCTime) extra_ld_inputs - let obj_times = map linkableTime linkables ++ extra_times + obj_files = concatMap linkableFiles linkables + (errs,obj_times) <- partitionWithM (tryIO . getModificationUTCTime) + (obj_files ++ extra_ld_inputs) if not (null errs) || any (t <) obj_times then return $ needsRecompileBecause ObjectsChanged else do @@ -936,9 +941,9 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do -- No object file produced, bytecode or NoBackend Nothing -> return mlinkable Just o_fp -> do - part_time <- liftIO getCurrentTime final_object <- use (T_MergeForeign pipe_env hsc_env o_fp fos) - let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton (DotO final_object ModuleObject)) + !obj_hash <- liftIO $ getFileHash final_object + let !linkable = Linkable obj_hash (ms_mod mod_sum) (NE.singleton (DotO final_object ModuleObject)) -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend. return (mlinkable { homeMod_object = Just linkable }) ===================================== compiler/GHC/Linker/ByteCode.hs ===================================== @@ -8,7 +8,8 @@ import GHC.Utils.Error import GHC.Driver.Env import GHC.Utils.Outputable import GHC.Linker.Loader -import Data.List (partition) +import Data.List (partition, sort) +import GHC.Utils.Fingerprint (fingerprintFingerprints) import GHC.Driver.Phases (isBytecodeFilename) import GHC.Runtime.Interpreter (interpreterDynamic) import Data.Maybe @@ -40,8 +41,10 @@ linkBytecodeLib hsc_env gbcs = do bytecodeLibFiles = all_cbcs, bytecodeLibForeign = interpreter_foreign_lib } + let inputs_hash = fingerprintFingerprints + (sort [ gbc_hash m | m <- on_disk_bcos ++ gbcs ]) let output_fn = fromMaybe "a.out" (outputFile dflags) - writeBytecodeLib bytecodeLib' output_fn + writeBytecodeLib inputs_hash bytecodeLib' output_fn return () ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -41,11 +41,10 @@ import qualified GHC.Unit.Home.Graph as HUG import GHC.Data.Maybe import Control.Applicative +import Control.Monad (forM_, unless) -import Data.List (isSuffixOf) +import System.Directory (doesFileExist) -import System.FilePath -import System.Directory data LinkDepsOpts = LinkDepsOpts { ldObjSuffix :: !String -- ^ Suffix of .o files @@ -87,18 +86,18 @@ getLinkDeps opts interp pls span mods = do -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. -- So here we check the build tag: if we're building a non-standard way -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay opts interp span + checkNonStdWay opts interp span - get_link_deps opts pls maybe_normal_osuf span mods + get_link_deps opts interp pls span mods get_link_deps :: LinkDepsOpts + -> Interp -> LoaderState - -> Maybe FilePath -- replace object suffixes? -> SrcSpan -> [Module] -> IO LinkDeps -get_link_deps opts pls maybe_normal_osuf span mods = do +get_link_deps opts interp pls span mods = do -- Three step process: @@ -122,9 +121,9 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot -- compilation) we may need to use maybe_getFileLinkable - lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed + lnks_needed <- mapM get_linkable mods_needed let - lnks_needed_usages = mkLinkablesUsage lnks_needed + lnks_needed_usages = mkLinkablesUsage (interpObjSuffix interp) lnks_needed new_link_deps lnks = LinkDeps { ldNeededLinkables = lnks_needed , ldAllLinkables = lnks @@ -156,9 +155,12 @@ get_link_deps opts pls maybe_normal_osuf span mods = do then homeModInfoByteCode hmi <|> homeModInfoObject hmi else homeModInfoObject hmi <|> homeModInfoByteCode hmi - get_linkable osuf mod -- A home-package module + get_linkable mod -- A home-package module = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case - Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info)) + Just mod_info -> do + let lnk = expectJust (homeModLinkable mod_info) + validate_objects lnk + pure lnk Nothing -> do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... @@ -185,30 +187,23 @@ get_link_deps opts pls maybe_normal_osuf span mods = do mb_lnk <- findObjectLinkableMaybe mod loc case mb_lnk of Nothing -> no_obj mod - Just lnk -> adjust_linkable lnk + Just lnk -> validate_objects lnk >> pure lnk _ -> no_obj (moduleName mod) - adjust_linkable lnk - | Just new_osuf <- maybe_normal_osuf = do - new_parts <- mapM (adjust_part new_osuf) - (linkableParts lnk) - return lnk{ linkableParts=new_parts } - | otherwise = - return lnk - - adjust_part new_osuf part = case part of - DotO file ModuleObject -> do - massert (osuf `isSuffixOf` file) - let file_base = fromJust (stripExtension osuf file) - new_file = file_base <.> new_osuf - ok <- doesFileExist new_file - if (not ok) - then dieWith opts span $ - text "cannot find object file " - <> quotes (text new_file) $$ while_linking_expr - else return (DotO new_file ModuleObject) - DotO file ForeignObject -> pure (DotO file ForeignObject) - DotGBC {} -> pure part + -- The loader loads the interpreter's object variant of each + -- module object. Check it exists here, where we can say which + -- module and expression needed it. + validate_objects lnk + | Just suffixes <- interpObjSuffix interp = + forM_ (linkableParts lnk) $ \part -> case part of + DotO f ModuleObject -> do + let f' = swapObjSuffix suffixes f + ok <- doesFileExist f' + unless ok $ dieWith opts span $ + text "cannot find object file" <+> quotes (text f') $$ + while_linking_expr + _ -> pure () + | otherwise = pure () {- @@ -241,19 +236,11 @@ dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg) throwProgramError :: LinkDepsOpts -> SDoc -> IO a throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc)) -checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO () checkNonStdWay _opts interp _srcspan - -- On some targets (e.g. wasm) the RTS linker only supports loading - -- dynamic code, in which case we need to ensure the .dyn_o object - -- is picked (instead of .o which is also present because of - -- -dynamic-too) - | ldForceDyn _opts = do - let target_ways = fullWays $ ldWays _opts - pure $ if target_ways `hasWay` WayDyn - then Nothing - else Just $ waysTag (WayDyn `addWay` target_ways) ++ "_o" - - | ExternalInterp {} <- interpInstance interp = return Nothing + | ldForceDyn _opts = return () + + | ExternalInterp {} <- interpInstance interp = return () -- with -fexternal-interpreter we load the .o files, whatever way -- they were built. If they were built for a non-std way, then -- we will use the appropriate variant of the iserv binary to load them. @@ -262,26 +249,23 @@ checkNonStdWay _opts interp _srcspan -- complain that they are redundant. #if defined(HAVE_INTERNAL_INTERPRETER) checkNonStdWay opts _interp srcspan - | hostFullWays == targetFullWays = return Nothing + | hostFullWays == targetFullWays = return () -- Only if we are compiling with the same ways as GHC is built -- with, can we dynamically load those object files. (see #3604) | ldObjSuffix opts == normalObjectSuffix && not (null targetFullWays) = failNonStd opts srcspan - | otherwise = return (Just (hostWayTag ++ "o")) + | otherwise = return () where targetFullWays = fullWays (ldWays opts) - hostWayTag = case waysTag hostFullWays of - "" -> "" - tag -> tag ++ "_" normalObjectSuffix :: String normalObjectSuffix = "o" data Way' = Normal | Prof | Dyn | ProfDyn -failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath) +failNonStd :: LinkDepsOpts -> SrcSpan -> IO () failNonStd opts srcspan = dieWith opts srcspan $ text "Cannot load" <+> pprWay' compWay <+> text "objects when GHC is built" <+> pprWay' ghciWay $$ ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -44,7 +44,6 @@ where import GHC.Prelude import GHC.Settings -import GHC.Utils.Misc import GHC.Platform import GHC.Platform.Ways @@ -673,14 +672,13 @@ findWholeCoreBindings hsc_env mod = do findBytecodeLinkableMaybe :: HscEnv -> ModLocation -> IO (Maybe Linkable) findBytecodeLinkableMaybe hsc_env locn = do - let bytecode_fn = ml_bytecode_file locn - bytecode_fn_os = ml_bytecode_file_ospath locn - maybe_bytecode_time <- modificationTimeIfExists bytecode_fn_os - case maybe_bytecode_time of - Nothing -> return Nothing - Just bytecode_time -> do + let bytecode_fn = ml_bytecode_file locn + exists <- doesFileExist bytecode_fn + if not exists + then return Nothing + else do bco <- readBinByteCode hsc_env bytecode_fn - return $ Just $ mkModuleByteCodeLinkable bytecode_time bco + return $ Just $ mkModuleByteCodeLinkable bco get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) get_reachable_nodes hsc_env mods @@ -834,7 +832,7 @@ linkableInSet :: Linkable -> LinkableSet LinkableUsage -> Bool linkableInSet l objs_loaded = case lookupModuleEnv objs_loaded (linkableModule l) of Nothing -> False - Just m -> linkableTime l == linkableTime m + Just m -> linkableHash l == linkableHash m {- ********************************************************************** @@ -854,9 +852,9 @@ loadObjects -> [Linkable] -> IO (LoaderState, SuccessFlag) loadObjects interp hsc_env pls objs = do - let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + let (objs_loaded', new_objs) = rmDupLinkables (interpObjSuffix interp) (objs_loaded pls) objs pls1 = pls { objs_loaded = objs_loaded' } - wanted_objs = concatMap linkableObjs new_objs + wanted_objs <- concat <$> mapM (loadableObjs interp) new_objs if interpreterDynamic interp then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs @@ -875,6 +873,18 @@ loadObjects interp hsc_env pls objs = do return (pls2, Failed) +loadableObjs :: Interp -> Linkable -> IO [FilePath] +loadableObjs interp l = concat <$> mapM go (Foldable.toList (linkableParts l)) + where + go (DotO fn ModuleObject) + | Just suffixes <- interpObjSuffix interp = do + let fn' = swapObjSuffix suffixes fn + ok <- doesFileExist fn' + if ok + then return [fn'] + else throwGhcExceptionIO (ProgramError ("cannot find object file " ++ fn')) + go part = return (linkablePartObjectPaths part) + -- | Create a shared library containing the given object files mkDynLoadLib :: HscEnv -> (Ways -> Ways) -> [(FilePath, String)] ->[UnitId] -> [FilePath] -> IO (Maybe (FilePath, FilePath, String)) mkDynLoadLib _ _ _ _ [] = return Nothing @@ -959,17 +969,18 @@ dynLoadObjs interp hsc_env pls objs = do then addWay WayProf else id -rmDupLinkables :: LinkableSet LinkableUsage -- ^ Already loaded +rmDupLinkables :: Maybe (String, String) + -> LinkableSet LinkableUsage -- ^ Already loaded -> [Linkable] -- ^ New linkables -> (LinkableSet LinkableUsage, -- New loaded set (including new ones) [Linkable]) -- New linkables (excluding dups) -rmDupLinkables already ls +rmDupLinkables mb_osuf already ls = go already [] ls where go !already extras [] = (already, extras) go !already extras (l:ls) | linkableInSet l already = go already extras ls - | otherwise = go (extendModuleEnv already (linkableModule l) $! mkLinkableUsage l) (l:extras) ls + | otherwise = go (extendModuleEnv already (linkableModule l) $! mkLinkableUsage mb_osuf l) (l:extras) ls {- ********************************************************************** @@ -981,7 +992,7 @@ rmDupLinkables already ls dynLinkBCOs :: Interp -> LoaderState -> KeepModuleLinkableDefinitions -> [Linkable] -> IO LoaderState dynLinkBCOs interp pls keep_spec bcos = - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + let (bcos_loaded', new_bcos) = rmDupLinkables Nothing (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } cbcs :: [CompiledByteCode] ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -36,8 +36,6 @@ module GHC.Linker.Types , LinkedBreaks(..) , emptyLinkedBreaks , LinkableSet - , mkLinkableSet - , unionLinkableSet , ObjFile , SptEntry(..) , LibrarySpec(..) @@ -58,9 +56,8 @@ module GHC.Linker.Types , linkableBCOs , linkablePartBCOs , linkableModuleByteCodes - , linkableNativeParts - , linkablePartitionParts , linkablePartPath + , linkablePartObjectPaths , isNativeCode , linkableFilterByteCode , linkableFilterNative @@ -70,6 +67,7 @@ module GHC.Linker.Types , linkableUsageObjs , mkLinkablesUsage , mkLinkableUsage + , swapObjSuffix , ModuleByteCode(..) ) @@ -95,6 +93,7 @@ import GHC.Unit.Module.Deps (LinkablePartUsage (..), linkablePartUsageObjectPath import GHC.Unit.Module.Env import GHC.Unit.Module.WholeCoreBindings import GHC.Utils.Misc (seqNonEmpty) +import GHC.Utils.Panic (pprPanic) import GHC.Utils.Outputable @@ -102,10 +101,10 @@ import Control.Applicative ((<|>)) import Control.Concurrent.MVar import Data.Array import Data.Functor.Identity -import Data.Time ( UTCTime ) import Data.Maybe (mapMaybe) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NE +import System.FilePath (stripExtension, (<.>)) {- ********************************************************************** @@ -376,10 +375,10 @@ instance Outputable LoadedPkgInfo where -- | Information we can use to dynamically link modules into the compiler data LinkableWith parts = Linkable - { linkableTime :: !UTCTime - -- ^ Time at which this linkable was built - -- (i.e. when the bytecodes were produced, - -- or the mod date on the files) + { linkableHash :: Fingerprint + -- ^ The identity of the linkable, derived from the hash of its contents + -- Lazy because bytecode is compiled lazily (see loadIfaceByteCodeLazy), + -- and inspecting the hash can force compiling the bytecode itself. , linkableModule :: !Module -- ^ The linkable module itself @@ -396,22 +395,12 @@ type LinkableUsage = LinkableWith (NonEmpty LinkablePartUsage) type LinkableSet = ModuleEnv -mkLinkableSet :: [Linkable] -> LinkableSet Linkable -mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls] - --- | Union of LinkableSets. --- --- In case of conflict, keep the most recent Linkable (as per linkableTime) -unionLinkableSet :: LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a) -unionLinkableSet = plusModuleEnv_C go - where - go l1 l2 - | linkableTime l1 > linkableTime l2 = l1 - | otherwise = l2 instance Outputable a => Outputable (LinkableWith a) where - ppr (Linkable when_made mod parts) - = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod) + -- Don't print the hash, forcing it can trigger compilation + -- See the comment on 'linkableHash' + ppr (Linkable _ mod parts) + = (text "Linkable" <+> ppr mod) $$ nest 3 (ppr parts) type ObjFile = FilePath @@ -452,13 +441,13 @@ data ModuleByteCode = ModuleByteCode { gbc_module :: Module , gbc_hash :: !Fingerprint } -mkModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> Linkable -mkModuleByteCodeLinkable linkable_time bco = do - Linkable linkable_time (gbc_module bco) (pure (DotGBC bco)) +mkModuleByteCodeLinkable :: ModuleByteCode -> Linkable +mkModuleByteCodeLinkable bco = + Linkable (gbc_hash bco) (gbc_module bco) (pure (DotGBC bco)) -mkOnlyModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> LinkableWith ModuleByteCode -mkOnlyModuleByteCodeLinkable linkable_time bco = do - Linkable linkable_time (gbc_module bco) bco +mkOnlyModuleByteCodeLinkable :: ModuleByteCode -> LinkableWith ModuleByteCode +mkOnlyModuleByteCodeLinkable bco = + Linkable (gbc_hash bco) (gbc_module bco) bco instance Outputable ModuleByteCode where ppr (ModuleByteCode mod _cbc _fos _) = text "ModuleByteCode" <+> ppr mod @@ -484,21 +473,13 @@ linkableBCOs l = [ gbc_compiled_byte_code gbc | DotGBC gbc <- NE.toList (linkabl linkableModuleByteCodes :: Linkable -> [ModuleByteCode] linkableModuleByteCodes l = [ mbc | DotGBC mbc <- NE.toList (linkableParts l) ] --- | List the native linkable parts (.o) of a linkable -linkableNativeParts :: Linkable -> [LinkablePart] -linkableNativeParts l = NE.filter isNativeCode (linkableParts l) - --- | Split linkable parts into (native code parts, BCOs parts) -linkablePartitionParts :: Linkable -> ([LinkablePart],[LinkablePart]) -linkablePartitionParts l = NE.partition isNativeCode (linkableParts l) - -- | List the native objects (.o) of a linkable linkableObjs :: Linkable -> [FilePath] linkableObjs l = concatMap linkablePartObjectPaths (linkableParts l) -- | List the paths of the native objects (.o) linkableFiles :: Linkable -> [FilePath] -linkableFiles l = concatMap linkablePartNativePaths (NE.toList (linkableParts l)) +linkableFiles l = mapMaybe linkablePartPath (NE.toList (linkableParts l)) ------------------------------------------- @@ -514,13 +495,6 @@ linkablePartPath = \case DotO fn _ -> Just fn DotGBC {} -> Nothing --- | Return the paths of all object code files (.o) contained in this --- 'LinkablePart'. -linkablePartNativePaths :: LinkablePart -> [FilePath] -linkablePartNativePaths = \case - DotO fn _ -> [fn] - DotGBC {} -> [] - -- | Return the paths of all object files (.o) contained in this 'LinkablePart'. linkablePartObjectPaths :: LinkablePart -> [FilePath] linkablePartObjectPaths = \case @@ -578,8 +552,13 @@ partitionLinkables linkables = -- -- Each 'LinkablePartUsage' is fully evaluated to avoid retaining any reference -- to the original 'LinkablePart'. -mkLinkableUsage :: Linkable -> LinkableUsage -mkLinkableUsage lnk = +swapObjSuffix :: (String, String) -> FilePath -> FilePath +swapObjSuffix (from, to) file = case stripExtension from file of + Just base -> base <.> to + Nothing -> pprPanic "swapObjSuffix" (text file <+> text from) + +mkLinkableUsage :: Maybe (String, String) -> Linkable -> LinkableUsage +mkLinkableUsage mb_osuf lnk = let linkablesWithUsage = NE.map (go (linkableModule lnk)) (linkableParts lnk) lnkUsage = lnk @@ -589,7 +568,9 @@ mkLinkableUsage lnk = seqNonEmpty linkablesWithUsage linkablesWithUsage } in - linkableParts lnkUsage `seq` lnkUsage + -- Also force the hash so that we don't retain the actual bytecode + -- from a LinkableUsage + linkableHash lnkUsage `seq` linkableParts lnkUsage `seq` lnkUsage where mkFileLinkablePartUsage m fp objs = FileLinkablePartUsage @@ -609,11 +590,15 @@ mkLinkableUsage lnk = go :: Module -> LinkablePart -> LinkablePartUsage go m lnkPart = case lnkPart of + DotO fn ModuleObject + | Just suffixes <- mb_osuf + , let fn' = swapObjSuffix suffixes fn + -> mkFileLinkablePartUsage m fn' [fn'] DotO fn _ -> mkFileLinkablePartUsage m fn (linkablePartObjectPaths lnkPart) DotGBC mbc -> mkByteCodeLinkablePartUsage m (gbc_hash mbc) (linkablePartObjectPaths lnkPart) -mkLinkablesUsage :: [Linkable] -> [LinkableUsage] -mkLinkablesUsage linkables = map mkLinkableUsage linkables +mkLinkablesUsage :: Maybe (String, String) -> [Linkable] -> [LinkableUsage] +mkLinkablesUsage mb_osuf linkables = map (mkLinkableUsage mb_osuf) linkables linkableUsageObjs :: LinkableUsage -> [FilePath] linkableUsageObjs lnkWithUsage = concatMap linkablePartUsageObjectPaths (linkableParts lnkWithUsage) ===================================== compiler/GHC/Runtime/Interpreter/Init.hs ===================================== @@ -11,6 +11,7 @@ where import GHC.Prelude import GHC.Data.FastString.Env import GHC.Driver.DynFlags +import GHC.Driver.Session (objectSuf) import GHC.Platform import GHC.Platform.Ways import GHC.Settings @@ -74,6 +75,23 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do fs_cache <- liftIO $ newMVar emptyFsEnv +#if defined(HAVE_INTERNAL_INTERPRETER) + let host_way_tag = case waysTag hostFullWays of + "" -> "" + tag -> tag ++ "_" + internal_obj_suffix + | hostFullWays == fullWays (interpWays opts) = Nothing + | otherwise = Just (objectSuf dflags, host_way_tag ++ "o") +#endif + +#if !defined(wasm32_HOST_ARCH) + let target_full_ways = fullWays (interpWays opts) + wasm_obj_suffix + | target_full_ways `hasWay` WayDyn = Nothing + | otherwise = + Just (objectSuf dflags, waysTag (WayDyn `addWay` target_full_ways) ++ "_o") +#endif + -- see Note [Target code interpreter] if #if !defined(wasm32_HOST_ARCH) @@ -103,7 +121,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do , wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (interpNameVer opts) , wasmInterpUnitState = ue_homeUnitState unit_env } - pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache fs_cache + pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache fs_cache wasm_obj_suffix #endif -- JavaScript interpreter @@ -122,7 +140,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do , jsInterpFinderOpts = interpFinderOpts opts , jsInterpFinderCache = finder_cache } - return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache fs_cache)) + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache fs_cache Nothing)) -- external interpreter | interpExternal opts @@ -149,7 +167,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do } s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache)) + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache Nothing)) -- Internal interpreter | otherwise @@ -157,7 +175,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do #if defined(HAVE_INTERNAL_INTERPRETER) do loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader lookup_cache fs_cache)) + return (Just (Interp InternalInterp loader lookup_cache fs_cache internal_obj_suffix)) #else return Nothing #endif ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -79,6 +79,10 @@ data Interp = Interp , interpStringCache :: !(MVar (FastStringEnv (RemotePtr ()))) -- ^ MallocStrings cache + + , interpObjSuffix :: !(Maybe (String, String)) + -- ^ @(from, to)@ object suffixes to swap when the interpreter cannot + -- load objects built the target's way } data InterpInstance ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -58,7 +58,6 @@ import GHC.Unit.Finder.Types import qualified GHC.Data.ShortText as ST -import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic @@ -72,7 +71,6 @@ import GHC.Fingerprint import Data.IORef import Control.Applicative ((<|>)) import Control.Monad -import Data.Time import qualified Data.Map as M import GHC.Types.Unique.Map import GHC.Driver.Env @@ -1004,15 +1002,15 @@ 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 (ml_obj_file_ospath locn) - case maybe_obj_time of - Nothing -> return Nothing - Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) - --- Make an object linkable when we know the object file exists, and we know --- its modification time. -findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = - pure (Linkable obj_time mod (NE.singleton (DotO obj_fn ModuleObject))) + exists <- doesFileExist (ml_obj_file_ospath locn) + if not exists + then return Nothing + else do + obj_hash <- getFileHash obj_fn + return (Just (findObjectLinkable mod obj_fn obj_hash)) + +findObjectLinkable :: Module -> FilePath -> Fingerprint -> Linkable +findObjectLinkable mod obj_fn obj_hash = + Linkable obj_hash mod (NE.singleton (DotO obj_fn ModuleObject)) -- We used to look for _stub.o files here, but that was a bug (#706) -- Now GHC merges the stub.o into the main .o (#3687) ===================================== testsuite/tests/driver/recomp023/M.hs ===================================== @@ -0,0 +1,4 @@ +module M where + +m :: Int +m = 5 ===================================== testsuite/tests/driver/recomp023/Makefile ===================================== @@ -0,0 +1,13 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +clean: + +recomp023: clean + '$(TEST_HC)' $(TEST_HC_OPTS) --make -bytecodelib -fbyte-code \ + -fwrite-interface -fwrite-byte-code -this-unit-id=recomp023 \ + -o recomp023.bytecodelib M.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --make -bytecodelib -fbyte-code \ + -fwrite-interface -fwrite-byte-code -this-unit-id=recomp023 \ + -o recomp023.bytecodelib M.hs ===================================== testsuite/tests/driver/recomp023/all.T ===================================== @@ -0,0 +1,2 @@ +test('recomp023', [extra_files(['M.hs']), req_bco, normalise_slashes], + makefile_test, []) ===================================== testsuite/tests/driver/recomp023/recomp023.stdout ===================================== @@ -0,0 +1,2 @@ +[1 of 2] Compiling M ( M.hs, M.gbc ) +[2 of 2] Linking recomp023.bytecodelib View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7b9750f8ac4e03574138e59a65bb92... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7b9750f8ac4e03574138e59a65bb92... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help