March 2026 - ghc-commits

[Git][ghc/ghc] Pushed new branch wip/T26972
by sheaf (＠sheaf) 03 Mar '26

03 Mar '26

sheaf pushed new branch wip/T26972 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26972 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fix-ghc-internal-windows-9.14
by Cheng Shao (＠TerrorJack) 03 Mar '26

03 Mar '26

Cheng Shao pushed new branch wip/fix-ghc-internal-windows-9.14 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fix-ghc-internal-windows-9.14 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/linkable-usage] 2 commits: WIP LinkableUsage
by Hannes Siebenhandl (＠fendor) 03 Mar '26

03 Mar '26

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/f7a197f6f0fe6f793e097a81fc3fb2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7a197f6f0fe6f793e097a81fc3fb2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/system-io-uncovering] Remove in-package dependencies on `GHC.Internal.System.IO`
by Wolfgang Jeltsch (＠jeltsch) 03 Mar '26

03 Mar '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-uncovering at Glasgow Haskell Compiler / GHC Commits: 4325be38 by Wolfgang Jeltsch at 2026-03-03T15:54:48+02:00 Remove in-package dependencies on `GHC.Internal.System.IO` This contribution eliminates all dependencies on `GHC.Internal.System.IO` from within `ghc-internal`. It comprises the following changes: * Make `GHC.Internal.Fingerprint` independent of I/O support * Tighten the dependencies of `GHC.Internal.Data.Version` * Tighten the dependencies of `GHC.Internal.TH.Monad` * Tighten the dependencies of `GHCi.Helpers` * Move some code that needs `System.IO` to `template-haskell` * Move the `GHC.ResponseFile` implementation into `base` * Move the `System.Exit` implementation into `base` * Move the `System.IO.OS` implementation into `base` Metric Decrease: size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip - - - - - 14 changed files: - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs - − libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs Changes: ===================================== libraries/base/src/GHC/Fingerprint.hs ===================================== @@ -9,3 +9,45 @@ module GHC.Fingerprint ( ) where import GHC.Internal.Fingerprint + +import Data.Function (($)) +import Control.Monad (return, when) +import Data.Bool (not, (&&)) +import Data.List ((++)) +import Data.Maybe (Maybe (Nothing, Just)) +import Data.Int (Int) +import Data.Word (Word8) +import Data.Eq ((/=)) +import Text.Show (show) +import System.IO + ( + IO, + FilePath, + IOMode (ReadMode), + withBinaryFile, + hGetBuf, + hIsEOF + ) +import Foreign.Ptr (Ptr) +import GHC.Err (errorWithoutStackTrace) + +-- | Computes the hash of a given file. +-- This function runs in constant memory. +-- +-- @since base-4.7.0.0 +getFileHash :: FilePath -> IO Fingerprint +getFileHash path = withBinaryFile path ReadMode $ \ hdl -> + let + readChunk :: Ptr Word8 -> Int -> IO (Maybe Int) + readChunk bufferPtr bufferSize = do + chunkSize <- hGetBuf hdl bufferPtr bufferSize + isFinished <- hIsEOF hdl + when (chunkSize /= bufferSize && not isFinished) + ( + errorWithoutStackTrace $ + "GHC.Fingerprint.getFileHash: could only read " ++ + show chunkSize ++ + " bytes, but more are available" + ) + return (if isFinished then Just chunkSize else Nothing) + in fingerprintBufferedStream readChunk ===================================== libraries/base/src/GHC/ResponseFile.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Safe #-} -- | @@ -19,4 +20,145 @@ module GHC.ResponseFile ( expandResponse ) where -import GHC.Internal.ResponseFile +import Control.Monad (return, (>>=), mapM) +import Control.Exception (IOException, catch) +import Data.Function (($), (.)) +import Data.Bool (Bool (False, True), otherwise, not, (||)) +import Data.Char (Char, isSpace) +import Data.List ((++), map, filter, concat, reverse) +import Data.String (String, unlines) +import Data.Functor (fmap) +import Data.Foldable (null, foldl') +import Data.Eq ((==)) +import Text.Show (show) +import System.Environment (getArgs) +import System.IO (IO, hPutStrLn, readFile, stderr) +import System.Exit (exitFailure) + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--\'two\' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechanism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like @\@foo@ will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== libraries/base/src/System/Exit.hs ===================================== @@ -21,4 +21,67 @@ module System.Exit die ) where -import GHC.Internal.System.Exit \ No newline at end of file +import GHC.IO.Exception + ( + IOErrorType (InvalidArgument), + IOException (IOError), + ExitCode (ExitSuccess, ExitFailure) + ) +import Control.Monad ((>>)) +import Control.Exception (throwIO, ioError) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Nothing)) +import Data.String (String) +import Data.Eq ((/=)) +import System.IO (IO, hPutStrLn, stderr) + +-- --------------------------------------------------------------------------- +-- exitWith + +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. +-- Normally this terminates the program, returning @code@ to the +-- program's caller. +-- +-- On program termination, the standard 'Handle's 'stdout' and +-- 'stderr' are flushed automatically; any other buffered 'Handle's +-- need to be flushed manually, otherwise the buffered data will be +-- discarded. +-- +-- A program that fails in any other way is treated as if it had +-- called 'exitFailure'. +-- A program that terminates successfully without calling 'exitWith' +-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. +-- +-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be +-- caught using the functions of "Control.Exception". This means that +-- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from +-- "Control.Exception") are also executed properly on 'exitWith'. +-- +-- Note: in GHC, 'exitWith' should be called from the main program +-- thread in order to exit the process. When called from another +-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the +-- exception will not cause the process itself to exit. +-- +exitWith :: ExitCode -> IO a +exitWith ExitSuccess = throwIO ExitSuccess +exitWith code@(ExitFailure n) + | n /= 0 = throwIO code + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) + +-- | The computation 'exitFailure' is equivalent to +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@, +-- where /exitfail/ is implementation-dependent. +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +-- | The computation 'exitSuccess' is equivalent to +-- 'exitWith' 'ExitSuccess', It terminates the program +-- successfully. +exitSuccess :: IO a +exitSuccess = exitWith ExitSuccess + +-- | Write given error message to `stderr` and terminate with `exitFailure`. +-- +-- @since base-4.8.0.0 +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-| This module bridges between Haskell handles and underlying operating-system @@ -21,17 +23,293 @@ module System.IO.OS ) where -import GHC.Internal.System.IO.OS +import Control.Monad (return) +import Control.Concurrent.MVar (MVar) +import Control.Exception (mask) +import Data.Function (const, (.), ($)) +import Data.Functor (fmap) +import Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Just)) +#endif +import Data.List ((++)) +import Data.String (String) +import Data.Typeable (Typeable, cast) +import System.IO (IO) +import GHC.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.IO.Windows.Handle ( - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE ) +#endif +import GHC.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import Foreign.Ptr (Ptr) +import Foreign.C.Types (CInt) + +-- * Obtaining POSIX file descriptors and Windows handles + +{-| + Executes a user-provided action on an operating-system handle that underlies + a Haskell handle. Before the user-provided action is run, user-defined + preparation based on the handle state that contains the operating-system + handle is performed. While the user-provided action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withOSHandle :: String + -- ^ The name of the overall operation + -> (Handle -> MVar Handle__) + {-^ + Obtaining of the handle state variable that holds the + operating-system handle + -} + -> (forall d. Typeable d => d -> IO a) + -- ^ Conversion of a device into an operating-system handle + -> (Handle__ -> IO ()) + -- ^ The preparation + -> Handle + -- ^ The Haskell handle to use + -> (a -> IO r) + -- ^ The action to execute on the operating-system handle + -> IO r +withOSHandle opName handleStateVar getOSHandle prepare handle act + = mask $ \ withOriginalMaskingState -> + withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do + osHandle <- getOSHandle dev + prepare handleState + withOriginalMaskingState $ act osHandle + where + + withHandleState = withHandle_' opName handle (handleStateVar handle) +{- + The 'withHandle_'' operation, which we use here, already performs masking. + Still, we have to employ 'mask', in order do obtain the operation that + restores the original masking state. The user-provided action should be + executed with this original masking state, as there is no inherent reason to + generally perform it with masking in place. The masking that 'withHandle_'' + performs is only for safely accessing handle state and thus constitutes an + implementation detail; it has nothing to do with the user-provided action. +-} +{- + The order of actions in 'withOSHandle' is such that any exception from + 'getOSHandle' is thrown before the user-defined preparation is performed. +-} + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for reading if the handle uses different state + variables for reading and writing. +-} +handleStateVarReadingBiased :: Handle -> MVar Handle__ +handleStateVarReadingBiased (FileHandle _ var) = var +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for writing if the handle uses different state + variables for reading and writing. +-} +handleStateVarWritingBiased :: Handle -> MVar Handle__ +handleStateVarWritingBiased (FileHandle _ var) = var +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar + +{-| + Yields the result of another operation if that operation succeeded, and + otherwise throws an exception that signals that the other operation failed + because some Haskell handle does not use an operating-system handle of a + required type. +-} +requiringOSHandleOfType :: String + -- ^ The name of the operating-system handle type + -> Maybe a + {-^ + The result of the other operation if it succeeded + -} + -> IO a +requiringOSHandleOfType osHandleTypeName + = maybe (ioException osHandleOfTypeRequired) return + where + + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + InappropriateType + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing + +{-| + Obtains the POSIX file descriptor of a device if the device contains one, + and throws an exception otherwise. +-} +getFileDescriptor :: Typeable d => d -> IO CInt +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast + +{-| + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. +-} +getWindowsHandle :: Typeable d => d -> IO (Ptr ()) +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where + + toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) +#if defined(mingw32_HOST_OS) + toMaybeWindowsHandle dev + | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) + = Just (toHANDLE nativeHandle) + | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) + = Just (toHANDLE consoleHandle) + | otherwise + = Nothing + {- + This is inspired by the implementation of + 'System.Win32.Types.withHandleToHANDLENative'. + -} +#else + toMaybeWindowsHandle _ = Nothing +#endif + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for reading if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" + handleStateVarReadingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for writing if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" + handleStateVarWritingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for reading if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" + handleStateVarReadingBiased + getWindowsHandle + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for writing if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" + handleStateVarWritingBiased + getWindowsHandle + flushBuffer + +{-| + Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiasedRaw + = withOSHandle "withFileDescriptorReadingBiasedRaw" + handleStateVarReadingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiasedRaw + = withOSHandle "withFileDescriptorWritingBiasedRaw" + handleStateVarWritingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiasedRaw + = withOSHandle "withWindowsHandleReadingBiasedRaw" + handleStateVarReadingBiased + getWindowsHandle + (const $ return ()) + +{-| + Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiasedRaw + = withOSHandle "withWindowsHandleWritingBiasedRaw" + handleStateVarWritingBiased + getWindowsHandle + (const $ return ()) -- ** Caveats ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -1,17 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} --- Late cost centres introduce a thunk in the asBox function, which leads to --- an additional wrapper being added to any value placed inside a box. --- This can be removed once our boot compiler is no longer affected by #25212 -{-# OPTIONS_GHC -fno-prof-late #-} -{-# LANGUAGE NamedFieldPuns #-} - module GHC.Exts.Heap.Closures ( -- * Closures Closure ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -284,7 +284,6 @@ Library GHC.Internal.Read GHC.Internal.Real GHC.Internal.Records - GHC.Internal.ResponseFile GHC.Internal.RTS.Flags GHC.Internal.RTS.Flags.Test GHC.Internal.ST @@ -323,10 +322,8 @@ Library GHC.Internal.Numeric.Natural GHC.Internal.System.Environment GHC.Internal.System.Environment.Blank - GHC.Internal.System.Exit GHC.Internal.System.IO GHC.Internal.System.IO.Error - GHC.Internal.System.IO.OS GHC.Internal.System.Mem GHC.Internal.System.Mem.StableName GHC.Internal.System.Posix.Internals ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Version.hs ===================================== @@ -41,8 +41,7 @@ import GHC.Internal.Data.Eq import GHC.Internal.Int ( Int ) import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord -import GHC.Internal.Data.String ( String ) -import GHC.Internal.Base ( Applicative(..), (&&) ) +import GHC.Internal.Base ( Applicative(..), (&&), String ) import GHC.Internal.Generics import GHC.Internal.Unicode ( isDigit, isAlphaNum ) import GHC.Internal.Read ===================================== libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs ===================================== @@ -16,23 +16,22 @@ module GHC.Internal.Fingerprint ( fingerprintData, fingerprintString, fingerprintFingerprints, - getFileHash + fingerprintBufferedStream ) where import GHC.Internal.IO import GHC.Internal.Base import GHC.Internal.Bits import GHC.Internal.Num +import GHC.Internal.Data.Maybe import GHC.Internal.List import GHC.Internal.Real import GHC.Internal.Word -import GHC.Internal.Show import GHC.Internal.Ptr import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Marshal.Alloc import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Foreign.Storable -import GHC.Internal.System.IO import GHC.Internal.Fingerprint.Type @@ -71,41 +70,27 @@ fingerprintString str = unsafeDupablePerformIO $ fromIntegral (w32 `shiftR` 8), fromIntegral w32] --- | Computes the hash of a given file. --- This function loops over the handle, running in constant memory. --- --- @since base-4.7.0.0 -getFileHash :: FilePath -> IO Fingerprint -getFileHash path = withBinaryFile path ReadMode $ \h -> +-- | Reads data in chunks and computes its hash. +-- This function runs in constant memory. +fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int)) + -> IO Fingerprint +fingerprintBufferedStream readChunk = allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do c_MD5Init pctxt - - processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size)) - + allocaBytes _BUFSIZE $ \arrPtr -> + let loop = do + maybeRemainderSize <- readChunk arrPtr _BUFSIZE + c_MD5Update pctxt + arrPtr + (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize)) + when (isNothing maybeRemainderSize) loop + in loop allocaBytes 16 $ \pdigest -> do c_MD5Final pdigest pctxt peek (castPtr pdigest :: Ptr Fingerprint) - where _BUFSIZE = 4096 - -- Loop over _BUFSIZE sized chunks read from the handle, - -- passing the callback a block of bytes and its size. - processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO () - processChunks h f = allocaBytes _BUFSIZE $ \arrPtr -> - - let loop = do - count <- hGetBuf h arrPtr _BUFSIZE - eof <- hIsEOF h - when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $ - "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes" - - f arrPtr count - - when (not eof) loop - - in loop - data MD5Context foreign import ccall unsafe "__hsbase_MD5Init" ===================================== libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs ===================================== @@ -24,9 +24,10 @@ module GHC.Internal.GHCi.Helpers , evalWrapper ) where -import GHC.Internal.Base -import GHC.Internal.System.IO -import GHC.Internal.System.Environment +import GHC.Internal.Base (String, IO) +import GHC.Internal.IO.Handle (BufferMode (NoBuffering), hSetBuffering, hFlush) +import GHC.Internal.IO.StdHandles (stdin, stdout, stderr) +import GHC.Internal.System.Environment (withProgName, withArgs) disableBuffering :: IO () disableBuffering = do ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs deleted ===================================== @@ -1,163 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.ResponseFile --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : internal --- Portability : portable --- --- GCC style response files. --- --- @since base-4.12.0.0 ----------------------------------------------------------------------------- - --- Migrated from Haddock. - -module GHC.Internal.ResponseFile ( - getArgsWithResponseFiles, - unescapeArgs, - escapeArgs, escapeArg, - expandResponse - ) where - -import GHC.Internal.Control.Exception -import GHC.Internal.Data.Foldable (Foldable(..)) -import GHC.Internal.Base -import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.List (filter, unlines, concat, reverse) -import GHC.Internal.Text.Show (show) -import GHC.Internal.System.Environment (getArgs) -import GHC.Internal.System.Exit (exitFailure) -import GHC.Internal.System.IO - -{-| -Like 'getArgs', but can also read arguments supplied via response files. - - -For example, consider a program @foo@: - -@ -main :: IO () -main = do - args <- getArgsWithResponseFiles - putStrLn (show args) -@ - - -And a response file @args.txt@: - -@ ---one 1 ---\'two\' 2 ---"three" 3 -@ - -Then the result of invoking @foo@ with @args.txt@ is: - -> > ./foo @args.txt -> ["--one","1","--two","2","--three","3"] - --} -getArgsWithResponseFiles :: IO [String] -getArgsWithResponseFiles = getArgs >>= expandResponse - --- | Given a string of concatenated strings, separate each by removing --- a layer of /quoting/ and\/or /escaping/ of certain characters. --- --- These characters are: any whitespace, single quote, double quote, --- and the backslash character. The backslash character always --- escapes (i.e., passes through without further consideration) the --- character which follows. Characters can also be escaped in blocks --- by quoting (i.e., surrounding the blocks with matching pairs of --- either single- or double-quotes which are not themselves escaped). --- --- Any whitespace which appears outside of either of the quoting and --- escaping mechanisms, is interpreted as having been added by this --- special concatenation process to designate where the boundaries --- are between the original, un-concatenated list of strings. These --- added whitespace characters are removed from the output. --- --- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - --- | Given a list of strings, concatenate them into a single string --- with escaping of certain characters, and the addition of a newline --- between each string. The escaping is done by adding a single --- backslash character before any whitespace, single quote, double --- quote, or backslash character, so this escaping character must be --- removed. Unescaped whitespace (in this case, newline) is part --- of this "transport" format to indicate the end of the previous --- string and the start of a new string. --- --- While 'unescapeArgs' allows using quoting (i.e., convenient --- escaping of many characters) by having matching sets of single- or --- double-quotes,'escapeArgs' does not use the quoting mechanism, --- and thus will always escape any whitespace, quotes, and --- backslashes. --- --- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" -escapeArgs :: [String] -> String -escapeArgs = unlines . map escapeArg - --- | Arguments which look like @\@foo@ will be replaced with the --- contents of file @foo@. A gcc-like syntax for response files arguments --- is expected. This must re-constitute the argument list by doing an --- inverse of the escaping mechanism done by the calling-program side. --- --- We quit if the file is not found or reading somehow fails. --- (A convenience routine for haddock or possibly other clients) -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . unescapeArgs - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs ===================================== libraries/ghc-internal/src/GHC/Internal/System/Exit.hs deleted ===================================== @@ -1,81 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.System.Exit --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : provisional --- Portability : portable --- --- Exiting the program. --- ------------------------------------------------------------------------------ - -module GHC.Internal.System.Exit - ( - ExitCode(ExitSuccess,ExitFailure) - , exitWith - , exitFailure - , exitSuccess - , die - ) where - -import GHC.Internal.System.IO - -import GHC.Internal.Base -import GHC.Internal.IO -import GHC.Internal.IO.Exception - --- --------------------------------------------------------------------------- --- exitWith - --- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. --- Normally this terminates the program, returning @code@ to the --- program's caller. --- --- On program termination, the standard 'Handle's 'stdout' and --- 'stderr' are flushed automatically; any other buffered 'Handle's --- need to be flushed manually, otherwise the buffered data will be --- discarded. --- --- A program that fails in any other way is treated as if it had --- called 'exitFailure'. --- A program that terminates successfully without calling 'exitWith' --- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. --- --- As an 'ExitCode' is an 'Control.Exception.Exception', it can be --- caught using the functions of "Control.Exception". This means that --- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from --- "Control.Exception") are also executed properly on 'exitWith'. --- --- Note: in GHC, 'exitWith' should be called from the main program --- thread in order to exit the process. When called from another --- thread, 'exitWith' will throw an 'ExitCode' as normal, but the --- exception will not cause the process itself to exit. --- -exitWith :: ExitCode -> IO a -exitWith ExitSuccess = throwIO ExitSuccess -exitWith code@(ExitFailure n) - | n /= 0 = throwIO code - | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) - --- | The computation 'exitFailure' is equivalent to --- 'exitWith' @(@'ExitFailure' /exitfail/@)@, --- where /exitfail/ is implementation-dependent. -exitFailure :: IO a -exitFailure = exitWith (ExitFailure 1) - --- | The computation 'exitSuccess' is equivalent to --- 'exitWith' 'ExitSuccess', It terminates the program --- successfully. -exitSuccess :: IO a -exitSuccess = exitWith ExitSuccess - --- | Write given error message to `stderr` and terminate with `exitFailure`. --- --- @since base-4.8.0.0 -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs deleted ===================================== @@ -1,323 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - -{-| - This module bridges between Haskell handles and underlying operating-system - features. --} -module GHC.Internal.System.IO.OS -( - -- * Obtaining file descriptors and Windows handles - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw - - -- ** Caveats - -- $with-ref-caveats -) -where - -#if defined(mingw32_HOST_OS) -import GHC.Internal.Base (otherwise) -#endif -import GHC.Internal.Control.Monad (return) -import GHC.Internal.Control.Concurrent.MVar (MVar) -import GHC.Internal.Control.Exception (mask) -import GHC.Internal.Data.Function (const, (.), ($)) -import GHC.Internal.Data.Functor (fmap) -import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) -#if defined(mingw32_HOST_OS) -import GHC.Internal.Data.Maybe (Maybe (Just)) -#endif -import GHC.Internal.Data.List ((++)) -import GHC.Internal.Data.String (String) -import GHC.Internal.Data.Typeable (Typeable, cast) -import GHC.Internal.System.IO (IO) -import GHC.Internal.IO.FD (fdFD) -#if defined(mingw32_HOST_OS) -import GHC.Internal.IO.Windows.Handle - ( - NativeHandle, - ConsoleHandle, - IoHandle, - toHANDLE - ) -#endif -import GHC.Internal.IO.Handle.Types - ( - Handle (FileHandle, DuplexHandle), - Handle__ (Handle__, haDevice) - ) -import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) -import GHC.Internal.IO.Exception - ( - IOErrorType (InappropriateType), - IOException (IOError), - ioException - ) -import GHC.Internal.Foreign.Ptr (Ptr) -import GHC.Internal.Foreign.C.Types (CInt) - --- * Obtaining POSIX file descriptors and Windows handles - -{-| - Executes a user-provided action on an operating-system handle that underlies - a Haskell handle. Before the user-provided action is run, user-defined - preparation based on the handle state that contains the operating-system - handle is performed. While the user-provided action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withOSHandle :: String - -- ^ The name of the overall operation - -> (Handle -> MVar Handle__) - {-^ - Obtaining of the handle state variable that holds the - operating-system handle - -} - -> (forall d. Typeable d => d -> IO a) - -- ^ Conversion of a device into an operating-system handle - -> (Handle__ -> IO ()) - -- ^ The preparation - -> Handle - -- ^ The Haskell handle to use - -> (a -> IO r) - -- ^ The action to execute on the operating-system handle - -> IO r -withOSHandle opName handleStateVar getOSHandle prepare handle act - = mask $ \ withOriginalMaskingState -> - withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do - osHandle <- getOSHandle dev - prepare handleState - withOriginalMaskingState $ act osHandle - where - - withHandleState = withHandle_' opName handle (handleStateVar handle) -{- - The 'withHandle_'' operation, which we use here, already performs masking. - Still, we have to employ 'mask', in order do obtain the operation that - restores the original masking state. The user-provided action should be - executed with this original masking state, as there is no inherent reason to - generally perform it with masking in place. The masking that 'withHandle_'' - performs is only for safely accessing handle state and thus constitutes an - implementation detail; it has nothing to do with the user-provided action. --} -{- - The order of actions in 'withOSHandle' is such that any exception from - 'getOSHandle' is thrown before the user-defined preparation is performed. --} - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for reading if the handle uses different state - variables for reading and writing. --} -handleStateVarReadingBiased :: Handle -> MVar Handle__ -handleStateVarReadingBiased (FileHandle _ var) = var -handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for writing if the handle uses different state - variables for reading and writing. --} -handleStateVarWritingBiased :: Handle -> MVar Handle__ -handleStateVarWritingBiased (FileHandle _ var) = var -handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar - -{-| - Yields the result of another operation if that operation succeeded, and - otherwise throws an exception that signals that the other operation failed - because some Haskell handle does not use an operating-system handle of a - required type. --} -requiringOSHandleOfType :: String - -- ^ The name of the operating-system handle type - -> Maybe a - {-^ - The result of the other operation if it succeeded - -} - -> IO a -requiringOSHandleOfType osHandleTypeName - = maybe (ioException osHandleOfTypeRequired) return - where - - osHandleOfTypeRequired :: IOException - osHandleOfTypeRequired - = IOError Nothing - InappropriateType - "" - ("handle does not use " ++ osHandleTypeName ++ "s") - Nothing - Nothing - -{-| - Obtains the POSIX file descriptor of a device if the device contains one, - and throws an exception otherwise. --} -getFileDescriptor :: Typeable d => d -> IO CInt -getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . - fmap fdFD . cast - -{-| - Obtains the Windows handle of a device if the device contains one, and - throws an exception otherwise. --} -getWindowsHandle :: Typeable d => d -> IO (Ptr ()) -getWindowsHandle = requiringOSHandleOfType "Windows handle" . - toMaybeWindowsHandle - where - - toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) -#if defined(mingw32_HOST_OS) - toMaybeWindowsHandle dev - | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) - = Just (toHANDLE nativeHandle) - | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) - = Just (toHANDLE consoleHandle) - | otherwise - = Nothing - {- - This is inspired by the implementation of - 'System.Win32.Types.withHandleToHANDLENative'. - -} -#else - toMaybeWindowsHandle _ = Nothing -#endif - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for reading if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" - handleStateVarReadingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for writing if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" - handleStateVarWritingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for reading if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" - handleStateVarReadingBiased - getWindowsHandle - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for writing if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" - handleStateVarWritingBiased - getWindowsHandle - flushBuffer - -{-| - Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiasedRaw - = withOSHandle "withFileDescriptorReadingBiasedRaw" - handleStateVarReadingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiasedRaw - = withOSHandle "withFileDescriptorWritingBiasedRaw" - handleStateVarWritingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiasedRaw - = withOSHandle "withWindowsHandleReadingBiasedRaw" - handleStateVarReadingBiased - getWindowsHandle - (const $ return ()) - -{-| - Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiasedRaw - = withOSHandle "withWindowsHandleWritingBiasedRaw" - handleStateVarWritingBiased - getWindowsHandle - (const $ return ()) - --- ** Caveats - -{-$with-ref-caveats - #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve - as the target of the hyperlinks above. The real documentation of the caveats - is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which - re-exports the above operations. --} ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -26,17 +26,19 @@ module GHC.Internal.TH.Monad import Prelude import Data.Data hiding (Fixity(..)) import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe (unsafePerformIO) import Control.Monad.IO.Class (MonadIO (..)) -import System.IO ( hPutStrLn, stderr ) +import System.IO (FilePath, hPutStrLn, stderr) import qualified Data.Kind as Kind (Type) -import GHC.Types (TYPE, RuntimeRep(..)) +import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.Traversable import GHC.Internal.IORef -import GHC.Internal.System.IO +import GHC.Internal.IO (FilePath) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.IO.StdHandles (stderr) import GHC.Internal.Data.Foldable import GHC.Internal.Data.Typeable import GHC.Internal.Control.Monad.IO.Class @@ -819,38 +821,6 @@ addTempFile suffix = Q (qAddTempFile suffix) addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) - --- | Emit a foreign file which will be compiled and linked to the object for --- the current module. Currently only languages that can be compiled with --- the C compiler are supported, and the flags passed as part of -optc will --- be also applied to the C compiler invocation that will compile them. --- --- Note that for non-C languages (for example C++) @extern "C"@ directives --- must be used to get symbols that we can access from Haskell. --- --- To get better errors, it is recommended to use #line pragmas when --- emitting C files, e.g. --- --- > {-# LANGUAGE CPP #-} --- > ... --- > addForeignSource LangC $ unlines --- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ --- > , ... --- > ] -addForeignSource :: ForeignSrcLang -> String -> Q () -addForeignSource lang src = do - let suffix = case lang of - LangC -> "c" - LangCxx -> "cpp" - LangObjc -> "m" - LangObjcxx -> "mm" - LangAsm -> "s" - LangJs -> "js" - RawObject -> "a" - path <- addTempFile suffix - runIO $ writeFile path src - addForeignFilePath lang path - -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in -- conjunction with 'addTempFile'. ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -209,7 +209,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) -- This module completely re-exports 'GHC.Boot.TH.Syntax', --- and exports additionally functions that depend on filepath. +-- and exports additionally functions that depend on @filepath@ or @System.IO@. -- | addForeignFile :: ForeignSrcLang -> String -> Q () @@ -218,6 +218,37 @@ addForeignFile = addForeignSource "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" #-} -- deprecated in 8.6 +-- | Emit a foreign file which will be compiled and linked to the object for +-- the current module. Currently only languages that can be compiled with +-- the C compiler are supported, and the flags passed as part of -optc will +-- be also applied to the C compiler invocation that will compile them. +-- +-- Note that for non-C languages (for example C++) @extern "C"@ directives +-- must be used to get symbols that we can access from Haskell. +-- +-- To get better errors, it is recommended to use #line pragmas when +-- emitting C files, e.g. +-- +-- > {-# LANGUAGE CPP #-} +-- > ... +-- > addForeignSource LangC $ unlines +-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ +-- > , ... +-- > ] +addForeignSource :: ForeignSrcLang -> String -> Q () +addForeignSource lang src = do + let suffix = case lang of + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" + LangObjcxx -> "mm" + LangAsm -> "s" + LangJs -> "js" + RawObject -> "a" + path <- addTempFile suffix + runIO $ writeFile path src + addForeignFilePath lang path + -- | The input is a filepath, which if relative is offset by the package root. makeRelativeToProject :: FilePath -> Q FilePath makeRelativeToProject fp | isRelative fp = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4325be38f440fe33a2d583fe3f63a0c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4325be38f440fe33a2d583fe3f63a0c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/system-io-uncovering] Remove in-package dependencies on `GHC.Internal.System.IO`
by Wolfgang Jeltsch (＠jeltsch) 03 Mar '26

