March 2026 - ghc-commits

[Git][ghc/ghc][wip/jeltsch/system-io-implementation-into-base] Move the `System.IO` implementation into `base`
by Wolfgang Jeltsch (＠jeltsch) 14 Mar '26

14 Mar '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-implementation-into-base at Glasgow Haskell Compiler / GHC Commits: a662500a by Wolfgang Jeltsch at 2026-03-13T21:54:17+02:00 Move the `System.IO` implementation into `base` - - - - - 21 changed files: - libraries/base/src/GHC/IO/Handle.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/IO.hs - libraries/base/src/Text/Printf.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - 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/plugins/plugins09.stdout - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/plugins11.stdout - testsuite/tests/plugins/static-plugins.stdout - testsuite/tests/typecheck/should_compile/T9497a.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T9497d.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 Changes: ===================================== libraries/base/src/GHC/IO/Handle.hs ===================================== @@ -53,6 +53,7 @@ module GHC.IO.Handle hGetEcho, hIsTerminalDevice, hSetNewlineMode, + hGetNewlineMode, Newline(..), NewlineMode(..), nativeNewline, ===================================== libraries/base/src/Prelude.hs ===================================== @@ -165,7 +165,7 @@ module Prelude ( ) where import GHC.Internal.Control.Monad -import GHC.Internal.System.IO +import System.IO import GHC.Internal.System.IO.Error import qualified GHC.Internal.Data.List as List import GHC.Internal.Data.Either ===================================== libraries/base/src/System/IO.hs ===================================== @@ -1,4 +1,5 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} -- | -- @@ -184,8 +185,666 @@ module System.IO nativeNewlineMode ) where -import GHC.Internal.System.IO +import GHC.Internal.System.IO (putStrLn, print) + +import GHC.Base (Bool (False, True), otherwise, failIO) +import GHC.Err (errorWithoutStackTrace) +import GHC.List (null, elem, last, (++), reverse, break) +import GHC.Num ((+)) +import GHC.IO (IO, FilePath) +import GHC.IO.IOMode (IOMode (ReadMode, WriteMode, ReadWriteMode, AppendMode)) +import qualified GHC.Internal.IO.FD as FD +import GHC.IO.Encoding + ( + TextEncoding, + mkTextEncoding, + getLocaleEncoding, + initLocaleEncoding, + utf8, + utf8_bom, + utf16, + utf16be, + utf16le, + utf32, + utf32be, + utf32le, + latin1, + char8 + ) +import GHC.IO.Handle + ( + Handle, + hLookAhead, + hFlush, + hClose, + hSetBinaryMode, + hSetEncoding, + hSetNewlineMode, + hSetEcho, + hSetFileSize, + hGetEncoding, + hGetNewlineMode, + hGetEcho, + hFileSize, + hIsOpen, + hIsReadable, + hIsSeekable, + hIsWritable, + hIsTerminalDevice, + hIsEOF, + hIsClosed, + hShow, + BufferMode (NoBuffering, LineBuffering, BlockBuffering), + hSetBuffering, + hGetBuffering, + HandlePosn, + hSetPosn, + hGetPosn, + SeekMode (AbsoluteSeek, RelativeSeek, SeekFromEnd), + hSeek, + hTell, + Newline (LF, CRLF), + nativeNewline, + NewlineMode (NewlineMode, inputNL, outputNL), + noNewlineTranslation, + nativeNewlineMode, + universalNewlineMode, + isEOF + ) +import GHC.IO.Handle.Text + ( + hPutChar, + hPutStr, + hPutStrLn, + hPutBuf, + hPutBufNonBlocking, + hGetChar, + hGetContents, + hGetContents', + hGetLine, + hGetBuf, + hGetBufNonBlocking, + hGetBufSome, + hWaitForInput + ) +import qualified GHC.Internal.IO.Handle.FD as POSIX +import GHC.IO.StdHandles + ( + openBinaryFile, + withBinaryFile, + openFile, + withFile, + stdin, + stdout, + stderr + ) +import GHC.IORef (atomicModifyIORef'_) import GHC.Internal.Control.Monad.Fix (fixIO) +import Control.Monad (return, (>>=)) +import Control.Exception (ioError) +import Data.Eq ((==)) +import Data.Ord ((<)) +import Data.Bits ((.|.)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe (Nothing, Just)) +import Data.Char (Char) +import Data.String (String) +import Data.Int (Int) +import Data.IORef (IORef, newIORef) +import System.IO.Error (userError) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Internals + ( + c_getpid, + c_open, + o_CREAT, + o_EXCL, + o_BINARY, + o_NONBLOCK, + o_RDWR, + o_NOCTTY, + withFilePath + ) +import System.Posix.Types (CMode) +import Text.Read (lex, Read, reads) +import Text.Show (Show, show) +import Foreign.C.Types (CInt) +import Foreign.C.Error (Errno, eEXIST, getErrno, errnoToIOError) + +#if defined(mingw32_HOST_OS) +import GHC.IO.SubSystem +import GHC.IO.Windows.Handle (openFileAsTemp) +import GHC.IO.Handle.Windows (mkHandleFromHANDLE) +import GHC.IO.Device as IODevice +import GHC.Internal.Real (fromIntegral) +import Foreign.C.String +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils (with) +import Foreign.Storable +#endif + +----------------------------------------------------------------------------- +-- Standard IO + +-- | Write a character to the standard output device +-- +-- 'putChar' is implemented as @'hPutChar' 'stdout'@. +-- +-- This operation may fail with the same errors as 'hPutChar'. +-- +-- ==== __Examples__ +-- +-- Note that the following do not put a newline. +-- +-- >>> putChar 'x' +-- x +-- +-- >>> putChar '\0042' +-- * +putChar :: Char -> IO () +putChar c = hPutChar stdout c + +-- | Write a string to the standard output device +-- +-- 'putStr' is implemented as @'hPutStr' 'stdout'@. +-- +-- This operation may fail with the same errors, and has the same issues with concurrency, as 'hPutStr'! +-- +-- ==== __Examples__ +-- +-- Note that the following do not put a newline. +-- +-- >>> putStr "Hello, World!" +-- Hello, World! +-- +-- >>> putStr "\0052\0042\0050" +-- 4*2 +-- +putStr :: String -> IO () +putStr s = hPutStr stdout s + +-- | Read a single character from the standard input device. +-- +-- 'getChar' is implemented as @'hGetChar' 'stdin'@. +-- +-- This operation may fail with the same errors as 'hGetChar'. +-- +-- ==== __Examples__ +-- +-- >>> getChar +-- a'a' +-- +-- >>> getChar +-- > +-- '\n' +getChar :: IO Char +getChar = hGetChar stdin + +-- | Read a line from the standard input device. +-- +-- 'getLine' is implemented as @'hGetLine' 'stdin'@. +-- +-- This operation may fail with the same errors as 'hGetLine'. +-- +-- ==== __Examples__ +-- +-- >>> getLine +-- > Hello World! +-- "Hello World!" +-- +-- >>> getLine +-- > +-- "" +getLine :: IO String +getLine = hGetLine stdin + +-- | The 'getContents' operation returns all user input as a single string, +-- which is read lazily as it is needed. +-- +-- 'getContents' is implemented as @'hGetContents' 'stdin'@. +-- +-- This operation may fail with the same errors as 'hGetContents'. +-- +-- ==== __Examples__ +-- +-- >>> getContents >>= putStr +-- > aaabbbccc :D +-- aaabbbccc :D +-- > I hope you have a great day +-- I hope you have a great day +-- > ^D +-- +-- >>> getContents >>= print . length +-- > abc +-- > <3 +-- > def ^D +-- 11 +getContents :: IO String +getContents = hGetContents stdin + +-- | The 'getContents'' operation returns all user input as a single string, +-- which is fully read before being returned +-- +-- 'getContents'' is implemented as @'hGetContents'' 'stdin'@. +-- +-- This operation may fail with the same errors as 'hGetContents''. +-- +-- ==== __Examples__ +-- +-- >>> getContents' >>= putStr +-- > aaabbbccc :D +-- > I hope you have a great day +-- aaabbbccc :D +-- I hope you have a great day +-- +-- >>> getContents' >>= print . length +-- > abc +-- > <3 +-- > def ^D +-- 11 +-- +-- @since base-4.15.0.0 +getContents' :: IO String +getContents' = hGetContents' stdin + +-- | @'interact' f@ takes the entire input from 'stdin' and applies @f@ to it. +-- The resulting string is written to the 'stdout' device. +-- +-- Note that this operation is lazy, which allows to produce output +-- even before all input has been consumed. +-- +-- This operation may fail with the same errors as 'getContents' and 'putStr'. +-- +-- If it doesn't produce output the buffering settings may not be +-- correct, use ^D (ctrl+D) to close stdin which forces +-- the buffer to be consumed. +-- +-- You may wish to set the buffering style appropriate to your program's +-- needs before using this function, for example: +-- +-- @ +-- main :: IO () +-- main = do +-- hSetBuffering stdin LineBuffering +-- hSetBuffering stdout NoBuffering +-- interact (concatMap (\str -> str ++ str) . L.lines) +-- @ +-- +-- ==== __Examples__ +-- +-- >>> interact (\str -> str ++ str) +-- > hi :) +-- hi :) +-- > ^D +-- hi :) +-- +-- >>> interact (const ":D") +-- :D +-- +-- >>> interact (show . words) +-- > hello world! +-- > I hope you have a great day +-- > ^D +-- ["hello","world!","I","hope","you","have","a","great","day"] +interact :: (String -> String) -> IO () +interact f = do s <- getContents + putStr (f s) + +-- | The 'readFile' function reads a file and +-- returns the contents of the file as a string. +-- +-- The file is read lazily, on demand, as with 'getContents'. +-- +-- This operation may fail with the same errors as 'hGetContents' and 'openFile'. +-- +-- ==== __Examples__ +-- +-- >>> readFile "~/hello_world" +-- "Greetings!" +-- +-- >>> take 5 <$> readFile "/dev/zero" +-- "\NUL\NUL\NUL\NUL\NUL" +readFile :: FilePath -> IO String +readFile name = openFile name ReadMode >>= hGetContents + +-- | The 'readFile'' function reads a file and +-- returns the contents of the file as a string. +-- +-- This is identical to 'readFile', but the file is fully read before being returned, +-- as with 'getContents''. +-- +-- @since base-4.15.0.0 +readFile' :: FilePath -> IO String +-- There's a bit of overkill here—both withFile and +-- hGetContents' will close the file in the end. +readFile' name = withFile name ReadMode hGetContents' + +-- | The computation @'writeFile' file str@ function writes the string @str@, +-- to the file @file@. +-- +-- This operation may fail with the same errors as 'hPutStr' and 'withFile'. +-- +-- ==== __Examples__ +-- +-- >>> writeFile "hello" "world" >> readFile "hello" +-- "world" +-- +-- >>> writeFile "~/" "D:" +-- *** Exception: ~/: withFile: inappropriate type (Is a directory) +writeFile :: FilePath -> String -> IO () +writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt) + +-- | The computation @'appendFile' file str@ function appends the string @str@, +-- to the file @file@. +-- +-- Note that 'writeFile' and 'appendFile' write a literal string +-- to a file. To write a value of any printable type, as with 'print', +-- use the 'show' function to convert the value to a string first. +-- +-- This operation may fail with the same errors as 'hPutStr' and 'withFile'. +-- +-- ==== __Examples__ +-- +-- The following example could be more efficently written by acquiring a handle +-- instead with 'openFile' and using the computations capable of writing to handles +-- such as 'hPutStr'. +-- +-- >>> let fn = "hello_world" +-- >>> in writeFile fn "hello" >> appendFile fn " world!" >> (readFile fn >>= putStrLn) +-- "hello world!" +-- +-- >>> let fn = "foo"; output = readFile' fn >>= putStrLn +-- >>> in output >> appendFile fn (show [1,2,3]) >> output +-- this is what's in the file +-- this is what's in the file[1,2,3] +appendFile :: FilePath -> String -> IO () +appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt) + +-- | The 'readLn' function combines 'getLine' and 'readIO'. +-- +-- This operation may fail with the same errors as 'getLine' and 'readIO'. +-- +-- ==== __Examples__ +-- +-- >>> fmap (+ 5) readLn +-- > 25 +-- 30 +-- +-- >>> readLn :: IO String +-- > this is not a string literal +-- *** Exception: user error (Prelude.readIO: no parse) +readLn :: Read a => IO a +readLn = getLine >>= readIO + +-- | The 'readIO' function is similar to 'read' except that it signals +-- parse failure to the 'IO' monad instead of terminating the program. +-- +-- This operation may fail with: +-- +-- * 'GHC.Internal.System.IO.Error.isUserError' if there is no unambiguous parse. +-- +-- ==== __Examples__ +-- +-- >>> fmap (+ 1) (readIO "1") +-- 2 +-- +-- >>> readIO "not quite ()" :: IO () +-- *** Exception: user error (Prelude.readIO: no parse) +readIO :: Read a => String -> IO a +readIO s = case (do { (x,t) <- reads s ; + ("","") <- lex t ; + return x }) of + [x] -> return x + [] -> ioError (userError "Prelude.readIO: no parse") + _ -> ioError (userError "Prelude.readIO: ambiguous parse") + +-- | The encoding of the current locale. +-- +-- This is the initial locale encoding: if it has been subsequently changed by +-- 'GHC.Internal.IO.Encoding.setLocaleEncoding' this value will not reflect that change. +localeEncoding :: TextEncoding +localeEncoding = initLocaleEncoding + +-- | Computation 'hReady' @hdl@ indicates whether at least one item is +-- available for input from handle @hdl@. +-- +-- This operation may fail with: +-- +-- * 'GHC.Internal.System.IO.Error.isEOFError' if the end of file has been reached. +hReady :: Handle -> IO Bool +hReady h = hWaitForInput h 0 + +-- | Computation 'hPrint' @hdl t@ writes the string representation of @t@ +-- given by the 'show' function to the file or channel managed by @hdl@ +-- and appends a newline. +-- +-- This operation may fail with the same errors as 'hPutStrLn' +-- +-- ==== __Examples__ +-- +-- >>> hPrint stdout [1,2,3] +-- [1,2,3] +-- +-- >>> hPrint stdin [4,5,6] +-- *** Exception: <stdin>: hPutStr: illegal operation (handle is not open for writing) +hPrint :: Show a => Handle -> a -> IO () +hPrint hdl = hPutStrLn hdl . show + +-- | The function creates a temporary file in ReadWrite mode. +-- The created file isn\'t deleted automatically, so you need to delete it manually. +-- +-- The file is created with permissions such that only the current +-- user can read\/write it. +-- +-- With some exceptions (see below), the file will be created securely +-- in the sense that an attacker should not be able to cause +-- openTempFile to overwrite another file on the filesystem using your +-- credentials, by putting symbolic links (on Unix) in the place where +-- the temporary file is to be created. On Unix the @O_CREAT@ and +-- @O_EXCL@ flags are used to prevent this attack, but note that +-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you +-- rely on this behaviour it is best to use local filesystems only. +openTempFile :: FilePath -- ^ Directory in which to create the file + -> String -- ^ File name template. If the template is \"foo.ext\" then + -- the created file will be \"fooXXX.ext\" where XXX is some + -- random number. Note that this should not contain any path + -- separator characters. On Windows, the template prefix may + -- be truncated to 3 chars, e.g. \"foobar.ext\" will be + -- \"fooXXX.ext\". + -> IO (FilePath, Handle) +openTempFile tmp_dir template + = openTempFile' "openTempFile" tmp_dir template False 0o600 + +-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template + = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600 + +-- | Like 'openTempFile', but uses the default file permissions +openTempFileWithDefaultPermissions :: FilePath -> String + -> IO (FilePath, Handle) +openTempFileWithDefaultPermissions tmp_dir template + = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666 + +-- | Like 'openBinaryTempFile', but uses the default file permissions +openBinaryTempFileWithDefaultPermissions :: FilePath -> String + -> IO (FilePath, Handle) +openBinaryTempFileWithDefaultPermissions tmp_dir template + = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666 + +openTempFile' :: String -> FilePath -> String -> Bool -> CMode + -> IO (FilePath, Handle) +openTempFile' loc tmp_dir template binary mode + | pathSeparator template + = failIO $ "openTempFile': Template string must not contain path separator characters: "++template + | otherwise = findTempName + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix, suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> errorWithoutStackTrace "bug in GHC.Internal.System.IO.openTempFile" +#if defined(mingw32_HOST_OS) + findTempName = findTempNamePosix <!> findTempNameWinIO + + findTempNameWinIO = do + let label = if null prefix then "ghc" else prefix + withCWString tmp_dir $ \c_tmp_dir -> + withCWString label $ \c_template -> + withCWString suffix $ \c_suffix -> + with nullPtr $ \c_ptr -> do + res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix c_ptr + if not res + then do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + else do c_p <- peek c_ptr + filename <- peekCWString c_p + free c_p + let flags = fromIntegral mode .&. o_EXCL + handleResultsWinIO filename (flags == o_EXCL) + + findTempNamePosix = do + let label = if null prefix then "ghc" else prefix + withCWString tmp_dir $ \c_tmp_dir -> + withCWString label $ \c_template -> + withCWString suffix $ \c_suffix -> + allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do + res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0 + c_str + if not res + then do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + else do filename <- peekCWString c_str + handleResultsPosix filename + + handleResultsPosix filename = do + let oflags1 = rw_flags .|. o_EXCL + binary_flags + | binary = o_BINARY + | otherwise = 0 + oflags = oflags1 .|. binary_flags + fd <- withFilePath filename $ \ f -> c_open f oflags mode + case fd < 0 of + True -> do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + False -> + do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} + False{-is_socket-} + True{-is_nonblock-} + + enc <- getLocaleEncoding + h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode + False{-set non-block-} (Just enc) + + return (filename, h) + + handleResultsWinIO filename excl = do + (hwnd, hwnd_type) <- openFileAsTemp filename True excl + mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding + + -- then use it to make a Handle + h <- mkHandleFromHANDLE hwnd hwnd_type filename ReadWriteMode mb_codec + `onException` IODevice.close hwnd + return (filename, h) + +foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo + :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool + +foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo + :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool + +pathSeparator :: String -> Bool +pathSeparator template = any (\x-> x == '/' || x == '\\') template + +output_flags = std_flags +#else /* else mingw32_HOST_OS */ + findTempName = do + rs <- rand_string + let filename = prefix ++ rs ++ suffix + filepath = tmp_dir `combine` filename + r <- openNewFile filepath binary mode + case r of + FileExists -> findTempName + OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + NewFileCreated fd -> do + (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} + False{-is_socket-} + True{-is_nonblock-} + + enc <- getLocaleEncoding + h <- POSIX.mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc) + + return (filepath, h) + + where + -- XXX bits copied from System.FilePath, since that's not available here + combine a b + | null b = a + | null a = b + | pathSeparator [last a] = a ++ b + | otherwise = a ++ [pathSeparatorChar] ++ b + +tempCounter :: IORef Int +tempCounter = unsafePerformIO $ newIORef 0 +{-# NOINLINE tempCounter #-} + +-- build large digit-alike number +rand_string :: IO String +rand_string = do + r1 <- c_getpid + (r2, _) <- atomicModifyIORef'_ tempCounter (+1) + return $ show r1 ++ "-" ++ show r2 + +data OpenNewFileResult + = NewFileCreated CInt + | FileExists + | OpenNewError Errno + +openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult +openNewFile filepath binary mode = do + let oflags1 = rw_flags .|. o_EXCL + + binary_flags + | binary = o_BINARY + | otherwise = 0 + + oflags = oflags1 .|. binary_flags + fd <- withFilePath filepath $ \ f -> + c_open f oflags mode + if fd < 0 + then do + errno <- getErrno + case errno of + _ | errno == eEXIST -> return FileExists + _ -> return (OpenNewError errno) + else return (NewFileCreated fd) + +-- XXX Should use filepath library +pathSeparatorChar :: Char +pathSeparatorChar = '/' + +pathSeparator :: String -> Bool +pathSeparator template = pathSeparatorChar `elem` template + +output_flags = std_flags .|. o_CREAT +#endif /* mingw32_HOST_OS */ + +-- XXX Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +rw_flags = output_flags .|. o_RDWR -- $locking -- Implementations should enforce as far as possible, at least locally to the ===================================== libraries/base/src/Text/Printf.hs ===================================== @@ -99,7 +99,7 @@ import GHC.Internal.Data.List (stripPrefix) import GHC.Internal.Word import GHC.Internal.Numeric import GHC.Internal.Numeric.Natural -import GHC.Internal.System.IO +import System.IO -- $setup -- >>> import Prelude ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -1,6 +1,4 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-} -{-# OPTIONS_GHC -Wno-x-partial #-} ----------------------------------------------------------------------------- -- | @@ -16,286 +14,13 @@ -- ----------------------------------------------------------------------------- -module GHC.Internal.System.IO ( - -- * The IO monad +module GHC.Internal.System.IO (putStrLn, print) where - IO, - - -- * Files and handles - - FilePath, - - Handle, -- abstract, instance of: Eq, Show. - - -- | GHC note: a 'Handle' will be automatically closed when the garbage - -- collector detects that it has become unreferenced by the program. - -- However, relying on this behaviour is not generally recommended: - -- the garbage collector is unpredictable. If possible, use - -- an explicit 'hClose' to close 'Handle's when they are no longer - -- required. GHC does not currently attempt to free up file - -- descriptors when they have run out, it is your responsibility to - -- ensure that this doesn't happen. - - -- ** Standard handles - - -- | Three handles are allocated during program initialisation, - -- and are initially open. - - stdin, stdout, stderr, - - -- * Opening and closing files - - -- ** Opening files - - withFile, - openFile, - IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), - - -- ** Closing files - - hClose, - - -- ** Special cases - - -- | These functions are also exported by the "Prelude". - - readFile, - readFile', - writeFile, - appendFile, - - -- * Operations on handles - - -- ** Determining and changing the size of a file - - hFileSize, - hSetFileSize, - - -- ** Detecting the end of input - - hIsEOF, - isEOF, - - -- ** Buffering operations - - BufferMode(NoBuffering,LineBuffering,BlockBuffering), - hSetBuffering, - hGetBuffering, - hFlush, - - -- ** Repositioning handles - - hGetPosn, - hSetPosn, - HandlePosn, -- abstract, instance of: Eq, Show. - - hSeek, - SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), - hTell, - - -- ** Handle properties - - hIsOpen, hIsClosed, - hIsReadable, hIsWritable, - hIsSeekable, - - -- ** Terminal operations (not portable: GHC only) - - hIsTerminalDevice, - - hSetEcho, - hGetEcho, - - -- ** Showing handle state (not portable: GHC only) - - hShow, - - -- * Text input and output - - -- ** Text input - - hWaitForInput, - hReady, - hGetChar, - hGetLine, - hLookAhead, - hGetContents, - hGetContents', - - -- ** Text output - - hPutChar, - hPutStr, - hPutStrLn, - hPrint, - - -- ** Special cases for standard input and output - - -- | These functions are also exported by the "Prelude". - - interact, - putChar, - putStr, - putStrLn, - print, - getChar, - getLine, - getContents, - getContents', - readIO, - readLn, - - -- * Binary input and output - - withBinaryFile, - openBinaryFile, - hSetBinaryMode, - hPutBuf, - hGetBuf, - hGetBufSome, - hPutBufNonBlocking, - hGetBufNonBlocking, - - -- * Temporary files - - openTempFile, - openBinaryTempFile, - openTempFileWithDefaultPermissions, - openBinaryTempFileWithDefaultPermissions, - - -- * Unicode encoding\/decoding - - -- | A text-mode 'Handle' has an associated 'TextEncoding', which - -- is used to decode bytes into Unicode characters when reading, - -- and encode Unicode characters into bytes when writing. - -- - -- The default 'TextEncoding' is the same as the default encoding - -- on your system, which is also available as 'localeEncoding'. - -- (GHC note: on Windows, we currently do not support double-byte - -- encodings; if the console\'s code page is unsupported, then - -- 'localeEncoding' will be 'latin1'.) - -- - -- Encoding and decoding errors are always detected and reported, - -- except during lazy I/O ('hGetContents', 'getContents', and - -- 'readFile'), where a decoding error merely results in - -- termination of the character stream, as with other I/O errors. - - hSetEncoding, - hGetEncoding, - - -- ** Unicode encodings - TextEncoding, - latin1, - utf8, utf8_bom, - utf16, utf16le, utf16be, - utf32, utf32le, utf32be, - localeEncoding, - char8, - mkTextEncoding, - - -- * Newline conversion - - -- | In Haskell, a newline is always represented by the character - -- @\'\\n\'@. However, in files and external character streams, a - -- newline may be represented by another character sequence, such - -- as @\'\\r\\n\'@. - -- - -- A text-mode 'Handle' has an associated 'NewlineMode' that - -- specifies how to translate newline characters. The - -- 'NewlineMode' specifies the input and output translation - -- separately, so that for instance you can translate @\'\\r\\n\'@ - -- to @\'\\n\'@ on input, but leave newlines as @\'\\n\'@ on output. - -- - -- The default 'NewlineMode' for a 'Handle' is - -- 'nativeNewlineMode', which does no translation on Unix systems, - -- but translates @\'\\r\\n\'@ to @\'\\n\'@ and back on Windows. - -- - -- Binary-mode 'Handle's do no newline translation at all. - -- - hSetNewlineMode, - hGetNewlineMode, - Newline(..), nativeNewline, - NewlineMode(..), - noNewlineTranslation, universalNewlineMode, nativeNewlineMode, - ) where - -import GHC.Internal.Control.Exception.Base - -import GHC.Internal.Data.Bits -import GHC.Internal.Data.Maybe -import GHC.Internal.Foreign.C.Error -#if defined(mingw32_HOST_OS) -import GHC.Internal.Foreign.C.String -import GHC.Internal.Foreign.Ptr -import GHC.Internal.Foreign.Marshal.Alloc -import GHC.Internal.Foreign.Marshal.Utils (with) -import GHC.Internal.Foreign.Storable -import GHC.Internal.IO.SubSystem -import GHC.Internal.IO.Windows.Handle (openFileAsTemp) -import GHC.Internal.IO.Handle.Windows (mkHandleFromHANDLE) -import GHC.Internal.IO.Device as IODevice -import GHC.Internal.Real (fromIntegral) -#endif -import GHC.Internal.Foreign.C.Types -import GHC.Internal.System.Posix.Internals -import GHC.Internal.System.Posix.Types - -import GHC.Internal.Base -import GHC.Internal.List -#if !defined(mingw32_HOST_OS) -import GHC.Internal.IORef -#endif -import GHC.Internal.Num -import GHC.Internal.IO hiding ( bracket, onException ) -import GHC.Internal.IO.IOMode -import qualified GHC.Internal.IO.FD as FD -import GHC.Internal.IO.Handle -import qualified GHC.Internal.IO.Handle.FD as POSIX -import GHC.Internal.IO.Handle.Text ( hGetBufSome, hPutStrLn ) -import GHC.Internal.IO.Exception ( userError ) -import GHC.Internal.IO.Encoding -import GHC.Internal.Text.Read -import GHC.Internal.IO.StdHandles -import GHC.Internal.Show ------------------------------------------------------------------------------ --- Standard IO - --- | Write a character to the standard output device --- --- 'putChar' is implemented as @'hPutChar' 'stdout'@. --- --- This operation may fail with the same errors as 'hPutChar'. --- --- ==== __Examples__ --- --- Note that the following do not put a newline. --- --- >>> putChar 'x' --- x --- --- >>> putChar '\0042' --- * -putChar :: Char -> IO () -putChar c = hPutChar stdout c - --- | Write a string to the standard output device --- --- 'putStr' is implemented as @'hPutStr' 'stdout'@. --- --- This operation may fail with the same errors, and has the same issues with concurrency, as 'hPutStr'! --- --- ==== __Examples__ --- --- Note that the following do not put a newline. --- --- >>> putStr "Hello, World!" --- Hello, World! --- --- >>> putStr "\0052\0042\0050" --- 4*2 --- -putStr :: String -> IO () -putStr s = hPutStr stdout s +import GHC.Internal.Base (String) +import GHC.Internal.IO (IO) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.IO.StdHandles (stdout) +import GHC.Internal.Show (Show, show) -- | The same as 'putStr', but adds a newline character. -- @@ -332,485 +57,3 @@ putStrLn s = hPutStrLn stdout s -- [(0,1),(1,2),(2,4),(3,8),(4,16),(5,32),(6,64),(7,128),(8,256)] print :: Show a => a -> IO () print x = putStrLn (show x) - --- | Read a single character from the standard input device. --- --- 'getChar' is implemented as @'hGetChar' 'stdin'@. --- --- This operation may fail with the same errors as 'hGetChar'. --- --- ==== __Examples__ --- --- >>> getChar --- a'a' --- --- >>> getChar --- > --- '\n' -getChar :: IO Char -getChar = hGetChar stdin - --- | Read a line from the standard input device. --- --- 'getLine' is implemented as @'hGetLine' 'stdin'@. --- --- This operation may fail with the same errors as 'hGetLine'. --- --- ==== __Examples__ --- --- >>> getLine --- > Hello World! --- "Hello World!" --- --- >>> getLine --- > --- "" -getLine :: IO String -getLine = hGetLine stdin - --- | The 'getContents' operation returns all user input as a single string, --- which is read lazily as it is needed. --- --- 'getContents' is implemented as @'hGetContents' 'stdin'@. --- --- This operation may fail with the same errors as 'hGetContents'. --- --- ==== __Examples__ --- --- >>> getContents >>= putStr --- > aaabbbccc :D --- aaabbbccc :D --- > I hope you have a great day --- I hope you have a great day --- > ^D --- --- >>> getContents >>= print . length --- > abc --- > <3 --- > def ^D --- 11 -getContents :: IO String -getContents = hGetContents stdin - --- | The 'getContents'' operation returns all user input as a single string, --- which is fully read before being returned --- --- 'getContents'' is implemented as @'hGetContents'' 'stdin'@. --- --- This operation may fail with the same errors as 'hGetContents''. --- --- ==== __Examples__ --- --- >>> getContents' >>= putStr --- > aaabbbccc :D --- > I hope you have a great day --- aaabbbccc :D --- I hope you have a great day --- --- >>> getContents' >>= print . length --- > abc --- > <3 --- > def ^D --- 11 --- --- @since base-4.15.0.0 -getContents' :: IO String -getContents' = hGetContents' stdin - --- | @'interact' f@ takes the entire input from 'stdin' and applies @f@ to it. --- The resulting string is written to the 'stdout' device. --- --- Note that this operation is lazy, which allows to produce output --- even before all input has been consumed. --- --- This operation may fail with the same errors as 'getContents' and 'putStr'. --- --- If it doesn't produce output the buffering settings may not be --- correct, use ^D (ctrl+D) to close stdin which forces --- the buffer to be consumed. --- --- You may wish to set the buffering style appropriate to your program's --- needs before using this function, for example: --- --- @ --- main :: IO () --- main = do --- hSetBuffering stdin LineBuffering --- hSetBuffering stdout NoBuffering --- interact (concatMap (\str -> str ++ str) . L.lines) --- @ --- --- ==== __Examples__ --- --- >>> interact (\str -> str ++ str) --- > hi :) --- hi :) --- > ^D --- hi :) --- --- >>> interact (const ":D") --- :D --- --- >>> interact (show . words) --- > hello world! --- > I hope you have a great day --- > ^D --- ["hello","world!","I","hope","you","have","a","great","day"] -interact :: (String -> String) -> IO () -interact f = do s <- getContents - putStr (f s) - --- | The 'readFile' function reads a file and --- returns the contents of the file as a string. --- --- The file is read lazily, on demand, as with 'getContents'. --- --- This operation may fail with the same errors as 'hGetContents' and 'openFile'. --- --- ==== __Examples__ --- --- >>> readFile "~/hello_world" --- "Greetings!" --- --- >>> take 5 <$> readFile "/dev/zero" --- "\NUL\NUL\NUL\NUL\NUL" -readFile :: FilePath -> IO String -readFile name = openFile name ReadMode >>= hGetContents - --- | The 'readFile'' function reads a file and --- returns the contents of the file as a string. --- --- This is identical to 'readFile', but the file is fully read before being returned, --- as with 'getContents''. --- --- @since base-4.15.0.0 -readFile' :: FilePath -> IO String --- There's a bit of overkill here—both withFile and --- hGetContents' will close the file in the end. -readFile' name = withFile name ReadMode hGetContents' - --- | The computation @'writeFile' file str@ function writes the string @str@, --- to the file @file@. --- --- This operation may fail with the same errors as 'hPutStr' and 'withFile'. --- --- ==== __Examples__ --- --- >>> writeFile "hello" "world" >> readFile "hello" --- "world" --- --- >>> writeFile "~/" "D:" --- *** Exception: ~/: withFile: inappropriate type (Is a directory) -writeFile :: FilePath -> String -> IO () -writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt) - --- | The computation @'appendFile' file str@ function appends the string @str@, --- to the file @file@. --- --- Note that 'writeFile' and 'appendFile' write a literal string --- to a file. To write a value of any printable type, as with 'print', --- use the 'show' function to convert the value to a string first. --- --- This operation may fail with the same errors as 'hPutStr' and 'withFile'. --- --- ==== __Examples__ --- --- The following example could be more efficently written by acquiring a handle --- instead with 'openFile' and using the computations capable of writing to handles --- such as 'hPutStr'. --- --- >>> let fn = "hello_world" --- >>> in writeFile fn "hello" >> appendFile fn " world!" >> (readFile fn >>= putStrLn) --- "hello world!" --- --- >>> let fn = "foo"; output = readFile' fn >>= putStrLn --- >>> in output >> appendFile fn (show [1,2,3]) >> output --- this is what's in the file --- this is what's in the file[1,2,3] -appendFile :: FilePath -> String -> IO () -appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt) - --- | The 'readLn' function combines 'getLine' and 'readIO'. --- --- This operation may fail with the same errors as 'getLine' and 'readIO'. --- --- ==== __Examples__ --- --- >>> fmap (+ 5) readLn --- > 25 --- 30 --- --- >>> readLn :: IO String --- > this is not a string literal --- *** Exception: user error (Prelude.readIO: no parse) -readLn :: Read a => IO a -readLn = getLine >>= readIO - --- | The 'readIO' function is similar to 'read' except that it signals --- parse failure to the 'IO' monad instead of terminating the program. --- --- This operation may fail with: --- --- * 'GHC.Internal.System.IO.Error.isUserError' if there is no unambiguous parse. --- --- ==== __Examples__ --- --- >>> fmap (+ 1) (readIO "1") --- 2 --- --- >>> readIO "not quite ()" :: IO () --- *** Exception: user error (Prelude.readIO: no parse) -readIO :: Read a => String -> IO a -readIO s = case (do { (x,t) <- reads s ; - ("","") <- lex t ; - return x }) of - [x] -> return x - [] -> ioError (userError "Prelude.readIO: no parse") - _ -> ioError (userError "Prelude.readIO: ambiguous parse") - --- | The encoding of the current locale. --- --- This is the initial locale encoding: if it has been subsequently changed by --- 'GHC.Internal.IO.Encoding.setLocaleEncoding' this value will not reflect that change. -localeEncoding :: TextEncoding -localeEncoding = initLocaleEncoding - --- | Computation 'hReady' @hdl@ indicates whether at least one item is --- available for input from handle @hdl@. --- --- This operation may fail with: --- --- * 'GHC.Internal.System.IO.Error.isEOFError' if the end of file has been reached. -hReady :: Handle -> IO Bool -hReady h = hWaitForInput h 0 - --- | Computation 'hPrint' @hdl t@ writes the string representation of @t@ --- given by the 'show' function to the file or channel managed by @hdl@ --- and appends a newline. --- --- This operation may fail with the same errors as 'hPutStrLn' --- --- ==== __Examples__ --- --- >>> hPrint stdout [1,2,3] --- [1,2,3] --- --- >>> hPrint stdin [4,5,6] --- *** Exception: <stdin>: hPutStr: illegal operation (handle is not open for writing) -hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStrLn hdl . show - --- | The function creates a temporary file in ReadWrite mode. --- The created file isn\'t deleted automatically, so you need to delete it manually. --- --- The file is created with permissions such that only the current --- user can read\/write it. --- --- With some exceptions (see below), the file will be created securely --- in the sense that an attacker should not be able to cause --- openTempFile to overwrite another file on the filesystem using your --- credentials, by putting symbolic links (on Unix) in the place where --- the temporary file is to be created. On Unix the @O_CREAT@ and --- @O_EXCL@ flags are used to prevent this attack, but note that --- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you --- rely on this behaviour it is best to use local filesystems only. -openTempFile :: FilePath -- ^ Directory in which to create the file - -> String -- ^ File name template. If the template is \"foo.ext\" then - -- the created file will be \"fooXXX.ext\" where XXX is some - -- random number. Note that this should not contain any path - -- separator characters. On Windows, the template prefix may - -- be truncated to 3 chars, e.g. \"foobar.ext\" will be - -- \"fooXXX.ext\". - -> IO (FilePath, Handle) -openTempFile tmp_dir template - = openTempFile' "openTempFile" tmp_dir template False 0o600 - --- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. -openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) -openBinaryTempFile tmp_dir template - = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600 - --- | Like 'openTempFile', but uses the default file permissions -openTempFileWithDefaultPermissions :: FilePath -> String - -> IO (FilePath, Handle) -openTempFileWithDefaultPermissions tmp_dir template - = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666 - --- | Like 'openBinaryTempFile', but uses the default file permissions -openBinaryTempFileWithDefaultPermissions :: FilePath -> String - -> IO (FilePath, Handle) -openBinaryTempFileWithDefaultPermissions tmp_dir template - = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666 - -openTempFile' :: String -> FilePath -> String -> Bool -> CMode - -> IO (FilePath, Handle) -openTempFile' loc tmp_dir template binary mode - | pathSeparator template - = failIO $ "openTempFile': Template string must not contain path separator characters: "++template - | otherwise = findTempName - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below filepath in the hierarchy here. - (prefix, suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> errorWithoutStackTrace "bug in GHC.Internal.System.IO.openTempFile" -#if defined(mingw32_HOST_OS) - findTempName = findTempNamePosix <!> findTempNameWinIO - - findTempNameWinIO = do - let label = if null prefix then "ghc" else prefix - withCWString tmp_dir $ \c_tmp_dir -> - withCWString label $ \c_template -> - withCWString suffix $ \c_suffix -> - with nullPtr $ \c_ptr -> do - res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix c_ptr - if not res - then do errno <- getErrno - ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) - else do c_p <- peek c_ptr - filename <- peekCWString c_p - free c_p - let flags = fromIntegral mode .&. o_EXCL - handleResultsWinIO filename (flags == o_EXCL) - - findTempNamePosix = do - let label = if null prefix then "ghc" else prefix - withCWString tmp_dir $ \c_tmp_dir -> - withCWString label $ \c_template -> - withCWString suffix $ \c_suffix -> - allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do - res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0 - c_str - if not res - then do errno <- getErrno - ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) - else do filename <- peekCWString c_str - handleResultsPosix filename - - handleResultsPosix filename = do - let oflags1 = rw_flags .|. o_EXCL - binary_flags - | binary = o_BINARY - | otherwise = 0 - oflags = oflags1 .|. binary_flags - fd <- withFilePath filename $ \ f -> c_open f oflags mode - case fd < 0 of - True -> do errno <- getErrno - ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) - False -> - do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} - False{-is_socket-} - True{-is_nonblock-} - - enc <- getLocaleEncoding - h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode - False{-set non-block-} (Just enc) - - return (filename, h) - - handleResultsWinIO filename excl = do - (hwnd, hwnd_type) <- openFileAsTemp filename True excl - mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding - - -- then use it to make a Handle - h <- mkHandleFromHANDLE hwnd hwnd_type filename ReadWriteMode mb_codec - `onException` IODevice.close hwnd - return (filename, h) - -foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo - :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool - -foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo - :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool - -pathSeparator :: String -> Bool -pathSeparator template = any (\x-> x == '/' || x == '\\') template - -output_flags = std_flags -#else /* else mingw32_HOST_OS */ - findTempName = do - rs <- rand_string - let filename = prefix ++ rs ++ suffix - filepath = tmp_dir `combine` filename - r <- openNewFile filepath binary mode - case r of - FileExists -> findTempName - OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) - NewFileCreated fd -> do - (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} - False{-is_socket-} - True{-is_nonblock-} - - enc <- getLocaleEncoding - h <- POSIX.mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc) - - return (filepath, h) - - where - -- XXX bits copied from System.FilePath, since that's not available here - combine a b - | null b = a - | null a = b - | pathSeparator [last a] = a ++ b - | otherwise = a ++ [pathSeparatorChar] ++ b - -tempCounter :: IORef Int -tempCounter = unsafePerformIO $ newIORef 0 -{-# NOINLINE tempCounter #-} - --- build large digit-alike number -rand_string :: IO String -rand_string = do - r1 <- c_getpid - (r2, _) <- atomicModifyIORef'_ tempCounter (+1) - return $ show r1 ++ "-" ++ show r2 - -data OpenNewFileResult - = NewFileCreated CInt - | FileExists - | OpenNewError Errno - -openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult -openNewFile filepath binary mode = do - let oflags1 = rw_flags .|. o_EXCL - - binary_flags - | binary = o_BINARY - | otherwise = 0 - - oflags = oflags1 .|. binary_flags - fd <- withFilePath filepath $ \ f -> - c_open f oflags mode - if fd < 0 - then do - errno <- getErrno - case errno of - _ | errno == eEXIST -> return FileExists - _ -> return (OpenNewError errno) - else return (NewFileCreated fd) - --- XXX Should use filepath library -pathSeparatorChar :: Char -pathSeparatorChar = '/' - -pathSeparator :: String -> Bool -pathSeparator template = pathSeparatorChar `elem` template - -output_flags = std_flags .|. o_CREAT -#endif /* mingw32_HOST_OS */ - --- XXX Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -rw_flags = output_flags .|. o_RDWR ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -7848,6 +7848,7 @@ module GHC.IO.Handle where hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding) hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool @@ -9883,7 +9884,7 @@ module System.Exit where exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a module System.IO where - -- Safety: Safe + -- Safety: Trustworthy type BufferMode :: * data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int) type FilePath :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -7820,6 +7820,7 @@ module GHC.IO.Handle where hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding) hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool @@ -9921,7 +9922,7 @@ module System.Exit where exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a module System.IO where - -- Safety: Safe + -- Safety: Trustworthy type BufferMode :: * data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int) type FilePath :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -8012,6 +8012,7 @@ module GHC.IO.Handle where hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding) hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool @@ -10163,7 +10164,7 @@ module System.Exit where exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a module System.IO where - -- Safety: Safe + -- Safety: Trustworthy type BufferMode :: * data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int) type FilePath :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -7848,6 +7848,7 @@ module GHC.IO.Handle where hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding) hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool @@ -9883,7 +9884,7 @@ module System.Exit where exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a module System.IO where - -- Safety: Safe + -- Safety: Trustworthy type BufferMode :: * data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int) type FilePath :: * ===================================== testsuite/tests/plugins/plugins09.stdout ===================================== @@ -1,5 +1,6 @@ parsePlugin(a,b) interfacePlugin: Prelude +interfacePlugin: System.IO interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/plugins/plugins10.stdout ===================================== @@ -2,6 +2,7 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: Language.Haskell.TH interfacePlugin: Language.Haskell.TH.Quote +interfacePlugin: System.IO interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/plugins/plugins11.stdout ===================================== @@ -1,5 +1,6 @@ parsePlugin() interfacePlugin: Prelude +interfacePlugin: System.IO interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/plugins/static-plugins.stdout ===================================== @@ -5,9 +5,9 @@ interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float interfacePlugin: GHC.Internal.Prim.Ext -interfacePlugin: GHC.Internal.System.IO interfacePlugin: GHC.Internal.Types interfacePlugin: GHC.Internal.Show +interfacePlugin: System.IO typeCheckPlugin (rn) interfacePlugin: GHC.Internal.Stack.Types interfacePlugin: GHC.Internal.Exception.Context ===================================== testsuite/tests/typecheck/should_compile/T9497a.stderr ===================================== @@ -1,4 +1,3 @@ - T9497a.hs:2:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] • Found hole: _main :: IO () Or perhaps ‘_main’ is mis-spelled, or not in scope @@ -8,8 +7,7 @@ T9497a.hs:2:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] main :: IO () (bound at T9497a.hs:2:1) readLn :: forall a. Read a => IO a with readLn @() - (imported from ‘Prelude’ - (and originally defined in ‘GHC.Internal.System.IO’)) + (imported from ‘Prelude’ (and originally defined in ‘System.IO’)) mempty :: forall a. Monoid a => a with mempty @(IO ()) (imported from ‘Prelude’ ===================================== testsuite/tests/typecheck/should_compile/holes.stderr ===================================== @@ -45,6 +45,15 @@ holes.hs:11:15: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] y :: [a] z :: [a] -> [a] f :: forall {p}. p + appendFile :: FilePath -> String -> IO () + getChar :: IO Char + getContents :: IO String + getLine :: IO String + interact :: (String -> String) -> IO () + putChar :: Char -> IO () + putStr :: String -> IO () + readFile :: FilePath -> IO String + writeFile :: FilePath -> String -> IO () otherwise :: Bool (&&) :: Bool -> Bool -> Bool not :: Bool -> Bool @@ -58,16 +67,7 @@ holes.hs:11:15: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] showChar :: Char -> ShowS showParen :: Bool -> ShowS -> ShowS showString :: String -> ShowS - appendFile :: FilePath -> String -> IO () - getChar :: IO Char - getContents :: IO String - getLine :: IO String - interact :: (String -> String) -> IO () - putChar :: Char -> IO () - putStr :: String -> IO () putStrLn :: String -> IO () - readFile :: FilePath -> IO String - writeFile :: FilePath -> String -> IO () EQ :: Ordering GT :: Ordering LT :: Ordering ===================================== testsuite/tests/typecheck/should_compile/holes3.stderr ===================================== @@ -48,6 +48,15 @@ holes3.hs:11:15: error: [GHC-88464] y :: [a] z :: [a] -> [a] f :: forall {p}. p + appendFile :: FilePath -> String -> IO () + getChar :: IO Char + getContents :: IO String + getLine :: IO String + interact :: (String -> String) -> IO () + putChar :: Char -> IO () + putStr :: String -> IO () + readFile :: FilePath -> IO String + writeFile :: FilePath -> String -> IO () otherwise :: Bool (&&) :: Bool -> Bool -> Bool not :: Bool -> Bool @@ -61,16 +70,7 @@ holes3.hs:11:15: error: [GHC-88464] showChar :: Char -> ShowS showParen :: Bool -> ShowS -> ShowS showString :: String -> ShowS - appendFile :: FilePath -> String -> IO () - getChar :: IO Char - getContents :: IO String - getLine :: IO String - interact :: (String -> String) -> IO () - putChar :: Char -> IO () - putStr :: String -> IO () putStrLn :: String -> IO () - readFile :: FilePath -> IO String - writeFile :: FilePath -> String -> IO () EQ :: Ordering GT :: Ordering LT :: Ordering ===================================== testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr ===================================== @@ -234,15 +234,14 @@ valid_hole_fits.hs:41:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] Valid hole fits include ps :: String -> IO () (defined at valid_hole_fits.hs:9:1) System.IO.putStr :: String -> IO () - (imported qualified from ‘System.IO’ at valid_hole_fits.hs:4:29-34 - (and originally defined in ‘GHC.Internal.System.IO’)) + (imported qualified from ‘System.IO’ at valid_hole_fits.hs:4:29-34) System.IO.putStrLn :: String -> IO () (imported qualified from ‘System.IO’ at valid_hole_fits.hs:4:37-44 (and originally defined in ‘GHC.Internal.System.IO’)) readIO :: forall a. Read a => String -> IO a with readIO @() (imported from ‘Prelude’ at valid_hole_fits.hs:3:1-40 - (and originally defined in ‘GHC.Internal.System.IO’)) + (and originally defined in ‘System.IO’)) fail :: forall (m :: * -> *) a. (MonadFail m, GHC.Internal.Stack.Types.HasCallStack) => String -> m a ===================================== testsuite/tests/typecheck/should_fail/T9497d.stderr ===================================== @@ -8,8 +8,7 @@ T9497d.hs:2:8: error: [GHC-88464] main :: IO () (bound at T9497d.hs:2:1) readLn :: forall a. Read a => IO a with readLn @() - (imported from ‘Prelude’ - (and originally defined in ‘GHC.Internal.System.IO’)) + (imported from ‘Prelude’ (and originally defined in ‘System.IO’)) mempty :: forall a. Monoid a => a with mempty @(IO ()) (imported from ‘Prelude’ ===================================== testsuite/tests/typecheck/should_run/T9497a-run.stderr ===================================== @@ -10,8 +10,7 @@ T9497a-run.hs:2:8: error: [GHC-88464] main :: IO () (bound at T9497a-run.hs:2:1) readLn :: forall a. Read a => IO a with readLn @() - (imported from ‘Prelude’ - (and originally defined in ‘GHC.Internal.System.IO’)) + (imported from ‘Prelude’ (and originally defined in ‘System.IO’)) mempty :: forall a. Monoid a => a with mempty @(IO ()) (imported from ‘Prelude’ ===================================== testsuite/tests/typecheck/should_run/T9497b-run.stderr ===================================== @@ -10,8 +10,7 @@ T9497b-run.hs:2:8: error: [GHC-88464] main :: IO () (bound at T9497b-run.hs:2:1) readLn :: forall a. Read a => IO a with readLn @() - (imported from ‘Prelude’ - (and originally defined in ‘GHC.Internal.System.IO’)) + (imported from ‘Prelude’ (and originally defined in ‘System.IO’)) mempty :: forall a. Monoid a => a with mempty @(IO ()) (imported from ‘Prelude’ ===================================== testsuite/tests/typecheck/should_run/T9497c-run.stderr ===================================== @@ -10,8 +10,7 @@ T9497c-run.hs:2:8: error: [GHC-88464] main :: IO () (bound at T9497c-run.hs:2:1) readLn :: forall a. Read a => IO a with readLn @() - (imported from ‘Prelude’ - (and originally defined in ‘GHC.Internal.System.IO’)) + (imported from ‘Prelude’ (and originally defined in ‘System.IO’)) mempty :: forall a. Monoid a => a with mempty @(IO ()) (imported from ‘Prelude’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a662500af11d46f435ff7b4f25cb7aa… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a662500af11d46f435ff7b4f25cb7aa… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 15 commits: hadrian: remove redundant library/rts ways definitions from stock flavours
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 669d09f9 by Cheng Shao at 2026-03-13T15:06:07-04:00 hadrian: remove redundant library/rts ways definitions from stock flavours This patch removes redundant library/rts ways definitions from stock flavours in hadrian; they can be replaced by applying appropriate filters on `defaultFlavour`. - - - - - a27dc081 by Teo Camarasu at 2026-03-13T15:06:51-04:00 ghc-internal: move bits Weak of finalizer interface to base We move parts of the Weak finalizer interface to `base` only the parts that the RTS needs to know about are kept in `ghc-internal`. This lets us then prune our imports somewhat and get rid of some SOURCE imports. Resolves #26985 - - - - - 6eef855b by Sylvain Henry at 2026-03-13T15:08:18-04:00 Stg/Unarise: constant-folding during unarisation (#25650) When building an unboxed sum from a literal argument, mkUbxSum previously emitted a runtime cast via `case primop [lit] of var -> ...`. This wrapper prevented GHC from recognising the result as a static StgRhsCon, causing top-level closures to be allocated as thunks instead of being statically allocated. Fix: try to perform the numeric literal cast at compile time using mkLitNumberWrap (wrapping semantics). If successful, return the cast literal directly with an identity wrapper (no case expression). The runtime cast path is kept as fallback for non-literal arguments. Test: codeGen/should_compile/T25650 - - - - - 905f8723 by Simon Jakobi at 2026-03-13T15:09:09-04:00 Add regression test for #2057 Test that GHC stops after an interface-file error instead of continuing into the linker. The test constructs a stale package dependency on purpose. `pkgB` is compiled against one version of package `A`, then the same unit id is replaced by an incompatible build of `A`. When `Main` imports `B`, GHC has to read `B.hi`, finds an unfolding that still mentions the old `A`, and should fail while loading interfaces. Closes #2057. Assisted-by: Codex - - - - - a13245a9 by Sylvain Henry at 2026-03-13T15:10:06-04:00 JS: fix recompilation avoidance (#23013) - we were checking the mtime of the *.jsexe directory, not of a file - we were not computing the PkgsLoaded at all - - - - - 07442653 by Cheng Shao at 2026-03-13T15:10:51-04:00 hadrian: bump index state & bootstrap plans This patch bumps hadrian index state & bootstrap plans: - The updated index state allows bootstrapping from 9.14 without cabal allow-newer hacks - The updated bootstrap plans all contain shake-0.19.9 containing important bugfix, allowing a subsequent patch to bump shake bound to ensure the bugfix is included - ghc 9.14.1 bootstrap plan is added - - - - - fdc1dbad by Cheng Shao at 2026-03-13T15:10:51-04:00 ci: add ghc 9.14.1 to bootstrap matrix This patch adds ghc 9.14.1 to bootstrap matrix, so that we test bootstrapping from ghc 9.14.1. - - - - - 91916079 by Sylvain Henry at 2026-03-13T15:11:43-04:00 T17912: wait for opener thread to block before killing it (#24739) Instead of a fixed 1000ms delay, poll threadStatus until the opener thread is in BlockedOnForeignCall, ensuring killThread only fires once the thread is provably inside the blocking open() syscall. This prevents the test from accidentally passing on Windows due to scheduling races. - - - - - baa4ebb4 by Cheng Shao at 2026-03-13T15:12:26-04:00 template-haskell: fix redundant import in Language.Haskell.TH.Quote This patch fixes a redundant import in `Language.Haskell.TH.Quote` that causes a ghc build failure when bootstrapping from 9.14 with validate flavours. Fixes #27014. - - - - - 02e68a86 by Brandon Simmons at 2026-03-13T15:13:19-04:00 Add a cumulative gc_sync_elapsed_ns counter to GHC.Internal.Stats This makes it possible to get an accurate view of time spent in sync phase when using prometheus-style sampling. Previously this was only available for the most recent GC. This intentionally leaves GHC.Stats API unchanged since it is marked as deprecated, and API changes there require CLC approval. Fixes #26944 - - - - - c0ba51fc by Matthew Pickering at 2026-03-13T15:46:40-04:00 exceptions: annotate onException continuation with WhileHandling Before this patch, an exception thrown in the `onException` handler would loose track of where the original exception was thrown. ``` import Control.Exception main :: IO () main = failingAction `onException` failingCleanup where failingAction = throwIO (ErrorCall "outer failure") failingCleanup = throwIO (ErrorCall "cleanup failure") ``` would report ``` T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure HasCallStack backtrace: throwIO, called at T28399.hs:<line>:<column> in <package-id>:Main ``` notice that the "outer failure" exception is not present in the error message. With this patch, any exception thrown is in the handler is annotated with WhileHandling. The resulting message looks like ``` T28399: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure While handling outer failure HasCallStack backtrace: throwIO, called at T28399.hs:7:22 in main:Main ``` CLC Proposal: https://github.com/haskell/core-libraries-committee/issues/397 Fixes #26759 - - - - - ab418a11 by Andreas Klebinger at 2026-03-13T15:46:41-04:00 Fix missing profiling header for origin_thunk frame. Fixes #27007 - - - - - a180327f by Matthew Pickering at 2026-03-13T15:46:42-04:00 rts: forward clone-stack messages after TSO migration MSG_CLONE_STACK assumed that the target TSO was still owned by the capability that received the message. This is not always true: the TSO can migrate before the inbox entry is handled. When that happened, handleCloneStackMessage could clone a live stack from the wrong capability and use the wrong capability for allocation and performTryPutMVar, leading to stack sanity failures such as checkStackFrame: weird activation record found on stack. Fix this by passing the current capability into handleCloneStackMessage, rechecking msg->tso->cap at handling time, and forwarding the message if the TSO has migrated. Once ownership matches, use the executing capability consistently for cloneStack, rts_apply, and performTryPutMVar. Fixes #27008 - - - - - 0e32fbb7 by Cheng Shao at 2026-03-13T15:46:43-04:00 ci: fix ci-images revision The current ci-images revision was a commit on the WIP branch of https://gitlab.haskell.org/ghc/ci-images/-/merge_requests/183, and it's not on the current ci-images master branch. This patch fixes the image revision to use the current tip of ci-images master. - - - - - dedb4fec by Andreas Klebinger at 2026-03-13T15:46:44-04:00 Revert "hadrian/build-cabal: Better respect and utilize -j" This reverts commit eab3dbba79650e6046efca79133b4c0a5257613d. While it's neat this currently isn't well supported on all platforms. It's time will come, but for now I'm reverting this to avoid issues for users on slightly unconvential platforms. This will be tracked at #26977. - - - - - 89 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/Stg/Unarise.hs - hadrian/bootstrap/generate_bootstrap_plans - hadrian/bootstrap/plan-9_10_1.json - hadrian/bootstrap/plan-9_10_2.json - hadrian/bootstrap/plan-9_10_3.json - hadrian/bootstrap/plan-9_12_1.json - hadrian/bootstrap/plan-9_12_2.json - + hadrian/bootstrap/plan-9_14_1.json - hadrian/bootstrap/plan-bootstrap-9_10_1.json - hadrian/bootstrap/plan-bootstrap-9_10_2.json - hadrian/bootstrap/plan-bootstrap-9_10_3.json - hadrian/bootstrap/plan-bootstrap-9_12_1.json - hadrian/bootstrap/plan-bootstrap-9_12_2.json - + hadrian/bootstrap/plan-bootstrap-9_14_1.json - hadrian/build-cabal - hadrian/cabal.project - hadrian/src/Settings/Flavours/Development.hs - hadrian/src/Settings/Flavours/GhcInGhci.hs - hadrian/src/Settings/Flavours/Quick.hs - hadrian/src/Settings/Flavours/QuickCross.hs - hadrian/src/Settings/Flavours/Quickest.hs - libraries/base/changelog.md - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs - − libraries/base/src/GHC/Weak/Finalizehs - libraries/base/src/System/Mem/Weak.hs - libraries/base/tests/IO/T17912.hs - libraries/base/tests/IO/all.T - libraries/ghc-internal/CHANGELOG.md - − libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs-boot - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - − libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs-boot - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - rts/CloneStack.c - rts/CloneStack.h - rts/Messages.c - rts/Stats.c - rts/StgMiscClosures.cmm - rts/include/RtsAPI.h - testsuite/.gitignore - testsuite/tests/annotations/should_run/all.T - testsuite/tests/codeGen/should_compile/Makefile - + testsuite/tests/codeGen/should_compile/T25650.hs - + testsuite/tests/codeGen/should_compile/T25650.stdout-ws-32 - + testsuite/tests/codeGen/should_compile/T25650.stdout-ws-64 - testsuite/tests/codeGen/should_compile/all.T - − testsuite/tests/driver/OneShotTH.stdout-javascript-unknown-ghcjs - + testsuite/tests/driver/T2057/Makefile - + testsuite/tests/driver/T2057/README.md - + testsuite/tests/driver/T2057/T2057.stderr - + testsuite/tests/driver/T2057/all.T - + testsuite/tests/driver/T2057/app/Main.hs - + testsuite/tests/driver/T2057/pkgA1/A.hs - + testsuite/tests/driver/T2057/pkgA1/pkg.conf - + testsuite/tests/driver/T2057/pkgA2/A.hs - + testsuite/tests/driver/T2057/pkgA2/pkg.conf - + testsuite/tests/driver/T2057/pkgB/B.hs - + testsuite/tests/driver/T2057/pkgB/pkg.conf - + testsuite/tests/driver/T20604/T20604.stdout-javascript-unknown-ghcjs - testsuite/tests/driver/T20604/all.T - testsuite/tests/driver/all.T - testsuite/tests/driver/fat-iface/fat010.stdout-javascript-unknown-ghcjs - testsuite/tests/driver/recomp011/all.T - testsuite/tests/driver/recompHash/recompHash.stdout-javascript-unknown-ghcjs - testsuite/tests/driver/recompNoTH/recompNoTH.stdout-javascript-unknown-ghcjs - − testsuite/tests/driver/th-new-test/th-new-test.stdout-javascript-unknown-ghcjs - + testsuite/tests/exceptions/T26759.hs - + testsuite/tests/exceptions/T26759.stderr - + testsuite/tests/exceptions/T26759a.hs - + testsuite/tests/exceptions/T26759a.stderr - + testsuite/tests/exceptions/T26759a.stdout - testsuite/tests/exceptions/all.T - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/rts/all.T - + testsuite/tests/rts/cloneThreadStackMigrating.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/01ab93dec36cf26bf771a08f064fdb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/01ab93dec36cf26bf771a08f064fdb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add a cumulative gc_sync_elapsed_ns counter to GHC.Internal.Stats
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 02e68a86 by Brandon Simmons at 2026-03-13T15:13:19-04:00 Add a cumulative gc_sync_elapsed_ns counter to GHC.Internal.Stats This makes it possible to get an accurate view of time spent in sync phase when using prometheus-style sampling. Previously this was only available for the most recent GC. This intentionally leaves GHC.Stats API unchanged since it is marked as deprecated, and API changes there require CLC approval. Fixes #26944 - - - - - 7 changed files: - libraries/base/src/GHC/Stats.hs - libraries/ghc-internal/CHANGELOG.md - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - rts/Stats.c - rts/include/RtsAPI.h - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 Changes: ===================================== libraries/base/src/GHC/Stats.hs ===================================== @@ -26,6 +26,7 @@ -- proposal -- #289](https://github.com/haskell/core-libraries-committee/issues/289). These -- declarations are now instead available from the @ghc-experimental@ package. +-- @ghc-experimental@ contains additional metrics not added to the API here. module GHC.Stats ( -- * Runtime statistics ===================================== libraries/ghc-internal/CHANGELOG.md ===================================== @@ -3,6 +3,7 @@ ## 9.1401.0 -- yyyy-mm-dd * Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively. +* Add new `gc_sync_elapsed_ns` counter to GHC.Internal.Stats ## 9.1001.0 -- 2024-05-01 ===================================== libraries/ghc-internal/src/GHC/Internal/Stats.hsc ===================================== @@ -111,6 +111,8 @@ data RTSStats = RTSStats { , gc_cpu_ns :: RtsTime -- | Total elapsed time used by the GC , gc_elapsed_ns :: RtsTime + -- | Total elapsed time used during GC synchronization + , gc_sync_elapsed_ns :: RtsTime -- | Total CPU time (at the previous GC) , cpu_ns :: RtsTime -- | Total elapsed time (at the previous GC) @@ -234,6 +236,7 @@ getRTSStats = do mutator_elapsed_ns <- (# peek RTSStats, mutator_elapsed_ns) p gc_cpu_ns <- (# peek RTSStats, gc_cpu_ns) p gc_elapsed_ns <- (# peek RTSStats, gc_elapsed_ns) p + gc_sync_elapsed_ns <- (# peek RTSStats, gc_sync_elapsed_ns) p cpu_ns <- (# peek RTSStats, cpu_ns) p elapsed_ns <- (# peek RTSStats, elapsed_ns) p nonmoving_gc_sync_cpu_ns <- (# peek RTSStats, nonmoving_gc_sync_cpu_ns) p ===================================== rts/Stats.c ===================================== @@ -163,6 +163,7 @@ initStats0(void) .mutator_elapsed_ns = 0, .gc_cpu_ns = 0, .gc_elapsed_ns = 0, + .gc_sync_elapsed_ns = 0, .cpu_ns = 0, .elapsed_ns = 0, .nonmoving_gc_cpu_ns = 0, @@ -288,6 +289,8 @@ stat_endExit(void) RELEASE_LOCK(&stats_mutex); } +// This is only called in the threaded RTS. On non-threaded RTS `gc_sync_start_elapsed` +// is conditonally set in `stat_startGC`. void stat_startGCSync (gc_thread *gct) { @@ -433,6 +436,11 @@ stat_startGC (Capability *cap, gc_thread *gct) } gct->gc_start_elapsed = getProcessElapsedTime(); +#if !defined(THREADED_RTS) + // Non-threaded RTS has no sync phase. Initializing in this way makes the + // calculated statistics correctly read zero. + gct->gc_sync_start_elapsed = gct->gc_start_elapsed; +#endif // Post EVENT_GC_START with the same timestamp as used for stats // (though converted from Time=StgInt64 to EventTimestamp=StgWord64). @@ -548,6 +556,7 @@ stat_endGC (Capability *cap, gc_thread *initiating_gct, W_ live, W_ copied, W_ s } stats.gc_cpu_ns += stats.gc.cpu_ns; stats.gc_elapsed_ns += stats.gc.elapsed_ns; + stats.gc_sync_elapsed_ns += stats.gc.sync_elapsed_ns; if (gen == RtsFlags.GcFlags.generations-1) { // major GC? stats.major_gcs++; @@ -915,6 +924,8 @@ static void report_summary(const RTSSummaryStats* sum) statsPrintf(" GC time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(stats.gc_cpu_ns), TimeToSecondsDbl(stats.gc_elapsed_ns)); + statsPrintf(" GC SYNC time (%7.3fs elapsed)\n", + TimeToSecondsDbl(stats.gc_sync_elapsed_ns)); if (RtsFlags.GcFlags.useNonmoving) { statsPrintf( " CONC GC time %7.3fs (%7.3fs elapsed)\n", @@ -1069,6 +1080,7 @@ static void report_machine_readable (const RTSSummaryStats * sum) TimeToSecondsDbl(stats.mutator_elapsed_ns)); MR_STAT("GC_cpu_seconds", "f", TimeToSecondsDbl(stats.gc_cpu_ns)); MR_STAT("GC_wall_seconds", "f", TimeToSecondsDbl(stats.gc_elapsed_ns)); + MR_STAT("GC_sync_wall_seconds", "f", TimeToSecondsDbl(stats.gc_sync_elapsed_ns)); // end backward compatibility ===================================== rts/include/RtsAPI.h ===================================== @@ -240,6 +240,8 @@ typedef struct _RTSStats { Time gc_cpu_ns; // Total elapsed time used by the GC Time gc_elapsed_ns; + // Total elapsed time used during GC synchronization + Time gc_sync_elapsed_ns; // Total CPU time (at the previous GC) Time cpu_ns; // Total elapsed time (at the previous GC) ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -6587,6 +6587,7 @@ module GHC.Stats.Experimental where mutator_elapsed_ns :: RtsTime, gc_cpu_ns :: RtsTime, gc_elapsed_ns :: RtsTime, + gc_sync_elapsed_ns :: RtsTime, cpu_ns :: RtsTime, elapsed_ns :: RtsTime, nonmoving_gc_sync_cpu_ns :: RtsTime, ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -6590,6 +6590,7 @@ module GHC.Stats.Experimental where mutator_elapsed_ns :: RtsTime, gc_cpu_ns :: RtsTime, gc_elapsed_ns :: RtsTime, + gc_sync_elapsed_ns :: RtsTime, cpu_ns :: RtsTime, elapsed_ns :: RtsTime, nonmoving_gc_sync_cpu_ns :: RtsTime, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02e68a86e438edb315ba8622c58733d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02e68a86e438edb315ba8622c58733d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] template-haskell: fix redundant import in Language.Haskell.TH.Quote
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: baa4ebb4 by Cheng Shao at 2026-03-13T15:12:26-04:00 template-haskell: fix redundant import in Language.Haskell.TH.Quote This patch fixes a redundant import in `Language.Haskell.TH.Quote` that causes a ghc build failure when bootstrapping from 9.14 with validate flavours. Fixes #27014. - - - - - 1 changed file: - libraries/template-haskell/Language/Haskell/TH/Quote.hs Changes: ===================================== libraries/template-haskell/Language/Haskell/TH/Quote.hs ===================================== @@ -23,7 +23,6 @@ module Language.Haskell.TH.Quote ) where import GHC.Boot.TH.Monad -import GHC.Boot.TH.Quote import Language.Haskell.TH.Syntax (dataToQa, dataToExpQ, dataToPatQ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/baa4ebb40dff80a7572a59e41fe5bc3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/baa4ebb40dff80a7572a59e41fe5bc3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] T17912: wait for opener thread to block before killing it (#24739)
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 91916079 by Sylvain Henry at 2026-03-13T15:11:43-04:00 T17912: wait for opener thread to block before killing it (#24739) Instead of a fixed 1000ms delay, poll threadStatus until the opener thread is in BlockedOnForeignCall, ensuring killThread only fires once the thread is provably inside the blocking open() syscall. This prevents the test from accidentally passing on Windows due to scheduling races. - - - - - 2 changed files: - libraries/base/tests/IO/T17912.hs - libraries/base/tests/IO/all.T Changes: ===================================== libraries/base/tests/IO/T17912.hs ===================================== @@ -6,6 +6,7 @@ import Control.Exception import System.IO import System.Exit import System.Process +import GHC.Conc (threadStatus, ThreadStatus(..), BlockReason(..)) import GHC.IO.Handle.FD main = do @@ -22,7 +23,14 @@ main = do putMVar passed True else print e throwIO e - threadDelay 1000 + let waitUntilBlocked = do + st <- threadStatus opener + case st of + ThreadBlocked BlockedOnForeignCall -> return () + ThreadFinished -> return () + ThreadDied -> return () + _ -> threadDelay 100 >> waitUntilBlocked + waitUntilBlocked forkIO $ killThread opener forkIO $ do threadDelay (10^6) ===================================== libraries/base/tests/IO/all.T ===================================== @@ -182,7 +182,7 @@ test('T17414', compile_and_run, ['']) test('T17510', expect_broken(17510), compile_and_run, ['']) test('bytestringread001', extra_run_opts('test.data'), compile_and_run, ['']) -test('T17912', [only_ways(['threaded1']), when(opsys('mingw32'),expect_broken(1))], compile_and_run, ['']) +test('T17912', [only_ways(['threaded1']), when(opsys('mingw32'),expect_broken(17912))], compile_and_run, ['']) test('T18832', only_ways(['threaded1']), compile_and_run, ['']) test('mkdirExists', [exit_code(1), when(opsys('mingw32'), ignore_stderr)], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91916079d8d7ce3fd4c2595b47c959c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91916079d8d7ce3fd4c2595b47c959c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: hadrian: bump index state & bootstrap plans
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 07442653 by Cheng Shao at 2026-03-13T15:10:51-04:00 hadrian: bump index state & bootstrap plans This patch bumps hadrian index state & bootstrap plans: - The updated index state allows bootstrapping from 9.14 without cabal allow-newer hacks - The updated bootstrap plans all contain shake-0.19.9 containing important bugfix, allowing a subsequent patch to bump shake bound to ensure the bugfix is included - ghc 9.14.1 bootstrap plan is added - - - - - fdc1dbad by Cheng Shao at 2026-03-13T15:10:51-04:00 ci: add ghc 9.14.1 to bootstrap matrix This patch adds ghc 9.14.1 to bootstrap matrix, so that we test bootstrapping from ghc 9.14.1. - - - - - 16 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - hadrian/bootstrap/generate_bootstrap_plans - hadrian/bootstrap/plan-9_10_1.json - hadrian/bootstrap/plan-9_10_2.json - hadrian/bootstrap/plan-9_10_3.json - hadrian/bootstrap/plan-9_12_1.json - hadrian/bootstrap/plan-9_12_2.json - + hadrian/bootstrap/plan-9_14_1.json - hadrian/bootstrap/plan-bootstrap-9_10_1.json - hadrian/bootstrap/plan-bootstrap-9_10_2.json - hadrian/bootstrap/plan-bootstrap-9_10_3.json - hadrian/bootstrap/plan-bootstrap-9_12_1.json - hadrian/bootstrap/plan-bootstrap-9_12_2.json - + hadrian/bootstrap/plan-bootstrap-9_14_1.json - hadrian/cabal.project The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a13245a92c4cacf81b7adf41cc3602… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a13245a92c4cacf81b7adf41cc3602… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] JS: fix recompilation avoidance (#23013)
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a13245a9 by Sylvain Henry at 2026-03-13T15:10:06-04:00 JS: fix recompilation avoidance (#23013) - we were checking the mtime of the *.jsexe directory, not of a file - we were not computing the PkgsLoaded at all - - - - - 14 changed files: - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - testsuite/tests/annotations/should_run/all.T - − testsuite/tests/driver/OneShotTH.stdout-javascript-unknown-ghcjs - + testsuite/tests/driver/T20604/T20604.stdout-javascript-unknown-ghcjs - testsuite/tests/driver/T20604/all.T - testsuite/tests/driver/all.T - testsuite/tests/driver/fat-iface/fat010.stdout-javascript-unknown-ghcjs - testsuite/tests/driver/recomp011/all.T - testsuite/tests/driver/recompHash/recompHash.stdout-javascript-unknown-ghcjs - testsuite/tests/driver/recompNoTH/recompNoTH.stdout-javascript-unknown-ghcjs - − testsuite/tests/driver/th-new-test/th-new-test.stdout-javascript-unknown-ghcjs Changes: ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -106,8 +106,6 @@ module GHC.Driver.Main import GHC.Prelude -import GHC.Platform - import GHC.Driver.Plugins import GHC.Driver.Session import GHC.Driver.Backend @@ -259,8 +257,6 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Utils.Touch -import qualified GHC.LanguageExtensions as LangExt - import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.OsPath (unsafeEncodeUtf) @@ -295,8 +291,8 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) import GHC.Stg.EnforceEpt.TagSig (seqTagSig) import GHC.StgToCmm.Utils (IPEStats) +import GHC.Types.Unique.DSet ( uniqDSetToList ) import GHC.Types.Unique.FM -import GHC.Types.Unique.DFM import GHC.Cmm.Config (CmmConfig) import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG @@ -855,14 +851,6 @@ hscRecompStatus msg UpToDate return $ HscUpToDate checked_iface emptyRecompLinkables - -- Always recompile with the JS backend when TH is enabled until - -- #23013 is fixed. - | ArchJavaScript <- platformArch (targetPlatform lcl_dflags) - , xopt LangExt.TemplateHaskell lcl_dflags - -> do - msg $ needsRecompileBecause THWithJS - return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface - | otherwise -> do -- Check the status of all the linkable types we might need. -- 1. The in-memory linkable we had at hand. @@ -2910,7 +2898,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do initLoaderState interp hsc_env -- Take lock for the actual work. - (dep_linkables, needed_units) <- modifyLoaderState interp $ \pls -> do + (dep_linkables, needed_units, this_pkgs_loaded) <- modifyLoaderState interp $ \pls -> do let link_opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required @@ -2921,11 +2909,14 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do let objs = mapMaybe linkableFilterNative (ldNeededLinkables deps) (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs - -- FIXME: we should make the JS linker load new_objs here, instead of - -- on-demand. - - let pls' = pls { objs_loaded = objs_loaded' } - pure (pls', (ldAllLinkables deps, ldUnits deps)) + -- Compute LoadedPkgInfo metadata for recompilation avoidance. + -- We don't call loadPackages' because the JS interpreter doesn't load + -- native .o/.so files; we only need the transitive-dep metadata. + (_, pkgs_almost_loaded) <- + loadMoreUnits hsc_env (ldUnits deps) (pkgs_loaded pls) + let this_pkgs_loaded = filterNeededPkgsLoaded (ldNeededUnits deps) pkgs_almost_loaded + pls' = pls { objs_loaded = objs_loaded', pkgs_loaded = pkgs_almost_loaded } + pure (pls', (ldAllLinkables deps, uniqDSetToList (ldNeededUnits deps), this_pkgs_loaded)) let foreign_stubs = NoStubs @@ -2950,11 +2941,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do binding_fref <- withJSInterp i $ \inst -> mkForeignRef href (freeReallyRemoteRef inst href) - -- FIXME: we don't report needed units because we would have to find a way to - -- build a meaningful LoadedPkgInfo (see the mess in - -- GHC.Linker.Loader.{loadPackage,loadPackages'}). - let pkgs_loaded = emptyUDFM - return (castForeignRef binding_fref, dep_linkables, pkgs_loaded) + return (castForeignRef binding_fref, dep_linkables, this_pkgs_loaded) {- ********************************************************************** ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -556,7 +556,14 @@ checkNativeLibraryLinkingNeeded staticLink _ dflags unit_env linkables pkg_deps unit_state = ue_homeUnitState unit_env arch_os = platformArchOS platform exe_file = exeFileName arch_os staticLink (outputFile_ dflags) - exe_file_os <- SysOsPath.encodeFS exe_file + -- For the JS backend, exe_file is a directory (*.jsexe). A directory's + -- mtime on Linux is only updated when entries are created/deleted, not + -- when existing files are overwritten. jsLink always overwrites out.js, + -- so use that as the mtime sentinel instead. + exe_time_file + | ArchJavaScript <- platformArch platform = exe_file </> "out.js" + | otherwise = exe_file + exe_file_os <- SysOsPath.encodeFS exe_time_file e_exe_time <- modificationTimeIfExists exe_file_os case e_exe_time of Nothing -> return $ NeedsRecompile MustCompile ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -204,7 +204,6 @@ data RecompReason | MismatchedDynHiFile | ObjectsChanged | LibraryChanged - | THWithJS deriving (Eq) @@ -241,7 +240,6 @@ instance Outputable RecompReason where MismatchedDynHiFile -> text "Mismatched dynamic interface file" ObjectsChanged -> text "Objects changed" LibraryChanged -> text "Library changed" - THWithJS -> text "JS backend always recompiles modules using Template Haskell for now (#23013)" recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -36,6 +36,8 @@ module GHC.Linker.Loader , initLinkDepsOpts , getGccSearchDirectory , mkDynLoadLib + , loadMoreUnits + , filterNeededPkgsLoaded ) where @@ -252,6 +254,20 @@ loadName interp hsc_env name = do (ppr sym_to_find) return (pls,(r, links, pkgs)) +-- | Restrict a 'PkgsLoaded' map to the packages directly needed and their +-- full transitive closure (via 'loaded_pkg_trans_deps'). +filterNeededPkgsLoaded :: UniqDSet UnitId -> PkgsLoaded -> PkgsLoaded +filterNeededPkgsLoaded directly_needed all_pkgs_loaded = + udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed + where + trans_pkgs_needed = + unionManyUniqDSets + (directly_needed : + [ loaded_pkg_trans_deps pkg + | pkg_id <- uniqDSetToList directly_needed + , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id] + ]) + loadDependencies :: Interp -> HscEnv @@ -271,12 +287,7 @@ loadDependencies interp hsc_env pls span needed_mods = do -- Link the packages and modules required pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls (pls2, succ) <- loadExternalModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps) - let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed - all_pkgs_loaded = pkgs_loaded pls2 - trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg - | pkg_id <- uniqDSetToList this_pkgs_needed - , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id] - ]) + let this_pkgs_loaded = filterNeededPkgsLoaded this_pkgs_needed (pkgs_loaded pls2) return (pls2, succ, ldAllLinkables deps, this_pkgs_loaded) @@ -1170,17 +1181,26 @@ loadPackages interp hsc_env new_pkgs = do modifyLoaderState_ interp $ \pls -> loadPackages' interp hsc_env new_pkgs pls -loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState -loadPackages' interp hsc_env new_pks pls = do - (reverse -> pkgs_info_list, pkgs_almost_loaded) <- - downsweep - ([], pkgs_loaded pls) - new_pks - loadPackage interp hsc_env pkgs_info_list (pls { pkgs_loaded = pkgs_almost_loaded }) +-- | Compute 'LoadedPkgInfo' metadata (with transitive deps) for new packages, +-- without loading any native libraries. Used for recompilation-avoidance +-- tracking and as the first pass of 'loadPackages''. +-- +-- The returned '[UnitInfo]' list is an accumulated *reverse* topologically +-- sorted list of new packages. The returned 'PkgsLoaded' is populated with +-- placeholder 'LoadedPkgInfo' for new packages (empty artifact fields, correct +-- 'loaded_pkg_trans_deps'). +loadMoreUnits + :: HscEnv + -> [UnitId] -- ^ New packages to process (not yet in PkgsLoaded) + -> PkgsLoaded -- ^ Existing loaded packages (used for memoization) + -> IO ([UnitInfo], PkgsLoaded) + -- ^ Reverse topologically-sorted new package infos + updated PkgsLoaded +loadMoreUnits hsc_env new_pks pkgs_loaded_init = + downsweep ([], pkgs_loaded_init) new_pks where -- The downsweep process takes an initial 'PkgsLoaded' and uses it -- to memoize new packages to load when recursively downsweeping - -- the dependencies. The returned 'PkgsLoaded' is popularized with + -- the dependencies. The returned 'PkgsLoaded' is populated with -- placeholder 'LoadedPkgInfo' for new packages yet to be loaded, -- which need to be modified later to fill in the missing fields. -- @@ -1221,6 +1241,12 @@ loadPackages' interp hsc_env new_pks pls = do throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) +loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState +loadPackages' interp hsc_env new_pks pls = do + (reverse -> pkgs_info_list, pkgs_almost_loaded) <- + loadMoreUnits hsc_env new_pks (pkgs_loaded pls) + loadPackage interp hsc_env pkgs_info_list (pls { pkgs_loaded = pkgs_almost_loaded }) + loadPackage :: Interp -> HscEnv -> [UnitInfo] -> LoaderState -> IO LoaderState loadPackage interp hsc_env pkgs pls ===================================== testsuite/tests/annotations/should_run/all.T ===================================== @@ -10,9 +10,6 @@ test('annrun01', [extra_files(['Annrun01_Help.hs']), req_th, req_process, - js_broken(23013), # strangely, the workaround for #23013 triggers - # a call to an undefined FFI function in bytestring. - # Before, it was slow but not failing. when(js_arch(), compile_timeout_multiplier(5)), pre_cmd('$MAKE -s --no-print-directory config'), omit_ways(['dyn'] + prof_ways)], ===================================== testsuite/tests/driver/OneShotTH.stdout-javascript-unknown-ghcjs deleted ===================================== ===================================== testsuite/tests/driver/T20604/T20604.stdout-javascript-unknown-ghcjs ===================================== @@ -0,0 +1,2 @@ +A1 +A ===================================== testsuite/tests/driver/T20604/all.T ===================================== @@ -10,6 +10,5 @@ def normalise_paths(s): test('T20604', [ req_th - , js_broken(23013) , extra_files(['A.hs', 'A1.hs']) , normalise_fun(normalise_paths)], makefile_test, []) ===================================== testsuite/tests/driver/all.T ===================================== @@ -299,7 +299,7 @@ test('T18369', normal, compile, ['-O']) test('T21682', normal, compile_fail, ['-Werror=unrecognised-warning-flags -Wfoo']) test('FullGHCVersion', normal, compile_and_run, ['-package ghc-boot']) test('OneShotTH', req_th, makefile_test, []) -test('T17481', js_broken(23013), makefile_test, []) +test('T17481', normal, makefile_test, []) test('T20084', normal, makefile_test, []) test('RunMode', [req_interp,extra_files(['RunMode/Test.hs'])], run_command, ['{compiler} --run -iRunMode/ -ignore-dot-ghci RunMode.hs -- hello']) test('T20439', normal, run_command, ===================================== testsuite/tests/driver/fat-iface/fat010.stdout-javascript-unknown-ghcjs ===================================== @@ -1,5 +1,4 @@ [1 of 3] Compiling THA [2 of 3] Compiling THB [3 of 3] Compiling THC -[1 of 3] Compiling THA [JS backend always recompiles modules using Template Haskell for now (#23013)] [2 of 3] Compiling THB [Source file changed] ===================================== testsuite/tests/driver/recomp011/all.T ===================================== @@ -2,6 +2,5 @@ test('recomp011', [ extra_files(['Main.hs']) - , js_broken(23013) ], makefile_test, []) ===================================== testsuite/tests/driver/recompHash/recompHash.stdout-javascript-unknown-ghcjs ===================================== @@ -1,3 +1,2 @@ [1 of 2] Compiling B [2 of 2] Compiling A -[2 of 2] Compiling A [JS backend always recompiles modules using Template Haskell for now (#23013)] ===================================== testsuite/tests/driver/recompNoTH/recompNoTH.stdout-javascript-unknown-ghcjs ===================================== @@ -1,4 +1,3 @@ [1 of 2] Compiling B [2 of 2] Compiling A [1 of 2] Compiling B [Source file changed] -[2 of 2] Compiling A [JS backend always recompiles modules using Template Haskell for now (#23013)] ===================================== testsuite/tests/driver/th-new-test/th-new-test.stdout-javascript-unknown-ghcjs deleted ===================================== @@ -1,26 +0,0 @@ -[1 of 6] Compiling B -[2 of 6] Compiling A -[3 of 6] Compiling D -[4 of 6] Compiling C -[5 of 6] Compiling Main -[6 of 6] Linking Main -[1 of 6] Compiling B [JS backend always recompiles modules using Template Haskell for now (#23013)] -[2 of 6] Compiling A [JS backend always recompiles modules using Template Haskell for now (#23013)] -[3 of 6] Compiling D [JS backend always recompiles modules using Template Haskell for now (#23013)] -[4 of 6] Compiling C [JS backend always recompiles modules using Template Haskell for now (#23013)] -[6 of 6] Linking Main [Objects changed] -[1 of 6] Compiling B [Source file changed] -[2 of 6] Compiling A [B[TH] changed] -[3 of 6] Compiling D [JS backend always recompiles modules using Template Haskell for now (#23013)] -[4 of 6] Compiling C [D[TH] changed] -[6 of 6] Linking Main [Objects changed] -[1 of 6] Compiling B [JS backend always recompiles modules using Template Haskell for now (#23013)] -[2 of 6] Compiling A [JS backend always recompiles modules using Template Haskell for now (#23013)] -[3 of 6] Compiling D [Source file changed] -[4 of 6] Compiling C [D[TH] changed] -[6 of 6] Linking Main [Objects changed] -[1 of 6] Compiling B [Source file changed] -[2 of 6] Compiling A [B[TH] changed] -[3 of 6] Compiling D [Source file changed] -[4 of 6] Compiling C [D[TH] changed] -[6 of 6] Linking Main [Objects changed] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a13245a92c4cacf81b7adf41cc36022… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a13245a92c4cacf81b7adf41cc36022… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add regression test for #2057
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 905f8723 by Simon Jakobi at 2026-03-13T15:09:09-04:00 Add regression test for #2057 Test that GHC stops after an interface-file error instead of continuing into the linker. The test constructs a stale package dependency on purpose. `pkgB` is compiled against one version of package `A`, then the same unit id is replaced by an incompatible build of `A`. When `Main` imports `B`, GHC has to read `B.hi`, finds an unfolding that still mentions the old `A`, and should fail while loading interfaces. Closes #2057. Assisted-by: Codex - - - - - 12 changed files: - testsuite/.gitignore - + testsuite/tests/driver/T2057/Makefile - + testsuite/tests/driver/T2057/README.md - + testsuite/tests/driver/T2057/T2057.stderr - + testsuite/tests/driver/T2057/all.T - + testsuite/tests/driver/T2057/app/Main.hs - + testsuite/tests/driver/T2057/pkgA1/A.hs - + testsuite/tests/driver/T2057/pkgA1/pkg.conf - + testsuite/tests/driver/T2057/pkgA2/A.hs - + testsuite/tests/driver/T2057/pkgA2/pkg.conf - + testsuite/tests/driver/T2057/pkgB/B.hs - + testsuite/tests/driver/T2057/pkgB/pkg.conf Changes: ===================================== testsuite/.gitignore ===================================== @@ -551,6 +551,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk /tests/driver/T10970 /tests/driver/T1959/E.hs /tests/driver/T1959/prog +/tests/driver/T2057/work/ /tests/driver/T3007/A/Setup /tests/driver/T3007/A/dist/ /tests/driver/T3007/B/Setup ===================================== testsuite/tests/driver/T2057/Makefile ===================================== @@ -0,0 +1,52 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +WORK = work +PKGDB = $(WORK)/pkgdb +PKGA1 = $(WORK)/pkgA1 +PKGA2 = $(WORK)/pkgA2 +PKGB = $(WORK)/pkgB +APP = $(WORK)/app +OUT = $(WORK)/T2057.out + +.PHONY: T2057 clean + +clean: + rm -rf $(WORK) + +T2057: clean + + # Create an isolated package DB and output directories for the repro. + mkdir -p '$(PKGA1)' '$(PKGA2)' '$(PKGB)' '$(APP)' + '$(GHC_PKG)' init '$(PKGDB)' + + # Build and register pkgA from the pkgA1 sources. + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -package-db '$(PKGDB)' \ + -this-unit-id pkgA -O -c pkgA1/A.hs -outputdir '$(PKGA1)' + '$(AR)' q '$(PKGA1)/libHSpkgA.a' '$(PKGA1)/A.o' >/dev/null 2>&1 + cp pkgA1/pkg.conf '$(WORK)/pkgA1.conf' + '$(GHC_PKG)' --package-db '$(PKGDB)' register '$(WORK)/pkgA1.conf' >/dev/null + + # Build and register pkgB against pkgA so INLINE g records the unfolding g = f in B.hi. + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -package-db '$(PKGDB)' \ + -package pkgA -this-unit-id pkgB -O -c pkgB/B.hs \ + -outputdir '$(PKGB)' + '$(AR)' q '$(PKGB)/libHSpkgB.a' '$(PKGB)/B.o' >/dev/null 2>&1 + cp pkgB/pkg.conf '$(WORK)/pkgB.conf' + '$(GHC_PKG)' --package-db '$(PKGDB)' register '$(WORK)/pkgB.conf' >/dev/null + + # Rebuild pkgA from the pkgA2 source tree, removing f. + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -package-db '$(PKGDB)' \ + -this-unit-id pkgA -O -c pkgA2/A.hs -outputdir '$(PKGA2)' + '$(AR)' q '$(PKGA2)/libHSpkgA.a' '$(PKGA2)/A.o' >/dev/null 2>&1 + cp pkgA2/pkg.conf '$(WORK)/pkgA2.conf' + '$(GHC_PKG)' --package-db '$(PKGDB)' update '$(WORK)/pkgA2.conf' >/dev/null + + # Compiling Main against pkgB should now fail while loading the stale B.hi. + ! '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make app/Main.hs \ + -O -fforce-recomp -package-db '$(PKGDB)' -package pkgB \ + >'$(OUT)' 2>&1 || { echo "expected compilation failure" >&2; exit 1; } + + # Strip the absolute test directory prefix before comparing against T2057.stderr. + sed "s#$(CURDIR)/##g" '$(OUT)' >&2 ===================================== testsuite/tests/driver/T2057/README.md ===================================== @@ -0,0 +1,23 @@ +`T2057` checks that GHC stops after an interface-file error instead of +continuing into the linker. + +The test constructs a stale package dependency on purpose. + +The dependency tree is + + app/Main -> pkgB -> pkgA + +where the two directories `pkgA1/` and `pkgA2/` are just two source trees +for the same package `pkgA`. + +`pkgA1` defines a local type `T` and a function `f :: T -> T`. +`pkgB` builds against that package and records an unfolding `g = f` in `B.hi`. + +After that, the Makefile updates the same package `pkgA` from `pkgA2/`, where +module `A` no longer exports `f`. When `Main` imports `B`, GHC has to load +`B.hi`, sees the stale reference to `f`, and must fail. + +The golden [`T2057.stderr`](T2057.stderr) captures the fixed behaviour: +diagnose the missing declaration in the stale interface and then stop with +`Cannot continue after interface file error`. Any linker output would be a +regression. ===================================== testsuite/tests/driver/T2057/T2057.stderr ===================================== @@ -0,0 +1,9 @@ +work/pkgB/B.hi +Declaration for g +Unfolding of g: + f ErrorWithoutFlag + Can't find interface-file declaration for variable f + Probable cause: bug in .hi-boot file, or inconsistent .hi file + Use -ddump-if-trace to get an idea of which file caused the error +<no location info>: + Cannot continue after interface file error ===================================== testsuite/tests/driver/T2057/all.T ===================================== @@ -0,0 +1,8 @@ +test( + 'T2057', + [ extra_files(['pkgA1', 'pkgA2', 'pkgB', 'app', 'README.md']) + , ignore_stdout + ], + makefile_test, + [] +) ===================================== testsuite/tests/driver/T2057/app/Main.hs ===================================== @@ -0,0 +1,7 @@ +module Main where + +import B + +main :: IO () +main = case g MkT of + MkT -> print () ===================================== testsuite/tests/driver/T2057/pkgA1/A.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module A (T(..), f) where + +data T = MkT + +f :: T -> T +f x = x ===================================== testsuite/tests/driver/T2057/pkgA1/pkg.conf ===================================== @@ -0,0 +1,11 @@ +name: pkgA +version: 1.0 +id: pkgA +key: pkgA +exposed: True +exposed-modules: A +import-dirs: ${pkgroot}/pkgA1 +library-dirs: ${pkgroot}/pkgA1 +dynamic-library-dirs: ${pkgroot}/pkgA1 +hs-libraries: HSpkgA +depends: ===================================== testsuite/tests/driver/T2057/pkgA2/A.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module A where + +-- no f here +data T = MkT ===================================== testsuite/tests/driver/T2057/pkgA2/pkg.conf ===================================== @@ -0,0 +1,11 @@ +name: pkgA +version: 1.0 +id: pkgA +key: pkgA +exposed: True +exposed-modules: A +import-dirs: ${pkgroot}/pkgA2 +library-dirs: ${pkgroot}/pkgA2 +dynamic-library-dirs: ${pkgroot}/pkgA2 +hs-libraries: HSpkgA +depends: ===================================== testsuite/tests/driver/T2057/pkgB/B.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module B (T(..), g) where + +import A + +{-# INLINE g #-} +g :: T -> T +g x = f x ===================================== testsuite/tests/driver/T2057/pkgB/pkg.conf ===================================== @@ -0,0 +1,11 @@ +name: pkgB +version: 1.0 +id: pkgB +key: pkgB +exposed: True +exposed-modules: B +import-dirs: ${pkgroot}/pkgB +library-dirs: ${pkgroot}/pkgB +dynamic-library-dirs: ${pkgroot}/pkgB +hs-libraries: HSpkgB +depends: pkgA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/905f8723b92cb34e9f1fa7b4306f32c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/905f8723b92cb34e9f1fa7b4306f32c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Stg/Unarise: constant-folding during unarisation (#25650)
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6eef855b by Sylvain Henry at 2026-03-13T15:08:18-04:00 Stg/Unarise: constant-folding during unarisation (#25650) When building an unboxed sum from a literal argument, mkUbxSum previously emitted a runtime cast via `case primop [lit] of var -> ...`. This wrapper prevented GHC from recognising the result as a static StgRhsCon, causing top-level closures to be allocated as thunks instead of being statically allocated. Fix: try to perform the numeric literal cast at compile time using mkLitNumberWrap (wrapping semantics). If successful, return the cast literal directly with an identity wrapper (no case expression). The runtime cast path is kept as fallback for non-literal arguments. Test: codeGen/should_compile/T25650 - - - - - 7 changed files: - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/Stg/Unarise.hs - testsuite/tests/codeGen/should_compile/Makefile - + testsuite/tests/codeGen/should_compile/T25650.hs - + testsuite/tests/codeGen/should_compile/T25650.stdout-ws-32 - + testsuite/tests/codeGen/should_compile/T25650.stdout-ws-64 - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== compiler/GHC/Stg/Pipeline.hs ===================================== @@ -143,7 +143,7 @@ stg2stg logger extra_vars opts this_mod binds StgUnarise -> do us <- getUniqueSupplyM liftIO (stg_linter False "Pre-unarise" binds) - let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds + let binds' = {-# SCC "StgUnarise" #-} unarise (stgPlatform opts) us (stgPipeline_allowTopLevelConApp opts this_mod) binds liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds') liftIO (stg_linter True "Unarise" binds') return binds' ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -413,6 +413,7 @@ import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Casts +import GHC.Platform import Data.List (mapAccumL) -- import GHC.Utils.Trace @@ -441,12 +442,13 @@ import Data.List (mapAccumL) -- (i.e. no unboxed tuples, sums or voids) -- data UnariseEnv = UnariseEnv - { ue_rho :: (VarEnv UnariseVal) + { ue_platform :: !Platform + , ue_rho :: VarEnv UnariseVal , ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool } -initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv -initUnariseEnv = UnariseEnv +initUnariseEnv :: Platform -> VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv +initUnariseEnv platform rho is_dll = UnariseEnv platform rho is_dll data UnariseVal = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). @@ -479,8 +481,8 @@ lookupRho env v = lookupVarEnv (ue_rho env) v -------------------------------------------------------------------------------- -unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding] -unarise us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv is_dll_con_app)) binds) +unarise :: Platform -> UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding] +unarise platform us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv platform emptyVarEnv is_dll_con_app)) binds) unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding unariseTopBinding rho (StgTopLifted bind) @@ -627,7 +629,7 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args | isUnboxedSumDataCon dc , let args1 = assert (isSingleton args) (unariseConArgs rho args) - = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us + = let (args2, cast_wrapper) = mkUbxSum (ue_platform rho) dc ty_args args1 us in (args2, Just cast_wrapper) | otherwise @@ -848,29 +850,29 @@ mapSumIdBinders alt_bndr args rhs rho0 -- right type. -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] - id_vars = [v | StgVarArg v <- id_arg_exprs] - typed_id_arg_input = assert (equalLength id_vars fld_reps) $ - zip3 id_vars fld_reps uss - - mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,rep,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep + typed_id_arg_input = assert (equalLength id_arg_exprs fld_reps) $ + zip3 id_arg_exprs fld_reps uss + + -- Process each (arg, target rep, unique supply) to produce + -- (rhs wrapper, typed arg). Handles both literal and variable args. + -- Literal args can arise after constant-folding in mkUbxSum + -- (see Note [Constant-folding during unarisation]). + mkCastArg :: (StgArg, PrimRep, UniqSupply) -> (StgExpr -> StgExpr, StgArg) + mkCastArg (StgLitArg lit, rep, _us) + | Just lit' <- castLiteralArg (ue_platform rho0) rep lit + = (id, StgLitArg lit') + | otherwise = pprPanic "mapSumIdBinders: cannot cast literal" (ppr lit $$ ppr rep) + mkCastArg (StgVarArg v, rep, bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType v) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of - [] -> id - _ -> let (_,ty,uq) = last cst_opts - in mkCastVar uq ty - in (cst_opts,id,out_id) - - cast_inputs = map mkCastInput typed_id_arg_input - (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs - where - cast_arg rhs_in (cast_ops,in_id,out_id) = - let rhs_out = castArgRename cast_ops (StgVarArg in_id) - in (rhs_in . rhs_out, out_id) + [] -> v + _ -> let (_,ty,uq) = last cst_opts in mkCastVar uq ty + in (castArgRename cst_opts (StgVarArg v), StgVarArg out_id) - typed_id_args = map StgVarArg typed_ids + (wrappers, typed_id_args) = unzip $ map mkCastArg typed_id_arg_input + rhs_with_casts = foldr (.) id wrappers if isMultiValBndr alt_bndr then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) @@ -913,14 +915,15 @@ mkCast arg_in cast_op out_id out_ty in_rhs = -- mkUbxSum :: HasDebugCallStack - => DataCon -- Sum data con + => Platform -- For compile-time constant-folding + -> DataCon -- Sum data con -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments ,(StgExpr->StgExpr) -- We might need to cast the args first ) -mkUbxSum dc ty_args args0 us +mkUbxSum platform dc ty_args args0 us = let tag_slot :| sum_slots = ubxSumRepType ty_args -- drop tag slot @@ -961,6 +964,11 @@ mkUbxSum dc ty_args args0 us , ubxSumRubbishArg slot) castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) + castArg us slot_ty arg@(StgLitArg lit) + -- See Note [Constant-folding during unarisation] + | slotPrimRep slot_ty /= stgArgRepU arg + , Just lit' <- castLiteralArg platform (slotPrimRep slot_ty) lit + = Just (StgLitArg lit', us, id) castArg us slot_ty arg -- Cast the argument to the type of the slot if required | slotPrimRep slot_ty /= stgArgRepU arg @@ -1006,6 +1014,101 @@ ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish TypeLike vec_rep) where vec_rep = primRepToRuntimeRep (VecRep n e) +{- +Note [Constant-folding during unarisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #25650. + +Goal: ensure that top-level bindings whose unboxed-sum fields are literals +become statically allocated closures (i.e. compile-time constants in the +object file) rather than CAFs. + +Background: A top-level RHS is statically allocated when it is a plain +`StgRhsCon`: a data constructor applied to arguments with no surrounding +expression. Any `StgCase` wrapper, even one that is a no-op at runtime, turns +the RHS into a CAF. + +The problem: When `mkUbxSum` builds an unboxed sum whose argument PrimRep does +not match the slot PrimRep, the general `castArg` path emits a runtime conversion +wrapper: + + case <conversion_primop> arg of x' -> <rhs using x'> + +For a *variable* argument this is unavoidable, the value is not known at +compile time. For a *literal* argument, however, the conversion can be performed +at compile time, avoiding the `StgCase` wrapper entirely. + +Example +~~~~~~~ +Consider: + + data A = MkA (# Int16# | Int32# #) + foo = MkA (# 10#Int16 | #) + +By the time this gets to the end of the Simplifier pipeline, this still looks +like: + foo = MkA (# 10#Int16 | #) +That is: the worker for the data constructor takes an unboxed sum as its +argument. + +The Unarise pass, which works on STG, decides that + (# 10#Int16 | #) :: (# Int16# | Int32# #) +should be represented as an pair of an integer tag (of type `Int8#`) and a payload +value (of type `Word32#`). But to do that it has to convert `10#Int16` into +`Word32#`, and that conversion is not a no-op. So without constant-folding we +get: + + foo = + \u [] + case int16ToWord16# [10#Int16] of cst_sum_gio { + __DEFAULT -> + case word16ToWord# [cst_sum_gio] of cst_sum_gip { + __DEFAULT -> MkA [1# cst_sum_gip]; + }; + }; + +Note that in the output of the unarise pass, the worker `MkA` takes two +arguments: the tag and the payload of our unboxed sum.. + +However it's a bit silly to generate a CAF here because with some +constant-folding we can easily avoid this thunk and generate a static datacon +instead. That's why the literal clause of `castArg` intercepts `Int16# 10`, +calls `castLiteralArg` to compute `Word32# 10` at compile time, and returns the +identity wrapper. The result is: + + foo = MkA! [1#Word8 10#Word32]; + + +Note that `castLiteralArg` uses `mkLitNumberWrap`, which matches the +semantics of GHC's integer-conversion primops (zero/sign extension to the target +width) — exactly the same transformation the runtime conversion would have +performed. + +-} + +-- | Try to convert a numeric literal to a new PrimRep at compile time. +-- Uses wrapping semantics (same as GHC's integer conversion primops). +-- Returns Nothing for non-numeric literals or unsupported PrimReps. +-- See Note [Constant-folding during unarisation]. +castLiteralArg :: Platform -> PrimRep -> Literal -> Maybe Literal +castLiteralArg platform to_rep (LitNumber _ n) + | Just to_ty <- litNumTypeFromPrimRep to_rep + = Just (mkLitNumberWrap platform to_ty n) +castLiteralArg _ _ _ = Nothing + +litNumTypeFromPrimRep :: PrimRep -> Maybe LitNumType +litNumTypeFromPrimRep WordRep = Just LitNumWord +litNumTypeFromPrimRep Word8Rep = Just LitNumWord8 +litNumTypeFromPrimRep Word16Rep = Just LitNumWord16 +litNumTypeFromPrimRep Word32Rep = Just LitNumWord32 +litNumTypeFromPrimRep Word64Rep = Just LitNumWord64 +litNumTypeFromPrimRep IntRep = Just LitNumInt +litNumTypeFromPrimRep Int8Rep = Just LitNumInt8 +litNumTypeFromPrimRep Int16Rep = Just LitNumInt16 +litNumTypeFromPrimRep Int32Rep = Just LitNumInt32 +litNumTypeFromPrimRep Int64Rep = Just LitNumInt64 +litNumTypeFromPrimRep _ = Nothing + -------------------------------------------------------------------------------- {- ===================================== testsuite/tests/codeGen/should_compile/Makefile ===================================== @@ -80,3 +80,6 @@ T17648: T25166: '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -dno-typeable-binds -ddump-cmm T25166.hs | awk '/foo_closure/{flag=1}/}]/{flag=0}flag' + +T25650: + '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -dno-typeable-binds -ddump-cmm T25650.hs | awk '/baz_foo_closure|baz_bar_closure/{flag=1}/}]/{flag=0}flag' ===================================== testsuite/tests/codeGen/should_compile/T25650.hs ===================================== @@ -0,0 +1,17 @@ +module T25650 (baz_foo, baz_bar) where + +import Data.Word + +data A + = A1 {-# UNPACK #-} !Word32 + | A2 {-# UNPACK #-} !B + +data B = B1 | B2 + +foo = A1 10 +bar = A2 B2 + +data C = C {-# UNPACK #-} !A + +baz_foo = C foo +baz_bar = C bar ===================================== testsuite/tests/codeGen/should_compile/T25650.stdout-ws-32 ===================================== @@ -0,0 +1,14 @@ +[section ""data" . T25650.baz_foo_closure" { + T25650.baz_foo_closure: + const T25650.C_con_info; + const 10; + const 1 :: W8; + const 0 :: W8; + const 0 :: W16; +[section ""data" . T25650.baz_bar_closure" { + T25650.baz_bar_closure: + const T25650.C_con_info; + const 2; + const 2 :: W8; + const 0 :: W8; + const 0 :: W16; ===================================== testsuite/tests/codeGen/should_compile/T25650.stdout-ws-64 ===================================== @@ -0,0 +1,14 @@ +[section ""data" . T25650.baz_foo_closure" { + T25650.baz_foo_closure: + const T25650.C_con_info; + const 10 :: W32; + const 1 :: W8; + const 0 :: W8; + const 0 :: W16; +[section ""data" . T25650.baz_bar_closure" { + T25650.baz_bar_closure: + const T25650.C_con_info; + const 2 :: W32; + const 2 :: W8; + const 0 :: W8; + const 0 :: W16; ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -140,6 +140,7 @@ test('callee-no-local', [ ) test('T25166', [req_cmm], makefile_test, []) +test('T25650', [req_cmm], makefile_test, []) # dump Core to ensure that d is defined as: d = D 10## RUBBISH(IntRep) test('T25177', normal, compile, ['-O2 -dno-typeable-binds -ddump-simpl -dsuppress-all -dsuppress-uniques -v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eef855b6b7fadb9038dfb52b95d0e5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eef855b6b7fadb9038dfb52b95d0e5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] ghc-internal: move bits Weak of finalizer interface to base
by Marge Bot (＠marge-bot) 14 Mar '26

14 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a27dc081 by Teo Camarasu at 2026-03-13T15:06:51-04:00 ghc-internal: move bits Weak of finalizer interface to base We move parts of the Weak finalizer interface to `base` only the parts that the RTS needs to know about are kept in `ghc-internal`. This lets us then prune our imports somewhat and get rid of some SOURCE imports. Resolves #26985 - - - - - 9 changed files: - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs - − libraries/base/src/GHC/Weak/Finalizehs - libraries/base/src/System/Mem/Weak.hs - − libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs-boot - − libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs-boot - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs Changes: ===================================== libraries/base/src/GHC/Weak.hs ===================================== @@ -29,3 +29,5 @@ module GHC.Weak ) where import GHC.Internal.Weak +import GHC.Internal.Weak.Finalize +import GHC.Weak.Finalize ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -14,9 +14,14 @@ module GHC.Weak.Finalize import GHC.Internal.Weak.Finalize --- These imports can be removed once runFinalizerBatch is removed, --- as can MagicHash above. -import GHC.Internal.Base (Int, Array#, IO, State#, RealWorld) +import GHC.Internal.Base +import GHC.Internal.Exception +import GHC.Internal.IORef +import GHC.Internal.Conc.Sync (labelThreadByteArray#, myThreadId) +import GHC.Internal.IO (catchException, unsafePerformIO) +import GHC.Internal.IO.Handle.Types (Handle) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.Encoding.UTF8 (utf8EncodeByteArray#) {-# DEPRECATED runFinalizerBatch @@ -36,3 +41,13 @@ runFinalizerBatch :: Int -> Array# (State# RealWorld -> State# RealWorld) -> IO () runFinalizerBatch = GHC.Internal.Weak.Finalize.runFinalizerBatch + +-- | An exception handler for 'Handle' finalization that prints the error to +-- the given 'Handle', but doesn't rethrow it. +-- +-- @since base-4.18.0.0 +printToHandleFinalizerExceptionHandler :: Handle -> SomeException -> IO () +printToHandleFinalizerExceptionHandler hdl se = + hPutStrLn hdl msg `catchException` (\(SomeException _) -> return ()) + where + msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n" ===================================== libraries/base/src/GHC/Weak/Finalizehs deleted ===================================== ===================================== libraries/base/src/System/Mem/Weak.hs ===================================== @@ -91,6 +91,7 @@ module System.Mem.Weak ( import Prelude import GHC.Internal.Weak +import GHC.Weak -- | A specialised version of 'mkWeak', where the key and the value are -- the same object: ===================================== libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs-boot deleted ===================================== @@ -1,70 +0,0 @@ -{-# LANGUAGE MagicHash, NoImplicitPrelude #-} -{-# OPTIONS_HADDOCK not-home #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Conc.Sync [boot] --- Copyright : (c) The University of Glasgow, 1994-2002 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs(a)haskell.org --- Stability : internal --- Portability : non-portable (GHC extensions) --- --- Basic concurrency stuff. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Conc.Sync - ( forkIO, - ThreadId(..), - myThreadId, - showThreadId, - ThreadStatus(..), - threadStatus, - sharedCAF, - labelThreadByteArray# - ) where - -import GHC.Internal.Base -import GHC.Internal.Ptr - -forkIO :: IO () -> IO ThreadId - -data ThreadId = ThreadId ThreadId# - -data BlockReason - = BlockedOnMVar - -- ^blocked on 'MVar' - {- possibly (see 'threadstatus' below): - | BlockedOnMVarRead - -- ^blocked on reading an empty 'MVar' - -} - | BlockedOnBlackHole - -- ^blocked on a computation in progress by another thread - | BlockedOnException - -- ^blocked in 'throwTo' - | BlockedOnSTM - -- ^blocked in 'retry' in an STM transaction - | BlockedOnForeignCall - -- ^currently in a foreign call - | BlockedOnOther - -- ^blocked on some other resource. Without @-threaded@, - -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ - -- they show up as 'BlockedOnMVar'. - -data ThreadStatus - = ThreadRunning - -- ^the thread is currently runnable or running - | ThreadFinished - -- ^the thread has finished - | ThreadBlocked BlockReason - -- ^the thread is blocked on some resource - | ThreadDied - -- ^the thread received an uncaught exception - -myThreadId :: IO ThreadId -showThreadId :: ThreadId -> String -threadStatus :: ThreadId -> IO ThreadStatus -sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a -labelThreadByteArray# :: ThreadId -> ByteArray# -> IO () ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs-boot deleted ===================================== @@ -1,8 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module GHC.Internal.IO.Handle.Text ( hPutStrLn ) where - -import GHC.Internal.Base (String, IO) -import {-# SOURCE #-} GHC.Internal.IO.Handle.Types (Handle) - -hPutStrLn :: Handle -> String -> IO () ===================================== libraries/ghc-internal/src/GHC/Internal/TopHandler.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Internal.IO.Handle import GHC.Internal.IO.StdHandles import GHC.Internal.IO.Exception import GHC.Internal.Weak +import GHC.Internal.Weak.Finalize +import GHC.Internal.IO.Handle.Types () #if defined(mingw32_HOST_OS) import GHC.Internal.ConsoleHandler as GHC.ConsoleHandler ===================================== libraries/ghc-internal/src/GHC/Internal/Weak.hs ===================================== @@ -24,19 +24,9 @@ module GHC.Internal.Weak ( mkWeak, deRefWeak, finalize, - - -- * Handling exceptions - -- | When an exception is thrown by a finalizer called by the - -- garbage collector, GHC calls a global handler which can be set with - -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by - -- this handler will be ignored. - setFinalizerExceptionHandler, - getFinalizerExceptionHandler, - printToHandleFinalizerExceptionHandler ) where import GHC.Internal.Base -import GHC.Internal.Weak.Finalize {-| A weak pointer object with a key and a value. The value has type @v@. ===================================== libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs ===================================== @@ -4,26 +4,17 @@ {-# LANGUAGE Unsafe #-} module GHC.Internal.Weak.Finalize - ( -- * Handling exceptions - -- | When an exception is thrown by a finalizer called by the - -- garbage collector, GHC calls a global handler which can be set with - -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by - -- this handler will be ignored. - setFinalizerExceptionHandler - , getFinalizerExceptionHandler - , printToHandleFinalizerExceptionHandler - -- * Internal + ( getFinalizerExceptionHandler + , setFinalizerExceptionHandler , runFinalizerBatch ) where import GHC.Internal.Base -import GHC.Internal.Exception -import GHC.Internal.IORef -import {-# SOURCE #-} GHC.Internal.Conc.Sync (labelThreadByteArray#, myThreadId) -import GHC.Internal.IO (catchException, unsafePerformIO) -import {-# SOURCE #-} GHC.Internal.IO.Handle.Types (Handle) -import {-# SOURCE #-} GHC.Internal.IO.Handle.Text (hPutStrLn) -import GHC.Internal.Encoding.UTF8 (utf8EncodeByteArray#) +import GHC.Internal.Conc.Sync ( labelThreadByteArray#, myThreadId ) +import GHC.Internal.Encoding.UTF8 ( utf8EncodeByteArray# ) +import GHC.Internal.Exception ( SomeException(..) ) +import GHC.Internal.IO ( catchException, unsafePerformIO ) +import GHC.Internal.IORef ( IORef, newIORef, readIORef, writeIORef ) data ByteArray = ByteArray ByteArray# @@ -82,13 +73,3 @@ getFinalizerExceptionHandler = readIORef finalizerExceptionHandler -- @since base-4.18.0.0 setFinalizerExceptionHandler :: (SomeException -> IO ()) -> IO () setFinalizerExceptionHandler = writeIORef finalizerExceptionHandler - --- | An exception handler for 'Handle' finalization that prints the error to --- the given 'Handle', but doesn't rethrow it. --- --- @since base-4.18.0.0 -printToHandleFinalizerExceptionHandler :: Handle -> SomeException -> IO () -printToHandleFinalizerExceptionHandler hdl se = - hPutStrLn hdl msg `catchException` (\(SomeException _) -> return ()) - where - msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a27dc08195bc7572866e676009033f0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a27dc08195bc7572866e676009033f0… You're receiving this email because of your account on gitlab.haskell.org.

1 0