April 2026 - ghc-commits

[Git][ghc/ghc][master] Move most of the `System.IO` implementation into `base`
by Marge Bot (＠marge-bot) 21 Apr '26

21 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 76528cc3 by Wolfgang Jeltsch at 2026-04-20T20:16:25-04:00 Move most of the `System.IO` implementation into `base` This involves a rewrite of the `combine` helper function to avoid the use of `last`, which would now be flagged as an error. Metric Decrease: LinkableUsage01 T3294 Metric Increase: T12227 T12707 T5642 - - - - - 27 changed files: - libraries/base/src/Control/Concurrent.hs - 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/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 - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug973.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/DefaultSignatures.html - utils/haddock/html-test/ref/Hash.html - utils/haddock/html-test/ref/PatternSyns.html - utils/haddock/html-test/ref/PatternSyns2.html - utils/haddock/html-test/ref/QuasiExpr.html - utils/haddock/html-test/ref/Test.html Changes: ===================================== libraries/base/src/Control/Concurrent.hs ===================================== @@ -120,7 +120,7 @@ import GHC.Internal.System.Posix.Types ( Fd ) #if defined(mingw32_HOST_OS) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types -import GHC.Internal.System.IO +import System.IO import GHC.Internal.Data.Functor ( void ) import GHC.Internal.Int ( Int64 ) #else ===================================== 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,683 @@ 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 ((++), reverse, break) +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, + 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.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 System.IO.Error (userError) +import System.Posix.Internals + ( + c_open, + 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 (getErrno, errnoToIOError) + +#if defined(mingw32_HOST_OS) +import GHC.Base (undefined, not, (||), fmap) +import GHC.List (null, any) +import GHC.Num ((*)) +import GHC.IO (onException) +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 Data.Bits ((.&.)) +import Foreign.C.Types (CUInt (CUInt), CWchar) +import Foreign.C.String +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils (with) +import Foreign.Storable +#else +import GHC.List (elem, unsnoc) +import GHC.Num ((+)) +import GHC.IO.Handle (SeekMode (AbsoluteSeek, RelativeSeek, SeekFromEnd)) +import GHC.IORef (atomicModifyIORef'_) +import Data.Int (Int) +import Data.IORef (IORef, newIORef) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Internals (c_getpid, o_CREAT) +import Foreign.C.Error (Errno, eEXIST) +#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 + {- + The following code is inspired by code from 'System.FilePath', since + that code is not available here. + -} + combine path1 [] + = path1 + combine path1 path2 + = case unsnoc path1 of + Nothing + -> path2 + Just (_, path1Last) + | pathSeparator [path1Last] + -> path1 ++ path2 + | otherwise + -> path1 ++ [pathSeparatorChar] ++ path2 + +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,293 +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.Classes (Eq(..), Ord(..)) -import GHC.Internal.Data.Bits -import GHC.Internal.Data.Maybe -import GHC.Internal.Err (errorWithoutStackTrace) -import GHC.Internal.Foreign.C.Error -#if defined(mingw32_HOST_OS) -import GHC.Internal.Base (fmap) -import GHC.Internal.Classes (not, (||)) -import GHC.Internal.Err (undefined) -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 (String, failIO, otherwise, return, ($), (.), (>>=)) -import GHC.Internal.List -#if !defined(mingw32_HOST_OS) -import GHC.Internal.IORef -import GHC.Internal.Types (Int) -#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 -import GHC.Internal.Types (Bool(..), Char) ------------------------------------------------------------------------------ --- 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. -- @@ -339,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 ===================================== @@ -7850,6 +7850,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 @@ -9885,7 +9886,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 ===================================== @@ -7822,6 +7822,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 @@ -9923,7 +9924,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 ===================================== @@ -8014,6 +8014,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 @@ -10165,7 +10166,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 ===================================== @@ -7850,6 +7850,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 @@ -9885,7 +9886,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/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 ===================================== @@ -230,15 +230,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’ ===================================== utils/haddock/html-test/ref/Bug1004.html ===================================== @@ -627,13 +627,13 @@ >liftReadsPrec</a > :: (<a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a - > a) -> <a href="#" title="Prelude" + > a) -> <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a > [a] -> <a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a > (<a href="#" title="Bug1004" >Product</a @@ -645,11 +645,11 @@ >liftReadList</a > :: (<a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a - > a) -> <a href="#" title="Prelude" + > a) -> <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a - > [a] -> <a href="#" title="Prelude" + > [a] -> <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a > [<a href="#" title="Bug1004" >Product</a @@ -735,15 +735,15 @@ >liftShowsPrec</a > :: (<a href="#" title="Data.Int" >Int</a - > -> a -> <a href="#" title="Prelude" + > -> a -> <a href="#" title="Text.Show" >ShowS</a - >) -> ([a] -> <a href="#" title="Prelude" + >) -> ([a] -> <a href="#" title="Text.Show" >ShowS</a >) -> <a href="#" title="Data.Int" >Int</a > -> <a href="#" title="Bug1004" >Product</a - > f g a -> <a href="#" title="Prelude" + > f g a -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a @@ -753,13 +753,13 @@ >liftShowList</a > :: (<a href="#" title="Data.Int" >Int</a - > -> a -> <a href="#" title="Prelude" + > -> a -> <a href="#" title="Text.Show" >ShowS</a - >) -> ([a] -> <a href="#" title="Prelude" + >) -> ([a] -> <a href="#" title="Text.Show" >ShowS</a >) -> [<a href="#" title="Bug1004" >Product</a - > f g a] -> <a href="#" title="Prelude" + > f g a] -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a @@ -2563,15 +2563,15 @@ > (<a href="#" title="Prelude" + ><a href="#" title="Text.Read" >Read</a > (f a), <a href="#" title="Prelude" + ><a href="#" title="Text.Read" >Read</a > (g a)) => <a href="#" title="Prelude" + > => <a href="#" title="Text.Read" >Read</a > (<a href="#" title="Bug1004" >Product</a @@ -2603,7 +2603,7 @@ >readsPrec</a > :: <a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a > (<a href="#" title="Bug1004" >Product</a @@ -2613,7 +2613,7 @@ ><a href="#" >readList</a - > :: <a href="#" title="Prelude" + > :: <a href="#" title="Text.ParserCombinators.ReadP" >ReadS</a > [<a href="#" title="Bug1004" >Product</a @@ -2651,15 +2651,15 @@ > (<a href="#" title="Prelude" + ><a href="#" title="Text.Show" >Show</a > (f a), <a href="#" title="Prelude" + ><a href="#" title="Text.Show" >Show</a > (g a)) => <a href="#" title="Prelude" + > => <a href="#" title="Text.Show" >Show</a > (<a href="#" title="Bug1004" >Product</a @@ -2693,7 +2693,7 @@ >Int</a > -> <a href="#" title="Bug1004" >Product</a - > f g a -> <a href="#" title="Prelude" + > f g a -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a @@ -2713,7 +2713,7 @@ >showList</a > :: [<a href="#" title="Bug1004" >Product</a - > f g a] -> <a href="#" title="Prelude" + > f g a] -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a ===================================== utils/haddock/html-test/ref/Bug973.html ===================================== @@ -58,11 +58,11 @@ >showRead</a > :: (<a href="#" title="Prelude" + ><a href="#" title="Text.Show" >Show</a > a, <a href="#" title="Prelude" + ><a href="#" title="Text.Read" >Read</a > b)forall b a. (<a href="#" title="Prelude" + ><a href="#" title="Text.Show" >Show</a > a, <a href="#" title="Prelude" + ><a href="#" title="Text.Read" >Read</a > b)<td class="src" >:: (<a href="#" title="Prelude" + ><a href="#" title="Text.Show" >Show</a > a, <a href="#" title="Prelude" + ><a href="#" title="Text.Read" >Read</a > b)forall b a. (<a href="#" title="Prelude" + ><a href="#" title="Text.Show" >Show</a > a, <a href="#" title="Prelude" + ><a href="#" title="Text.Read" >Read</a > b)pattern <a id="v:BlubCons" class="def" >BlubCons</a - > :: () => <a href="#" title="Prelude" + > :: () => <a href="#" title="Text.Show" >Show</a > b => b -> Blub <a href="#" class="selflink" >#</a ===================================== utils/haddock/html-test/ref/DefaultSignatures.html ===================================== @@ -133,7 +133,7 @@ >default <a id="v:bar" class="def" >bar</a - > :: <a href="#" title="Prelude" + > :: <a href="#" title="Text.Show" >Show</a > a => a -> <a href="#" title="Data.String" >String</a @@ -177,7 +177,7 @@ >default <a id="v:baz-39-" class="def" >baz'</a - > :: <a href="#" title="Prelude" + > :: <a href="#" title="Text.Read" >Read</a > a => <a href="#" title="Data.String" >String</a ===================================== utils/haddock/html-test/ref/Hash.html ===================================== @@ -111,7 +111,7 @@ >) => <a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="System.IO" >IO</a > (<a href="#" title="Hash" >HashTable</a @@ -129,7 +129,7 @@ >Hash</a > key) => key -> val -> <a href="#" title="Prelude" + > => key -> val -> <a href="#" title="System.IO" >IO</a > ()</li ><li class="src short" @@ -137,7 +137,7 @@ >lookup</a > :: <a href="#" title="Hash" >Hash</a - > key => key -> <a href="#" title="Prelude" + > key => key -> <a href="#" title="System.IO" >IO</a > (<a href="#" title="Data.Maybe" >Maybe</a @@ -215,7 +215,7 @@ >) => <a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="System.IO" >IO</a > (<a href="#" title="Hash" >HashTable</a @@ -241,7 +241,7 @@ >Hash</a > key) => key -> val -> <a href="#" title="Prelude" + > => key -> val -> <a href="#" title="System.IO" >IO</a > () <a href="#" class="selflink" >#</a @@ -257,7 +257,7 @@ >lookup</a > :: <a href="#" title="Hash" >Hash</a - > key => key -> <a href="#" title="Prelude" + > key => key -> <a href="#" title="System.IO" >IO</a > (<a href="#" title="Data.Maybe" >Maybe</a ===================================== utils/haddock/html-test/ref/PatternSyns.html ===================================== @@ -104,7 +104,7 @@ >data <a href="#" >BlubType</a - > = <a href="#" title="Prelude" + > = <a href="#" title="Text.Show" >Show</a > x => <a href="#" >BlubCtor</a @@ -114,7 +114,7 @@ >pattern <a href="#" >Blub</a - > :: () => <a href="#" title="Prelude" + > :: () => <a href="#" title="Text.Show" >Show</a > x => x -> <a href="#" title="PatternSyns" >BlubType</a @@ -266,7 +266,7 @@ ><table ><tr ><td class="src" - ><a href="#" title="Prelude" + ><a href="#" title="Text.Show" >Show</a > x => <a id="v:BlubCtor" class="def" >BlubCtor</a @@ -283,7 +283,7 @@ >pattern <a id="v:Blub" class="def" >Blub</a - > :: () => <a href="#" title="Prelude" + > :: () => <a href="#" title="Text.Show" >Show</a > x => x -> <a href="#" title="PatternSyns" >BlubType</a ===================================== utils/haddock/html-test/ref/PatternSyns2.html ===================================== @@ -145,7 +145,7 @@ >P</a > :: () => forall k (a :: k) b. <a href="#" title="Prelude" + > k (a :: k) b. <a href="#" title="Text.Show" >Show</a > b => <a href="#" title="Data.Proxy" >Proxy</a ===================================== utils/haddock/html-test/ref/QuasiExpr.html ===================================== @@ -122,7 +122,7 @@ > <a href="#" title="Prelude" + > <a href="#" title="Text.Show" >Show</a > <a href="#" title="QuasiExpr" >Expr</a @@ -152,7 +152,7 @@ >Int</a > -> <a href="#" title="QuasiExpr" >Expr</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a @@ -172,7 +172,7 @@ >showList</a > :: [<a href="#" title="QuasiExpr" >Expr</a - >] -> <a href="#" title="Prelude" + >] -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a @@ -244,7 +244,7 @@ > <a href="#" title="Prelude" + > <a href="#" title="Text.Show" >Show</a > <a href="#" title="QuasiExpr" >BinOp</a @@ -274,7 +274,7 @@ >Int</a > -> <a href="#" title="QuasiExpr" >BinOp</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a @@ -294,7 +294,7 @@ >showList</a > :: [<a href="#" title="QuasiExpr" >BinOp</a - >] -> <a href="#" title="Prelude" + >] -> <a href="#" title="Text.Show" >ShowS</a > <a href="#" class="selflink" >#</a ===================================== utils/haddock/html-test/ref/Test.html ===================================== @@ -521,7 +521,7 @@ ><li ><a href="#" >a</a - > :: <a href="#" title="Prelude" + > :: <a href="#" title="System.IO" >IO</a > a</li ><li @@ -575,7 +575,7 @@ >a</a > :: <a href="#" title="Test" >C</a - > a => <a href="#" title="Prelude" + > a => <a href="#" title="System.IO" >IO</a > a</li ><li class="src short" @@ -591,7 +591,7 @@ >g</a > :: <a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="System.IO" >IO</a > CInt</li ><li class="src short" @@ -661,7 +661,7 @@ >Float</a >) -> <a href="#" title="Test" >T5</a - > () () -> <a href="#" title="Prelude" + > () () -> <a href="#" title="System.IO" >IO</a > ()</li ><li class="src short" @@ -683,7 +683,7 @@ >R</a > -> <a href="#" title="Test" >N1</a - > () -> <a href="#" title="Prelude" + > () -> <a href="#" title="System.IO" >IO</a > <a href="#" title="Data.Int" >Int</a @@ -693,7 +693,7 @@ >o</a > :: <a href="#" title="Prelude" >Float</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="System.IO" >IO</a > <a href="#" title="Prelude" >Float</a @@ -1674,7 +1674,7 @@ ><a id="v:a" class="def" >a</a - > :: <a href="#" title="Prelude" + > :: <a href="#" title="System.IO" >IO</a > a <a href="#" class="selflink" >#</a @@ -1903,7 +1903,7 @@ >a</a > :: <a href="#" title="Test" >C</a - > a => <a href="#" title="Prelude" + > a => <a href="#" title="System.IO" >IO</a > a <a href="#" class="selflink" >#</a @@ -1991,7 +1991,7 @@ using double quotes: <a href="#" >g</a > :: <a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Prelude" + > -> <a href="#" title="System.IO" >IO</a > CInt <a href="#" class="selflink" >#</a @@ -2267,7 +2267,7 @@ is at the beginning of the line).</pre ></tr ><tr ><td class="src" - >-> <a href="#" title="Prelude" + >-> <a href="#" title="System.IO" >IO</a > ()</td ><td class="doc" @@ -2355,7 +2355,7 @@ is at the beginning of the line).</pre ></tr ><tr ><td class="src" - >-> <a href="#" title="Prelude" + >-> <a href="#" title="System.IO" >IO</a > <a href="#" title="Data.Int" >Int</a @@ -2395,7 +2395,7 @@ is at the beginning of the line).</pre ></tr ><tr ><td class="src" - >-> <a href="#" title="Prelude" + >-> <a href="#" title="System.IO" >IO</a > <a href="#" title="Prelude" >Float</a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76528cc323b6338a873fa68ef8c9a76… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76528cc323b6338a873fa68ef8c9a76… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Marge Bot (＠marge-bot) 21 Apr '26

