Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC Commits: b9e9525e by fendor at 2026-03-03T14:42:21+01:00 WIP LinkableUsage - - - - - dad0f5de by fendor at 2026-03-03T14:56:19+01:00 Drop loadInterface - - - - - 23 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/Utils/Binary.hs - compiler/ghc.cabal.in - ghc/GHCi/Leak.hs 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.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +import Data.ByteString (ByteString) +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 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 + + +instance Binary OnDiskModuleByteCode where + get bh = do + odgbc_module <- get bh + odgbc_hash <- 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_hash + put_ bh odgbc_compiled_byte_code + put_ bh odgbc_foreign + +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,40 +14,35 @@ 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.Utils.Binary -import GHC.Utils.Exception -import GHC.Utils.Panic import GHC.Utils.TmpFs -import System.FilePath +import GHC.Utils.Logger +import GHC.Utils.Fingerprint (Fingerprint) import GHC.Unit.Types -import GHC.Driver.DynFlags -import System.Directory -import Data.ByteString (ByteString) +import GHC.Linker.Types + 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 System.Directory +import System.FilePath + {- Note [Overview of persistent bytecode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -87,74 +82,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 @@ -167,22 +94,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. @@ -197,7 +112,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 @@ -256,7 +172,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. @@ -268,7 +185,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. @@ -281,161 +198,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 +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 - 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 - -addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle -addBinNameWriter bh' = - evaluate - $ flip addWriterToUserData bh' - $ BinaryWriter - $ \bh (BinName nm) -> - if - | isExternalName nm -> do - putByte bh 0 - put_ bh nm - | otherwise -> do - putByte bh 1 - put_ bh - $ occNameFS (occName nm) - `appendFS` mkFastString - (show $ nameUnique nm) - -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] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- NOTE: This approach means that bytecode objects are not deterministic. --- We need to revisit this in order to make the output deterministic. --- --- 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. So normally uniques aren't supposed to be --- serialized, but for this invariant to work, we do append uniques to --- OccNames of internal Names, so that they can be uniquely identified --- by OccName alone. When deserializing, we check a global cached --- mapping from OccName to Unique, and create the real Name with the --- right Unique if it's already deserialized at least once. +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 @@ -190,31 +184,31 @@ for a module or not. This is similar to how the recompilation checking for the l -- | 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 - let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed) +mkObjectUsage :: Plugins -> FinderCache -> [LinkableUsage] -> PkgsLoaded -> IO [Usage] +mkObjectUsage plugins fc th_links_needed th_pkgs_needed = do + let ls = 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) - - msg m = moduleNameString (moduleName m) ++ "[TH] changed" + linkableToUsage :: LinkableUsage -> IO [Usage] + linkableToUsage (Linkable _ _m parts) = traverse partToUsage (NE.toList parts) + + partToUsage link_usage = + case link_usage of + FileLinkablePartUsage{flu_file, flu_message} -> do + fing flu_message flu_file + + 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 - 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) - librarySpecToUsage :: LibrarySpec -> IO [Usage] librarySpecToUsage (Objects os) = traverse (fing Nothing) os librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn] ===================================== 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,37 +68,45 @@ module GHC.Linker.Types , linkableFilterNative , partitionLinkables + , LinkableUsage + , linkableUsageObjs + , mkLinkablesUsage + , mkLinkableUsage + , ModuleByteCode(..) ) where import GHC.Prelude -import GHC.Unit ( UnitId, Module ) +import GHC.Unit ( UnitId, Module, moduleNameString, moduleName ) import GHC.ByteCode.Types 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) + +type LinkableSet = ModuleEnv -mkLinkableSet :: [Linkable] -> LinkableSet +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,60 @@ 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 () + + msg m = moduleNameString (moduleName m) ++ "[TH] changed" + + mkFileLinkablePartUsage m fp objs = + FileLinkablePartUsage + { flu_file = fp + , flu_message = Just $ msg 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,24 @@ module GHC.Unit.Module.Deps , ImportAvails (..) , IfaceImportLevel(..) , tcImportLevel + , LinkablePartUsage(..) + , linkablePartUsageObjectPaths + , noLinkableUsage + , combineLinkableUsage ) 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 +51,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 +379,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 +419,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 +448,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 +490,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 +702,38 @@ 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_message :: !(Maybe String) + , 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 mmsg _objs -> + text "FileLinkableUsage" <+> text fp <> maybe empty (\ msg -> text " " <> text msg) mmsg + 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 + +noLinkableUsage :: [LinkablePartUsage] +noLinkableUsage = [] + +combineLinkableUsage :: [LinkablePartUsage] -> [LinkablePartUsage] -> [LinkablePartUsage] +combineLinkableUsage a b = a ++ b ===================================== compiler/GHC/Unit/Module/Status.hs ===================================== @@ -18,7 +18,7 @@ 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, linkableBCOs, linkableModuleByteCodes ) import GHC.Utils.Fingerprint import GHC.Utils.Outputable @@ -59,7 +59,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 @@ -87,7 +87,8 @@ justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables justBytecode = \case Left lm -> assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) - $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) } + $ assertPpr (length (linkableBCOs lm) == 1) (text "Expected 1 DotGBC linkable" $$ ppr lm ) + $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just (head (linkableModuleByteCodes lm) <$ lm)) } Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm } justObjects :: Linkable -> RecompLinkables @@ -99,7 +100,8 @@ bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> R 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) + $ assertPpr (length (linkableBCOs bc) == 1) (text "Expected 1 DotGBC linkable" $$ ppr bc ) + $ RecompLinkables (NormalLinkable (Just (head (linkableModuleByteCodes bc) <$ bc))) (Just o) Right bc -> assertPpr (linkableIsNativeCodeOnly o) (ppr o) $ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o) ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -37,6 +37,7 @@ module GHC.Utils.Binary tellBinWriter, castBin, withBinBuffer, + withReadBinBuffer, freezeWriteHandle, shrinkBinBuffer, thawReadHandle, @@ -349,6 +350,12 @@ withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do arr <- readIORef arr_r action $ BS.fromForeignPtr arr 0 ix +-- | Get access to the underlying buffer. +withReadBinBuffer :: ReadBinHandle -> (ByteString -> IO a) -> IO a +withReadBinBuffer (ReadBinMem _ ix_r _ arr) action = do + ix <- readFastMutInt ix_r + action $ BS.fromForeignPtr arr 0 ix + unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle unsafeUnpackBinBuffer (BS.BS arr len) = do ix_r <- newFastMutInt 0 ===================================== 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7a197f6f0fe6f793e097a81fc3fb2e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7a197f6f0fe6f793e097a81fc3fb2e... You're receiving this email because of your account on gitlab.haskell.org.