03 Mar '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-uncovering at Glasgow Haskell Compiler / GHC Commits: b8df08ac by Wolfgang Jeltsch at 2026-03-03T15:21:55+02:00 Remove in-package dependencies on `GHC.Internal.System.IO` This contribution eliminates all dependencies on `GHC.Internal.System.IO` from within `ghc-internal`. It comprises the following changes: * Make `GHC.Internal.Fingerprint` independent of I/O support * Tighten the dependencies of `GHC.Internal.Data.Version` * Tighten the dependencies of `GHC.Internal.TH.Monad` * Tighten the dependencies of `GHCi.Helpers` * Move the `* -> *` `Heap.Closure` instances into `ghc-heap` * Move some code that needs `System.IO` to `template-haskell` * Move the `GHC.ResponseFile` implementation into `base` * Move the `System.Exit` implementation into `base` * Move the `System.IO.OS` implementation into `base` Metric Decrease: size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip - - - - - 14 changed files: - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs - − libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs Changes: ===================================== libraries/base/src/GHC/Fingerprint.hs ===================================== @@ -9,3 +9,45 @@ module GHC.Fingerprint ( ) where import GHC.Internal.Fingerprint + +import Data.Function (($)) +import Control.Monad (return, when) +import Data.Bool (not, (&&)) +import Data.List ((++)) +import Data.Maybe (Maybe (Nothing, Just)) +import Data.Int (Int) +import Data.Word (Word8) +import Data.Eq ((/=)) +import Text.Show (show) +import System.IO + ( + IO, + FilePath, + IOMode (ReadMode), + withBinaryFile, + hGetBuf, + hIsEOF + ) +import Foreign.Ptr (Ptr) +import GHC.Err (errorWithoutStackTrace) + +-- | Computes the hash of a given file. +-- This function runs in constant memory. +-- +-- @since base-4.7.0.0 +getFileHash :: FilePath -> IO Fingerprint +getFileHash path = withBinaryFile path ReadMode $ \ hdl -> + let + readChunk :: Ptr Word8 -> Int -> IO (Maybe Int) + readChunk bufferPtr bufferSize = do + chunkSize <- hGetBuf hdl bufferPtr bufferSize + isFinished <- hIsEOF hdl + when (chunkSize /= bufferSize && not isFinished) + ( + errorWithoutStackTrace $ + "GHC.Fingerprint.getFileHash: could only read " ++ + show chunkSize ++ + " bytes, but more are available" + ) + return (if isFinished then Just chunkSize else Nothing) + in fingerprintBufferedStream readChunk ===================================== libraries/base/src/GHC/ResponseFile.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Safe #-} -- | @@ -19,4 +20,145 @@ module GHC.ResponseFile ( expandResponse ) where -import GHC.Internal.ResponseFile +import Control.Monad (return, (>>=), mapM) +import Control.Exception (IOException, catch) +import Data.Function (($), (.)) +import Data.Bool (Bool (False, True), otherwise, not, (||)) +import Data.Char (Char, isSpace) +import Data.List ((++), map, filter, concat, reverse) +import Data.String (String, unlines) +import Data.Functor (fmap) +import Data.Foldable (null, foldl') +import Data.Eq ((==)) +import Text.Show (show) +import System.Environment (getArgs) +import System.IO (IO, hPutStrLn, readFile, stderr) +import System.Exit (exitFailure) + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--\'two\' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechanism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like @\@foo@ will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== libraries/base/src/System/Exit.hs ===================================== @@ -21,4 +21,67 @@ module System.Exit die ) where -import GHC.Internal.System.Exit \ No newline at end of file +import GHC.IO.Exception + ( + IOErrorType (InvalidArgument), + IOException (IOError), + ExitCode (ExitSuccess, ExitFailure) + ) +import Control.Monad ((>>)) +import Control.Exception (throwIO, ioError) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Nothing)) +import Data.String (String) +import Data.Eq ((/=)) +import System.IO (IO, hPutStrLn, stderr) + +-- --------------------------------------------------------------------------- +-- exitWith + +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. +-- Normally this terminates the program, returning @code@ to the +-- program's caller. +-- +-- On program termination, the standard 'Handle's 'stdout' and +-- 'stderr' are flushed automatically; any other buffered 'Handle's +-- need to be flushed manually, otherwise the buffered data will be +-- discarded. +-- +-- A program that fails in any other way is treated as if it had +-- called 'exitFailure'. +-- A program that terminates successfully without calling 'exitWith' +-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. +-- +-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be +-- caught using the functions of "Control.Exception". This means that +-- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from +-- "Control.Exception") are also executed properly on 'exitWith'. +-- +-- Note: in GHC, 'exitWith' should be called from the main program +-- thread in order to exit the process. When called from another +-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the +-- exception will not cause the process itself to exit. +-- +exitWith :: ExitCode -> IO a +exitWith ExitSuccess = throwIO ExitSuccess +exitWith code@(ExitFailure n) + | n /= 0 = throwIO code + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) + +-- | The computation 'exitFailure' is equivalent to +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@, +-- where /exitfail/ is implementation-dependent. +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +-- | The computation 'exitSuccess' is equivalent to +-- 'exitWith' 'ExitSuccess', It terminates the program +-- successfully. +exitSuccess :: IO a +exitSuccess = exitWith ExitSuccess + +-- | Write given error message to `stderr` and terminate with `exitFailure`. +-- +-- @since base-4.8.0.0 +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-| This module bridges between Haskell handles and underlying operating-system @@ -21,17 +23,293 @@ module System.IO.OS ) where -import GHC.Internal.System.IO.OS +import Control.Monad (return) +import Control.Concurrent.MVar (MVar) +import Control.Exception (mask) +import Data.Function (const, (.), ($)) +import Data.Functor (fmap) +import Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Just)) +#endif +import Data.List ((++)) +import Data.String (String) +import Data.Typeable (Typeable, cast) +import System.IO (IO) +import GHC.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.IO.Windows.Handle ( - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE ) +#endif +import GHC.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import Foreign.Ptr (Ptr) +import Foreign.C.Types (CInt) + +-- * Obtaining POSIX file descriptors and Windows handles + +{-| + Executes a user-provided action on an operating-system handle that underlies + a Haskell handle. Before the user-provided action is run, user-defined + preparation based on the handle state that contains the operating-system + handle is performed. While the user-provided action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withOSHandle :: String + -- ^ The name of the overall operation + -> (Handle -> MVar Handle__) + {-^ + Obtaining of the handle state variable that holds the + operating-system handle + -} + -> (forall d. Typeable d => d -> IO a) + -- ^ Conversion of a device into an operating-system handle + -> (Handle__ -> IO ()) + -- ^ The preparation + -> Handle + -- ^ The Haskell handle to use + -> (a -> IO r) + -- ^ The action to execute on the operating-system handle + -> IO r +withOSHandle opName handleStateVar getOSHandle prepare handle act + = mask $ \ withOriginalMaskingState -> + withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do + osHandle <- getOSHandle dev + prepare handleState + withOriginalMaskingState $ act osHandle + where + + withHandleState = withHandle_' opName handle (handleStateVar handle) +{- + The 'withHandle_'' operation, which we use here, already performs masking. + Still, we have to employ 'mask', in order do obtain the operation that + restores the original masking state. The user-provided action should be + executed with this original masking state, as there is no inherent reason to + generally perform it with masking in place. The masking that 'withHandle_'' + performs is only for safely accessing handle state and thus constitutes an + implementation detail; it has nothing to do with the user-provided action. +-} +{- + The order of actions in 'withOSHandle' is such that any exception from + 'getOSHandle' is thrown before the user-defined preparation is performed. +-} + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for reading if the handle uses different state + variables for reading and writing. +-} +handleStateVarReadingBiased :: Handle -> MVar Handle__ +handleStateVarReadingBiased (FileHandle _ var) = var +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for writing if the handle uses different state + variables for reading and writing. +-} +handleStateVarWritingBiased :: Handle -> MVar Handle__ +handleStateVarWritingBiased (FileHandle _ var) = var +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar + +{-| + Yields the result of another operation if that operation succeeded, and + otherwise throws an exception that signals that the other operation failed + because some Haskell handle does not use an operating-system handle of a + required type. +-} +requiringOSHandleOfType :: String + -- ^ The name of the operating-system handle type + -> Maybe a + {-^ + The result of the other operation if it succeeded + -} + -> IO a +requiringOSHandleOfType osHandleTypeName + = maybe (ioException osHandleOfTypeRequired) return + where + + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + InappropriateType + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing + +{-| + Obtains the POSIX file descriptor of a device if the device contains one, + and throws an exception otherwise. +-} +getFileDescriptor :: Typeable d => d -> IO CInt +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast + +{-| + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. +-} +getWindowsHandle :: Typeable d => d -> IO (Ptr ()) +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where + + toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) +#if defined(mingw32_HOST_OS) + toMaybeWindowsHandle dev + | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) + = Just (toHANDLE nativeHandle) + | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) + = Just (toHANDLE consoleHandle) + | otherwise + = Nothing + {- + This is inspired by the implementation of + 'System.Win32.Types.withHandleToHANDLENative'. + -} +#else + toMaybeWindowsHandle _ = Nothing +#endif + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for reading if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" + handleStateVarReadingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for writing if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" + handleStateVarWritingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for reading if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" + handleStateVarReadingBiased + getWindowsHandle + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for writing if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" + handleStateVarWritingBiased + getWindowsHandle + flushBuffer + +{-| + Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiasedRaw + = withOSHandle "withFileDescriptorReadingBiasedRaw" + handleStateVarReadingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiasedRaw + = withOSHandle "withFileDescriptorWritingBiasedRaw" + handleStateVarWritingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiasedRaw + = withOSHandle "withWindowsHandleReadingBiasedRaw" + handleStateVarReadingBiased + getWindowsHandle + (const $ return ()) + +{-| + Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiasedRaw + = withOSHandle "withWindowsHandleWritingBiasedRaw" + handleStateVarWritingBiased + getWindowsHandle + (const $ return ()) -- ** Caveats ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -1,17 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} --- Late cost centres introduce a thunk in the asBox function, which leads to --- an additional wrapper being added to any value placed inside a box. --- This can be removed once our boot compiler is no longer affected by #25212 -{-# OPTIONS_GHC -fno-prof-late #-} -{-# LANGUAGE NamedFieldPuns #-} - module GHC.Exts.Heap.Closures ( -- * Closures Closure ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -284,7 +284,6 @@ Library GHC.Internal.Read GHC.Internal.Real GHC.Internal.Records - GHC.Internal.ResponseFile GHC.Internal.RTS.Flags GHC.Internal.RTS.Flags.Test GHC.Internal.ST @@ -323,10 +322,8 @@ Library GHC.Internal.Numeric.Natural GHC.Internal.System.Environment GHC.Internal.System.Environment.Blank - GHC.Internal.System.Exit GHC.Internal.System.IO GHC.Internal.System.IO.Error - GHC.Internal.System.IO.OS GHC.Internal.System.Mem GHC.Internal.System.Mem.StableName GHC.Internal.System.Posix.Internals ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Version.hs ===================================== @@ -41,8 +41,7 @@ import GHC.Internal.Data.Eq import GHC.Internal.Int ( Int ) import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord -import GHC.Internal.Data.String ( String ) -import GHC.Internal.Base ( Applicative(..), (&&) ) +import GHC.Internal.Base ( Applicative(..), (&&), String ) import GHC.Internal.Generics import GHC.Internal.Unicode ( isDigit, isAlphaNum ) import GHC.Internal.Read ===================================== libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs ===================================== @@ -16,23 +16,22 @@ module GHC.Internal.Fingerprint ( fingerprintData, fingerprintString, fingerprintFingerprints, - getFileHash + fingerprintBufferedStream ) where import GHC.Internal.IO import GHC.Internal.Base import GHC.Internal.Bits import GHC.Internal.Num +import GHC.Internal.Data.Maybe import GHC.Internal.List import GHC.Internal.Real import GHC.Internal.Word -import GHC.Internal.Show import GHC.Internal.Ptr import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Marshal.Alloc import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Foreign.Storable -import GHC.Internal.System.IO import GHC.Internal.Fingerprint.Type @@ -71,41 +70,27 @@ fingerprintString str = unsafeDupablePerformIO $ fromIntegral (w32 `shiftR` 8), fromIntegral w32] --- | Computes the hash of a given file. --- This function loops over the handle, running in constant memory. --- --- @since base-4.7.0.0 -getFileHash :: FilePath -> IO Fingerprint -getFileHash path = withBinaryFile path ReadMode $ \h -> +-- | Reads data in chunks and computes its hash. +-- This function runs in constant memory. +fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int)) + -> IO Fingerprint +fingerprintBufferedStream readChunk = allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do c_MD5Init pctxt - - processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size)) - + allocaBytes _BUFSIZE $ \arrPtr -> + let loop = do + maybeRemainderSize <- readChunk arrPtr _BUFSIZE + c_MD5Update pctxt + arrPtr + (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize)) + when (isNothing maybeRemainderSize) loop + in loop allocaBytes 16 $ \pdigest -> do c_MD5Final pdigest pctxt peek (castPtr pdigest :: Ptr Fingerprint) - where _BUFSIZE = 4096 - -- Loop over _BUFSIZE sized chunks read from the handle, - -- passing the callback a block of bytes and its size. - processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO () - processChunks h f = allocaBytes _BUFSIZE $ \arrPtr -> - - let loop = do - count <- hGetBuf h arrPtr _BUFSIZE - eof <- hIsEOF h - when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $ - "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes" - - f arrPtr count - - when (not eof) loop - - in loop - data MD5Context foreign import ccall unsafe "__hsbase_MD5Init" ===================================== libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs ===================================== @@ -24,9 +24,10 @@ module GHC.Internal.GHCi.Helpers , evalWrapper ) where -import GHC.Internal.Base -import GHC.Internal.System.IO -import GHC.Internal.System.Environment +import GHC.Internal.Base (String, IO) +import GHC.Internal.IO.Handle (BufferMode (NoBuffering), hSetBuffering, hFlush) +import GHC.Internal.IO.StdHandles (stdin, stdout, stderr) +import GHC.Internal.System.Environment (withProgName, withArgs) disableBuffering :: IO () disableBuffering = do ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs deleted ===================================== @@ -1,163 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.ResponseFile --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : internal --- Portability : portable --- --- GCC style response files. --- --- @since base-4.12.0.0 ----------------------------------------------------------------------------- - --- Migrated from Haddock. - -module GHC.Internal.ResponseFile ( - getArgsWithResponseFiles, - unescapeArgs, - escapeArgs, escapeArg, - expandResponse - ) where - -import GHC.Internal.Control.Exception -import GHC.Internal.Data.Foldable (Foldable(..)) -import GHC.Internal.Base -import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.List (filter, unlines, concat, reverse) -import GHC.Internal.Text.Show (show) -import GHC.Internal.System.Environment (getArgs) -import GHC.Internal.System.Exit (exitFailure) -import GHC.Internal.System.IO - -{-| -Like 'getArgs', but can also read arguments supplied via response files. - - -For example, consider a program @foo@: - -@ -main :: IO () -main = do - args <- getArgsWithResponseFiles - putStrLn (show args) -@ - - -And a response file @args.txt@: - -@ ---one 1 ---\'two\' 2 ---"three" 3 -@ - -Then the result of invoking @foo@ with @args.txt@ is: - -> > ./foo @args.txt -> ["--one","1","--two","2","--three","3"] - --} -getArgsWithResponseFiles :: IO [String] -getArgsWithResponseFiles = getArgs >>= expandResponse - --- | Given a string of concatenated strings, separate each by removing --- a layer of /quoting/ and\/or /escaping/ of certain characters. --- --- These characters are: any whitespace, single quote, double quote, --- and the backslash character. The backslash character always --- escapes (i.e., passes through without further consideration) the --- character which follows. Characters can also be escaped in blocks --- by quoting (i.e., surrounding the blocks with matching pairs of --- either single- or double-quotes which are not themselves escaped). --- --- Any whitespace which appears outside of either of the quoting and --- escaping mechanisms, is interpreted as having been added by this --- special concatenation process to designate where the boundaries --- are between the original, un-concatenated list of strings. These --- added whitespace characters are removed from the output. --- --- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - --- | Given a list of strings, concatenate them into a single string --- with escaping of certain characters, and the addition of a newline --- between each string. The escaping is done by adding a single --- backslash character before any whitespace, single quote, double --- quote, or backslash character, so this escaping character must be --- removed. Unescaped whitespace (in this case, newline) is part --- of this "transport" format to indicate the end of the previous --- string and the start of a new string. --- --- While 'unescapeArgs' allows using quoting (i.e., convenient --- escaping of many characters) by having matching sets of single- or --- double-quotes,'escapeArgs' does not use the quoting mechanism, --- and thus will always escape any whitespace, quotes, and --- backslashes. --- --- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" -escapeArgs :: [String] -> String -escapeArgs = unlines . map escapeArg - --- | Arguments which look like @\@foo@ will be replaced with the --- contents of file @foo@. A gcc-like syntax for response files arguments --- is expected. This must re-constitute the argument list by doing an --- inverse of the escaping mechanism done by the calling-program side. --- --- We quit if the file is not found or reading somehow fails. --- (A convenience routine for haddock or possibly other clients) -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . unescapeArgs - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs ===================================== libraries/ghc-internal/src/GHC/Internal/System/Exit.hs deleted ===================================== @@ -1,81 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.System.Exit --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : provisional --- Portability : portable --- --- Exiting the program. --- ------------------------------------------------------------------------------ - -module GHC.Internal.System.Exit - ( - ExitCode(ExitSuccess,ExitFailure) - , exitWith - , exitFailure - , exitSuccess - , die - ) where - -import GHC.Internal.System.IO - -import GHC.Internal.Base -import GHC.Internal.IO -import GHC.Internal.IO.Exception - --- --------------------------------------------------------------------------- --- exitWith - --- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. --- Normally this terminates the program, returning @code@ to the --- program's caller. --- --- On program termination, the standard 'Handle's 'stdout' and --- 'stderr' are flushed automatically; any other buffered 'Handle's --- need to be flushed manually, otherwise the buffered data will be --- discarded. --- --- A program that fails in any other way is treated as if it had --- called 'exitFailure'. --- A program that terminates successfully without calling 'exitWith' --- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. --- --- As an 'ExitCode' is an 'Control.Exception.Exception', it can be --- caught using the functions of "Control.Exception". This means that --- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from --- "Control.Exception") are also executed properly on 'exitWith'. --- --- Note: in GHC, 'exitWith' should be called from the main program --- thread in order to exit the process. When called from another --- thread, 'exitWith' will throw an 'ExitCode' as normal, but the --- exception will not cause the process itself to exit. --- -exitWith :: ExitCode -> IO a -exitWith ExitSuccess = throwIO ExitSuccess -exitWith code@(ExitFailure n) - | n /= 0 = throwIO code - | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) - --- | The computation 'exitFailure' is equivalent to --- 'exitWith' @(@'ExitFailure' /exitfail/@)@, --- where /exitfail/ is implementation-dependent. -exitFailure :: IO a -exitFailure = exitWith (ExitFailure 1) - --- | The computation 'exitSuccess' is equivalent to --- 'exitWith' 'ExitSuccess', It terminates the program --- successfully. -exitSuccess :: IO a -exitSuccess = exitWith ExitSuccess - --- | Write given error message to `stderr` and terminate with `exitFailure`. --- --- @since base-4.8.0.0 -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs deleted ===================================== @@ -1,323 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - -{-| - This module bridges between Haskell handles and underlying operating-system - features. --} -module GHC.Internal.System.IO.OS -( - -- * Obtaining file descriptors and Windows handles - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw - - -- ** Caveats - -- $with-ref-caveats -) -where - -#if defined(mingw32_HOST_OS) -import GHC.Internal.Base (otherwise) -#endif -import GHC.Internal.Control.Monad (return) -import GHC.Internal.Control.Concurrent.MVar (MVar) -import GHC.Internal.Control.Exception (mask) -import GHC.Internal.Data.Function (const, (.), ($)) -import GHC.Internal.Data.Functor (fmap) -import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) -#if defined(mingw32_HOST_OS) -import GHC.Internal.Data.Maybe (Maybe (Just)) -#endif -import GHC.Internal.Data.List ((++)) -import GHC.Internal.Data.String (String) -import GHC.Internal.Data.Typeable (Typeable, cast) -import GHC.Internal.System.IO (IO) -import GHC.Internal.IO.FD (fdFD) -#if defined(mingw32_HOST_OS) -import GHC.Internal.IO.Windows.Handle - ( - NativeHandle, - ConsoleHandle, - IoHandle, - toHANDLE - ) -#endif -import GHC.Internal.IO.Handle.Types - ( - Handle (FileHandle, DuplexHandle), - Handle__ (Handle__, haDevice) - ) -import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) -import GHC.Internal.IO.Exception - ( - IOErrorType (InappropriateType), - IOException (IOError), - ioException - ) -import GHC.Internal.Foreign.Ptr (Ptr) -import GHC.Internal.Foreign.C.Types (CInt) - --- * Obtaining POSIX file descriptors and Windows handles - -{-| - Executes a user-provided action on an operating-system handle that underlies - a Haskell handle. Before the user-provided action is run, user-defined - preparation based on the handle state that contains the operating-system - handle is performed. While the user-provided action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withOSHandle :: String - -- ^ The name of the overall operation - -> (Handle -> MVar Handle__) - {-^ - Obtaining of the handle state variable that holds the - operating-system handle - -} - -> (forall d. Typeable d => d -> IO a) - -- ^ Conversion of a device into an operating-system handle - -> (Handle__ -> IO ()) - -- ^ The preparation - -> Handle - -- ^ The Haskell handle to use - -> (a -> IO r) - -- ^ The action to execute on the operating-system handle - -> IO r -withOSHandle opName handleStateVar getOSHandle prepare handle act - = mask $ \ withOriginalMaskingState -> - withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do - osHandle <- getOSHandle dev - prepare handleState - withOriginalMaskingState $ act osHandle - where - - withHandleState = withHandle_' opName handle (handleStateVar handle) -{- - The 'withHandle_'' operation, which we use here, already performs masking. - Still, we have to employ 'mask', in order do obtain the operation that - restores the original masking state. The user-provided action should be - executed with this original masking state, as there is no inherent reason to - generally perform it with masking in place. The masking that 'withHandle_'' - performs is only for safely accessing handle state and thus constitutes an - implementation detail; it has nothing to do with the user-provided action. --} -{- - The order of actions in 'withOSHandle' is such that any exception from - 'getOSHandle' is thrown before the user-defined preparation is performed. --} - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for reading if the handle uses different state - variables for reading and writing. --} -handleStateVarReadingBiased :: Handle -> MVar Handle__ -handleStateVarReadingBiased (FileHandle _ var) = var -handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for writing if the handle uses different state - variables for reading and writing. --} -handleStateVarWritingBiased :: Handle -> MVar Handle__ -handleStateVarWritingBiased (FileHandle _ var) = var -handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar - -{-| - Yields the result of another operation if that operation succeeded, and - otherwise throws an exception that signals that the other operation failed - because some Haskell handle does not use an operating-system handle of a - required type. --} -requiringOSHandleOfType :: String - -- ^ The name of the operating-system handle type - -> Maybe a - {-^ - The result of the other operation if it succeeded - -} - -> IO a -requiringOSHandleOfType osHandleTypeName - = maybe (ioException osHandleOfTypeRequired) return - where - - osHandleOfTypeRequired :: IOException - osHandleOfTypeRequired - = IOError Nothing - InappropriateType - "" - ("handle does not use " ++ osHandleTypeName ++ "s") - Nothing - Nothing - -{-| - Obtains the POSIX file descriptor of a device if the device contains one, - and throws an exception otherwise. --} -getFileDescriptor :: Typeable d => d -> IO CInt -getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . - fmap fdFD . cast - -{-| - Obtains the Windows handle of a device if the device contains one, and - throws an exception otherwise. --} -getWindowsHandle :: Typeable d => d -> IO (Ptr ()) -getWindowsHandle = requiringOSHandleOfType "Windows handle" . - toMaybeWindowsHandle - where - - toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) -#if defined(mingw32_HOST_OS) - toMaybeWindowsHandle dev - | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) - = Just (toHANDLE nativeHandle) - | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) - = Just (toHANDLE consoleHandle) - | otherwise - = Nothing - {- - This is inspired by the implementation of - 'System.Win32.Types.withHandleToHANDLENative'. - -} -#else - toMaybeWindowsHandle _ = Nothing -#endif - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for reading if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" - handleStateVarReadingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for writing if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" - handleStateVarWritingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for reading if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" - handleStateVarReadingBiased - getWindowsHandle - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for writing if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" - handleStateVarWritingBiased - getWindowsHandle - flushBuffer - -{-| - Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiasedRaw - = withOSHandle "withFileDescriptorReadingBiasedRaw" - handleStateVarReadingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiasedRaw - = withOSHandle "withFileDescriptorWritingBiasedRaw" - handleStateVarWritingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiasedRaw - = withOSHandle "withWindowsHandleReadingBiasedRaw" - handleStateVarReadingBiased - getWindowsHandle - (const $ return ()) - -{-| - Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiasedRaw - = withOSHandle "withWindowsHandleWritingBiasedRaw" - handleStateVarWritingBiased - getWindowsHandle - (const $ return ()) - --- ** Caveats - -{-$with-ref-caveats - #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve - as the target of the hyperlinks above. The real documentation of the caveats - is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which - re-exports the above operations. --} ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -26,17 +26,19 @@ module GHC.Internal.TH.Monad import Prelude import Data.Data hiding (Fixity(..)) import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe (unsafePerformIO) import Control.Monad.IO.Class (MonadIO (..)) -import System.IO ( hPutStrLn, stderr ) +import System.IO (FilePath, hPutStrLn, stderr) import qualified Data.Kind as Kind (Type) -import GHC.Types (TYPE, RuntimeRep(..)) +import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.Traversable import GHC.Internal.IORef -import GHC.Internal.System.IO +import GHC.Internal.IO (FilePath) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.IO.StdHandles (stderr) import GHC.Internal.Data.Foldable import GHC.Internal.Data.Typeable import GHC.Internal.Control.Monad.IO.Class @@ -819,38 +821,6 @@ addTempFile suffix = Q (qAddTempFile suffix) addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) - --- | Emit a foreign file which will be compiled and linked to the object for --- the current module. Currently only languages that can be compiled with --- the C compiler are supported, and the flags passed as part of -optc will --- be also applied to the C compiler invocation that will compile them. --- --- Note that for non-C languages (for example C++) @extern "C"@ directives --- must be used to get symbols that we can access from Haskell. --- --- To get better errors, it is recommended to use #line pragmas when --- emitting C files, e.g. --- --- > {-# LANGUAGE CPP #-} --- > ... --- > addForeignSource LangC $ unlines --- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ --- > , ... --- > ] -addForeignSource :: ForeignSrcLang -> String -> Q () -addForeignSource lang src = do - let suffix = case lang of - LangC -> "c" - LangCxx -> "cpp" - LangObjc -> "m" - LangObjcxx -> "mm" - LangAsm -> "s" - LangJs -> "js" - RawObject -> "a" - path <- addTempFile suffix - runIO $ writeFile path src - addForeignFilePath lang path - -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in -- conjunction with 'addTempFile'. ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -209,7 +209,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) -- This module completely re-exports 'GHC.Boot.TH.Syntax', --- and exports additionally functions that depend on filepath. +-- and exports additionally functions that depend on @filepath@ or @System.IO@. -- | addForeignFile :: ForeignSrcLang -> String -> Q () @@ -218,6 +218,37 @@ addForeignFile = addForeignSource "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" #-} -- deprecated in 8.6 +-- | Emit a foreign file which will be compiled and linked to the object for +-- the current module. Currently only languages that can be compiled with +-- the C compiler are supported, and the flags passed as part of -optc will +-- be also applied to the C compiler invocation that will compile them. +-- +-- Note that for non-C languages (for example C++) @extern "C"@ directives +-- must be used to get symbols that we can access from Haskell. +-- +-- To get better errors, it is recommended to use #line pragmas when +-- emitting C files, e.g. +-- +-- > {-# LANGUAGE CPP #-} +-- > ... +-- > addForeignSource LangC $ unlines +-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ +-- > , ... +-- > ] +addForeignSource :: ForeignSrcLang -> String -> Q () +addForeignSource lang src = do + let suffix = case lang of + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" + LangObjcxx -> "mm" + LangAsm -> "s" + LangJs -> "js" + RawObject -> "a" + path <- addTempFile suffix + runIO $ writeFile path src + addForeignFilePath lang path + -- | The input is a filepath, which if relative is offset by the package root. makeRelativeToProject :: FilePath -> Q FilePath makeRelativeToProject fp | isRelative fp = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8df08ace861178ccb3b2d2d00b9e5c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8df08ace861178ccb3b2d2d00b9e5c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/linkable-usage] WIP LinkableUsage
by Hannes Siebenhandl (＠fendor) 03 Mar '26