21 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 72d6dc74 by aparker at 2026-04-20T20:15:44-04:00 NCG: Implement constant folding for vector simd ops (Issue #25030) - - - - - b9cab907 by sheaf at 2026-04-20T20:15:44-04:00 Mark some SIMD tests as broken on i386 optllvm As seen in #25498, several SIMD tests are broken on i386 in the optllvm way. This commit marks them as "expect_broken". - - - - - 7 changed files: - + changelog.d/simd_constant_folding - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Utils/Misc.hs - + testsuite/tests/simd/should_run/Makefile - + testsuite/tests/simd/should_run/T25030.hs - + testsuite/tests/simd/should_run/T25030.stdout - testsuite/tests/simd/should_run/all.T Changes: ===================================== changelog.d/simd_constant_folding ===================================== @@ -0,0 +1,14 @@ +section: codegen +synopsis: Implement Cmm constant folding for some SIMD vector instructions +issues: #25030 #26915 +mrs: !15512 + +description: { +The Cmm constant folding pass now handles the following vector operations: + +- insert and extract (broadcast was already supported) +- integer arithmetic operations: negation, addition, subtraction, multiplication, + minimum, maximum +- logical operations: and, or, xor +} + ===================================== compiler/GHC/Cmm/Opt.hs ===================================== @@ -24,6 +24,7 @@ import GHC.Platform import GHC.Types.Literal.Floating import Data.Maybe +import Control.Monad (zipWithM, guard) import GHC.Float @@ -47,7 +48,6 @@ cmmMachOpFold -> MachOp -- The operation from an CmmMachOp -> [CmmExpr] -- The optimized arguments -> CmmExpr - cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args) -- Returns Nothing if no changes, useful for Hoopl, also reduces @@ -65,6 +65,30 @@ cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs = case exprs of [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l) _ -> Nothing + +cmmMachOpFoldM plat (MO_V_Extract l _) [v, (CmmLit (CmmInt idx W32))] + | idx >= 0, idx < fromIntegral l + = do + es <- vectorElements_maybe plat v + es !! fromInteger idx + +cmmMachOpFoldM plat (MO_VF_Extract l _) [v, (CmmLit (CmmInt idx W32))] + | idx >= 0, idx < fromIntegral l + = do + es <- vectorElements_maybe plat v + es !! fromInteger idx + +cmmMachOpFoldM plat op [v, newval@(CmmLit _), CmmLit (CmmInt idx W32)] + | MO_V_Insert l _ <- op = foldToVecLit l + | MO_VF_Insert l _ <- op = foldToVecLit l + where foldToVecLit l = do + guard (idx >= 0 && idx < fromIntegral l) + ls <- vectorElements_maybe plat v + lits <- sequence $ map toLit_maybe (replaceAt (fromIntegral idx) (Just newval) ls) + Just $! CmmLit (CmmVec lits) + toLit_maybe (Just (CmmLit l)) = Just l + toLit_maybe _ = Nothing + cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)] | MO_WF_Bitcast width <- op = case width of W32 | res <- castWord32ToFloat (fromInteger x) @@ -457,6 +481,64 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _w))] x2 = if p == 1 then x1 else CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] +-- Many vector MachOps are simply element-wise scalar MachOps. For these, we reduce +-- to the scalar case using 'vectorMachOpScalarMachOp_maybe' and 'vectorElements_maybe'. + +-- Unary vector MachOps. +cmmMachOpFoldM plat op [v] + | Just scalar_op <- vectorMachOpToScalarMachOp_maybe op + = do es <- vectorElements_maybe plat v + ls <- mapM (foldToLit plat scalar_op) es + Just $! CmmLit $ CmmVec ls + + where foldToLit plat mop (Just a) = do + CmmLit l <- cmmMachOpFoldM plat mop [a] + return l + foldToLit _ _ _ = Nothing + +-- Binary vector MachOps. +cmmMachOpFoldM plat op [v1, v2] + | Just scalar_op <- vectorMachOpToScalarMachOp_maybe op + = do + es1 <- vectorElements_maybe plat v1 + es2 <- vectorElements_maybe plat v2 + ls <- zipWithM (foldToLit plat scalar_op) es1 es2 + Just $! CmmLit $ CmmVec ls + -- MIN/MAX don't have scalar equivalents, so handle them manually. + | MO_VS_Max _ w <- op = do + es1 <- vectorElements_maybe plat v1 + es2 <- vectorElements_maybe plat v2 + ls <- zipWithM (foldOp (narrowS w) max) es1 es2 + Just $! CmmLit $ CmmVec ls + | MO_VU_Max _ w <- op = do + es1 <- vectorElements_maybe plat v1 + es2 <- vectorElements_maybe plat v2 + ls <- zipWithM (foldOp (narrowU w) max) es1 es2 + Just $! CmmLit $ CmmVec ls + | MO_VS_Min _ w <- op = do + es1 <- vectorElements_maybe plat v1 + es2 <- vectorElements_maybe plat v2 + ls <- zipWithM (foldOp (narrowS w) min) es1 es2 + Just $! CmmLit $ CmmVec ls + | MO_VU_Min _ w <- op = do + es1 <- vectorElements_maybe plat v1 + es2 <- vectorElements_maybe plat v2 + ls <- zipWithM (foldOp (narrowU w) min) es1 es2 + Just $! CmmLit $ CmmVec ls + + where + foldToLit plat mop (Just a1) (Just a2) = do + CmmLit l <- cmmMachOpFoldM plat mop [a1, a2] + return l + foldToLit _ _ _ _ = Nothing + + foldOp do_narrow op + (Just (CmmLit (CmmInt x rep))) + (Just (CmmLit (CmmInt y _))) + = Just $! CmmInt (do_narrow x `op` do_narrow y) rep + foldOp _ _ _ _ = Nothing + + -- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x -- Unfortunately this needs a unique supply because x might not be a -- register. See #2253 (program 6) for an example. @@ -473,6 +555,59 @@ validOffsetRep :: Width -> Bool validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int) +-- Is this a vector 'MachOp' that is an element-wise lift of +-- a scalar 'MachOp'? If so, returns the corresponding scalar 'MachOp'. +vectorMachOpToScalarMachOp_maybe :: MachOp -> Maybe MachOp +vectorMachOpToScalarMachOp_maybe m = case m of + MO_VS_Neg _ w -> Just $ MO_S_Neg w + MO_VF_Neg _ w -> Just $ MO_F_Neg w + MO_V_Add _ w -> Just $ MO_Add w + MO_V_Sub _ w -> Just $ MO_Sub w + MO_V_Mul _ w -> Just $ MO_Mul w + MO_VF_Add _ w -> Just $ MO_F_Add w + MO_VF_Sub _ w -> Just $ MO_F_Sub w + MO_VF_Mul _ w -> Just $ MO_F_Mul w + MO_VF_Min _ w -> Just $ MO_F_Min w + MO_VF_Max _ w -> Just $ MO_F_Max w + MO_V_And _ w -> Just $ MO_And w + MO_V_Or _ w -> Just $ MO_Or w + MO_V_Xor _ w -> Just $ MO_Xor w + _ -> Nothing + + +-- | Helper function that tells us what we know about the elements of a vector. +-- +-- Returns 'Nothing' for non-vectors, and @[Nothing, Nothing, ...]@ for vectors +-- with unknown elements. +vectorElements_maybe :: Platform -> CmmExpr -> Maybe [Maybe CmmExpr] +vectorElements_maybe _plat (CmmLit (CmmVec es)) = Just $! map (Just . CmmLit) es + +vectorElements_maybe _plat (CmmMachOp (MO_V_Broadcast l _) args) + | [CmmLit v] <- args = Just $! replicate l (Just $! CmmLit v) +vectorElements_maybe _plat (CmmMachOp (MO_VF_Broadcast l _) args) + | [CmmLit v] <- args = Just $! replicate l (Just $! CmmLit v) + +vectorElements_maybe plat (CmmMachOp (MO_V_Insert _ _) args) + | [v, e, (CmmLit (CmmInt i _w))] <- args + , Just es <- vectorElements_maybe plat v + = Just $! (replaceAt (fromInteger i) (Just $! e) es) + +vectorElements_maybe plat (CmmMachOp (MO_VF_Insert _ _) args) + | [v, e, (CmmLit (CmmInt i _w))] <- args + , Just es <- vectorElements_maybe plat v + = Just $! (replaceAt (fromInteger i) (Just $! e) es) + +vectorElements_maybe plat (CmmMachOp mop _) + | isVecType result_type = Just $! replicate (vecLength result_type) Nothing + where result_type = machOpResultType plat mop [] + +vectorElements_maybe _plat (CmmReg reg) + | isVecType reg_type = Just $! replicate (vecLength reg_type) Nothing + where reg_type = cmmRegType reg + +vectorElements_maybe _ _ = Nothing + + {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -56,7 +56,7 @@ module GHC.Utils.Misc ( -- * List operations controlled by another list takeList, dropList, splitAtList, split, - dropTail, capitalise, + replaceAt, dropTail, capitalise, -- * Sorting sortWith, minWith, nubSort, ordNub, ordNubOn, @@ -718,6 +718,14 @@ splitAtList xs ys = go 0# xs ys go n [] bs = (take (I# n) ys, bs) -- = splitAt n ys go n (_:as) (_:bs) = go (n +# 1#) as bs +-- | given an index n and element y, replace the nth element of list xs with y +replaceAt :: Int -> a -> [a] -> [a] +replaceAt n y xs + | n >= length xs = xs + | n < 0 = xs + | otherwise = before ++ (y : drop 1 after) + where (before, after) = splitAt n xs + -- | drop from the end of a list dropTail :: Int -> [a] -> [a] -- Specification: dropTail n = reverse . drop n . reverse ===================================== testsuite/tests/simd/should_run/Makefile ===================================== @@ -0,0 +1,42 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T25030: + '$(TEST_HC)' $(TEST_HC_OPTS) T25030.hs -v0 -O1 -fforce-recomp -ddump-cmm > T25030.cmm 2>&1 + + # testFoldPlus: 111111+121212=232323, 121212+131313=252525 should be folded + grep -m 1 -o "232323" T25030.cmm + grep -m 1 -o "252525" T25030.cmm + # operands should not appear in the output + grep -o "111111" T25030.cmm || echo "Does not appear: 111111" + grep -o "121212" T25030.cmm || echo "Does not appear: 121212" + grep -o "131313" T25030.cmm || echo "Does not appear: 131313" + + # testFoldMax: max(333333,333332)=333333 should be folded + grep -m 1 -o "333333" T25030.cmm + # lesser operand should not appear + grep -o "333332" T25030.cmm || echo "Does not appear: 333332" + + # testNeg: negate(343434)=-343434 should be folded + grep -m 1 -o -- "-343434" T25030.cmm + + # testInserts: insert 363636 into broadcast(353535) and extract it; + # should fold to constant 363636 + grep -m 1 -o "363636" T25030.cmm + # broadcast operand should not appear + grep -o "353535" T25030.cmm || echo "Does not appear: 353535" + + # testInserts2: 383838+393939=777777 should be folded + grep -m 1 -o "777777" T25030.cmm + # addends should not appear + grep -o "383838" T25030.cmm || echo "Does not appear: 383838" + + # testOverwrite: inserting 404040,404041 into broadcast(414141) should fold to <404040,404041> + grep -m 1 -o "404040" T25030.cmm + grep -m 1 -o "404041" T25030.cmm + # original broadcast value should not appear + grep -o "414141" T25030.cmm || echo "Does not appear: 414141" + + # testExtractFromInsert: extract(insert(unknown_v, 454545, 3), 3) should fold to 454545 + grep -m 1 -o "454545" T25030.cmm ===================================== testsuite/tests/simd/should_run/T25030.hs ===================================== @@ -0,0 +1,79 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, LexicalNegation, ExtendedLiterals #-} + +import GHC.Prim +import GHC.Int + +-- Cmm constant folding tests for vector operations + +data IntX2 = IX2# Int64X2# +data IntX4 = IX4# Int32X4# + +instance Show IntX2 where + show (IX2# d) = case (unpackInt64X2# d) of + (# a, b #) -> show ((I64# a), (I64# b)) + +instance Show IntX4 where + show (IX4# v) = case (unpackInt32X4# v) of + (# a, b, c, d #) -> show ((I32# a), (I32# b), (I32# c), (I32# d)) + +testFoldPlus = do + let v1 = packInt64X2# (# 111111#Int64, 121212#Int64 #) + let v2 = packInt64X2# (# 121212#Int64, 131313#Int64 #) + print $ IX2# $ plusInt64X2# v1 v2 -- expect to see 232323 and 252525 here, + -- and not 111111, 121212, or 131313 + +testFoldMax = do + let v1 = broadcastInt32X4# 333333#Int32 + let v2 = broadcastInt32X4# 333332#Int32 + print $ IX4# $ maxInt32X4# v1 v2 -- expect to see 333333 here and not 333332 + +testFoldMin = do + let v1 = broadcastInt32X4# 474747#Int32 + let v2 = broadcastInt32X4# 474748#Int32 + print $ IX4# $ minInt32X4# v1 v2 -- expect to see 474747 here and not 474748 + +testNeg = do + let v1 = broadcastInt32X4# 343434#Int32 + print $ IX4# $ negateInt32X4# v1 -- expect to see -343434 here, not positive 343434 + + +testInserts = do + let v1 = broadcastInt32X4# 353535#Int32 + let v2 = insertInt32X4# v1 363636#Int32 0# + let (# a, _, _, _ #) = unpackInt32X4# v2 + print $ (I32# a) -- expect to see 363636 here, not 353535 + + +testInserts2 = do + let v1 = broadcastInt32X4# 373737#Int32 + let v2 = insertInt32X4# v1 383838#Int32 0# + let v3 = plusInt32X4# v2 (broadcastInt32X4# 393939#Int32) + let (# a, _, _, _ #) = unpackInt32X4# v3 + print $ (I32# a) -- expect to see 777777 == 383838+393939 here, and not 373737, 383838, or 393939 + +{-# INLINE testOverwrite #-} +testOverwrite :: Int64X2# -> IO () +testOverwrite v = do + let v1 = insertInt64X2# v 404040#Int64 0# + let v2 = insertInt64X2# v1 404041#Int64 1# + print $ IX2# v2 -- expect <404040, 404041> to appear in the cmm as a single assignment, + -- rather than a series of inserts + +{-# NOINLINE testExtractFromInsert #-} +testExtractFromInsert :: Int32X4# -> IO () +testExtractFromInsert v = do + let v2 = insertInt32X4# v 454545#Int32 3# + let (# _, _, _, d #) = unpackInt32X4# v2 + print (I32# d) -- 454545 should fold as a constant even though v is a runtime value + + +main = do + testFoldPlus + testFoldMax + testFoldMin + testNeg + testInserts + testInserts2 + testOverwrite (broadcastInt64X2# 414141#Int64) + testExtractFromInsert (broadcastInt32X4# 464646#Int32) + ===================================== testsuite/tests/simd/should_run/T25030.stdout ===================================== @@ -0,0 +1,20 @@ +232323 +252525 +Does not appear: 111111 +Does not appear: 121212 +Does not appear: 131313 +333333 +333333 +333333 +Does not appear: 333332 +-343434 +-343434 +-343434 +363636 +Does not appear: 353535 +777777 +Does not appear: 383838 +404040 +404041 +Does not appear: 414141 +454545 ===================================== testsuite/tests/simd/should_run/all.T ===================================== @@ -49,6 +49,8 @@ test('int16x8_shuffle_baseline', [], compile_and_run, ['']) test('int32x4_shuffle_baseline', [], compile_and_run, ['']) test('int64x2_shuffle_baseline', [], compile_and_run, ['']) +test('T25030', [when(arch('i386'), expect_broken_for(25498, ['optllvm']))], makefile_test, []) + test('T25658', [], compile_and_run, ['']) # #25658 is a bug with SSE2 code generation test('T25659', [], compile_and_run, ['']) @@ -83,6 +85,7 @@ test('simd007', [], compile_and_run, ['']) test('simd008', [], compile_and_run, ['']) test('simd009', [ req_th , extra_files(['Simd009b.hs', 'Simd009c.hs']) + , when(arch('i386'), expect_broken_for(25498, ['optllvm'])) ] , multimod_compile_and_run, ['simd009', '']) test('simd010', [], compile_and_run, ['']) @@ -174,7 +177,7 @@ test('T25062_V64' , compile_and_run if have_cpu_feature('avx512f') else compile , ['']) -test('T25169', [], compile_and_run, ['']) +test('T25169', [when(arch('i386'), expect_broken_for(25498, ['optllvm']))], compile_and_run, ['']) test('T25455', [], compile_and_run, ['']) test('T25486', [], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86ca6c2cf93147ed67a39be1112911… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86ca6c2cf93147ed67a39be1112911… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/build-opt] 4 commits: SOURCE-import HsInstances inside ghc.
by Andreas Klebinger (＠AndreasK) 20 Apr '26

20 Apr '26

Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC Commits: 74e4e745 by Andreas Klebinger at 2026-04-20T20:04:26+00:00 SOURCE-import HsInstances inside ghc. Fixes #27198 by SOURCE importing HsInstances unlocking more build paralleism. - - - - - 2bfb4ced by Andreas Klebinger at 2026-04-20T20:04:48+00:00 SOURCE import GHC.Types.Error in some places for build parallelism. Performance for these interfaces is not very relevant since it's only used for error handling. This means we can use SOURCE imports to shorten the critical build path by a non trivial amount. - - - - - 0be2e78a by Andreas Klebinger at 2026-04-20T20:04:48+00:00 Split GHC.Driver.Main.hs up into multiple components. This module was getting far too large to reason about, it split it into components that all are re-exported from GHC.Driver.Main I mostly did this for clarity but it also helps (slightly) with build times. - - - - - b4b25892 by Andreas Klebinger at 2026-04-20T20:04:48+00:00 Add a few boot files and SOURCE import them to improve build parallelism. See the Note [hs-boot files as "header" files] for details. Modules with new SOURCE exports: * GHC.HsToCore (deSugar) * GHC.Tc.Deriv.hs-boot * GHC.Driver.Main.Compile/Passes - - - - - 24 changed files: - compiler/GHC/Core/Opt/Stats.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot - + compiler/GHC/Driver/Main/Hsc.hs - + compiler/GHC/Driver/Main/Interactive.hs - + compiler/GHC/Driver/Main/Passes.hs - + compiler/GHC/Driver/Main/Passes.hs-boot - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Instances.hs - + compiler/GHC/Hs/Instances.hs-boot - + compiler/GHC/HsToCore.hs-boot - compiler/GHC/Iface/Load.hs - + compiler/GHC/Tc/Deriv.hs-boot - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/Instance.hs-boot - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/ghc.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/613871fdec67e432a70bf148f57907… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/613871fdec67e432a70bf148f57907… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Marge Bot (＠marge-bot) 20 Apr '26

20 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c32aacb0 by aparker at 2026-04-20T16:05:03-04:00 NCG: Implement constant folding for vector simd ops (Issue #25030) - - - - - 8ed41a6c by sheaf at 2026-04-20T16:05:04-04:00 Mark some SIMD tests as broken on i386 optllvm As seen in #25498, several SIMD tests are broken on i386 in the optllvm way. This commit marks them as "expect_broken". - - - - - d52b3d45 by Wolfgang Jeltsch at 2026-04-20T16:05:05-04:00 Move most of the `System.IO` implementation into `base` This involves a rewrite of the `combine` helper function to avoid the use of `last`, which would now be flagged as an error. Metric Decrease: LinkableUsage01 T3294 Metric Increase: T12227 T12707 T5642 - - - - - 34 changed files: - + changelog.d/simd_constant_folding - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Utils/Misc.hs - libraries/base/src/Control/Concurrent.hs - 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/simd/should_run/Makefile - + testsuite/tests/simd/should_run/T25030.hs - + testsuite/tests/simd/should_run/T25030.stdout - testsuite/tests/simd/should_run/all.T - 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 - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug973.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/DefaultSignatures.html - utils/haddock/html-test/ref/Hash.html - utils/haddock/html-test/ref/PatternSyns.html - utils/haddock/html-test/ref/PatternSyns2.html - utils/haddock/html-test/ref/QuasiExpr.html - utils/haddock/html-test/ref/Test.html The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82d2f00ecbe315c01a922ad8d63c37… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82d2f00ecbe315c01a922ad8d63c37… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/build-opt] 2 commits: Clean up Instances.hs-boot a bit
by Andreas Klebinger (＠AndreasK) 20 Apr '26

20 Apr '26

Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC Commits: 6aa2e67e by Andreas Klebinger at 2026-04-20T19:45:21+00:00 Clean up Instances.hs-boot a bit - - - - - 613871fd by Andreas Klebinger at 2026-04-20T19:48:08+00:00 Even better note - - - - - 1 changed file: - compiler/GHC/Hs/Instances.hs-boot Changes: ===================================== compiler/GHC/Hs/Instances.hs-boot ===================================== @@ -2,35 +2,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- This module contains exclusively Data instances, which are going to be slow --- no matter what we do. Furthermore, they are incredibly slow to compile with --- optimisation (see #9557). Consequently we compile this with -O0. --- See #18254. - module GHC.Hs.Instances where --- This module defines the Data instances for the hsSyn AST. - --- It happens here to avoid massive constraint types on the AST with concomitant --- slow GHC bootstrap times. - --- UndecidableInstances ? - -{- Note [Data.Data instances for GHC AST Types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We give all of the frontend types and their instantiations (HsSyn) and -some other types Data.Data instances. There are two main motivations to -do so: - -* For users of the GHC API it allows to write Generic code over the GHC AST. -* GHC itself has a few uses of these as well: - * In the showAstData, showAstDataFull helpers to print a representation of - the actual AST using it's constructors rather than just user facing pretty printing. - * It's used to some degree for HIE file generation in the ToHIE instances. - * TH serialization uses it for serialization of Annotations (GHC.Serialized) - * Some of the dump flags use showAstData to produce the actual dump output. --} - {- Note [hs-boot files as "header" files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can use hs-boot files like C header files to unlock parallel @@ -64,8 +37,10 @@ inlining things from TakesForever.hs or needs to know the exact representation o types for unboxing or similar this trick will do more harm than good. For GHC itself we can figure out where it makes sense to insert such "header" boot -files by looking at a build profile and look for places where the build sequentializes -to one or two concurrent GHC invocations. +files by looking at a build profile generated by shake. +They can be generated via `--profile=report.trace` and looking for places where +the build sequentializes to one or two concurrent GHC invocations is visually +pretty obvious in those cases. -} import Data.Data hiding ( Fixity ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c930572d0e0d369147ba23f99f8e3a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c930572d0e0d369147ba23f99f8e3a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/build-opt] 2 commits: Update note
by Andreas Klebinger (＠AndreasK) 20 Apr '26

20 Apr '26

Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC Commits: 2b309962 by Andreas Klebinger at 2026-04-20T19:42:42+00:00 Update note - - - - - c930572d by Andreas Klebinger at 2026-04-20T19:43:41+00:00 Reference Note more places - - - - - 2 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Instances.hs-boot Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -280,6 +280,7 @@ import GHC.Utils.Error (emptyDiagOpts, logInfo) import GHC.Settings import GHC.CmmToAsm.CFG.Weight import GHC.Core.Opt.CallerCC +-- See Note [hs-boot files as "header" files] import {-# SOURCE #-} GHC.Parser (parseIdentifier) -- build time optimization import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..)) import GHC.Stg.Debug.Types ===================================== compiler/GHC/Hs/Instances.hs-boot ===================================== @@ -49,10 +49,10 @@ TakesForver.hs -> Depends.hs -> Step2-1.hs If inlining thinks from `TakesForever` isn't performance critical we can change it using SOURCE imports such that we have: -TakesForver.hs -> Depends.hs -> Step2-1.hs - | -> Step2-2.hs - | -> Step2-3.hs - | -> Step2-4.hs +TakesForver.hs-boot -> Depends.hs -> Step2-1.hs + | -> Step2-2.hs + | -> Step2-3.hs + | -> Step2-4.hs This replaces TakesForever.hs with TakesForever.hs-boot which will compile in no time at all reducing the compile time along the critical path significantly. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee3550f91f54aa9e783edca1292f52… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee3550f91f54aa9e783edca1292f52… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/build-opt] 17 commits: Migrate `ghc-pkg` to use `OsPath` and `file-io`
by Andreas Klebinger (＠AndreasK) 20 Apr '26

20 Apr '26

Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC Commits: 7666f4a9 by Fendor at 2026-04-17T22:29:51-04:00 Migrate `ghc-pkg` to use `OsPath` and `file-io` `ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH issues on windows. `file-io` uses UNC Paths by default on windows, ensuring we use the correct APIs and that we finally are no longer plagued by MAX_PATH issues in CI and private machines. On top of it, the higher correctness of `OsPath` is appreciated in this small codebase. Also, we improve memory usage very slightly, due to the more efficient memory representation of `OsPath` over `FilePath` Adds `ghc-pkg` regression test for MAX_PATH on windows Make sure `ghc-pkg` behaves as expected when long paths (> 255) are involved on windows. Let's generate a testcase where we can actually observe that `ghc-pkg` behaves as epxected. See the documentation for windows on Maximum Path Length Limitation: * `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation` Adds changelog entry for long path support in ghc-pkg. - - - - - 78434e8c by Simon Peyton Jones at 2026-04-17T22:30:38-04:00 Kill off the substitution in Lint Now that we have invariant (NoTypeShadowing) we no longer need Lint to carry an ambient substitution. This makes it simpler and faster. A really worthwhile refactor. There are some knock-on effects * Linting join points after worker/wrapper. See Note [Join points and beta redexes] * Running a type substitution after the desugarer. See Note [Substituting type-lets] in the new module GHC.Core.SubstTypeLets Implements #27078 Most perf tests don't use Lint so we won't see a perf incresae. But T1969, which uses -O0 and Lint, gets 1.3% worse because it has to run the SubstTypeLets pass which is a somewhat expensive no-op Overall though compile-time allocations are down 0.1%. Metric Increase: T1969 - - - - - 86ca6c2c by mangoiv at 2026-04-17T22:31:22-04:00 testsuite: inline elemCoreTest Some weird (probably python scoping) rule caused elemCoreTest, a regex being out of scope on ubuntu, presumably because of a newer python version. This patch just inlines the regex, which fixes the issue. Fixes #27193 - - - - - 1f30005b by Andreas Klebinger at 2026-04-19T21:48:05+00:00 SOURCE import parseIdentifer to improve parallelism. - - - - - e96b8d63 by Andreas Klebinger at 2026-04-19T21:48:05+00:00 CallerCC: Remove CoreM dependency Pass DynFlags directly, making the dependency graph more parallel. - - - - - 26090197 by Andreas Klebinger at 2026-04-19T21:58:28+00:00 SOURCE-import HsInstances inside ghc. Fixes #27198 by SOURCE importing HsInstances unlocking more build paralleism. (cherry picked from commit 7e53835977538e3c37e5d78502ff422ad87d4f9d) - - - - - cb679710 by Andreas Klebinger at 2026-04-19T22:06:08+00:00 HsInstances - fix a warning - - - - - f5722894 by Andreas Klebinger at 2026-04-20T15:11:06+00:00 SOURCE import GHC.Types.Error in some places for build parallelism. Performance for these interfaces is not very relevant since it's only used for error handling. This means we can use SOURCE imports to shorten the critical build path by a non trivial amount. - - - - - a64cd962 by Andreas Klebinger at 2026-04-20T15:11:26+00:00 Split GHC.Driver.Main.hs up into multiple components. This module was getting far too large to reason about, it split it into components that all are re-exported from GHC.Driver.Main - - - - - cf62c053 by Andreas Klebinger at 2026-04-20T15:42:58+00:00 Fix hs-boot import - - - - - e6550ad1 by Andreas Klebinger at 2026-04-20T15:45:33+00:00 Fix hs-boot import2 - - - - - 900317b2 by Andreas Klebinger at 2026-04-20T15:54:23+00:00 Use SOURCE header for Driver.Main.Compiler import - - - - - 8de7314b by Andreas Klebinger at 2026-04-20T16:23:24+00:00 more hs-boot workarounds - - - - - c6ce86ca by Andreas Klebinger at 2026-04-20T17:15:07+00:00 Driver interactive boot import - - - - - 19fd9f7e by Andreas Klebinger at 2026-04-20T17:18:27+00:00 deSugar SOURCE header - - - - - eff8fd32 by Andreas Klebinger at 2026-04-20T17:27:00+00:00 Add GHC.Tc.Deriv.hs-boot - - - - - ee3550f9 by Andreas Klebinger at 2026-04-20T18:56:35+00:00 Remove a potentially pointless import - - - - - 44 changed files: - + changelog.d/ghc-pkg-long-path-support - compiler/GHC/Core/Lint.hs - + compiler/GHC/Core/Lint/SubstTypeLets.hs - compiler/GHC/Core/Opt/CallerCC.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Stats.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot - + compiler/GHC/Driver/Main/Hsc.hs - + compiler/GHC/Driver/Main/Interactive.hs - + compiler/GHC/Driver/Main/Passes.hs - + compiler/GHC/Driver/Main/Passes.hs-boot - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Instances.hs - + compiler/GHC/Hs/Instances.hs-boot - + compiler/GHC/HsToCore.hs-boot - compiler/GHC/Iface/Load.hs - + compiler/GHC/Tc/Deriv.hs-boot - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/Instance.hs-boot - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - libraries/base/tests/perf/all.T - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.stdout - testsuite/tests/corelint/LintEtaExpand.stderr - testsuite/tests/corelint/T21115b.stderr - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c622f0df932d3d0e0a36ec171499a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c622f0df932d3d0e0a36ec171499a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] Wibbles
by Simon Peyton Jones (＠simonpj) 20 Apr '26

20 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 9af7210e by Simon Peyton Jones at 2026-04-20T17:41:41+01:00 Wibbles ... around (>>>) and Floating class - - - - - 6 changed files: - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/Builtin/TH.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Errors/Ppr.hs - libraries/base/src/GHC/KnownKeyNames.hs Changes: ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -86,6 +86,11 @@ have the correct one in scope when looking up a known-occ name. module GHC.Internal.Base where foldrList = foldr make `foldrList` known-occ, and refer to that in desugaring list comprehensions. + +* (>>>). You might think that the known-occ version is the one defined in + GHC.Internal.Control.Category. But no, it isn't. We have a different one + (albeit with the same definitino!) in GHC.Internal.Desugar, whose type + has the right "shape" type for `newKnownOccMethod`. Sigh. -} ===================================== compiler/GHC/Builtin/TH.hs ===================================== @@ -903,11 +903,6 @@ forallEIdKey = mkPreludeMiscIdUnique 802 forallVisEIdKey = mkPreludeMiscIdUnique 803 constrainedEIdKey = mkPreludeMiscIdUnique 804 --- data Guard = ... -normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 310 -patGEIdKey = mkPreludeMiscIdUnique 311 - -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -629,7 +629,7 @@ dsLookupKnownKeyName uniq Succeeded name -> return name Failed msg -> failIfM (pprDiagnostic msg) } } -dsLookupKnownKeyThing :: KnownKey -> DsM TyThing +dsLookupKnownKeyThing :: HasDebugCallStack => KnownKey -> DsM TyThing dsLookupKnownKeyThing uniq = do { rebindable_src <- dsGetKnownKeySource ; dsToIfL $ @@ -638,13 +638,13 @@ dsLookupKnownKeyThing uniq Succeeded thing -> return thing Failed msg -> failIfM (pprDiagnostic msg) } } -dsLookupKnownKeyTyCon :: KnownKey -> DsM TyCon +dsLookupKnownKeyTyCon :: HasDebugCallStack => KnownKey -> DsM TyCon dsLookupKnownKeyTyCon uniq = tyThingTyCon <$> dsLookupKnownKeyThing uniq -dsLookupKnownKeyDataCon :: KnownKey -> DsM DataCon +dsLookupKnownKeyDataCon :: HasDebugCallStack => KnownKey -> DsM DataCon dsLookupKnownKeyDataCon uniq = tyThingDataCon <$> dsLookupKnownKeyThing uniq -dsLookupKnownKeyId :: KnownKey -> DsM Id +dsLookupKnownKeyId :: HasDebugCallStack => KnownKey -> DsM Id dsLookupKnownKeyId uniq = tyThingId <$> dsLookupKnownKeyThing uniq -------------------------------------- ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -2370,10 +2370,10 @@ lookupType :: KnownOcc -- Name of type constructor (e.g. (M TH.Exp)) lookupType tc_name = do { tc <- lift $ dsLookupKnownOccTyCon tc_name ; return (mkTyConTy tc) } -lookupKnownKeyType :: Unique -- Unique of type constructor (e.g. (M TH.Exp)) +lookupKnownOccType :: KnownOcc -- Occ-name of type constructor (e.g. (M TH.Exp)) -> MetaM Type -- The type -lookupKnownKeyType tc_key - = do { tc <- lift $ dsLookupKnownKeyTyCon tc_key +lookupKnownOccType tc_key + = do { tc <- lift $ dsLookupKnownOccTyCon tc_key ; return (mkTyConApp tc []) } wrapGenSyms :: [GenSymBind] @@ -3133,7 +3133,7 @@ mk_integer :: Integer -> MetaM (HsLit GhcTc) mk_integer i = return $ XLit $ HsInteger NoSourceText i integerTy mk_rational :: FractionalLit -> MetaM (HsLit GhcTc) -mk_rational r = do rat_ty <- lookupKnownKeyType rationalTyConKey +mk_rational r = do rat_ty <- lookupKnownOccType rationalTyConOcc return $ XLit $ HsRat r rat_ty mk_string :: FastString -> MetaM (HsLit GhcRn) ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -299,7 +299,8 @@ interfaceErrorDiagnostic opts = \ case MissingKnownKey1 key -> hang (text "Could not find known key" <+> quotes (pprKnownKey key)) 2 (vcat [ text "in the exports of GHC.KnownKeys" - , text "occname:" <+> pp_occ (knownKeyOccName_maybe key) ]) + , text "occname:" <+> pp_occ (knownKeyOccName_maybe key) + , text "REMEMBER: for tycons, divide by 2!!"]) where pp_occ (Just occ) = ppr occ pp_occ Nothing = text "Yikes: that key isn't in the known-key table" ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -92,7 +92,7 @@ module GHC.KnownKeyNames , error -- Numbers - , Num, Integral, Real, Fractional, RealFloat, RealFrac + , Num, Integral, Real, Floating, Fractional, RealFloat, RealFrac , (+), (-), (*), negate, fromInteger , divInt#, modInt# @@ -204,6 +204,7 @@ module GHC.KnownKeyNames , Clause, clause , Stmt, bindS, letS, noBindS, parS, recS , Body, normalB, guardedB + , Guard, normalGE, patGE ) where import GHC.Internal.Base hiding( foldr ) @@ -226,7 +227,8 @@ import GHC.Internal.IO( seq# ) import GHC.Internal.Control.Monad( fail, guard ) import GHC.Internal.Control.Monad.Fix( mfix, loop ) import GHC.Internal.Control.Monad.Zip( mzip ) -import GHC.Internal.Control.Arrow( arr, (>>>), first, app, (|||) ) +import GHC.Internal.Control.Arrow( arr, first, app, (|||) ) +import GHC.Internal.Desugar( (>>>) ) -- See Note [Tricky known-occ cases] import GHC.Internal.OverloadedLabels( fromLabel ) import GHC.Internal.Records import GHC.Internal.CString as CS View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9af7210e9c2adf040bf4ea4466c6035… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9af7210e9c2adf040bf4ea4466c6035… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Marge Bot (＠marge-bot) 20 Apr '26

20 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 311c6d60 by aparker at 2026-04-20T11:33:14-04:00 NCG: Implement constant folding for vector simd ops (Issue #25030) - - - - - e5743d44 by sheaf at 2026-04-20T11:33:14-04:00 Mark some SIMD tests as broken on i386 optllvm As seen in #25498, several SIMD tests are broken on i386 in the optllvm way. This commit marks them as "expect_broken". - - - - - 82d2f00e by Wolfgang Jeltsch at 2026-04-20T11:33:15-04:00 Move most of the `System.IO` implementation into `base` This involves a rewrite of the `combine` helper function to avoid the use of `last`, which would now be flagged as an error. Metric Decrease: LinkableUsage01 T3294 Metric Increase: T12227 T12707 T5642 - - - - - 34 changed files: - + changelog.d/simd_constant_folding - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Utils/Misc.hs - libraries/base/src/Control/Concurrent.hs - 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/simd/should_run/Makefile - + testsuite/tests/simd/should_run/T25030.hs - + testsuite/tests/simd/should_run/T25030.stdout - testsuite/tests/simd/should_run/all.T - 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 - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug973.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/DefaultSignatures.html - utils/haddock/html-test/ref/Hash.html - utils/haddock/html-test/ref/PatternSyns.html - utils/haddock/html-test/ref/PatternSyns2.html - utils/haddock/html-test/ref/QuasiExpr.html - utils/haddock/html-test/ref/Test.html The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6d2aa4ad60064eefc2156b369120c2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6d2aa4ad60064eefc2156b369120c2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Marge Bot (＠marge-bot) 20 Apr '26

20 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c236fd68 by aparker at 2026-04-20T07:27:47-04:00 NCG: Implement constant folding for vector simd ops (Issue #25030) - - - - - 6665c649 by sheaf at 2026-04-20T07:27:48-04:00 Mark some SIMD tests as broken on i386 optllvm As seen in #25498, several SIMD tests are broken on i386 in the optllvm way. This commit marks them as "expect_broken". - - - - - 6d2aa4ad by Wolfgang Jeltsch at 2026-04-20T07:27:49-04:00 Move most of the `System.IO` implementation into `base` This involves a rewrite of the `combine` helper function to avoid the use of `last`, which would now be flagged as an error. Metric Decrease: LinkableUsage01 T3294 Metric Increase: T12227 T12707 T5642 - - - - - 34 changed files: - + changelog.d/simd_constant_folding - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Utils/Misc.hs - libraries/base/src/Control/Concurrent.hs - 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/simd/should_run/Makefile - + testsuite/tests/simd/should_run/T25030.hs - + testsuite/tests/simd/should_run/T25030.stdout - testsuite/tests/simd/should_run/all.T - 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 - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug973.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/DefaultSignatures.html - utils/haddock/html-test/ref/Hash.html - utils/haddock/html-test/ref/PatternSyns.html - utils/haddock/html-test/ref/PatternSyns2.html - utils/haddock/html-test/ref/QuasiExpr.html - utils/haddock/html-test/ref/Test.html The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbf4abb9729bfa017faacd4d9ea673… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbf4abb9729bfa017faacd4d9ea673… You're receiving this email because of your account on gitlab.haskell.org.

1 0