[Git][ghc/ghc][wip/fendor/linkable-usage] Record `LinkableUsage` instead of `Linkable` in `LoaderState`
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC Commits: 31a3cbc3 by fendor at 2026-03-16T14:56:24+01:00 Record `LinkableUsage` instead of `Linkable` in `LoaderState` Retaining a ByteCode `Linkable` after it has been loaded retains its `UnlinkedBCO`, keeping it alive for the remainder of the program. This starts accumulating a lot of `UnlinkedBCO` and memory over time. However, the `Linkable` is merely used to later record its usage in `mkObjectUsage`, which is used for recompilation checking. However, this is incorrect, as the interface file and bytecode objects could be in different states, e.g. the interface changes, but the bytecode library hasn't changed so we don't need to recompile and vice versa. By computing a `Fingerprint` for the `ModuleByteCode`, and recording it in the `LinkableUsage`, we know precisely whether the `ByteCode` object on disk is outdated. Thus, parts of this commit just makes sure that we efficiently compute a `Fingerprint` for `ModuleByteCode` and store it in the on-disk representation of `ModuleByteCode`. We change the `LoaderState` to retain `LinkableUsage`, which is smaller representation of a `Linkable`. This allows us to free the unneeded fields of `Linkable` after linking them. We declare the following memory invariants that this commit implements: * No `LinkablePart` should be retained from `LoaderState`. * `Linkable`s should be unloaded after they have been loaded. These invariants are unfortunately tricky to automatically uphold, so we are simply documenting our assumptions for now. ------------------------- Metric Increase: MultiLayerModulesTH_OneShot ------------------------- We allocate a bit more, but the peak number of bytes doesn't change. While a bit unfortunate, accepting the metric increase. We add multiple new performance measurements where we were able to observe the desired memory invariants. Further, we add regression tests to validate that the recompilation checker behaves more correct than before. - - - - - 25 changed files: - + compiler/GHC/ByteCode/Binary.hs - + compiler/GHC/ByteCode/Recomp/Binary.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Hooks.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Status.hs - compiler/ghc.cabal.in - ghc/GHCi/Leak.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout Changes: ===================================== compiler/GHC/ByteCode/Binary.hs ===================================== @@ -0,0 +1,293 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.ByteCode.Binary ( + -- * ByteCode objects on disk and intermediate representations + OnDiskModuleByteCode(..), + BytecodeLibX(..), + BytecodeLib, + OnDiskBytecodeLib, + InterpreterLibrary(..), + InterpreterLibraryContents(..), + -- * Binary 'Name' serializers + BytecodeNameEnv(..), + addBinNameWriter, + addBinNameReader, +) where + +import GHC.Prelude + +import GHC.ByteCode.Types +import GHC.Data.FastString +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Unit.Types +import GHC.Utils.Binary +import GHC.Utils.Exception +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Fingerprint (Fingerprint) + +import Control.Monad +import Data.Binary qualified as Binary +import Data.ByteString (ByteString) +import Data.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +import System.IO.Unsafe (unsafeInterleaveIO) + +-- | The on-disk representation of a bytecode object for a specific module. +-- +-- This is the representation which we serialise and write to disk. +-- The difference from 'ModuleByteCode' is that the contents of the object files +-- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to +-- temporary files. +data OnDiskModuleByteCode = OnDiskModuleByteCode { odgbc_module :: Module + , odgbc_hash :: Fingerprint + , odgbc_compiled_byte_code :: CompiledByteCode + , odgbc_foreign :: [ByteString] -- ^ Contents of object files + } + +type OnDiskBytecodeLib = BytecodeLibX (Maybe InterpreterLibraryContents) + +instance Outputable a => Outputable (BytecodeLibX a) where + ppr (BytecodeLib {..}) = vcat [ + (text "BytecodeLib" <+> ppr bytecodeLibUnitId), + (text "Files" <+> ppr bytecodeLibFiles), + (text "Foreign" <+> ppr bytecodeLibForeign) ] + +type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary) + +-- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs +data BytecodeLibX a = BytecodeLib { + bytecodeLibUnitId :: UnitId, + bytecodeLibFiles :: [CompiledByteCode], + bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI) +} + +data InterpreterLibrary = InterpreterSharedObject { getSharedObjectFilePath :: FilePath, getSharedObjectDir :: FilePath, getSharedObjectLibName :: String } + | InterpreterStaticObjects { getStaticObjects :: [FilePath] } + + +instance Outputable InterpreterLibrary where + ppr (InterpreterSharedObject path dir name) = text "SharedObject" <+> text path <+> text dir <+> text name + ppr (InterpreterStaticObjects paths) = text "StaticObjects" <+> text (show paths) + + +data InterpreterLibraryContents = InterpreterLibrarySharedContents { interpreterLibraryContents :: ByteString } + | InterpreterLibraryStaticContents { interpreterLibraryStaticContents :: [ByteString] } + +instance Binary InterpreterLibraryContents where + get bh = do + t <- getByte bh + case t of + 0 -> InterpreterLibrarySharedContents <$> get bh + 1 -> InterpreterLibraryStaticContents <$> get bh + _ -> panic "Binary InterpreterLibraryContents: invalid byte" + put_ bh (InterpreterLibrarySharedContents contents) = do + putByte bh 0 + put_ bh contents + put_ bh (InterpreterLibraryStaticContents contents) = do + putByte bh 1 + put_ bh contents + +instance Binary OnDiskModuleByteCode where + get bh = do + odgbc_hash <- get bh + odgbc_module <- get bh + odgbc_compiled_byte_code <- get bh + odgbc_foreign <- get bh + pure OnDiskModuleByteCode {..} + + put_ bh OnDiskModuleByteCode {..} = do + put_ bh odgbc_hash + put_ bh odgbc_module + put_ bh odgbc_compiled_byte_code + put_ bh odgbc_foreign + +instance Binary OnDiskBytecodeLib where + get bh = do + bytecodeLibUnitId <- get bh + bytecodeLibFiles <- get bh + bytecodeLibForeign <- get bh + pure BytecodeLib {..} + + put_ bh BytecodeLib {..} = do + put_ bh bytecodeLibUnitId + put_ bh bytecodeLibFiles + put_ bh bytecodeLibForeign + +instance Binary CompiledByteCode where + get bh = do + bc_bcos <- get bh + bc_itbls_len <- get bh + bc_itbls <- replicateM bc_itbls_len $ do + nm <- getViaBinName bh + itbl <- get bh + pure (nm, itbl) + bc_strs_len <- get bh + bc_strs <- + replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh + bc_breaks <- get bh + bc_spt_entries <- get bh + return $ + CompiledByteCode + { bc_bcos, + bc_itbls, + bc_strs, + bc_breaks, + bc_spt_entries + } + + put_ bh CompiledByteCode {..} = do + put_ bh bc_bcos + put_ bh $ length bc_itbls + for_ bc_itbls $ \(nm, itbl) -> do + putViaBinName bh nm + put_ bh itbl + put_ bh $ length bc_strs + for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str + put_ bh bc_breaks + put_ bh bc_spt_entries + +instance Binary UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaBinName bh + <*> get bh + <*> (Binary.decode <$> get bh) + <*> (Binary.decode <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaBinName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ Binary.encode unlinkedBCOInstrs + put_ bh $ Binary.encode unlinkedBCOBitmap + put_ bh unlinkedBCOLits + put_ bh unlinkedBCOPtrs + +instance Binary BCOPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCOPtrName <$> getViaBinName bh + 1 -> BCOPtrPrimOp <$> get bh + 2 -> BCOPtrBCO <$> get bh + 3 -> BCOPtrBreakArray <$> get bh + _ -> panic "Binary BCOPtr: invalid byte" + + put_ bh ptr = case ptr of + BCOPtrName nm -> putByte bh 0 *> putViaBinName bh nm + BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op + BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco + BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod + +instance Binary BCONPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64) + 1 -> BCONPtrLbl <$> get bh + 2 -> BCONPtrItbl <$> getViaBinName bh + 3 -> BCONPtrAddr <$> getViaBinName bh + 4 -> BCONPtrStr <$> get bh + 5 -> BCONPtrFS <$> get bh + 6 -> BCONPtrFFIInfo <$> get bh + 7 -> BCONPtrCostCentre <$> get bh + _ -> panic "Binary BCONPtr: invalid byte" + + put_ bh ptr = case ptr of + BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64) + BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym + BCONPtrItbl nm -> putByte bh 2 *> putViaBinName bh nm + BCONPtrAddr nm -> putByte bh 3 *> putViaBinName bh nm + BCONPtrStr str -> putByte bh 4 *> put_ bh str + BCONPtrFS fs -> putByte bh 5 *> put_ bh fs + BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi + BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi + +newtype BinName = BinName {unBinName :: Name} + +getViaBinName :: ReadBinHandle -> IO Name +getViaBinName bh = case findUserDataReader Proxy bh of + BinaryReader f -> unBinName <$> f bh + +putViaBinName :: WriteBinHandle -> Name -> IO () +putViaBinName bh nm = case findUserDataWriter Proxy bh of + BinaryWriter f -> f bh $ BinName nm + +-- | NameEnv for serialising Names in 'CompiledByteCode'. +-- +-- See Note [Serializing Names in bytecode] + +data BytecodeNameEnv = ByteCodeNameEnv { _bytecode_next_id :: !Word64 + , _bytecode_name_subst :: NameEnv Word64 + } + +addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle +addBinNameWriter bh' = do + env_ref <- newIORef (ByteCodeNameEnv 0 emptyNameEnv) + evaluate + $ flip addWriterToUserData bh' + $ BinaryWriter + $ \bh (BinName nm) -> + if + | isExternalName nm -> do + putByte bh 0 + put_ bh nm + | otherwise -> do + putByte bh 1 + key <- getBinNameKey env_ref nm + -- Delimit the OccName from the deterministic counter to keep the + -- encoding injective, avoiding collisions like "foo1" vs "foo#1". + put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key)) + where + -- Find a deterministic key for local names. This + getBinNameKey ref name = do + atomicModifyIORef ref (\b@(ByteCodeNameEnv next subst) -> + case lookupNameEnv subst name of + Just idx -> (b, idx) + Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next)) + +addBinNameReader :: NameCache -> ReadBinHandle -> IO ReadBinHandle +addBinNameReader nc bh' = do + env_ref <- newIORef emptyOccEnv + pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do + t <- getByte bh + case t of + 0 -> do + nm <- get bh + pure $ BinName nm + 1 -> do + occ <- mkVarOccFS <$> get bh + -- We don't want to get a new unique from the NameCache each time we + -- see a name. + nm' <- unsafeInterleaveIO $ do + u <- takeUniqFromNameCache nc + evaluate $ mkInternalName u occ noSrcSpan + fmap BinName $ atomicModifyIORef' env_ref $ \env -> + case lookupOccEnv env occ of + Just nm -> (env, nm) + _ -> nm' `seq` (extendOccEnv env occ nm', nm') + _ -> panic "Binary BinName: invalid byte" + +-- Note [Serializing Names in bytecode] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The bytecode related types contain various Names which we need to +-- serialize. Unfortunately, we can't directly use the Binary instance +-- of Name: it is only meant to be used for serializing external Names +-- in BinIface logic, but bytecode does contain internal Names. +-- +-- We also need to maintain the invariant that: any pair of internal +-- Names with equal/different uniques must also be deserialized to +-- have the same equality. Therefore when we write the names to the interface, we +-- use an incrementing counter to give each local name it's own unique number. A substitution +-- is maintained to give each occurence of the Name the same unique key. When the interface +-- is read, a reverse mapping is used from these unique keys to a Name. +-- ===================================== compiler/GHC/ByteCode/Recomp/Binary.hs ===================================== @@ -0,0 +1,34 @@ +module GHC.ByteCode.Recomp.Binary ( + -- * Fingerprinting ByteCode objects + computeFingerprint, +) where + +import GHC.Prelude + +import GHC.ByteCode.Binary (addBinNameWriter) +import GHC.Iface.Binary +import GHC.Iface.Recomp.Binary (putNameLiterally, fingerprintBinMem) +import GHC.Types.Name +import GHC.Utils.Fingerprint +import GHC.Utils.Binary + +import System.IO.Unsafe + +-- | Create a 'Fingerprint' using the appropriate serializers +-- for 'ModuleByteCode'. +-- +computeFingerprint :: (Binary a) + => (WriteBinHandle -> Name -> IO ()) + -> a + -> Fingerprint +computeFingerprint put_nonbinding_name a = unsafePerformIO $ do + bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block + bh' <- addBinNameWriter bh + putWithUserData QuietBinIFace NormalCompression bh' a + fingerprintBinMem bh' + where + set_user_data bh = setWriterUserData bh $ mkWriterUserData + [ mkSomeBinaryWriter $ mkWriter put_nonbinding_name + , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally + , mkSomeBinaryWriter $ mkWriter putFS + ] ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -2,11 +2,11 @@ {-# LANGUAGE RecordWildCards #-} -- Orphans are here since the Binary instances use an ad-hoc means of serialising -- names which we don't want to pollute the rest of the codebase with. -{-# OPTIONS_GHC -Wno-orphans #-} {- | This module implements the serialization of bytecode objects to and from disk. -} module GHC.ByteCode.Serialize - ( writeBinByteCode, readBinByteCode, ModuleByteCode(..) + ( writeBinByteCode, readBinByteCode + , ModuleByteCode(..) , BytecodeLibX(..) , BytecodeLib , OnDiskBytecodeLib @@ -14,41 +14,34 @@ module GHC.ByteCode.Serialize , InterpreterLibraryContents(..) , writeBytecodeLib , readBytecodeLib + , mkModuleByteCode + , fingerprintModuleByteCodeContents , decodeOnDiskModuleByteCode , decodeOnDiskBytecodeLib ) where -import Control.Monad -import Data.Binary qualified as Binary -import Data.Foldable -import Data.IORef -import Data.Proxy -import Data.Word +import GHC.Prelude + +import GHC.ByteCode.Binary import GHC.ByteCode.Types -import GHC.Data.FastString +import GHC.ByteCode.Recomp.Binary (computeFingerprint) +import Data.ByteString (ByteString) import GHC.Driver.Env +import GHC.Driver.DynFlags import GHC.Iface.Binary -import GHC.Prelude -import GHC.Types.Name -import GHC.Types.Name.Cache -import GHC.Types.SrcLoc +import GHC.Iface.Recomp.Binary (putNameLiterally) +import GHC.Linker.Types +import GHC.Unit.Types import GHC.Utils.Binary -import GHC.Utils.Exception -import GHC.Utils.Panic import GHC.Utils.TmpFs -import System.FilePath -import GHC.Unit.Types -import GHC.Driver.DynFlags -import System.Directory -import Data.ByteString (ByteString) +import GHC.Utils.Logger +import GHC.Utils.Fingerprint (Fingerprint) + import qualified Data.ByteString as BS import Data.Traversable -import GHC.Utils.Logger -import GHC.Linker.Types -import System.IO.Unsafe (unsafeInterleaveIO) -import GHC.Utils.Outputable -import GHC.Types.Name.Env +import System.Directory +import System.FilePath {- Note [Overview of persistent bytecode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -88,74 +81,6 @@ See Note [Recompilation avoidance with bytecode objects] -} --- | The on-disk representation of a bytecode object for a specific module. --- --- This is the representation which we serialise and write to disk. --- The difference from 'ModuleByteCode' is that the contents of the object files --- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to --- temporary files. -data OnDiskModuleByteCode = OnDiskModuleByteCode { odgbc_module :: Module - , odgbc_compiled_byte_code :: CompiledByteCode - , odgbc_foreign :: [ByteString] -- ^ Contents of object files - } - -type OnDiskBytecodeLib = BytecodeLibX (Maybe InterpreterLibraryContents) - -instance Outputable a => Outputable (BytecodeLibX a) where - ppr (BytecodeLib {..}) = vcat [ - (text "BytecodeLib" <+> ppr bytecodeLibUnitId), - (text "Files" <+> ppr bytecodeLibFiles), - (text "Foreign" <+> ppr bytecodeLibForeign) ] - -type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary) - --- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs -data BytecodeLibX a = BytecodeLib { - bytecodeLibUnitId :: UnitId, - bytecodeLibFiles :: [CompiledByteCode], - bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI) -} - -data InterpreterLibrary = InterpreterSharedObject { getSharedObjectFilePath :: FilePath, getSharedObjectDir :: FilePath, getSharedObjectLibName :: String } - | InterpreterStaticObjects { getStaticObjects :: [FilePath] } - - -instance Outputable InterpreterLibrary where - ppr (InterpreterSharedObject path dir name) = text "SharedObject" <+> text path <+> text dir <+> text name - ppr (InterpreterStaticObjects paths) = text "StaticObjects" <+> text (show paths) - - -data InterpreterLibraryContents = InterpreterLibrarySharedContents { interpreterLibraryContents :: ByteString } - | InterpreterLibraryStaticContents { interpreterLibraryStaticContents :: [ByteString] } - -instance Binary InterpreterLibraryContents where - get bh = do - t <- getByte bh - case t of - 0 -> InterpreterLibrarySharedContents <$> get bh - 1 -> InterpreterLibraryStaticContents <$> get bh - _ -> panic "Binary InterpreterLibraryContents: invalid byte" - put_ bh (InterpreterLibrarySharedContents contents) = do - putByte bh 0 - put_ bh contents - put_ bh (InterpreterLibraryStaticContents contents) = do - putByte bh 1 - put_ bh contents - -instance Binary OnDiskBytecodeLib where - get bh = do - bytecodeLibUnitId <- get bh - bytecodeLibFiles <- get bh - bytecodeLibForeign <- get bh - pure BytecodeLib {..} - - put_ bh BytecodeLib {..} = do - put_ bh bytecodeLibUnitId - put_ bh bytecodeLibFiles - put_ bh bytecodeLibForeign - - - writeBytecodeLib :: BytecodeLib -> FilePath -> IO () writeBytecodeLib lib path = do odbco <- encodeBytecodeLib lib @@ -168,22 +93,10 @@ writeBytecodeLib lib path = do readBytecodeLib :: HscEnv -> FilePath -> IO OnDiskBytecodeLib readBytecodeLib hsc_env path = do bh' <- readBinMem path - bh <- addBinNameReader hsc_env bh' + bh <- addBinNameReader (hsc_NC hsc_env) bh' res <- getWithUserData (hsc_NC hsc_env) bh pure res -instance Binary OnDiskModuleByteCode where - get bh = do - odgbc_module <- get bh - odgbc_compiled_byte_code <- get bh - odgbc_foreign <- get bh - pure OnDiskModuleByteCode {..} - - put_ bh OnDiskModuleByteCode {..} = do - put_ bh odgbc_module - put_ bh odgbc_compiled_byte_code - put_ bh odgbc_foreign - -- | 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. @@ -198,7 +111,8 @@ decodeOnDiskModuleByteCode hsc_env odbco = do pure $ ModuleByteCode { gbc_module = odgbc_module odbco, gbc_compiled_byte_code = odgbc_compiled_byte_code odbco, - gbc_foreign_files = foreign_files + gbc_foreign_files = foreign_files, + gbc_hash = odgbc_hash odbco } decodeOnDiskBytecodeLib :: HscEnv -> OnDiskBytecodeLib -> IO BytecodeLib @@ -257,7 +171,8 @@ encodeOnDiskModuleByteCode bco = do pure $ OnDiskModuleByteCode { odgbc_module = gbc_module bco, odgbc_compiled_byte_code = gbc_compiled_byte_code bco, - odgbc_foreign = foreign_contents + odgbc_foreign = foreign_contents, + odgbc_hash = gbc_hash bco } -- | Read a 'ModuleByteCode' from a file. @@ -269,7 +184,7 @@ readBinByteCode hsc_env f = do readOnDiskModuleByteCode :: HscEnv -> FilePath -> IO OnDiskModuleByteCode readOnDiskModuleByteCode hsc_env f = do bh' <- readBinMem f - bh <- addBinNameReader hsc_env bh' + bh <- addBinNameReader (hsc_NC hsc_env) bh' getWithUserData (hsc_NC hsc_env) bh -- | Write a 'ModuleByteCode' to a file. @@ -282,169 +197,12 @@ writeBinByteCode f cbc = do putWithUserData QuietBinIFace NormalCompression bh odbco writeBinMem bh f -instance Binary CompiledByteCode where - get bh = do - bc_bcos <- get bh - bc_itbls_len <- get bh - bc_itbls <- replicateM bc_itbls_len $ do - nm <- getViaBinName bh - itbl <- get bh - pure (nm, itbl) - bc_strs_len <- get bh - bc_strs <- - replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh - bc_breaks <- get bh - bc_spt_entries <- get bh - return $ - CompiledByteCode - { bc_bcos, - bc_itbls, - bc_strs, - bc_breaks, - bc_spt_entries - } - - put_ bh CompiledByteCode {..} = do - put_ bh bc_bcos - put_ bh $ length bc_itbls - for_ bc_itbls $ \(nm, itbl) -> do - putViaBinName bh nm - put_ bh itbl - put_ bh $ length bc_strs - for_ bc_strs $ \(nm, str) -> putViaBinName bh nm *> put_ bh str - put_ bh bc_breaks - put_ bh bc_spt_entries - -instance Binary UnlinkedBCO where - get bh = - UnlinkedBCO - <$> getViaBinName bh - <*> get bh - <*> (Binary.decode <$> get bh) - <*> (Binary.decode <$> get bh) - <*> get bh - <*> get bh - - put_ bh UnlinkedBCO {..} = do - putViaBinName bh unlinkedBCOName - put_ bh unlinkedBCOArity - put_ bh $ Binary.encode unlinkedBCOInstrs - put_ bh $ Binary.encode unlinkedBCOBitmap - put_ bh unlinkedBCOLits - put_ bh unlinkedBCOPtrs +mkModuleByteCode :: Module -> CompiledByteCode -> [FilePath] -> IO ModuleByteCode +mkModuleByteCode modl cbc foreign_files = do + !bcos_hash <- fingerprintModuleByteCodeContents modl cbc foreign_files + return $! ModuleByteCode modl cbc foreign_files bcos_hash -instance Binary BCOPtr where - get bh = do - t <- getByte bh - case t of - 0 -> BCOPtrName <$> getViaBinName bh - 1 -> BCOPtrPrimOp <$> get bh - 2 -> BCOPtrBCO <$> get bh - 3 -> BCOPtrBreakArray <$> get bh - _ -> panic "Binary BCOPtr: invalid byte" - - put_ bh ptr = case ptr of - BCOPtrName nm -> putByte bh 0 *> putViaBinName bh nm - BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op - BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco - BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod - -instance Binary BCONPtr where - get bh = do - t <- getByte bh - case t of - 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64) - 1 -> BCONPtrLbl <$> get bh - 2 -> BCONPtrItbl <$> getViaBinName bh - 3 -> BCONPtrAddr <$> getViaBinName bh - 4 -> BCONPtrStr <$> get bh - 5 -> BCONPtrFS <$> get bh - 6 -> BCONPtrFFIInfo <$> get bh - 7 -> BCONPtrCostCentre <$> get bh - _ -> panic "Binary BCONPtr: invalid byte" - - put_ bh ptr = case ptr of - BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64) - BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym - BCONPtrItbl nm -> putByte bh 2 *> putViaBinName bh nm - BCONPtrAddr nm -> putByte bh 3 *> putViaBinName bh nm - BCONPtrStr str -> putByte bh 4 *> put_ bh str - BCONPtrFS fs -> putByte bh 5 *> put_ bh fs - BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi - BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi - -newtype BinName = BinName {unBinName :: Name} - -getViaBinName :: ReadBinHandle -> IO Name -getViaBinName bh = case findUserDataReader Proxy bh of - BinaryReader f -> unBinName <$> f bh - -putViaBinName :: WriteBinHandle -> Name -> IO () -putViaBinName bh nm = case findUserDataWriter Proxy bh of - BinaryWriter f -> f bh $ BinName nm - -data BytecodeNameEnv = ByteCodeNameEnv { _bytecode_next_id :: !Word64 - , _bytecode_name_subst :: NameEnv Word64 - } - -addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle -addBinNameWriter bh' = do - env_ref <- newIORef (ByteCodeNameEnv 0 emptyNameEnv) - evaluate - $ flip addWriterToUserData bh' - $ BinaryWriter - $ \bh (BinName nm) -> - if - | isExternalName nm -> do - putByte bh 0 - put_ bh nm - | otherwise -> do - putByte bh 1 - key <- getBinNameKey env_ref nm - -- Delimit the OccName from the deterministic counter to keep the - -- encoding injective, avoiding collisions like "foo1" vs "foo#1". - put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key)) - where - -- Find a deterministic key for local names. This - getBinNameKey ref name = do - atomicModifyIORef ref (\b@(ByteCodeNameEnv next subst) -> - case lookupNameEnv subst name of - Just idx -> (b, idx) - Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next)) - -addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle -addBinNameReader HscEnv {..} bh' = do - env_ref <- newIORef emptyOccEnv - pure $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do - t <- getByte bh - case t of - 0 -> do - nm <- get bh - pure $ BinName nm - 1 -> do - occ <- mkVarOccFS <$> get bh - -- 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) - _ -> nm' `seq` (extendOccEnv env occ nm', nm') - _ -> panic "Binary BinName: invalid byte" - --- Note [Serializing Names in bytecode] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The bytecode related types contain various Names which we need to --- serialize. Unfortunately, we can't directly use the Binary instance --- of Name: it is only meant to be used for serializing external Names --- in BinIface logic, but bytecode does contain internal Names. --- --- We also need to maintain the invariant that: any pair of internal --- Names with equal/different uniques must also be deserialized to --- have the same equality. Therefore when we write the names to the interface, we --- use an incrementing counter to give each local name it's own unique number. A substitution --- is maintained to give each occurence of the Name the same unique key. When the interface --- is read, a reverse mapping is used from these unique keys to a Name. --- +fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> IO Fingerprint +fingerprintModuleByteCodeContents modl cbc foreign_files = do + foreign_contents <- readObjectFiles foreign_files + pure $ computeFingerprint putNameLiterally (modl, cbc, foreign_contents) ===================================== compiler/GHC/Driver/Hooks.hs ===================================== @@ -137,7 +137,7 @@ data Hooks = Hooks , tcForeignExportsHook :: !(Maybe ([LForeignDecl GhcRn] -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))) , hscFrontendHook :: !(Maybe (ModSummary -> Hsc FrontendResult)) - , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded))) + , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded))) , ghcPrimIfaceHook :: !(Maybe ModIface) , runPhaseHook :: !(Maybe PhaseHook) , runMetaHook :: !(Maybe (MetaHook TcM)) @@ -145,7 +145,7 @@ data Hooks = Hooks -> HomePackageTable -> IO SuccessFlag)) , runRnSpliceHook :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn))) , getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type - -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))) + -> IO (Either Type (HValue, [LinkableUsage], PkgsLoaded)))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) , stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos)) ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -301,8 +301,7 @@ import GHC.Cmm.Config (CmmConfig) import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable - -import GHC.ByteCode.Serialize +import qualified GHC.ByteCode.Serialize as ByteCode {- ********************************************************************** %* * @@ -866,7 +865,7 @@ hscRecompStatus | otherwise -> do -- Check the status of all the linkable types we might need. -- 1. The in-memory linkable we had at hand. - bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeMod_bytecode old_linkable) + bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeModLinkableByteCode old_linkable) -- 2. The bytecode object file bc_obj_linkable <- checkByteCodeFromObject hsc_env mod_summary -- 3. Bytecode from an interface's whole core bindings. @@ -1013,7 +1012,7 @@ checkByteCodeFromObject hsc_env mod_sum = do -- Don't force this if we reuse the linkable already loaded into memory, but we have to check -- that the one we have on disk would be suitable as well. linkable <- unsafeInterleaveIO $ do - bco <- readBinByteCode hsc_env obj_fn + bco <- ByteCode.readBinByteCode hsc_env obj_fn return $ mkModuleByteCodeLinkable obj_date bco return $ UpToDateItem linkable _ -> return $ outOfDateItemBecause MissingBytecode Nothing @@ -1098,7 +1097,7 @@ loadIfaceByteCodeLazy :: ModIface -> ModLocation -> TypeEnv -> - IO (Maybe Linkable) + IO (Maybe (LinkableWith ModuleByteCode)) loadIfaceByteCodeLazy hsc_env iface location type_env = case iface_core_bindings iface location of Nothing -> return Nothing @@ -1106,8 +1105,9 @@ loadIfaceByteCodeLazy hsc_env iface location type_env = Just <$> compile wcb where compile decls = do - bco <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls - linkable $ NE.singleton (DotGBC bco) + bco <- unsafeInterleaveIO $ do + compileWholeCoreBindings hsc_env type_env decls + linkable bco linkable parts = do if_time <- modificationTimeIfExists (ml_hi_file_ospath location) @@ -1148,14 +1148,14 @@ initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do where type_env = md_types details - go :: RecompBytecodeLinkable -> IO (Maybe Linkable) + 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 $ - compileWholeCoreBindings hsc_env type_env wcb - pure $ NE.singleton (DotGBC bco) + bco <- unsafeInterleaveIO $ do + compileWholeCoreBindings hsc_env type_env wcb + pure bco -- | Hydrate interface Core bindings and compile them to bytecode. -- @@ -2217,7 +2217,7 @@ generateAndWriteByteCode hsc_env cgguts mod_location = do -- See Note [-fwrite-byte-code is not the default] when (gopt Opt_WriteByteCode dflags) $ do let bc_path = ml_bytecode_file mod_location - writeBinByteCode bc_path comp_bc + ByteCode.writeBinByteCode bc_path comp_bc return comp_bc {- @@ -2232,20 +2232,20 @@ make user's opt into writing the files. -} -- | Generate a 'ModuleByteCode' and write it to disk if `-fwrite-byte-code` is enabled. -generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO Linkable +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 $ mkModuleByteCodeLinkable bco_time bco_object + return $ mkOnlyModuleByteCodeLinkable bco_time bco_object mkModuleByteCode :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ModuleByteCode mkModuleByteCode hsc_env mod mod_location cgguts = do bcos <- hscGenerateByteCode hsc_env cgguts mod_location objs <- outputAndCompileForeign hsc_env mod mod_location (cgi_foreign_files cgguts) (cgi_foreign cgguts) - return $! ModuleByteCode mod bcos objs + ByteCode.mkModuleByteCode mod bcos objs -- | Generate a fresh 'ModuleByteCode' for a given module but do not write it to disk. generateFreshByteCodeLinkable :: HscEnv @@ -2767,13 +2767,13 @@ hscTidy hsc_env guts = do %* * %********************************************************************* -} -hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded) hscCompileCoreExpr hsc_env loc expr = case hscCompileCoreExprHook (hsc_hooks hsc_env) of Nothing -> hscCompileCoreExpr' hsc_env loc expr Just h -> h hsc_env loc expr -hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded) hscCompileCoreExpr' hsc_env srcspan ds_expr = do {- Simplify it -} -- Question: should we call SimpleOpt.simpleOptExpr here instead? @@ -2859,8 +2859,9 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do {- 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 (ModuleByteCode this_mod bcos []) + Linkable bco_time this_mod $ NE.singleton (DotGBC 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 -} @@ -2876,7 +2877,7 @@ jsCodeGen -> Module -> [(CgStgTopBinding,IdSet)] -> Id - -> IO (ForeignHValue, [Linkable], PkgsLoaded) + -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded) jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do let logger = hsc_logger hsc_env tmpfs = hsc_tmpfs hsc_env ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -430,7 +430,7 @@ link' hsc_env batch_attempt_linking mHscMessager hpt let obj_files = concatMap linkableObjs linkables in action obj_files linkBytecodeLinkable action = - checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeMod_bytecode $ \linkables -> + checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeModLinkableByteCode $ \linkables -> let bytecode = concatMap linkableModuleByteCodes linkables in action bytecode ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -342,7 +342,7 @@ data Plugins = Plugins -- The purpose of this field is to cache the plugins so they -- don't have to be loaded each time they are needed. See -- 'GHC.Runtime.Loader.initializePlugins'. - , loadedPluginDeps :: !([Linkable], PkgsLoaded) + , loadedPluginDeps :: !([LinkableUsage], PkgsLoaded) -- ^ The object files required by the loaded plugins -- See Note [Plugin dependencies] } ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -7,8 +7,6 @@ module GHC.HsToCore.Usage ( import GHC.Prelude -import GHC.Driver.Env - import GHC.Tc.Types import GHC.Iface.Load @@ -27,7 +25,6 @@ import GHC.Types.Unique.Set import GHC.Unit import GHC.Unit.Env -import GHC.Unit.External import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps @@ -35,18 +32,17 @@ import GHC.Unit.Module.Deps import GHC.Data.Maybe import GHC.Data.FastString -import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.List.NonEmpty as NE import GHC.Linker.Types import GHC.Unit.Finder import GHC.Types.Unique.DFM import GHC.Driver.Plugins import qualified GHC.Unit.Home.Graph as HUG +import qualified Data.List.NonEmpty as NE {- Note [Module self-dependency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -75,19 +71,17 @@ data UsageConfig = UsageConfig mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> [ImportUserSpec] -> NameSet - -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded + -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [LinkableUsage] -> PkgsLoaded -> IfG [Usage] mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods imp_decls used_names dependent_files dependent_dirs merged needed_links needed_pkgs = do - eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env)) file_hashes <- liftIO $ mapM getFileHash dependent_files dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs let hu = ue_unsafeHomeUnit unit_env - hug = ue_home_unit_graph unit_env -- Dependencies on object files due to TH and plugins - object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs + object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env) mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod dir_imp_mods imp_decls used_names @@ -176,44 +170,39 @@ For bytecode objects there are also two forms of dependencies. 1. The existence of the .gbc file for the module you are currently compiling. 2. The usage of bytecode to evaluate TH splices (similar to Note [Object File Dependencies]) -In situation (2), we would ideally want to record the hash of the `CompiledByteCode` which -was used when evaluating the TH splice. This was a bit tricky to implement so it's tracked as a future -improvement to the recompilation checking for bytecode objects. - -For now, the interface hash is used as a proxy to determine if the BCO will have changed -for a module or not. This is similar to how the recompilation checking for the legacy -`-fwrite-if-simplified-core` code path which generated bytecode from core bindings used to work. - +In both cases, we record the hash of the 'CompiledByteCode' which was used when evaluating +the TH splice. -} -- | Find object files corresponding to the transitive closure of given home -- modules and direct object files for pkg dependencies -mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage] -mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do +mkObjectUsage :: Plugins -> FinderCache -> [LinkableUsage] -> PkgsLoaded -> IO [Usage] +mkObjectUsage plugins fc th_links_needed th_pkgs_needed = do let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed) ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds) where - linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls) + linkableToUsage (Linkable _ _m parts) = traverse partToUsage (NE.toList parts) msg m = moduleNameString (moduleName m) ++ "[TH] changed" - fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg + partToUsage link_usage = + case link_usage of + FileLinkablePartUsage{flu_file, flu_module} -> do + fing (Just $ msg flu_module) flu_file - partToUsage m part = - case linkablePartPath part of - Just fn -> fing (Just (msg m)) fn - Nothing -> do - -- This should only happen for home package things but oneshot puts - -- home package ifaces in the PIT. - miface <- lookupIfaceByModule hug pit m - case miface of - Nothing -> pprPanic "linkableToUsage" (ppr m) - Just iface -> - return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash iface) + ByteCodeLinkablePartUsage{bclu_module, bclu_hash} -> + pure $ + UsageHomeModuleBytecode + { usg_mod_name = moduleName bclu_module + , usg_unit_id = toUnitId $ moduleUnit bclu_module + , usg_bytecode_hash = bclu_hash + } + + fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg librarySpecToUsage :: LibrarySpec -> IO [Usage] librarySpecToUsage (Objects os) = traverse (fing Nothing) os ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -88,6 +88,10 @@ import GHC.Iface.Errors.Ppr import Data.Functor import Data.Bifunctor (first) import GHC.Types.PkgQual +import GHC.ByteCode.Serialize (ModuleByteCode, gbc_hash) +import GHC.Unit.Home.Graph (lookupHugByModule) +import GHC.Unit.Home.ModInfo (HomeModLinkable(..), HomeModInfo (..)) +import GHC.Linker.Types (linkableParts) {- ----------------------------------------------- @@ -190,6 +194,7 @@ data RecompReason | ModuleAdded (ImportLevel, UnitId, ModuleName) | ModuleChangedRaw ModuleName | ModuleChangedIface ModuleName + | ModuleChangedBytecode ModuleName | FileChanged FilePath | DirChanged FilePath | CustomReason String @@ -225,6 +230,7 @@ instance Outputable RecompReason where ModuleChanged m -> ppr m <+> text "changed" ModuleChangedRaw m -> ppr m <+> text "changed (raw)" ModuleChangedIface m -> ppr m <+> text "changed (interface)" + ModuleChangedBytecode m -> ppr m <+> text "changed (bytecode)" ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed" ModuleAdded (_st, _uid, m) -> ppr m <+> text "added" FileChanged fp -> text fp <+> text "changed" @@ -718,6 +724,15 @@ needInterface mod continue Nothing -> return $ NeedsRecompile MustCompile Just iface -> liftIO $ continue iface +needBytecode :: Module -> (ModuleByteCode -> IO RecompileRequired) + -> IfG RecompileRequired +needBytecode mod continue + = do + mb_recomp <- tryGetBytecode mod + case mb_recomp of + Nothing -> return $ NeedsRecompile MustCompile + Just mbc -> liftIO $ continue mbc + tryGetModIface :: String -> Module -> IfG (Maybe ModIface) tryGetModIface doc_msg mod = do -- Load the imported interface if possible @@ -739,6 +754,27 @@ tryGetModIface doc_msg mod -- import and it's been deleted Succeeded iface -> pure $ Just iface +tryGetBytecode :: Module -> IfG (Maybe ModuleByteCode) +tryGetBytecode mod + = do -- Load the imported bytecode if possible + logger <- getLogger + liftIO $ trace_hi_diffs logger (text "Checking bytecode hash for module" <+> ppr mod <+> ppr (moduleUnit mod)) + + mb_module_bytecode <- do + env <- getTopEnv + liftIO (lookupHugByModule mod (hsc_HUG env)) >>= \ case + Nothing -> pure Nothing + Just hmi -> + case homeMod_bytecode (hm_linkable hmi) of + Nothing -> pure Nothing + Just gbc_linkable -> pure $ Just $ linkableParts gbc_linkable + + case mb_module_bytecode of + Nothing -> do + liftIO $ trace_hi_diffs logger (sep [text "Couldn't find bytecode for module", ppr mod]) + return Nothing + Just module_bytecode -> pure $ Just module_bytecode + -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. @@ -760,14 +796,14 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha needInterface mod $ \iface -> do let reason = ModuleChangedRaw (moduleName mod) checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) -checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name +checkModUsage _ UsageHomeModuleBytecode{ usg_mod_name = mod_name , usg_unit_id = uid - , usg_iface_hash = old_mod_hash } = do + , usg_bytecode_hash = old_bytecode_hash } = do let mod = mkModule (RealUnit (Definite uid)) mod_name logger <- getLogger - needInterface mod $ \iface -> do - let reason = ModuleChangedIface mod_name - checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash iface) + needBytecode mod $ \cbc -> do + let reason = ModuleChangedBytecode mod_name + checkBytecodeFingerprint logger reason old_bytecode_hash (gbc_hash cbc) checkModUsage _ UsageHomeModule{ usg_mod_name = mod_name, @@ -1032,19 +1068,18 @@ checkModuleFingerprint logger reason old_mod_hash new_mod_hash = out_of_date_hash logger reason (text " Module fingerprint has changed") old_mod_hash new_mod_hash -checkIfaceFingerprint +checkBytecodeFingerprint :: Logger -> RecompReason -> Fingerprint -> Fingerprint -> IO RecompileRequired -checkIfaceFingerprint logger reason old_mod_hash new_mod_hash - | new_mod_hash == old_mod_hash - = up_to_date logger (text "Iface fingerprint unchanged") - +checkBytecodeFingerprint logger reason old_bytecode_hash new_bytecode_hash + | old_bytecode_hash == new_bytecode_hash + = up_to_date logger (text "Bytecode fingerprint unchanged") | otherwise - = out_of_date_hash logger reason (text " Iface fingerprint has changed") - old_mod_hash new_mod_hash + = out_of_date_hash logger reason (text " Bytecode fingerprint has changed") + old_bytecode_hash new_bytecode_hash ------------------------ checkEntityUsage :: Logger ===================================== compiler/GHC/Iface/Recomp/Types.hs ===================================== @@ -146,10 +146,10 @@ pprUsage usage@UsageDirectory{} ppr (usg_dir_hash usage)] pprUsage usage@UsageMergedRequirement{} = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] -pprUsage usage@UsageHomeModuleInterface{} - = hsep [text "implementation", ppr (usg_mod_name usage) +pprUsage usage@UsageHomeModuleBytecode{} + = hsep [text "Bytecode", ppr (usg_mod_name usage) , ppr (usg_unit_id usage) - , ppr (usg_iface_hash usage)] + , ppr (usg_bytecode_hash usage)] pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc pprUsageImport mod hash safe @@ -157,4 +157,4 @@ pprUsageImport mod hash safe , ppr hash ] where pp_safe | safe = text "safe" - | otherwise = text " -/ " \ No newline at end of file + | otherwise = text " -/ " ===================================== compiler/GHC/Linker/ByteCode.hs ===================================== @@ -31,7 +31,7 @@ linkBytecodeLib hsc_env gbcs = do on_disk_bcos <- mapM (readBinByteCode hsc_env) bytecodeObjects - let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs <- on_disk_bcos ++ gbcs] + let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs _hash <- on_disk_bcos ++ gbcs] interpreter_foreign_lib <- mkInterpreterLib hsc_env (concat foreign_stubs ++ objectFiles) @@ -67,4 +67,4 @@ mkInterpreterLib hsc_env files = return $ Just (InterpreterSharedObject foreign_stub_lib_path foreign_stub_lib_dir foreign_stub_lib_name) Nothing -> pure Nothing False -> do - pure $ Just (InterpreterStaticObjects files) \ No newline at end of file + pure $ Just (InterpreterStaticObjects files) ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -63,7 +63,7 @@ data LinkDepsOpts = LinkDepsOpts data LinkDeps = LinkDeps { ldNeededLinkables :: [Linkable] - , ldAllLinkables :: [Linkable] + , ldAllLinkables :: [LinkableUsage] , ldUnits :: [UnitId] , ldNeededUnits :: UniqDSet UnitId } @@ -126,7 +126,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do return $ LinkDeps { ldNeededLinkables = lnks_needed - , ldAllLinkables = links_got ++ lnks_needed + , ldAllLinkables = links_got ++ mkLinkablesUsage lnks_needed , ldUnits = pkgs_needed , ldNeededUnits = pkgs_s } ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -228,7 +228,7 @@ lookupFromLoadedEnv interp name = do -- | Load the module containing the given Name and get its associated 'HValue'. -- -- Throws a 'ProgramError' if loading fails or the name cannot be found. -loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded) +loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded) loadName interp hsc_env name = do initLoaderState interp hsc_env modifyLoaderState interp $ \pls0 -> do @@ -258,7 +258,7 @@ loadDependencies -> LoaderState -> SrcSpan -> [Module] - -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required + -> IO (LoaderState, SuccessFlag, [LinkableUsage], PkgsLoaded) -- ^ returns the set of linkables required -- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do let opts = initLinkDepsOpts hsc_env @@ -645,7 +645,7 @@ initLinkDepsOpts hsc_env = opts dflags = hsc_dflags hsc_env ldLoadByteCode mod locn = do - bytecode_linkable <- findBytecodeLinkableMaybe hsc_env mod locn + bytecode_linkable <- findBytecodeLinkableMaybe hsc_env locn case bytecode_linkable of Nothing -> findWholeCoreBindings hsc_env mod Just bco -> return (Just bco) @@ -659,19 +659,14 @@ findWholeCoreBindings hsc_env mod = do sequence (lookupModuleEnv eps_iface_bytecode mod) -findBytecodeLinkableMaybe :: HscEnv -> Module -> ModLocation -> IO (Maybe Linkable) -findBytecodeLinkableMaybe hsc_env mod locn = 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 - -- Also load the interface, for reasons to do with recompilation avoidance. - -- See Note [Recompilation avoidance with bytecode objects] - _ <- initIfaceLoad hsc_env $ - loadInterface (text "get_reachable_nodes" <+> parens (ppr mod)) - mod ImportBySystem bco <- readBinByteCode hsc_env bytecode_fn return $ Just $ mkModuleByteCodeLinkable bytecode_time bco @@ -723,7 +718,7 @@ get_reachable_nodes hsc_env mods ********************************************************************* -} -- | Load the dependencies of a linkable, and then load the linkable itself. -loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([Linkable], PkgsLoaded) +loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([LinkableUsage], PkgsLoaded) loadDecls interp hsc_env span linkable = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env @@ -823,7 +818,7 @@ loadModuleLinkables interp hsc_env pls keep_spec linkables (objs, bcos) = partitionLinkables linkables -linkableInSet :: Linkable -> LinkableSet -> Bool +linkableInSet :: Linkable -> LinkableSet LinkableUsage -> Bool linkableInSet l objs_loaded = case lookupModuleEnv objs_loaded (linkableModule l) of Nothing -> False @@ -952,17 +947,17 @@ dynLoadObjs interp hsc_env pls objs = do then addWay WayProf else id -rmDupLinkables :: LinkableSet -- Already loaded - -> [Linkable] -- New linkables - -> (LinkableSet, -- New loaded set (including new ones) +rmDupLinkables :: LinkableSet LinkableUsage -- ^ Already loaded + -> [Linkable] -- ^ New linkables + -> (LinkableSet LinkableUsage, -- New loaded set (including new ones) [Linkable]) -- New linkables (excluding dups) rmDupLinkables already ls = go already [] ls where - go already extras [] = (already, extras) - go already extras (l:ls) + go !already extras [] = (already, extras) + go !already extras (l:ls) | linkableInSet l already = go already extras ls - | otherwise = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls + | otherwise = go (extendModuleEnv already (linkableModule l) $! mkLinkableUsage l) (l:extras) ls {- ********************************************************************** @@ -1115,7 +1110,7 @@ unload_wkr interp pls@LoaderState{..} = do -- If we unloaded any object files at all, we need to purge the cache -- of lookupSymbol results. - when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $ + when (not (null (filter (not . null . linkableUsageObjs) linkables_to_unload))) $ purgeLookupSymbolCache interp let !new_pls = pls { bco_loader_state = modifyHomePackageBytecodeState bco_loader_state $ \_ -> emptyBytecodeState, @@ -1125,7 +1120,7 @@ unload_wkr interp pls@LoaderState{..} = do return new_pls where - unloadObjs :: Linkable -> IO () + unloadObjs :: LinkableUsage -> IO () unloadObjs lnk | interpreterDynamic interp = return () -- We don't do any cleanup when linking objects with the @@ -1133,7 +1128,7 @@ unload_wkr interp pls@LoaderState{..} = do -- not much benefit. | otherwise - = mapM_ (unloadObj interp) (linkableObjs lnk) + = mapM_ (unloadObj interp) (linkableUsageObjs lnk) -- The components of a BCO linkable may contain -- dot-o files (generated from C stubs). -- ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -49,6 +49,7 @@ module GHC.Linker.Types , WholeCoreBindingsLinkable , LinkableWith(..) , mkModuleByteCodeLinkable + , mkOnlyModuleByteCodeLinkable , LinkablePart(..) , LinkableObjectSort (..) , linkableIsNativeCodeOnly @@ -67,6 +68,11 @@ module GHC.Linker.Types , linkableFilterNative , partitionLinkables + , LinkableUsage + , linkableUsageObjs + , mkLinkablesUsage + , mkLinkableUsage + , ModuleByteCode(..) ) where @@ -78,26 +84,29 @@ import GHCi.BreakArray import GHCi.RemoteTypes import GHCi.Message ( LoadedDLL ) +import qualified GHC.Data.OsPath as OsPath +import qualified GHC.Data.FlatBag as FlatBag +import GHC.Fingerprint (Fingerprint) import GHC.Stack.CCS import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, lookupNameEnv ) import GHC.Types.Name ( Name ) import GHC.Types.SptEntry +import GHC.Types.Unique.DSet +import GHC.Types.Unique.DFM +import GHC.Unit.Module.Deps (LinkablePartUsage (..), linkablePartUsageObjectPaths) +import GHC.Unit.Module.Env +import GHC.Unit.Module.WholeCoreBindings import GHC.Utils.Outputable +import Control.Applicative ((<|>)) import Control.Concurrent.MVar import Data.Array +import Data.Functor.Identity import Data.Time ( UTCTime ) -import GHC.Unit.Module.Env -import GHC.Types.Unique.DSet -import GHC.Types.Unique.DFM -import GHC.Unit.Module.WholeCoreBindings import Data.Maybe (mapMaybe) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NE -import Control.Applicative ((<|>)) -import Data.Functor.Identity - {- ********************************************************************** @@ -172,10 +181,10 @@ data LoaderState = LoaderState -- ^ Information about bytecode objects we have loaded into the -- interpreter. - , bcos_loaded :: !LinkableSet + , bcos_loaded :: !(LinkableSet LinkableUsage) -- ^ The currently loaded interpreted modules (home package) - , objs_loaded :: !LinkableSet + , objs_loaded :: !(LinkableSet LinkableUsage) -- ^ And the currently-loaded compiled modules (home package) , pkgs_loaded :: !PkgsLoaded @@ -384,15 +393,17 @@ type Linkable = LinkableWith (NonEmpty LinkablePart) type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings -type LinkableSet = ModuleEnv Linkable +type LinkableUsage = LinkableWith (NonEmpty LinkablePartUsage) -mkLinkableSet :: [Linkable] -> LinkableSet +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 -> LinkableSet -> LinkableSet +unionLinkableSet :: LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a) unionLinkableSet = plusModuleEnv_C go where go l1 l2 @@ -435,8 +446,9 @@ data LinkablePart | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | DotGBC ModuleByteCode - -- ^ A byte-code object, lives only in memory. + | DotGBC + -- ^ A byte-code object, lives only in memory. + ModuleByteCode -- | The in-memory representation of a bytecode object @@ -444,14 +456,19 @@ data LinkablePart data ModuleByteCode = ModuleByteCode { gbc_module :: Module , gbc_compiled_byte_code :: CompiledByteCode , gbc_foreign_files :: [FilePath] -- ^ Path to object files + , gbc_hash :: !Fingerprint } mkModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> Linkable -mkModuleByteCodeLinkable linkable_time bco = +mkModuleByteCodeLinkable linkable_time bco = do Linkable linkable_time (gbc_module bco) (pure (DotGBC bco)) +mkOnlyModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> LinkableWith ModuleByteCode +mkOnlyModuleByteCodeLinkable linkable_time bco = do + Linkable linkable_time (gbc_module bco) bco + instance Outputable ModuleByteCode where - ppr (ModuleByteCode mod _cbc _fos) = text "ModuleByteCode" <+> ppr mod + ppr (ModuleByteCode mod _cbc _fos _) = text "ModuleByteCode" <+> ppr mod instance Outputable LinkablePart where ppr (DotO path sort) = text "DotO" <+> text path <+> pprSort sort @@ -544,8 +561,8 @@ linkablePartObjectPaths = \case -- Contrary to linkableBCOs, this includes byte-code from LazyBCOs. linkablePartBCOs :: LinkablePart -> [CompiledByteCode] linkablePartBCOs = \case - DotGBC bco -> [gbc_compiled_byte_code bco] - _ -> [] + DotGBC bco -> [gbc_compiled_byte_code bco] + _ -> [] linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable linkableFilter f linkable = do @@ -586,6 +603,59 @@ partitionLinkables linkables = mapMaybe linkableFilterByteCode linkables ) +-- | Turn a 'Linkable' into a 'LinkableUsage'. +-- This stores much less information than 'Linkable' and allows us +-- to free the fields of the 'Linkable'. +-- +-- Each 'LinkablePartUsage' is fully evaluated to avoid retaining any reference +-- to the original 'LinkablePart'. +mkLinkableUsage :: Linkable -> LinkableUsage +mkLinkableUsage lnk = + let + linkablesWithUsage = NE.map (go (linkableModule lnk)) (linkableParts lnk) + lnkUsage = lnk + { linkableParts = + -- We force the elements intentionally to whnf. + -- + elemsToWhnf linkablesWithUsage `seq` linkablesWithUsage + } + in + linkableParts lnkUsage `seq` lnkUsage + where + -- Make sure 'LinkableUsagePart' is evaluated to whnf + elemsToWhnf :: NonEmpty a -> () + elemsToWhnf = foldr seq () + + + mkFileLinkablePartUsage m fp objs = + FileLinkablePartUsage + { flu_file = fp + , flu_module = m + , flu_linkable_objs = + FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ] + } + + mkByteCodeLinkablePartUsage m fp objs = + ByteCodeLinkablePartUsage + { bclu_module = m + , bclu_hash = fp + , bclu_linkable_objs = + FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ] + } + + go :: Module -> LinkablePart -> LinkablePartUsage + go m lnkPart = case lnkPart of + DotO fn _ -> mkFileLinkablePartUsage m fn (linkablePartObjectPaths lnkPart) + DotA fn -> mkFileLinkablePartUsage m fn (linkablePartObjectPaths lnkPart) + DotDLL fn -> mkFileLinkablePartUsage m fn (linkablePartObjectPaths lnkPart) + DotGBC mbc -> mkByteCodeLinkablePartUsage m (gbc_hash mbc) (linkablePartObjectPaths lnkPart) + +mkLinkablesUsage :: [Linkable] -> [LinkableUsage] +mkLinkablesUsage linkables = map mkLinkableUsage linkables + +linkableUsageObjs :: LinkableUsage -> [FilePath] +linkableUsageObjs lnkWithUsage = concatMap linkablePartUsageObjectPaths (linkableParts lnkWithUsage) + {- ********************************************************************** Loading packages ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -153,7 +153,7 @@ initializePlugins hsc_env ([] , _ ) -> False -- some external plugin added (p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss -loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded) +loadPlugins :: HscEnv -> IO ([LoadedPlugin], [LinkableUsage], PkgsLoaded) loadPlugins hsc_env = do { unless (null to_load) $ checkExternalInterpreter hsc_env @@ -173,7 +173,7 @@ loadPlugins hsc_env loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env -loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded) +loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [LinkableUsage], PkgsLoaded) loadFrontendPlugin hsc_env mod_name = do checkExternalInterpreter hsc_env (plugin, _iface, links, pkgs) @@ -188,7 +188,7 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of -> throwIO (InstallationError "Plugins require -fno-external-interpreter") _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded) +loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [LinkableUsage], PkgsLoaded) loadPlugin' occ_name plugin_name hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env @@ -266,7 +266,7 @@ forceLoadTyCon hsc_env con_name = do -- * If the Name does not exist in the module -- * If the link failed -getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded)) +getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [LinkableUsage], PkgsLoaded)) getValueSafely hsc_env val_name expected_type = do eith_hval <- case getValueSafelyHook hooks of Nothing -> getHValueSafely interp hsc_env val_name expected_type @@ -281,7 +281,7 @@ getValueSafely hsc_env val_name expected_type = do logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env -getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded)) +getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [LinkableUsage], PkgsLoaded)) getHValueSafely interp hsc_env val_name expected_type = do forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -562,7 +562,7 @@ data TcGblEnv -- is implicit rather than explicit, so we have to zap a -- mutable variable. - tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded), + tcg_th_needed_deps :: TcRef ([LinkableUsage], PkgsLoaded), -- ^ The set of runtime dependencies required by this module -- See Note [Object File Dependencies] ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -2259,7 +2259,7 @@ fillCoercionHole (CH { ch_ref = ref, ch_co_var = cv }) co recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } -recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM () +recordThNeededRuntimeDeps :: [LinkableUsage] -> PkgsLoaded -> TcM () recordThNeededRuntimeDeps new_links new_pkgs = do { env <- getGblEnv ; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) -> ===================================== compiler/GHC/Unit/Home/ModInfo.hs ===================================== @@ -3,9 +3,11 @@ module GHC.Unit.Home.ModInfo ( HomeModInfo (..) - , HomeModLinkable (..) , homeModInfoObject , homeModInfoByteCode + , HomeModLinkable (..) + , homeModLinkableByteCode + , homeModLinkableObject , emptyHomeModInfoLinkable ) where @@ -15,9 +17,10 @@ import GHC.Prelude import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails -import GHC.Linker.Types ( Linkable ) +import GHC.Linker.Types ( Linkable, LinkableWith, ModuleByteCode, LinkablePart (..) ) import GHC.Utils.Outputable +import qualified Data.List.NonEmpty as NE -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo @@ -48,18 +51,24 @@ data HomeModInfo = HomeModInfo } homeModInfoByteCode :: HomeModInfo -> Maybe Linkable -homeModInfoByteCode = homeMod_bytecode . hm_linkable +homeModInfoByteCode = homeModLinkableByteCode . hm_linkable homeModInfoObject :: HomeModInfo -> Maybe Linkable -homeModInfoObject = homeMod_object . hm_linkable +homeModInfoObject = homeModLinkableObject . hm_linkable emptyHomeModInfoLinkable :: HomeModLinkable emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing -- See Note [Home module build products] -data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable) +data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe (LinkableWith ModuleByteCode)) , homeMod_object :: !(Maybe Linkable) } +homeModLinkableByteCode :: HomeModLinkable -> Maybe Linkable +homeModLinkableByteCode = fmap (fmap (NE.singleton . DotGBC)) . homeMod_bytecode + +homeModLinkableObject :: HomeModLinkable -> Maybe Linkable +homeModLinkableObject = homeMod_object + instance Outputable HomeModLinkable where ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2 ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -22,16 +22,22 @@ module GHC.Unit.Module.Deps , ImportAvails (..) , IfaceImportLevel(..) , tcImportLevel + , LinkablePartUsage(..) + , linkablePartUsageObjectPaths ) where import GHC.Prelude import GHC.Data.FastString +import GHC.Data.FlatBag +import GHC.Data.OsPath +import qualified GHC.Data.OsPath as OsPath import GHC.Types.Avail import GHC.Types.SafeHaskell import GHC.Types.Name +import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Unit.Module.Imported @@ -43,13 +49,12 @@ import GHC.Utils.Fingerprint import GHC.Utils.Binary import GHC.Utils.Outputable +import Control.DeepSeq +import Data.Bifunctor +import qualified Data.Foldable as Foldable import Data.List (sortBy, sort, partition) import Data.Set (Set) import qualified Data.Set as Set -import Data.Bifunctor -import Control.DeepSeq -import GHC.Types.Name.Set - -- | Dependency information about ALL modules and packages below this one @@ -372,12 +377,12 @@ data Usage -- we won't spot it here. If you do want to spot that, the caller -- should recursively add them to their useage. } - | UsageHomeModuleInterface { + | UsageHomeModuleBytecode { usg_mod_name :: ModuleName -- ^ Name of the module , usg_unit_id :: UnitId -- ^ UnitId of the HomeUnit the module is from - , usg_iface_hash :: Fingerprint + , usg_bytecode_hash :: Fingerprint -- ^ The *interface* hash of the module, not the ABI hash. -- This changes when anything about the interface (and hence the -- module) has changed. @@ -412,7 +417,7 @@ instance NFData Usage where rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` () rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` () rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` () - rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` () + rnf (UsageHomeModuleBytecode mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` () instance Binary Usage where put_ bh usg@UsagePackageModule{} = do @@ -441,11 +446,11 @@ instance Binary Usage where put_ bh (usg_mod usg) put_ bh (usg_mod_hash usg) - put_ bh usg@UsageHomeModuleInterface{} = do + put_ bh usg@UsageHomeModuleBytecode{} = do putByte bh 4 put_ bh (usg_mod_name usg) put_ bh (usg_unit_id usg) - put_ bh (usg_iface_hash usg) + put_ bh (usg_bytecode_hash usg) put_ bh usg@UsageDirectory{} = do putByte bh 5 @@ -483,7 +488,7 @@ instance Binary Usage where mod <- get bh uid <- get bh hash <- get bh - return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash } + return UsageHomeModuleBytecode { usg_mod_name = mod, usg_unit_id = uid, usg_bytecode_hash = hash } 5 -> do dp <- get bh hash <- get bh @@ -695,3 +700,33 @@ data ImportAvails -- ^ Family instance modules below us in the import tree (and maybe -- including us for imported modules) } + +-- | Record usage of a 'LinkablePart'. +data LinkablePartUsage + = FileLinkablePartUsage + { flu_file :: !FilePath + , flu_module :: !Module + , flu_linkable_objs :: !(FlatBag OsPath) + } + | ByteCodeLinkablePartUsage + { bclu_module :: !Module + , bclu_hash :: !Fingerprint + , bclu_linkable_objs :: !(FlatBag OsPath) + } + +instance Outputable LinkablePartUsage where + ppr = \ case + FileLinkablePartUsage fp modl _objs -> + text "FileLinkableUsage" <+> text fp <+> ppr modl + + ByteCodeLinkablePartUsage modl hash _objs -> + text "ByteCodeLinkableUsage" <+> ppr modl <+> ppr hash + +linkablePartUsageObjectPaths :: LinkablePartUsage -> [FilePath] +linkablePartUsageObjectPaths lnkUsage = + map OsPath.unsafeDecodeUtf . Foldable.toList $ linkableUsageObjectOsPaths lnkUsage + +linkableUsageObjectOsPaths :: LinkablePartUsage -> FlatBag OsPath +linkableUsageObjectOsPaths lnkUsage = case lnkUsage of + FileLinkablePartUsage{flu_linkable_objs} -> flu_linkable_objs + ByteCodeLinkablePartUsage{bclu_linkable_objs} -> bclu_linkable_objs ===================================== compiler/GHC/Unit/Module/Status.hs ===================================== @@ -18,11 +18,12 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface -import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly ) +import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly, ModuleByteCode, LinkableWith, linkableModuleByteCodes ) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Stack.Types (HasCallStack) -- | Status of a module in incremental compilation data HscRecompStatus @@ -59,7 +60,7 @@ data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompByte , recompLinkables_object :: !(Maybe Linkable) } data RecompBytecodeLinkable - = NormalLinkable !(Maybe Linkable) + = NormalLinkable !(Maybe (LinkableWith ModuleByteCode)) | WholeCoreBindingsLinkable !WholeCoreBindingsLinkable instance Outputable HscRecompStatus where @@ -86,8 +87,11 @@ safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables justBytecode = \case Left lm -> + let + mbc = expectSingletonGbcLinkable lm + in assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) - $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) } + $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just mbc) } Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm } justObjects :: Linkable -> RecompLinkables @@ -98,8 +102,17 @@ justObjects lm = bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables bytecodeAndObjects either_bc o = case either_bc of Left bc -> - assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) - $ RecompLinkables (NormalLinkable (Just bc)) (Just o) + let + mbc = expectSingletonGbcLinkable bc + in + assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) + $ RecompLinkables (NormalLinkable (Just mbc)) (Just o) Right bc -> assertPpr (linkableIsNativeCodeOnly o) (ppr o) $ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o) + +expectSingletonGbcLinkable :: HasCallStack => Linkable -> LinkableWith ModuleByteCode +expectSingletonGbcLinkable lm = case linkableModuleByteCodes lm of + [] -> pprPanic "Expected 1 ModuleByteCode in Linkable" (ppr lm) + [mbc] -> mbc <$ lm + _ -> pprPanic "Expected 1 in Linkable" (ppr lm) ===================================== compiler/ghc.cabal.in ===================================== @@ -210,10 +210,12 @@ Library GHC.Builtin.Uniques GHC.Builtin.Utils GHC.ByteCode.Asm + GHC.ByteCode.Binary GHC.ByteCode.Breakpoints GHC.ByteCode.InfoTable GHC.ByteCode.Instr GHC.ByteCode.Linker + GHC.ByteCode.Recomp.Binary GHC.ByteCode.Serialize GHC.ByteCode.Types GHC.Cmm ===================================== ghc/GHCi/Leak.hs ===================================== @@ -52,8 +52,11 @@ getLeakIndicators hsc_env = return $ LeakModIndicators{..} where mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)] - mkWeakLinkables (HomeModLinkable mbc mo) = - mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo] + mkWeakLinkables hml = + mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) + [ homeModLinkableByteCode hml + , homeModLinkableObject hml + ] -- | Look at the LeakIndicators collected by an earlier call to -- `getLeakIndicators`, and print messasges if any of them are still ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -60,6 +60,7 @@ GHC.Data.FastMutInt GHC.Data.FastString GHC.Data.FastString.Env GHC.Data.FiniteMap +GHC.Data.FlatBag GHC.Data.Graph.Directed GHC.Data.Graph.Directed.Internal GHC.Data.Graph.UnVar ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -61,6 +61,7 @@ GHC.Data.FastMutInt GHC.Data.FastString GHC.Data.FastString.Env GHC.Data.FiniteMap +GHC.Data.FlatBag GHC.Data.Graph.Directed GHC.Data.Graph.Directed.Internal GHC.Data.Graph.Directed.Reachability ===================================== testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout ===================================== @@ -3,6 +3,6 @@ GHCi, version 9.15.20260122: https://www.haskell.org/ghc/ :? for help [2 of 2] Compiling RecompTH ( RecompTH.hs, interpreted )[recomp] Ok, two modules loaded. ghci> ghci> ghci> [1 of 2] Compiling Dep ( Dep.hs, interpreted )[dep] [Source file changed] -[2 of 2] Compiling RecompTH ( RecompTH.hs, interpreted )[recomp] [Dep changed (interface)] +[2 of 2] Compiling RecompTH ( RecompTH.hs, interpreted )[recomp] [Dep changed (bytecode)] Ok, two modules reloaded. ghci> Leaving GHCi. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31a3cbc3cf14831f506f1e52933e596d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31a3cbc3cf14831f506f1e52933e596d... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Hannes Siebenhandl (@fendor)