03 Mar '26

Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC Commits: f7a197f6 by fendor at 2026-03-03T14:08:32+01:00 WIP LinkableUsage - - - - - 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,33 @@ +module GHC.ByteCode.Recomp.Binary ( + -- * Fingerprinting ByteCode objects + computeFingerprint, +) where + +import GHC.Prelude + +import GHC.ByteCode.Binary (addBinNameWriter) +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 + put_ 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 @@ -667,6 +667,7 @@ findBytecodeLinkableMaybe hsc_env mod locn = do case maybe_bytecode_time of Nothing -> return Nothing Just bytecode_time -> do + -- TODO: @fendor This must go -- Also load the interface, for reasons to do with recompilation avoidance. -- See Note [Recompilation avoidance with bytecode objects] _ <- initIfaceLoad hsc_env $ @@ -723,7 +724,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 +824,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 +953,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) - [Linkable]) -- New linkables (excluding dups) +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 {- ********************************************************************** @@ -974,7 +975,7 @@ rmDupLinkables already ls dynLinkBCOs :: Interp -> LoaderState -> KeepModuleLinkableDefinitions -> [Linkable] -> IO LoaderState dynLinkBCOs interp pls keep_spec bcos = - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos -- TODO: @fendor, convert to linkable usage here? pls1 = pls { bcos_loaded = bcos_loaded' } cbcs :: [CompiledByteCode] @@ -1115,7 +1116,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 +1126,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 +1134,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/-/commit/f7a197f6f0fe6f793e097a81fc3fb2e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7a197f6f0fe6f793e097a81fc3fb2e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/backports-9.12.4] 70 commits: Allow users to customise the collection of exception annotations
by Zubin (＠wz1000) 03 Mar '26

03 Mar '26

Zubin pushed to branch wip/backports-9.12.4 at Glasgow Haskell Compiler / GHC Commits: f3cb6ffa by fendor at 2026-03-03T16:34:59+05:30 Allow users to customise the collection of exception annotations Add a global `CollectExceptionAnnotationMechanism` which determines how `ExceptionAnnotation`s are collected upon throwing an `Exception`. This API is exposed via `ghc-experimental`. By overriding how we collect `Backtraces`, we can control how the `Backtraces` are displayed to the user by newtyping `Backtraces` and giving a different instance for `ExceptionAnnotation`. A concrete use-case for this feature is allowing us to experiment with alternative stack decoders, without having to modify `base`, which take additional information from the stack frames. This commit does not modify how `Backtraces` are currently collected or displayed. (cherry picked from commit dee28cdd794652a3ebc271184e2ab3c866b5e219) - - - - - f34b8530 by fendor at 2026-03-03T16:34:59+05:30 Expose Backtraces internals from ghc-experimental Additionally, expose the same API `base:Control.Exception.Backtrace` to make it easier to use as a drop-in replacement. (cherry picked from commit 6602472273e1cdffcdb7753c9133047e571896bd) - - - - - 0469b8d0 by Zubin Duggal at 2026-03-03T16:34:59+05:30 testsuite: Be more permissive when filtering out GNU_PROPERTY_TYPE linker warnings The warning text is slightly different with ld.bfd. Fixes #26249 (cherry picked from commit 51c701fef034e2062809eed5de3a51bb0a4243ba) - - - - - 1608afe0 by Cheng Shao at 2026-03-03T16:34:59+05:30 hadrian: enforce have_llvm=False for wasm32/js This patch fixes hadrian to always pass have_llvm=False to the testsuite driver for wasm32/js targets. These targets don't really support the LLVM backend, and the optllvm test way doesn't work. We used to special-case wasm32/js to avoid auto-adding optllvm way in testsuite/config/ghc, but this is still problematic if someone writes a new LLVM-related test and uses something like when(have_llvm(), extra_ways(["optllvm"])). So better just enforce have_llvm=False for these targets here. (cherry picked from commit 1cdc6f46c4168dd92a8f5ea0c398b67fc59449a9) - - - - - 317f1d4f by Cheng Shao at 2026-03-03T16:34:59+05:30 libffi: update to 3.5.2 Bumps libffi submodule. (cherry picked from commit 45dbfa23f508f221b6aeb667783a928511a7654e) - - - - - 04cddfe3 by Cheng Shao at 2026-03-03T16:34:59+05:30 wasm: ensure setKeepCAFs() is called in ghci This patch is a critical bugfix for #26106, see comment and linked issue for details. (cherry picked from commit 10f06163d9adcb3b6e6438f1524faaca3bf6c3b2) - - - - - 19040130 by sheaf at 2026-03-03T16:34:59+05:30 Use tcMkScaledFunTys in matchExpectedFunTys We should use tcMkScaledFunTys rather than mkScaledFunTys in GHC.Tc.Utils.Unify.matchExpectedFunTys, as the latter crashes when the kind of the result type is a bare metavariable. We know the result is always Type-like, so we don't need scaledFunTys to try to rediscover that from the kind. Fixes #26277 (cherry picked from commit 624afa4a65caa8ec23f85e70574dfb606f90c173) - - - - - acf1860c by sheaf at 2026-03-03T16:34:59+05:30 Improve Notes about disambiguating record updates This commit updates the notes [Disambiguating record updates] and [Type-directed record disambiguation], in particular adding more information about the deprecation status of type-directed disambiguation of record updates. (cherry picked from commit a2d9d7c2073867ee0cabb8d49f93246d95ec0b09) - - - - - 9cd8faa5 by sheaf at 2026-03-03T16:34:59+05:30 Add test for #26216 (cherry picked from commit 2e73f3426ab6e3cf1938b53831005593f3fd351c) - - - - - 0ae0a7db by Vladislav Zavialov at 2026-03-03T16:34:59+05:30 Fix PREP_MAYBE_LIBRARY in prep_target_file.m4 This change fixes a configure error introduced in: commit 8235dd8c4945db9cb03e3be3c388d729d576ed1e ghc-toolchain: Move UseLibdw to per-Target file Now the build no longer fails with: acghc-toolchain: Failed to read a valid Target value from hadrian/cfg/default.target (cherry picked from commit 1480872af6b80db1b035a44409188416df041048) - - - - - 8bedc98f by Cheng Shao at 2026-03-03T16:34:59+05:30 rts: remove obsolete CC_SUPPORTS_TLS logic This patch removes obsolete CC_SUPPORTS_TLS logic throughout the rts, given __thread is now uniformly supported by C toolchains of all platforms we currently support. (cherry picked from commit 0f034942724233e1457549123b46880f7b93e805) - - - - - 2799bcb4 by Cheng Shao at 2026-03-03T16:34:59+05:30 rts: remove obsolete HAS_VISIBILITY_HIDDEN logic This patch removes obsolete HAS_VISIBILITY_HIDDEN logic throughout the rts, given __attribute__((visibility("hidden"))) is uniformly supported by C toolchains of all platforms we currently support. (cherry picked from commit ef7056554df5603ec4d1e33193abe953970e6ab3) - - - - - 80f04f24 by Cheng Shao at 2026-03-03T16:35:00+05:30 rts: remove -O3 pragma hack in Hash.c This patch removes an obsolete gcc pragma to specify -O3 in Hash.c. Hadrian already passes the right flag. (cherry picked from commit 9fdc1f7d855cc61f90de909875f6ae0d6798dca7) - - - - - a7ed406a by Cheng Shao at 2026-03-03T16:35:00+05:30 wasm: fix dyld handling for forward declared GOT.func items This patch fixes wasm shared linker's handling of forward declared GOT.func items, see linked issue for details. Also adds T26430 test to witness the fix. Fixes #26430. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 867c26755e8855c6df949e65df0c2aebc9da64c3) - - - - - 1d0e59b5 by Cheng Shao at 2026-03-03T16:35:00+05:30 rts: remove obsolete __GNUC__ related logic This patch removes obsolete `__GNUC__` related logic, given on any currently supported platform and toolchain, `__GNUC__ >= 4` is universally true. Also pulls some other weeds and most notably, use `__builtin___clear_cache` for clang as well, since clang has supported this gcc intrinsic since 2014, see https://github.com/llvm/llvm-project/commit/c491a8d4577052bc6b3b4c72a7db6a7…. (cherry picked from commit 67de53a6ced23caad640d2c7421089242f0dfb76) - - - - - f09d6f18 by Cheng Shao at 2026-03-03T16:35:00+05:30 hadrian: fix GHC.Platform.Host generation for cross stage1 This patch fixes incorrectly GHC.Platform.Host generation logic for cross stage1 in hadrian (#26449). Also adds T26449 test case to witness the fix. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 8cbe006ad09d5a64e4a3cdf4c91a8b81ff1511be) - - - - - 4d1f030f by Luite Stegeman at 2026-03-03T16:35:00+05:30 rts: Fix lost wakeups in threadPaused for threads blocked on black holes The lazy blackholing code in threadPaused could overwrite closures that were already eagerly blackholed, and as such wouldn't have a marked update frame. If the black hole was overwritten by its original owner, this would lead to an undetected collision, and the contents of any existing blocking queue being lost. This adds a check for eagerly blackholed closures and avoids overwriting their contents. Fixes #26324 (cherry picked from commit a1de535f762bc23d4cf23a5b1853591dda12cdc9) - - - - - 52da5ad6 by Luite Stegeman at 2026-03-03T16:35:00+05:30 rts: push the correct update frame in stg_AP_STACK The frame contains an eager black hole (__stg_EAGER_BLACKHOLE_info) so we should push an stg_bh_upd_frame_info instead of an stg_upd_frame_info. (cherry picked from commit b7e21e498d39e0ee764e3237544b4c39ddf98467) - - - - - 166e7016 by Cheng Shao at 2026-03-03T16:35:00+05:30 testsuite: remove unused expected output files This patch removes unused expected output files in the testsuites on platforms that we no longer support. (cherry picked from commit 6992ac097b9da989f125f896afe21b75dba8b4c9) - - - - - 4df0eeb0 by Ben Gamari at 2026-03-03T16:35:00+05:30 rts/posix: Enforce iteration limit on heap reservation logic Previously we could loop indefinitely when attempting to get an address space reservation for our heap. Limit the logic to 8 iterations to ensure we instead issue a reasonable error message. Addresses #26151. (cherry picked from commit ff1650c96c61af02e193854312a9ccd303968e47) - - - - - 9d41ca6e by Ben Gamari at 2026-03-03T16:35:00+05:30 rts/posix: Hold on to low reservations when reserving heap Previously when the OS gave us an address space reservation in low memory we would immediately release it and try again. However, on some platforms this meant that we would get the same allocation again in the next iteration (since mmap's `hint` argument is just that, a hint). Instead we now hold on to low reservations until we have found a suitable heap reservation. Fixes #26151. (cherry picked from commit 0184455728f841a699648f879fdb29128081fc6b) - - - - - dd07582d by Julian Ospald at 2026-03-03T16:35:00+05:30 ghc-toolchain: Drop `ld.gold` from merge object command It's deprecated. Also see #25716 (cherry picked from commit c58f9a615f05e9d43629f6e846ae22cad2a6163d) - - - - - 2fb93a78 by Ben Gamari at 2026-03-03T16:35:00+05:30 gitlab-ci: Make RELEASE_JOB an input Rather than an undocumented variable. (cherry picked from commit f9790ca81deb8b14ff2eabf701aecbcfd6501963) - - - - - b5c445b4 by Cheng Shao at 2026-03-03T16:35:00+05:30 testsuite: fix T3586 for non-SSE3 platforms `T3586.hs` contains `-fvia-C -optc-msse3` which I think is a best-effort basis to harvest the C compiler's auto vectorization optimizations via the C backend back when the test was added. The `-fvia-C` part is now a deprecated no-op because GHC can't fall back to the C backend on a non-unregisterised build, and `-optc-msse3` might actually cause the test to fail on non x86/x64 platforms, e.g. recent builds of wasi-sdk would report `wasm32-wasi-clang: error: unsupported option '-msse3' for target 'wasm32-unknown-wasi'`. So this patch cleans up this historical cruft. `-fvia-C` is removed, and `-optc-msse3` is only passed when cpuid contains `pni` (which indicates support of SSE3). (cherry picked from commit 70ee825a516bcf7aac762bfedb4a017d35f8dcf3) - - - - - 8836b947 by Julian Ospald at 2026-03-03T16:35:00+05:30 Improve error handling in 'getPackageArchives' When the library dirs in the package conf files are not set up correctly, the JS linker will happily ignore such packages and not link against them, although they're part of the link plan. Fixes #26383 (cherry picked from commit 91b6be10bd58c2bfc1c7c22e81b06ab3be583228) - - - - - 6d883ca9 by Ben Gamari at 2026-03-03T16:35:00+05:30 rts: Annotate BCOs with their Name This introduces a new bytecode instruction, `BCO_NAME`, to aid in debugging bytecode execution. This instruction is injected by `mkProtoBCO` and captures the Haskell name of the BCO. It is then printed by the disassembler, allowing ready correlation with STG dumps. (cherry picked from commit 5192a75fe9b272e8b1ef290fa834714c81bd1f79) - - - - - 3dde94cd by sheaf at 2026-03-03T16:35:00+05:30 Bad record update msg: allow out-of-scope datacons This commit ensures that, when we encounter an invalid record update (because no constructor exists which contains all of the record fields mentioned in the record update), we graciously handle the situation in which the constructors themselves are not in scope. In that case, instead of looking up the constructors in the GlobalRdrEnv, directly look up their GREInfo using the lookupGREInfo function. Fixes #26391 (cherry picked from commit cef8938f3c0d22583f01d5ea29e6109bccd36040) - - - - - e7fcece4 by Cheng Shao at 2026-03-03T16:35:00+05:30 rts: remove obsolete COMPILING_WINDOWS_DLL logic This patch removes obsolete COMPILING_WINDOWS_DLL logic throughout the rts. They were once used for compiling to win32 DLLs, but we haven't been able to compile Haskell units to win32 DLLs for many years now, due to PE format's restriction of no more than 65536 exported symbols in a single DLL. (cherry picked from commit b8cfa8f741729ef123569fb321c4b2ab4a1a941c) - - - - - f22b7309 by Julian Ospald at 2026-03-03T16:35:00+05:30 Skip uniques test if sources are not available (cherry picked from commit 5dc2e9eaf60fd72771bf2e8112aec182665461a1) - - - - - cfdb79bf by Julian Ospald at 2026-03-03T16:35:00+05:30 rts: remove unneccesary cabal flags We perform those checks via proper autoconf macros instead that do the right thing and then add those libs to the rts buildinfo. (cherry picked from commit 643ce801a8b559071683cad0e5adbc26b9fc8385) - - - - - 42fd7682 by Wang Xin at 2026-03-03T16:35:00+05:30 Add -mcmodel=medium moduleflag to generated LLVM IR on LoongArch platform With the Medium code model, the jump range of the generated jump instruction is larger than that of the Small code model. It's a temporary fix of the problem descriped in https://gitlab.haskell .org/ghc/ghc/-/issues/25495. This commit requires that the LLVM used contains the code of commit 9dd1d451d9719aa91b3bdd59c0c6679 83e1baf05, i.e., version 8.0 and later. Actually we should not rely on LLVM, so the only way to solve this problem is to implement the LoongArch backend. Add new type for codemodel (cherry picked from commit e70d41406b5d5638b42c4d8222cd03e76bbfeb86) - - - - - 9dd4278e by Peng Fan at 2026-03-03T16:35:00+05:30 Pass the mcmodel=medium parameter to CC via GHC Ensure that GHC-driver builds default to mcmodel=medium, so that GHC passes this default parameter to CC without having to add it to the compiled project. Commit e70d41406b5d5638b42c4d8222cd03e76bbfeb86 does not ensure that all GHC-built object files have a default model of medium, and will raise an R_LARCH_B26 overflow error. (cherry picked from commit 1a3f11314cc7b8dbf9af03dd2ae2cb066a998d63) - - - - - 845258e5 by Ben Gamari at 2026-03-03T16:35:00+05:30 gitlab-ci: Run ghcup-metadata jobs on OpenCape runners This significantly reduces our egress traffic and makes the jobs significantly faster. (cherry picked from commit ff3f0d09bce1c261638b572af2bac1d87f1f6df7) - - - - - 27474eb7 by Luite Stegeman at 2026-03-03T16:35:00+05:30 rts: fix eager black holes: record mutated closure and fix assertion This fixes two problems with handling eager black holes, introduced by a1de535f762bc23d4cf23a5b1853591dda12cdc9. - the closure mutation must be recorded even for eager black holes, since the mutator has mutated it before calling threadPaused - The assertion that an unmarked eager black hole must be owned by the TSO calling threadPaused is incorrect, since multiple threads can race to claim the black hole. fixes #26495 (cherry picked from commit 3ba3d9f9db784c903ebe8fd617447ce62d30b7d3) - - - - - f2a5ec52 by ARATA Mizuki at 2026-03-03T16:35:00+05:30 LLVM backend: Pass the +evex512 attribute to LLVM 18+ if -mavx512f is set The newer LLVM requires the +evex512 attribute to enable use of ZMM registers. LLVM exhibits a backward-compatible behavior if the cpu is `x86-64`, but not if `penryn`. Therefore, on macOS, where the cpu is set to `penryn`, we need to explicitly pass +evex512. Fixes #26410 (cherry picked from commit b22777d4b7182f40a31eb430fa27f5fb9ef0f292) - - - - - e0b35b99 by Matthew Pickering at 2026-03-03T16:35:00+05:30 hadrian: Use a response file to invoke GHC for dep gathering. In some cases we construct an argument list too long for GHC to handle directly on windows. This happens when we generate the dependency file because the command line will contain references to a large number of .hs files. To avoid this we now invoke GHC using a response file when generating dependencies to sidestep length limitations. Note that we only pass the actual file names in the dependency file. Why? Because this side-steps #26560 (cherry picked from commit 9d371d23c526fd160d7e99bef2bc7da825cf3c0f) - - - - - af0b5f1e by Andreas Klebinger at 2026-03-03T16:35:00+05:30 Add hpc to release script (cherry picked from commit 64ec82ffa7f48399e18fcec43051d2b7ddcb7cc2) - - - - - 25d1768c by Matthew Pickering at 2026-03-03T16:35:00+05:30 rts: Fix a deadlock with eventlog flush interval and RTS shutdown The ghc_ticker thread attempts to flush at the eventlog tick interval, this requires waiting to take all capabilities. At the same time, the main thread is shutting down, the schedule is stopped and then we wait for the ticker thread to finish. Therefore we are deadlocked. The solution is to use `newBoundTask/exitMyTask`, so that flushing can cooperate with the scheduler shutdown. Fixes #26573 (cherry picked from commit b7fe744598b4569cd0236268e4f6f5b9d27e12b7) - - - - - e91c3d94 by Julian Ospald at 2026-03-03T16:35:00+05:30 rts: Fix object file format detection in loadArchive Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to have introduced this bug, ultimately leading to failure of test T11788. I can only theorize that this test isn't run in upstream's CI, because they don't build a static GHC. The culprit is that we go through the thin archive, trying to follow the members on the filesystem, but don't re-identify the new object format of the member. This pins `object_fmt` to `NotObject` from the thin archive. Thanks to @angerman for spotting this. (cherry picked from commit fc958fc9eb6f6f4db473cdda23c381da8f32163d) - - - - - bf30088c by Simon Peyton Jones at 2026-03-03T16:35:00+05:30 Add missing InVar->OutVar lookup in SetLevels As #26681 showed, the SetLevels pass was failing to map an InVar to an OutVar. Very silly! I'm amazed it hasn't broken before now. I have improved the type singatures (to mention InVar and OutVar) so it's more obvious what needs to happen. (cherry picked from commit 52d00c05e1d803b36c93295399fe931c871166bf) - - - - - c85a5eb7 by Cheng Shao at 2026-03-03T16:35:00+05:30 compiler: change sectionProtection to take SectionType argument This commit changes `sectionProtection` to only take `SectionType` argument instead of whole `Section`, since it doesn't need the Cmm section content anyway, and it can then be called in parts of NCG where we only have a `SectionType` in scope. (cherry picked from commit 2433e91d41675d56f48f82d22430a8dee915e7a0) - - - - - ceac560b by Cheng Shao at 2026-03-03T16:35:00+05:30 compiler: change isInitOrFiniSection to take SectionType argument This commit changes `isInitOrFiniSection` to only take `SectionType` argument instead of whole `Section`, since it doesn't need the Cmm section content anyway, and it can then be called in parts of NCG where we only have a `SectionType` in scope. Also marks it as exported. (cherry picked from commit e5926fbebf341ee547227d41710d78471eecd09c) - - - - - 16941b01 by Cheng Shao at 2026-03-03T16:35:00+05:30 compiler: fix split sections on windows This patch fixes split sections on windows by emitting the right COMDAT section header in NCG, see added comment for more explanation. Fix #26696 #26494. ------------------------- Metric Decrease: LargeRecord T9675 size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip Metric Increase: T13035 ------------------------- Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit 244d57d79a555dcecc7590287bb14976d561291a) - - - - - 38251395 by Matthew Pickering at 2026-03-03T16:35:00+05:30 rts: Use INFO_TABLE_CONSTR for stg_dummy_ret_closure Since the closure type is CONSTR_NOCAF, we need to use INFO_TABLE_CONSTR to populate the constructor description field (this crashes ghc-debug when decoding AP_STACK frames sometimes) Fixes #26745 (cherry picked from commit 322dd6726b11c7101c28ffb8aeb7cb4cee34ab56) - - - - - 64011deb by Matthew Pickering at 2026-03-03T16:35:00+05:30 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 (cherry picked from commit 94dcd15e54146abecf9b4f5e47d258ca3cd40f1b) - - - - - 4b5668e6 by fendor at 2026-03-03T16:35:00+05:30 Remove `traceId` from ghc-pkg executable (cherry picked from commit d0966e64880e9fa30ce07c0fa5ea28108c6e8ad9) - - - - - fd64a588 by sheaf at 2026-03-03T16:35:00+05:30 Don't re-use stack slots for growing registers This commit avoids re-using a stack slot for a register that has grown but already had a stack slot. For example, suppose we have stack slot assigments %v1 :: FF64 |-> StackSlot 0 %v2 :: FF64 |-> StackSlot 1 Later, we start using %v1 at a larger format (e.g. F64x2) and we need to spill it again. Then we **must not** use StackSlot 0, as a spill at format F64x2 would clobber the data in StackSlot 1. This can cause some fragmentation of the `StackMap`, but that's probably OK. Fixes #26668 (cherry picked from commit 023c301c51e7346af3d4d773c448277ad3645ad2) - - - - - 161aff8b by Cheng Shao at 2026-03-03T16:35:00+05:30 llvm: fix split sections for llvm backend This patch fixes split sections for llvm backend: - Pass missing `--data-sections`/`--function-sections` flags to llc/opt. - Use `(a)llvm.compiler.used` instead of `(a)llvm.used` to avoid sections being unnecessarily retained at link-time. Fixes #26770. ------------------------- Metric Decrease: libdir size_hello_artifact size_hello_unicode ------------------------- Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit b18b2c42c32488ad6d3480a56a1fcd753cad2023) - - - - - 330d8ba5 by Matthew Pickering at 2026-03-03T16:35:00+05:30 Fix ghc-experimental GHC.Exception.Backtrace.Experimental module This module wasn't added to the cabal file so it was never compiled or included in the library. (cherry picked from commit ee937134aa0ddf35c1a9dc7334c0aec0de13b719) - - - - - d0eb1c85 by Sylvain Henry at 2026-03-03T16:35:01+05:30 GC: don't use CAS without PARALLEL_GC on If we're not using the parallel GC, there is no reason to do a costly CAS. This was flagged as taking time in a perf profile. (cherry picked from commit 0491f08a965df0d6448bd9cd940d2b86fca2db5d) - - - - - ac3b7ef0 by Sylvain Henry at 2026-03-03T16:35:01+05:30 GC: suffix parallel GC with "par" instead of "thr" Avoid some potential confusion (see discussion in !15351). (cherry picked from commit 211a8f5633f0a5069c0689171f60b57719a242be) - - - - - 82071896 by Cheng Shao at 2026-03-03T16:35:01+05:30 testsuite: avoid re.sub in favor of simple string replacements This patch refactors the testsuite driver and avoids the usage of re.sub in favor of simple string replacements when possible. The changes are not comprehensive, and there are still a lot of re.sub usages lingering around the tree, but this already addresses a major performance bottleneck in the testsuite driver that might has to do with quadratic or worse slowdown in cpython's regular expression engine when handling certain regex patterns with large strings. Especially on i386, and i386 jobs are the bottlenecks of all full-ci validate pipelines! Here are the elapsed times of testing x86_64/i386 with -j48 before this patch: x86_64: `Build completed in 6m06s` i386: `Build completed in 1h36m` And with this patch: x86_64: `Build completed in 4m55s` i386: `Build completed in 4m23s` Fixes #26786. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit ca79475f6b4dfba991e2c933bac9c22d54a4950d) - - - - - d70c4204 by Zubin Duggal at 2026-03-03T16:35:01+05:30 hadrian: Add ghc-{experimental,internal}.cabal to the list of dependencies of the doc target We need these files to detect the version of these libraries Fixes #26738 (cherry picked from commit 1b490f5a7bbdb1441948241e6089b31efba9db45) - - - - - edec419b by Jessica Clarke at 2026-03-03T16:35:01+05:30 PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC There is no native instruction for this, and even if there were a register pair version we could use, the implementation here is assuming the values fit in a single register, and we end up only using / defining the low halves of the registers. Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes") Fixes: #23969 (cherry picked from commit ce2d62fba69d2ea0c74c46c50628feb8b81719d2) - - - - - 67eae519 by John Paul Adrian Glaubitz at 2026-03-03T16:35:01+05:30 rts: Switch prim to use modern atomic compiler builtins The __sync_*() atomic compiler builtins have been deprecated in GCC for a while now and also don't provide variants for 64-bit values such as __sync_fetch_and_add_8(). Thus, replace them with the modern __atomic_*() compiler builtins and while we're at it, also drop the helper macro CAS_NAND() which is now no longer needed since we stopped using the __sync_*() compiler builtins altogether. Co-authored-by: Ilias Tsitsimpis <iliastsi(a)debian.org> Fixes #26729 (cherry picked from commit 7c52c4f9bc8d6ae6404039ec02efe48fbf7a4778) - - - - - f0723f59 by sterni at 2026-03-03T16:35:01+05:30 users_guide: fix runtime error during build with Sphinx 9.1.0 Appears that pathto is stricter about what it accepts now. Tested Sphinx 8.2.3 and 9.1.0 on the ghc-9.10 branch. Resolves #26810. Co-authored-by: Martin Weinelt <hexa(a)darmstadt.ccc.de> (cherry picked from commit e8f5a45de561ec80c88cd3da2c66502deb32d4c3) - - - - - 667cc709 by Michael Karcher at 2026-03-03T16:35:01+05:30 NCG for PPC: add pattern for CmmRegOff to iselExpr64 Closes #26828 (cherry picked from commit 43d977619de65c0cf87695fa5d86f1a3ff3176c3) - - - - - 5661cc49 by Matthew Pickering at 2026-03-03T16:35:01+05:30 determinism: Use deterministic map for Strings in TyLitMap When generating typeable evidence the types we need evidence for all cached in a TypeMap, the order terms are retrieved from a type map determines the order the bindings appear in the program. A TypeMap is quite diligent to use deterministic maps, apart from in the TyLitMap, which uses a UniqFM for storing strings, whose ordering depends on the Unique of the FastString. This can cause non-deterministic .hi and .o files. An unexpected side-effect is the error message but RecordDotSyntaxFail8 changing. I looked into this with Sam and this change caused the constraints to be solved in a different order which results in a slightly different error message. I have accepted the new test, since the output before was non-deterministic and the new output is consistent with the other messages in that file. Fixes #26846 (cherry picked from commit aeeb4a2034e80e26503eb88f5abde85e87a82f7b) - - - - - b2c5f223 by Andrew Lelechenko at 2026-03-03T16:35:01+05:30 Upgrade text submodule to 2.1.4 (cherry picked from commit 9e4d70c2764d117c5cf753127f93056d66e4f0d7) - - - - - 8e257c26 by Zubin Duggal at 2026-03-03T16:35:01+05:30 Bump transformers submodule to 0.6.3.0 Fixes #26790 (cherry picked from commit ea0d1317a630799a6b7bea12b24ef7e1ea6ed512) - - - - - 1f9c98a8 by Matthew Pickering at 2026-03-03T16:35:01+05:30 determinism: Use a stable sort in WithHsDocIdentifiers binary instance `WithHsDocIdentifiers` is defined as ``` 71 data WithHsDocIdentifiers a pass = WithHsDocIdentifiers 72 { hsDocString :: !a 73 , hsDocIdentifiers :: ![Located (IdP pass)] 74 } ``` This list of names is populated from `rnHsDocIdentifiers`, which calls `lookupGRE`, which calls `lookupOccEnv_AllNameSpaces`, which calls `nonDetEltsUFM` and returns the results in an order depending on uniques. Sorting the list with a stable sort before returning the interface makes the output deterministic and follows the approach taken by other fields in `Docs`. Fixes #26858 (cherry picked from commit 0020e38a021b5f0371c48fe73cddf8987acb1eb1) - - - - - 8eabffd3 by Simon Peyton Jones at 2026-03-03T16:35:01+05:30 Fix subtle bug in cast worker/wrapper See (CWw4) in Note [Cast worker/wrapper]. The true payload is in the change to the definition of GHC.Types.Id.Info.hasInlineUnfolding Everthing else is just documentation. There is a 2% compile time decrease for T13056; I'll take the win! Metric Decrease: T13056 (cherry picked from commit 99d8c146c12146e1e21b1f2d31809845d4afe9d4) - - - - - 54bae547 by Cheng Shao at 2026-03-03T16:35:01+05:30 wasm: use import.meta.main for proper distinction of nodejs main modules This patch uses `import.meta.main` for proper distinction of nodejs main modules, especially when the main module might be installed as a symlink. Fixes #26916. (cherry picked from commit 039f19778e35b193af0de2a2c6ed89556038627a) - - - - - 4dd0cb12 by Simon Peyton Jones at 2026-03-03T16:35:01+05:30 Report solid equality errors before custom errors This MR fixes #26255 by * Reporting solid equality errors like Int ~ Bool before "custom type errors". See comments in `report1` in `reportWanteds` * Suppressing errors that arise from superclasses of Wanteds. See (SCE1) in Note [Suppressing confusing errors] More details in #26255. (cherry picked from commit ba210d981b0812aea604f884d3c0aada4c8ca75c) - - - - - 6b4b8374 by Simon Peyton Jones at 2026-03-03T16:35:01+05:30 Fix a horrible shadowing bug in implicit parameters Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts where we now do /not/ delete /Wanted/ implicit-parameeter constraints. This bug has been in GHC since 9.8! But it's quite hard to provoke; I contructed a tests in T26451, but it was hard to do so. (cherry picked from commit c052c724d2dfc994994b6548545836969aee8ed8) - - - - - 561cf2e3 by Simon Peyton Jones at 2026-03-03T16:35:01+05:30 Fix subtle bug in GHC.Core.Utils.mkTick This patch fixes a decade-old bug in `mkTick`, which could generate type-incorrect code! See the diagnosis in #26772. The new code is simpler and easier to understand. (As #26772 says, I think it could be improved further.) (cherry picked from commit cbe4300ef586c8bee1800426624db12e0237c6b5) - - - - - 439ddc80 by Simon Peyton Jones at 2026-03-03T16:35:01+05:30 Fix long-standing interaction between ticks and casts The code for Note [Eliminate Identity Cases] was simply wrong when ticks and casts interacted. This patch fixes the interaction. It was shown up when validating #26772, although it's not the exactly the bug that's reported by #26772. Nor is it easy to reproduce, hence no regression test. (cherry picked from commit b579dfdc614e288b0fd754ac69ae7ff723d808be) - - - - - 61987e71 by sheaf at 2026-03-03T16:35:01+05:30 NamedDefaults: require the class to be standard We now only default type variables if they only appear in constraints of the form `C v`, where `C` is either a standard class or a class with an in-scope default declaration. This rectifies an oversight in the original implementation of the NamedDefault extensions that was remarked in #25775; that implementation allowed type variables to appear in unary constraints which had arbitrary classes at the head. See the rewritten Note [How type-class constraints are defaulted] for details of the implementation. Fixes #25775 Fixes #25778 (cherry picked from commit f1acdd2c2b664ad0bdcaae4064b50e84aa7bc599) - - - - - 0e0cd635 by Rodrigo Mesquita at 2026-03-03T16:35:01+05:30 bytecode: Use 32bits for breakpoint index Fixes #26325 (cherry picked from commit e368e24779f8a7bf110a025383db23521b313407) - - - - - ecb62efc by Zubin Duggal at 2026-03-03T16:35:01+05:30 Prepare release 9.12.4 - - - - - 213 changed files: - .gitlab-ci.yml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Cmm.hs - compiler/GHC/Cmm/InitFini.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Unit/Info.hs - compiler/ghc.cabal.in - + docs/users_guide/9.12.4-notes.rst - docs/users_guide/debugging.rst - docs/users_guide/release-notes.rst - docs/users_guide/rtd-theme/layout.html - hadrian/src/Builder.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Rts.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Builders/RunTest.hs - libffi-tarballs - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/Exception/Backtrace/Experimental.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - + libraries/ghc-internal/tests/Makefile - + libraries/ghc-internal/tests/all.T - + libraries/ghc-internal/tests/backtraces/Makefile - + libraries/ghc-internal/tests/backtraces/T14532a.hs - + libraries/ghc-internal/tests/backtraces/T14532a.stdout - + libraries/ghc-internal/tests/backtraces/T14532b.hs - + libraries/ghc-internal/tests/backtraces/T14532b.stdout - + libraries/ghc-internal/tests/backtraces/all.T - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - libraries/text - libraries/transformers - m4/fp_check_pthreads.m4 - − m4/fp_visibility_hidden.m4 - m4/fptools_set_c_ld_flags.m4 - m4/prep_target_file.m4 - rts/Apply.cmm - rts/BeginPrivate.h - rts/Disassembler.c - rts/EndPrivate.h - rts/Hash.c - rts/Interpreter.c - − rts/RtsDllMain.c - − rts/RtsDllMain.h - rts/RtsStartup.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/Task.c - rts/Task.h - rts/ThreadPaused.c - rts/configure.ac - rts/eventlog/EventLog.c - rts/include/Rts.h - rts/include/RtsAPI.h - rts/include/Stg.h - rts/include/rts/OSThreads.h - rts/include/rts/Types.h - rts/include/stg/DLL.h - rts/linker/LoadArchive.c - rts/posix/OSMem.c - rts/posix/OSThreads.c - rts/prim/atomic.c - rts/prim/ctz.c - + rts/rts.buildinfo.in - rts/rts.cabal - rts/sm/BlockAlloc.c - rts/sm/Evac.c - rts/sm/Evac.h - rts/sm/Evac_thr.c → rts/sm/Evac_par.c - rts/sm/GCTDecl.h - rts/sm/GCThread.h - rts/sm/Scav_thr.c → rts/sm/Scav_par.c - rts/sm/Storage.c - rts/win32/OSThreads.c - testsuite/config/ghc - testsuite/driver/cpu_features.py - testsuite/driver/runtests.py - testsuite/driver/testlib.py - testsuite/driver/testutil.py - testsuite/tests/arrows/should_compile/T21301.stderr - + testsuite/tests/bytecode/T26216.hs - + testsuite/tests/bytecode/T26216.script - + testsuite/tests/bytecode/T26216.stdout - + testsuite/tests/bytecode/T26216_aux.hs - testsuite/tests/bytecode/all.T - + testsuite/tests/cross/should_run/T26449.hs - + testsuite/tests/cross/should_run/all.T - testsuite/tests/deSugar/should_fail/DsStrictFail.stderr - testsuite/tests/deSugar/should_run/T20024.stderr - testsuite/tests/deSugar/should_run/dsrun005.stderr - testsuite/tests/deSugar/should_run/dsrun007.stderr - testsuite/tests/deSugar/should_run/dsrun008.stderr - + testsuite/tests/default/T25775.hs - + testsuite/tests/default/T25775.stderr - testsuite/tests/default/all.T - testsuite/tests/deriving/should_run/T9576.stderr - + testsuite/tests/ghc-api/TypeMapStringLiteral.hs - testsuite/tests/ghc-api/all.T - + testsuite/tests/ghci-wasm/Makefile - + testsuite/tests/ghci-wasm/T26430.hs - + testsuite/tests/ghci-wasm/T26430A.c - + testsuite/tests/ghci-wasm/T26430B.c - + testsuite/tests/ghci-wasm/all.T - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout - testsuite/tests/ghci/scripts/Defer02.stderr - testsuite/tests/ghci/scripts/T15325.stderr - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/linters/all.T - + testsuite/tests/overloadedrecflds/should_fail/T26391.hs - + testsuite/tests/overloadedrecflds/should_fail/T26391.stderr - testsuite/tests/overloadedrecflds/should_fail/all.T - testsuite/tests/patsyn/should_run/ghci.stderr - testsuite/tests/perf/should_run/T3586.hs - testsuite/tests/perf/should_run/all.T - − testsuite/tests/process/process010.stdout-i386-unknown-solaris2 - testsuite/tests/rts/all.T - − testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 - − testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-32-mingw32 - − testsuite/tests/rts/outofmem.stderr-i386-apple-darwin - − testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 - − testsuite/tests/rts/outofmem.stderr-powerpc-apple-darwin - testsuite/tests/safeHaskell/safeLanguage/SafeLang15.stderr - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - + testsuite/tests/simd/should_run/T26410_ffi.hs - + testsuite/tests/simd/should_run/T26410_ffi.stdout - + testsuite/tests/simd/should_run/T26410_ffi_c.c - + testsuite/tests/simd/should_run/T26410_prim.hs - + testsuite/tests/simd/should_run/T26410_prim.stdout - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26681.hs - + testsuite/tests/simplCore/should_compile/T26903.hs - + testsuite/tests/simplCore/should_compile/T26903.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/T10279.hs - testsuite/tests/th/T10279.stderr - testsuite/tests/type-data/should_run/T22332a.stderr - + testsuite/tests/typecheck/should_compile/T26277.hs - + testsuite/tests/typecheck/should_compile/T26451.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T12921.stderr - testsuite/tests/typecheck/should_fail/T18851.hs - + testsuite/tests/typecheck/should_fail/T26255a.hs - + testsuite/tests/typecheck/should_fail/T26255a.stderr - + testsuite/tests/typecheck/should_fail/T26255b.hs - + testsuite/tests/typecheck/should_fail/T26255b.stderr - + testsuite/tests/typecheck/should_fail/T26255c.hs - + testsuite/tests/typecheck/should_fail/T26255c.stderr - testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_run/T10284.stderr - testsuite/tests/typecheck/should_run/T13838.stderr - testsuite/tests/typecheck/should_run/T9497a-run.stderr - testsuite/tests/typecheck/should_run/T9497b-run.stderr - testsuite/tests/typecheck/should_run/T9497c-run.stderr - testsuite/tests/unsatisfiable/T23816.stderr - testsuite/tests/unsatisfiable/UnsatDefer.stderr - utils/ghc-pkg/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs - utils/jsffi/dyld.mjs - utils/jsffi/post-link.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c378a834df1687e8344f0ab04d86ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c378a834df1687e8344f0ab04d86ee… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/linkable-usage] 19 commits: Add optional `SrcLoc` to `StackAnnotation` class
by Hannes Siebenhandl (＠fendor) 03 Mar '26

03 Mar '26

Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC Commits: 4c40df3d by fendor at 2026-02-20T10:24:48-05:00 Add optional `SrcLoc` to `StackAnnotation` class `StackAnnotation`s give access to an optional `SrcLoc` field that user-added stack annotations can use to provide better backtraces in both error messages and when decoding the callstack. We update builtin stack annotations such as `StringAnnotation` and `ShowAnnotation` to also capture the `SrcLoc` of the current `CallStack` to improve backtraces by default (if stack annotations are used). This change is backwards compatible with GHC 9.14.1. - - - - - fd9aaa28 by Simon Hengel at 2026-02-20T10:25:33-05:00 docs: Fix grammar in explicit_namespaces.rst - - - - - 44354255 by Vo Minh Thu at 2026-02-20T18:53:06-05:00 GHCi: add a :version command. This looks like: ghci> :version GHCi, version 9.11.20240322 This closes #24576. Co-Author: Markus Läll <markus.l2ll(a)gmail.com> - - - - - eab3dbba by Andreas Klebinger at 2026-02-20T18:53:51-05:00 hadrian/build-cabal: Better respect and utilize -j * We now respect -j<n> for the cabal invocation to build hadrian rather than hardcoding -j * We use the --semaphore flag to ensure cabal/ghc build the hadrian executable in parallel using the -jsem mechanism. Saves 10-15s on fresh builds for me. Fixes #26876 - - - - - 17839248 by Teo Camarasu at 2026-02-24T08:36:03-05:00 ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix This module contains the definition of MonadFix, since we want an instance for IO, that instance requires a lot of machinery and we want to avoid an orphan instance, this will naturally be quite high up in the dependency graph. So we want to avoid other modules depending on it as far as possible. On Windows, the IO manager depends on the RTSFlags type, which transtively depends on MonadFix. We refactor things to avoid this dependency, which would have caused a regression. Resolves #26875 Metric Decrease: T12227 - - - - - fa88d09a by Wolfgang Jeltsch at 2026-02-24T08:36:47-05:00 Refine the imports of `System.IO.OS` Commit 68bd08055594b8cbf6148a72d108786deb6c12a1 replaced the `GHC.Internal.Data.Bool` import by a `GHC.Internal.Base` import. However, while the `GHC.Internal.Data.Bool` import was conditional and partial, the `GHC.Internal.Base` import is unconditional and total. As a result, the import list is not tuned to import only the necessary bits anymore, and furthermore GHC emits a lot of warnings about redundant imports. This commit makes the `GHC.Internal.Base` import conditional and partial in the same way that the `GHC.Internal.Data.Bool` import was. - - - - - c951fef1 by Cheng Shao at 2026-02-25T20:58:28+00:00 wasm: add /assets endpoint to serve user-specified assets This patch adds an `/assets` endpoint to the wasm dyld http server, so that users can also fetch assets from the same host with sensible default MIME types, without needing a separate http server for assets that also introduces CORS headaches: - A `-fghci-browser-assets-dir` driver flag is added to specify the assets root directory (defaults to `$PWD`) - The dyld http server fetches `mime-db` on demand and uses it as source of truth for mime types. Closes #26951. - - - - - dde22f97 by Sylvain Henry at 2026-02-26T13:14:03-05:00 Fix -fcheck-prim-bounds for non constant args (#26958) Previously we were only checking bounds for constant (literal) arguments! I've refactored the code to simplify the generation of out-of-line Cmm code for the primop composed of some inline code + some call to an external Cmm function. - - - - - bd3eba86 by Vladislav Zavialov at 2026-02-27T05:48:01-05:00 Check for negative type literals in the type checker (#26861) GHC disallows negative type literals (e.g., -1), as tested by T8306 and T8412. This check is currently performed in the renamer: rnHsTyLit tyLit@(HsNumTy x i) = do when (i < 0) $ addErr $ TcRnNegativeNumTypeLiteral tyLit However, this check can be bypassed using RequiredTypeArguments (see the new test case T26861). Prior to this patch, such programs caused the compiler to hang instead of reporting a proper error. This patch addresses the issue by adding an equivalent check in the type checker, namely in tcHsType. The diff is deliberately minimal to facilitate backporting. A more comprehensive rework of HsTyLit is planned for a separate commit. - - - - - faf14e0c by Vladislav Zavialov at 2026-02-27T05:48:45-05:00 Consistent pretty-printing of HsString, HsIsString, HsStrTy Factor out a helper to pretty-print string literals, thus fixing newline handling for overloaded string literals and type literals. Test cases: T26860ppr T26860ppr_overloaded T26860ppr_tylit Follow up to ddf1434ff9bb08cfef3c93f23de6b83ec698aa27 - - - - - f108a972 by Arnaud Spiwack at 2026-02-27T12:53:01-05:00 Make list comprehension completely non-linear Fixes #25081 From the note: The usefulness of list comprehension in conjunction with linear types is dubious. After all, statements are made to be run many times, for instance in ```haskell [u | y <- [0,1], stmts] ``` both `u` and `stmts` are going to be run several times. In principle, though, there are some position in a monad comprehension expression which could be considered linear. We could try and make it so that these positions are considered linear by the typechecker, but in practice the desugarer doesn't take enough care to ensure that these are indeed desugared to linear sites. We tried in the past, and it turned out that we'd miss a desugaring corner case (#25772). Until there's a demand for this very specific improvement, let's instead be conservative, and consider list comprehension to be completely non-linear. - - - - - ae799cab by Simon Jakobi at 2026-02-27T12:53:54-05:00 PmAltConSet: Use Data.Set instead of Data.Map ...to store `PmLit`s. The Map was only used to map keys to themselves. Changing the Map to a Set saves a Word of memory per entry. Resolves #26756. - - - - - dcd7819c by Vladislav Zavialov at 2026-02-27T18:46:03-05:00 Drop HsTyLit in favor of HsLit (#26862, #25121) This patch is a small step towards unification of HsExpr and HsType, taking care of literals (HsLit) and type literals (HsTyLit). Additionally, it improves error messages for unsupported type literals, such as unboxed or fractional literals (test cases: T26862, T26862_th). Changes to the AST: * Use HsLit where HsTyLit was previously used * Use HsChar where HsCharTy was previously used * Use HsString where HsStrTy was previously used * Use HsNatural (NEW) where HsNumTy was previously used * Use HsDouble (NEW) to represent unsupported fractional type literals Changes to logic: * Parse unboxed and fractional type literals (to be rejected later) * Drop the check for negative literals in the renamer (rnHsTyLit) in favor of checking in the type checker (tc_hs_lit_ty) * Check for invalid type literals in TH (repTyLit) and report unrepresentable literals with ThUnsupportedTyLit * Allow negative type literals in TH (numTyLit). This is fine as these will be taken care of at splice time (test case: T8306_th) - - - - - c927954f by Vladislav Zavialov at 2026-02-27T18:46:50-05:00 Increase test coverage of diagnostics Add test cases for the previously untested diagnostics: [GHC-01239] PsErrIfInFunAppExpr [GHC-04807] PsErrProcInFunAppExpr [GHC-08195] PsErrInvalidRecordCon [GHC-16863] PsErrUnsupportedBoxedSumPat [GHC-18910] PsErrSemiColonsInCondCmd [GHC-24737] PsErrInvalidWhereBindInPatSynDecl [GHC-25037] PsErrCaseInFunAppExpr [GHC-25078] PsErrPrecedenceOutOfRange [GHC-28021] PsErrRecordSyntaxInPatSynDecl [GHC-35827] TcRnNonOverloadedSpecialisePragma [GHC-40845] PsErrUnpackDataCon [GHC-45106] PsErrInvalidInfixHole [GHC-50396] PsErrInvalidRuleActivationMarker [GHC-63930] MultiWayIfWithoutAlts [GHC-65536] PsErrNoSingleWhereBindInPatSynDecl [GHC-67630] PsErrMDoInFunAppExpr [GHC-70526] PsErrLetCmdInFunAppCmd [GHC-77808] PsErrDoCmdInFunAppCmd [GHC-86934] ClassPE [GHC-90355] PsErrLetInFunAppExpr [GHC-91745] CasesExprWithoutAlts [GHC-92971] PsErrCaseCmdInFunAppCmd [GHC-95644] PsErrBangPatWithoutSpace [GHC-97005] PsErrIfCmdInFunAppCmd Remove unused error constructors: [GHC-44524] PsErrExpectedHyphen [GHC-91382] TcRnIllegalKindSignature - - - - - 3a9470fd by Torsten Schmits at 2026-02-27T18:47:34-05:00 Avoid expensive computation for debug logging in `mergeDatabases` when log level is low This computed and traversed a set intersection for every single dependency unconditionally. - - - - - ea4c2cbd by Brandon Chinn at 2026-02-27T16:22:38-08:00 Implement QualifiedStrings (#26503) See Note [Implementation of QualifiedStrings] - - - - - 08bc245b by sheaf at 2026-03-01T11:11:54-05:00 Clean up join points, casts & ticks This commit shores up the logic dealing with casts and ticks occurring in between a join point binding and a jump. Fixes #26642 #26929 #26693 Makes progress on #14610 #26157 #26422 Changes: - Remove 'GHC.Types.Tickish.TickishScoping' in favour of simpler predicates 'tickishHasNoScope'/'tickishHasSoftScope', as things were before commit 993975d3. This makes the code easier to read and document (fewer indirections). - Introduce 'canCollectArgsThroughTick' for consistent handling of ticks around PrimOps and other 'Id's that cannot be eta-reduced. See overhauled Note [Ticks and mandatory eta expansion]. - New Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt that explains robustness of JoinId vs fragility of TailCallInfo. - Allow casts/non-soft-scoped ticks to occur in between a join point binder and a jump, but only in Core Prep. See Note [Join points, casts, and ticks] and Note [Join points, casts, and ticks... in Core Prep] in GHC.Core.Opt.Simplify.Iteration. Also update Core Lint to account for this. See Note [Linting join points with casts or ticks] in GHC.Core.Lint. - Update 'GHC.Core.Utils.mergeCaseAlts' to avoid pushing a cast in between a join point binding and its jumps. This fixes #26642. See the new (MC5) and (MC6) in Note [Merge Nested Cases]. - Update float out to properly handle source note ticks. They are now properly floated out instead of being discarded. This increases the number of ticks in certain tests with -g. Test cases: T26642 and TrickyJoins. Metric increase due to more source note ticks with -g: ------------------------- Metric Increase: libdir size_hello_artifact size_hello_unicode ------------------------- - - - - - 9544b6b9 by fendor at 2026-03-03T11:38:29+01:00 Add bytecode linkable regression test - - - - - f8d8d87d by fendor at 2026-03-03T11:38:29+01:00 WIP LinkableUsage - - - - - 260 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - + compiler/GHC/ByteCode/Binary.hs - + compiler/GHC/ByteCode/Recomp/Binary.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Cmm/Node.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Hooks.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - + compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Runtime/Interpreter/Wasm.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Binary.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Language/Haskell/Syntax/Pat.hs - compiler/Language/Haskell/Syntax/Type.hs - compiler/ghc.cabal.in - + docs/users_guide/10.0.1-notes.rst - docs/users_guide/9.16.1-notes.rst - docs/users_guide/exts/explicit_namespaces.rst - + docs/users_guide/exts/qualified_strings.rst - docs/users_guide/ghci.rst - docs/users_guide/wasm.rst - ghc/GHCi/Leak.hs - ghc/GHCi/UI.hs - hadrian/build-cabal - libraries/base/src/Control/Arrow.hs - libraries/base/src/System/IO.hs - libraries/ghc-experimental/CHANGELOG.md - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - + libraries/ghc-experimental/tests/Makefile - + libraries/ghc-experimental/tests/all.T - + libraries/ghc-experimental/tests/backtraces/Makefile - + libraries/ghc-experimental/tests/backtraces/T26806a.hs - + libraries/ghc-experimental/tests/backtraces/T26806a.stderr - + libraries/ghc-experimental/tests/backtraces/T26806b.hs - + libraries/ghc-experimental/tests/backtraces/T26806b.stderr - + libraries/ghc-experimental/tests/backtraces/T26806c.hs - + libraries/ghc-experimental/tests/backtraces/T26806c.stderr - + libraries/ghc-experimental/tests/backtraces/all.T - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - + testsuite/ghc-config/ghc-config - + testsuite/tests/bytecode/TLinkable/Makefile - + testsuite/tests/bytecode/TLinkable/all.T - + testsuite/tests/bytecode/TLinkable/genSplices - + testsuite/tests/bytecode/TLinkable/genSplices2 - + testsuite/tests/bytecode/TLinkable/linkable_bytecodelib.stdout - testsuite/tests/codeGen/should_compile/debug.stdout - + testsuite/tests/codeGen/should_fail/T26958.hs - testsuite/tests/codeGen/should_fail/all.T - + testsuite/tests/dependent/should_fail/SelfDepCls.hs - + testsuite/tests/dependent/should_fail/SelfDepCls.stderr - testsuite/tests/dependent/should_fail/all.T - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/T4437.hs - testsuite/tests/ghc-api/annotations-literals/literals.stdout - testsuite/tests/ghc-api/annotations-literals/parsed.hs - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - − testsuite/tests/linear/should_compile/LinearListComprehension.hs - testsuite/tests/linear/should_compile/all.T - testsuite/tests/linear/should_fail/T25081.hs - testsuite/tests/linear/should_fail/T25081.stderr - testsuite/tests/mdo/should_fail/mdofail006.stderr - testsuite/tests/module/all.T - + testsuite/tests/module/mod70b.hs - + testsuite/tests/module/mod70b.stderr - + testsuite/tests/parser/should_fail/NoBlockArgumentsFail4.hs - + testsuite/tests/parser/should_fail/NoBlockArgumentsFail4.stderr - testsuite/tests/parser/should_fail/NoBlockArgumentsFailArrowCmds.hs - testsuite/tests/parser/should_fail/NoBlockArgumentsFailArrowCmds.stderr - + testsuite/tests/parser/should_fail/NoDoAndIfThenElseArrowCmds.hs - + testsuite/tests/parser/should_fail/NoDoAndIfThenElseArrowCmds.stderr - + testsuite/tests/parser/should_fail/T26860ppr_overloaded.hs - + testsuite/tests/parser/should_fail/T26860ppr_overloaded.stderr - + testsuite/tests/parser/should_fail/T26860ppr_tylit.hs - + testsuite/tests/parser/should_fail/T26860ppr_tylit.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/parser/should_fail/badRuleMarker.hs - + testsuite/tests/parser/should_fail/badRuleMarker.stderr - + testsuite/tests/parser/should_fail/patFail010.hs - + testsuite/tests/parser/should_fail/patFail010.stderr - + testsuite/tests/parser/should_fail/patFail011.hs - + testsuite/tests/parser/should_fail/patFail011.stderr - + testsuite/tests/parser/should_fail/precOutOfRange.hs - + testsuite/tests/parser/should_fail/precOutOfRange.stderr - + testsuite/tests/parser/should_fail/unpack_data_con.hs - + testsuite/tests/parser/should_fail/unpack_data_con.stderr - testsuite/tests/patsyn/should_fail/T10426.stderr - testsuite/tests/patsyn/should_fail/all.T - + testsuite/tests/patsyn/should_fail/patsyn_where_fail1.hs - + testsuite/tests/patsyn/should_fail/patsyn_where_fail1.stderr - + testsuite/tests/patsyn/should_fail/patsyn_where_fail2.hs - + testsuite/tests/patsyn/should_fail/patsyn_where_fail2.stderr - + testsuite/tests/patsyn/should_fail/patsyn_where_fail3.hs - + testsuite/tests/patsyn/should_fail/patsyn_where_fail3.stderr - + testsuite/tests/patsyn/should_fail/patsyn_where_fail4.hs - + testsuite/tests/patsyn/should_fail/patsyn_where_fail4.stderr - + testsuite/tests/qualified-strings/Makefile - + testsuite/tests/qualified-strings/should_compile/Example/Length.hs - + testsuite/tests/qualified-strings/should_compile/all.T - + testsuite/tests/qualified-strings/should_compile/qstrings_redundant_pattern.hs - + testsuite/tests/qualified-strings/should_compile/qstrings_redundant_pattern.stderr - + testsuite/tests/qualified-strings/should_fail/Example/Length.hs - + testsuite/tests/qualified-strings/should_fail/Makefile - + testsuite/tests/qualified-strings/should_fail/all.T - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.hs - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.stderr - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.hs - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.stderr - + testsuite/tests/qualified-strings/should_fail/qstrings_multiline_no_ext.hs - + testsuite/tests/qualified-strings/should_fail/qstrings_multiline_no_ext.stderr - + testsuite/tests/qualified-strings/should_run/Example/ByteStringAscii.hs - + testsuite/tests/qualified-strings/should_run/Example/ByteStringUtf8.hs - + testsuite/tests/qualified-strings/should_run/Example/Text.hs - + testsuite/tests/qualified-strings/should_run/Makefile - + testsuite/tests/qualified-strings/should_run/all.T - + testsuite/tests/qualified-strings/should_run/qstrings_expr.hs - + testsuite/tests/qualified-strings/should_run/qstrings_expr.stdout - + testsuite/tests/qualified-strings/should_run/qstrings_pat.hs - + testsuite/tests/qualified-strings/should_run/qstrings_pat.stdout - + testsuite/tests/qualified-strings/should_run/qstrings_th.hs - + testsuite/tests/qualified-strings/should_run/qstrings_th.stdout - + testsuite/tests/simplCore/should_compile/T26642.hs - + testsuite/tests/simplCore/should_compile/TrickyJoins.hs - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/th/T26862_th.script - + testsuite/tests/th/T26862_th.stderr - + testsuite/tests/th/T8306_th.script - + testsuite/tests/th/T8306_th.stderr - + testsuite/tests/th/T8306_th.stdout - testsuite/tests/th/T8412.stderr - + testsuite/tests/th/TH_EmptyLamCases.hs - + testsuite/tests/th/TH_EmptyLamCases.stderr - + testsuite/tests/th/TH_EmptyMultiIf.hs - + testsuite/tests/th/TH_EmptyMultiIf.stderr - testsuite/tests/th/all.T - + testsuite/tests/typecheck/should_fail/T26861.hs - + testsuite/tests/typecheck/should_fail/T26861.stderr - + testsuite/tests/typecheck/should_fail/T26862.hs - + testsuite/tests/typecheck/should_fail/T26862.stderr - testsuite/tests/typecheck/should_fail/T8306.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/unboxedsums/all.T - + testsuite/tests/unboxedsums/unboxedsums4p.hs - + testsuite/tests/unboxedsums/unboxedsums4p.stderr - + testsuite/tests/warnings/should_compile/SpecMultipleTysMono.hs - + testsuite/tests/warnings/should_compile/SpecMultipleTysMono.stderr - testsuite/tests/warnings/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef36444353ee2fc503a2bd3c43e081… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef36444353ee2fc503a2bd3c43e081… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T20264] More wibbles
by Simon Peyton Jones (＠simonpj) 03 Mar '26

03 Mar '26

Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: 687f3662 by Simon Peyton Jones at 2026-03-03T10:11:06+00:00 More wibbles - - - - - 6 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/HsToCore/Utils.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -465,8 +465,8 @@ TL;DR: we relaxed the let/app invariant to become the let-can-float invariant. Note [Type and coercion lets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow - let @a = TYPE ty in ... +We allow non-recursive type lets: + let a = TYPE ty in ... and similarly for coercions. TODO: fill this out @@ -475,7 +475,7 @@ Wrinkles: (TCL1) In a type let (Let @a = TYPE ty in body), we do /not/ insist that the binder `a` has a TyVarUnfolding. But if it does not, then `body` - must be well-typed without paying atention to the binding. More precisely, + must be well-typed without paying attention to the binding. More precisely, let @a = TYPE ty in body where `a` has no TyVarUnfolding, is well-typed iff (/\a. body) ty @@ -489,15 +489,32 @@ Wrinkles: (which is always substituted) with the tyvar-replete-with-unfolding, rather than merely extending the in-scope set as we do for Ids. +(TCL3) In the output of the desugarer it is very convenient to allow + let a = <type> in ...a.... + where the occurrences of `a` do /not/ have an unfolding, but yet it is essential + to substitute <type> for `a` when Linting. Why? When compiling nested pattern + matching we may combine patterns + K @a1 (co1 :: a1 ~ T) pat1 -> e1 + K @a2 (co2 :: a2 ~ T) pat2 -> e2 + to get a single, shared pattern, something like + K @a1 (co1 :: a1 ~ T) x -> let { a2 = a1; co2 = co1 } in + case x of + pat1 -> e1 + pat2 -> e2 + The bindings { a2=a1; co2=co1 } just make the binders in the two patterns line + up. But for this to be Lint-correct we must actually substitute `a1` for `a2`. + + So, in the ouptut of the desugarer only, if there is no unfolding on the binder, + we just extend the subustitution. + + It's a bit of a hack, but the first roun dof simplification esablishes (TCL1) or + (TCL2). + So: (TCL1) + (TCL2) = EITHER `a` has an unfolding at its binding site, and that unfolding is replicated at every occurrence site OR it doesn't and the occurrences don't either. - -OR we could insist that tyvar bindings always have an unfolding, and use -a beta-redex if not. - Note [Core top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As an exception to the usual rule that top-level binders must be lifted, ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -235,8 +235,6 @@ in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this featur for this purpose -- it contains only TyCoVars. Instead we have a separate le_ids for the in-scope Id binders. -Sigh. We might want to explore getting rid of type-let! - Note [Bad unsafe coercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~ For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions @@ -570,23 +568,31 @@ lintLetExpr :: TyVarSet -- Enclosing let-bound tyvars, all with unfoldings lintLetExpr tvs (Let (NonRec tv (Type rhs_ty)) body) | isTyVar tv = -- See Note [Linting type lets] - do { case tyVarUnfolding_maybe tv of - Nothing -> return () -- See GHC.Core Note [Type and coercion lets] wrinkle (TCL1) - Just unf_ty -> -- These comparisons compare InTypes, which is fine - do { ensureEqTys (tyVarKind tv) (typeKind rhs_ty) $ - tv_err unf_ty "Let-bound tyvar kind incompatible with RHS:" - ; ensureEqTys unf_ty rhs_ty $ - tv_err unf_ty "Let-bound tyvar unfolding not same as RHS:" } - - ; addLoc (RhsOf tv) $ lintType rhs_ty - - ; lintTyCoBndr tv $ \ tv' -> - addLoc (BodyOfLet tv) $ - lintLetExpr (tvs `extendVarSet` tv') body } + do { -- Lint the RHS type + rhs_ty' <- addLoc (RhsOf tv) $ lintTypeAndSubst rhs_ty + + ; lintTyCoBndr tv $ \ tv' -> + do { -- Check that the RHS has the same kind as the tyvar + addLoc (RhsOf tv) $ + lintTyKind tv' rhs_ty' + + -- Check the unfolding + -- See GHC.Core Note [Type and coercion lets] wrinkle (TCL1) + ; case tyVarUnfolding_maybe tv' of + Nothing -> return () + Just unf_ty' -> ensureEqTys unf_ty' rhs_ty' $ + tv_err tv' unf_ty' rhs_ty' + + -- Check the body + ; extendTvLetSubst tv rhs_ty' $ + addLoc (BodyOfLet tv) $ + lintLetExpr (tvs `extendVarSet` tv') body + } } where - tv_err unf_ty msg = hang (text msg <+> pprTyVarWithKind tv) - 2 (vcat [ text "Unfolding:" <+> ppr unf_ty - , text "RHS: " <+> ppr rhs_ty ]) + tv_err tv unf_ty rhs_ty = hang (text "Let-bound tyvar unfolding not same as RHS:" + <+> pprTyVarWithKind tv) + 2 (vcat [ text "Unfolding:" <+> ppr unf_ty + , text "RHS: " <+> ppr rhs_ty ]) lintLetExpr tvs (Let (NonRec bndr rhs) body) | isId bndr @@ -3086,6 +3092,7 @@ data LintFlags , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] , lf_check_fixed_rep :: Bool -- ^ See Note [Checking for representation polymorphism] , lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals] + , lf_inline_type_lets :: Bool -- ^ See Note [Linting type lets] XXX TODO } -- See Note [Checking StaticPtrs] @@ -3505,10 +3512,12 @@ getLintFlags :: LintM LintFlags getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs) updLintFlags :: (LintFlags -> LintFlags) -> LintM a -> LintM a -updLintFlags upd_flags thing_inside - = LintM $ \env errs -> - let env' = env { le_flags = upd_flags (le_flags env) } - in unLintM thing_inside env' errs +updLintFlags upd_flags + = updLintEnv (\env -> env { le_flags = upd_flags (le_flags env) }) + +updLintEnv :: (LintEnv -> LintEnv) -> LintM a -> LintM a +updLintEnv upd thing_inside + = LintM $ \env errs -> unLintM thing_inside (upd env) errs checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -3634,6 +3643,17 @@ addInScopeTyCoVar tcv tcv_type thing_inside Just unf_ty -> setTyVarUnfolding tcv2 (substTy subst unf_ty) Nothing -> tcv2 +extendTvLetSubst :: TyVar -> Type -> LintM a -> LintM a +extendTvLetSubst tv ty thing_inside + | isJust (tyVarUnfolding_maybe tv) + = thing_inside + | otherwise + = do { flags <- getLintFlags + ; if (lf_inline_type_lets flags) + then updLintEnv (\ env -> env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) + thing_inside + else thing_inside } + getInVarEnv :: LintM (VarEnv (InId, OutVar)) getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs)) @@ -3742,7 +3762,7 @@ checkBndrOccCompatibility in_bndr v_occ sameUnfolding :: InVar -- Binder -> InVar -- Occurrence -> LintM Bool --- Check that any unfolding in the /occurence/ is the same as that in the /binder/ +-- Check that any unfolding in the /occurrence/ is the same as that in the /binder/ -- An unfolding in the occurrence is optional for Ids, but compulsory for type-let-boud -- TyVars. Somewhat lazily, we only check the latter. -- We also just compare them as InTypes (as we do the type of the variable); ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -3323,11 +3323,7 @@ mkPolyAbsLams (getter,setter) bndrs body = go emptyVarSet [] bndrs where wrap_bind :: Expr b -> (b,Expr b) -> Expr b - -- wrap_bind e (bndr, rhs) = (\bndr.e) rhs - -- Very like let bndr=rhs in e - -- but, for type-bindings at least, does not require that the occurrences - -- of bndr have the unfolding from the let-binding - wrap_bind e (bndr, rhs) = App (Lam bndr e) rhs + wrap_bind e (bndr, rhs) = Let (NonRec bndr rhs) e go :: TyVarSet -- Earlier TyVar bndrs that have TyVarUnfoldings -> [(b,Expr b)] -- Accumulated impedence-matching bindings (reversed) ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1527,7 +1527,7 @@ cpeArg :: CorePrepEnv -> Demand -> CoreArg -> UniqSM (Floats, CpeArg) cpeArg env dmd arg = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda - ; let arg_ty = exprType arg1 + ; let arg_ty = exprType arg lev = typeLevity arg_ty dec = wantFloatLocal NonRecursive dmd lev floats1 arg1 ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1 ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -119,7 +119,8 @@ perPassFlags dflags pass , lf_check_inline_loop_breakers = check_lbs , lf_check_static_ptrs = check_static_ptrs , lf_check_linearity = check_linearity - , lf_check_rubbish_lits = check_rubbish } + , lf_check_rubbish_lits = check_rubbish + , lf_inline_type_lets = inline_type_lets } where -- See Note [Checking for global Ids] check_globals = case pass of @@ -156,6 +157,11 @@ perPassFlags dflags pass CorePrep -> True _ -> False + -- See Note [Linting type lets] in GHC.Core.Lint + inline_type_lets = case pass of + CoreDesugar -> True + _ -> False + initLintConfig :: DynFlags -> [Var] -> LintConfig initLintConfig dflags vars =LintConfig { l_diagOpts = initDiagOpts dflags @@ -172,4 +178,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False , lf_report_unsat_syns = True , lf_check_fixed_rep = True , lf_check_rubbish_lits = True + , lf_inline_type_lets = False } ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -245,6 +245,8 @@ wrapBinds [] e = e wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) wrapBind :: Var -> Var -> CoreExpr -> CoreExpr +-- Used only to line up varaibles when combining case patterns, +-- in GHC.HsToCore.Match.Constructor and GHC.HsToCore.Match.Literal wrapBind new old body -- NB: this function must deal with term | new==old = body -- variables, type variables or coercion variables | otherwise = Let (NonRec new (varToCoreExpr old)) body View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/687f3662c2f384dec27130862a3352a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/687f3662c2f384dec27130862a3352a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26878] Simplify `GHC.Core.Utils.mkTick`
by sheaf (＠sheaf) 03 Mar '26

03 Mar '26

sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC Commits: d66cb452 by Simon Peyton Jones at 2026-03-03T10:24:02+01:00 Simplify `GHC.Core.Utils.mkTick` Addresses #26878, by deleting code! Fixes #26941 by no longer wrapping coercions with SCC ticks. Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 4 changed files: - compiler/GHC/Core/Utils.hs - + testsuite/tests/simplCore/should_compile/T26941.hs - + testsuite/tests/simplCore/should_compile/T26941_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -304,58 +304,58 @@ mkCast expr co ********************************************************************* -} -- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. +-- annotation if possible. So +-- mkTick t e = Tick t e +-- except that we may optimise by pushing `t` inwards or dropping it mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id orig_expr +mkTick t orig_expr = mkTick' orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. - canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + can_split = tickishCanSplit t - -- mkTick' handles floating of ticks *into* the expression. - mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) - -- Always a composition of (Tick t) wrappers - -> CoreExpr -- Current expression - -> CoreExpr - -- So in the call (mkTick' rest e), the expression - -- (rest e) - -- has the same type as e - -- Returns an expression equivalent to (Tick t (rest e)) - mkTick' rest expr = case expr of - -- Float ticks into unsafe coerce the same way we would do with a cast. - Case scrut bndr ty alts@[Alt ac abs _rhs] - | Just rhs <- isUnsafeEqualityCase scrut bndr alts - -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)] + stop_here e = Tick t e -- Just wrap `t` around the current expression + -- That's the default option! - -- Cost centre ticks should never be reordered relative to each - -- other. Therefore we can stop whenever two collide. + -- mkTick' handles floating of tick `t` *into* the expression. + mkTick' :: CoreExpr -> CoreExpr + mkTick' expr = case expr of Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr + | ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 } <- t + , ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 } <- t2 + -> + -- If the two ticks share the same cost centre and at most one of them + -- counts, then we can merge the two. + if cc1 == cc2 && (not cnt1 || not cnt2) + then + let t' = ProfNote { profNoteCC = cc1 + , profNoteCount = cnt1 || cnt2 + , profNoteScope = scope1 || scope2 + } + in mkTick t' e + else + -- Cost centre ticks for different cost centres should never be reordered + -- relative to each other. Therefore we can stop whenever two collide. + stop_here expr + + | tickishPlace t2 /= tickishPlace t + -> -- Otherwise, we assume that ticks of different + -- placements float through each other. + Tick t2 $ mkTick' e + + -- For source note ticks, this is where we make sure to + -- not introduce redundant ticks. + | tickishContains t t2 -> mkTick' e -- Drop t2 + | tickishContains t2 t -> expr -- Drop t - -- Otherwise we assume that ticks of different placements float - -- through each other. - | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e - - -- For annotations this is where we make sure to not introduce - -- redundant ticks. - | tickishContains t t2 -> mkTick' rest e -- Drop t2 - | tickishContains t2 t -> rest e -- Drop t - | otherwise -> mkTick' (rest . Tick t2) e - - -- Ticks don't care about types, so we just float all ticks - -- through them. Note that it's not enough to check for these - -- cases top-level. While mkTick will never produce Core with type - -- expressions below ticks, such constructs can be the result of - -- unfoldings. We therefore make an effort to put everything into - -- the right place no matter what we start with. - Cast e co -> mkCast (mkTick' rest e) co - Coercion co -> Tick t $ rest (Coercion co) + | otherwise + -> stop_here expr -- Always safe Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> Lam x $ mkTick' rest e + -> Lam x $ mkTick' e -- If it is both counting and scoped, we split the tick into its -- two components, often allowing us to keep the counting tick on @@ -363,26 +363,41 @@ mkTick t orig_expr = mkTick' id orig_expr -- The point of this is that the counting tick can probably be -- floated, and the lambda may then be in a position to be -- beta-reduced. - | canSplit - -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + | can_split + -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e App f arg -- Always float through type applications. | not (isRuntimeArg arg) - -> App (mkTick' rest f) arg + -> App (mkTick' f) arg -- We can also float through constructor applications, placement -- permitting. Again we can split. - | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + | isSaturatedConApp expr + , tickishPlace t == PlaceCostCentre || can_split -> if tickishPlace t == PlaceCostCentre - then rest $ tickHNFArgs t expr - else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then tickHNFArgs t expr + else Tick (mkNoScope t) $ tickHNFArgs (mkNoCount t) expr + + -- Ticks don't care about types, so we just float all ticks + -- through them. Note that it's not enough to check for these + -- cases at the top-level. While mkTick will never produce Core with type + -- expressions below ticks, such constructs can be the result of + -- unfoldings. We therefore make an effort to put everything into + -- the right place no matter what we start with. + Cast e co -> mkCast (mkTick' e) co + + -- Float ticks into 'unsafeCoerce' the same way we would do with a cast. + Case scrut bndr ty alts@[Alt ac abs _rhs] + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -> Case scrut bndr ty [Alt ac abs (mkTick' rhs)] Var x - | notFunction && tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t - | notFunction && canSplit - -> Tick (mkNoScope t) $ rest expr + | notFunction + , tickishPlace t == PlaceCostCentre || can_split + -> if tickishPlace t == PlaceCostCentre + then expr -- Drop tick t entirely + else Tick (mkNoScope t) expr where -- SCCs can be eliminated on variables provided the variable -- is not a function. In these cases the SCC makes no difference: @@ -392,12 +407,24 @@ mkTick t orig_expr = mkTick' id orig_expr -- when the function is called, so we must retain those. notFunction = not (isFunTy (idType x)) + Coercion co + -- Make sure to drop SCCs around coercions, to avoid generating Core + -- of the form 'let co = scc<foo> <Int>_N' (which Core Lint isn't happy with). + -- See #26941. + | tickishPlace t == PlaceCostCentre + -> Coercion co -- Drop tick t entirely + | can_split + -> Tick (mkNoScope t) expr + Lit{} | tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t + -> expr -- Drop tick t entirely + | can_split + -> Tick (mkNoScope t) expr - -- Catch-all: Annotate where we stand - _any -> Tick t $ rest expr + -- Catch-all: Annotate where we stand. + -- Used for Type, Let, most Cases + _any -> Tick t expr mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks ===================================== testsuite/tests/simplCore/should_compile/T26941.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +module T26941 where + +import GHC.TypeLits + +import T26941_aux ( SMayNat(SKnown), ListH, shxHead ) + +shsHead :: ListH (Just n : sh) Int -> SNat n +shsHead shx = + case shxHead shx of + SKnown SNat -> SNat ===================================== testsuite/tests/simplCore/should_compile/T26941_aux.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T26941_aux where + +import Data.Kind +import GHC.TypeLits + +shxHead :: ListH (n : sh) i -> SMayNat i n +shxHead list = {-# SCC "bad_scc" #-} + ( case list of (i `ConsKnown` _) -> SKnown i ) + +type ListH :: [Maybe Nat] -> Type -> Type +data ListH sh i where + ConsKnown :: SNat n -> ListH sh i -> ListH (Just n : sh) i + +data SMayNat i n where + SKnown :: SNat n -> SMayNat i (Just n) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -568,6 +568,8 @@ test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniqu test('T26349', normal, compile, ['-O -ddump-rules']) test('T26681', normal, compile, ['-O']) +test('T26941', [extra_files(['T26941_aux.hs']), req_profiling], multimod_compile, ['T26941', '-v0 -O -prof']) + # T26709: we expect three `case` expressions not four test('T26709', [grep_errmsg(r'case')], multimod_compile, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d66cb45238904ad9213dbc58aa29e69… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d66cb45238904ad9213dbc58aa29e69… You're receiving this email because of your account on gitlab.haskell.org.

1 0