[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Wobbly Manoeuvres in the Light (WML)
by Wolfgang Jeltsch (＠jeltsch) 03 Jun '26
by Wolfgang Jeltsch (＠jeltsch) 03 Jun '26
03 Jun '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC
Commits:
ca5bf454 by Wolfgang Jeltsch at 2026-06-03T19:58:25+03:00
Wobbly Manoeuvres in the Light (WML)
- - - - -
2 changed files:
- compiler/GHC/ByteCode/Show.hs
- libraries/ghci/GHCi/ResolvedBCO.hs
Changes:
=====================================
compiler/GHC/ByteCode/Show.hs
=====================================
@@ -11,12 +11,15 @@ import Control.Exception (assert)
import Data.Eq ((==))
import Data.Bits (FiniteBits, finiteBitSize)
import Data.Function (($), (.))
+import Data.Bool (otherwise)
import Data.Int (Int)
import Data.Word (Word, Word16)
import Data.Maybe (Maybe, maybe)
import Data.List (length, (++), map, zipWith, take, drop, replicate)
import Data.String (String)
import Data.ByteString (ByteString, unpack)
+import Data.Array.IArray (IArray, elems)
+import Data.Array.Unboxed (UArray)
import Numeric (showHex)
import Text.Show (show)
import System.IO (IO, FilePath)
@@ -36,17 +39,17 @@ import GHC.Utils.Outputable
text,
(<+>),
hsep,
- nest,
- ($$),
vcat,
+ hang,
withPprStyle,
ppr
)
+import GHC.Unit.Types (Module)
import GHC.ByteCode.Types
(
FFIInfo (..),
BCONPtr (..),
- BCOPtr,
+ BCOPtr (..),
UnlinkedBCO (..),
ByteCodeHpcInfo,
CompiledByteCode (..)
@@ -55,7 +58,7 @@ import GHC.ByteCode.Breakpoints (InternalBreakpointId (..), InternalModBreaks)
import GHC.ByteCode.Binary (OnDiskModuleByteCode (..))
import GHC.ByteCode.Serialize (readOnDiskModuleByteCode)
import GHC.Driver.Env.Types (HscEnv)
-import GHCi.ResolvedBCO (BCOByteArray)
+import GHCi.ResolvedBCO (BCOByteArray, fromBCOByteArray)
import GHCi.FFI (FFIType)
import GHCi.Message (ConInfoTable)
@@ -73,9 +76,9 @@ pprOnDiskModuleByteCode :: OnDiskModuleByteCode -> SDoc
pprOnDiskModuleByteCode OnDiskModuleByteCode {..}
= entry (text "module" <+> ppr odgbc_module) $
vcat [
- pprHash odgbc_hash,
- pprCompiledByteCode odgbc_compiled_byte_code,
- pprObjectFileContents odgbc_foreign
+ pprHash $ odgbc_hash,
+ pprCompiledByteCode odgbc_module $ odgbc_compiled_byte_code,
+ pprObjectFileContents $ odgbc_foreign
]
-- | […]
@@ -83,52 +86,53 @@ pprHash :: Fingerprint -> SDoc
pprHash = entry (text "hash:") . ppr
-- | […]
-pprCompiledByteCode :: CompiledByteCode -> SDoc
-pprCompiledByteCode CompiledByteCode {..}
+pprCompiledByteCode :: Module -> CompiledByteCode -> SDoc
+pprCompiledByteCode currentModule CompiledByteCode {..}
= entry (text "compiled bytecode:") $
vcat [
- pprByteCodeObjects bc_bcos,
- pprDataConstructorInfoTables bc_itbls,
- pprTopLevelStrings bc_strs,
- pprBreakpoints bc_breaks,
- pprStaticPointerTableEntries bc_spt_entries,
- pprHPCInfo bc_hpc_info
+ pprByteCodeObjects currentModule $ bc_bcos,
+ pprDataConstructorInfoTables $ bc_itbls,
+ pprTopLevelStrings $ bc_strs,
+ pprBreakpoints $ bc_breaks,
+ pprStaticPointerTableEntries $ bc_spt_entries,
+ pprHPCInfo $ bc_hpc_info
]
-- | […]
-pprByteCodeObjects :: FlatBag UnlinkedBCO -> SDoc
-pprByteCodeObjects = entry (text "bytecode objects:") .
- vcatOrNone .
- map pprByteCodeObject .
- elemsFlatBag
+pprByteCodeObjects :: Module -> FlatBag UnlinkedBCO -> SDoc
+pprByteCodeObjects currentModule = entry (text "bytecode objects:") .
+ vcatOrNone .
+ map (pprByteCodeObject currentModule) .
+ elemsFlatBag
-- | […]
-pprByteCodeObject :: UnlinkedBCO -> SDoc
-pprByteCodeObject UnlinkedBCO {..}
- = entry (text "ordinary bytecode object" <+> ppr unlinkedBCOName) $
- vcat [
- pprArity unlinkedBCOArity,
- pprInstructions unlinkedBCOInstrs,
- pprBitmap unlinkedBCOBitmap,
- pprLiterals unlinkedBCOLits,
- pprPointers unlinkedBCOPtrs
- ]
-pprByteCodeObject UnlinkedStaticCon {{-..-}}
- = entry (text "static constructor object:") $
- vcat [
- {-
- unlinkedStaticConName :: !Name,
- -- ^ The name to which this static constructor is bound, not to be
- -- confused with the name of the static constructor itself
- -- ('unlinkedStaticConDataConName')
- unlinkedStaticConDataConName :: !Name,
- unlinkedStaticConLits :: !(FlatBag BCONPtr),
- -- ^ non-ptrs full words, where sub-word literals have already been
- -- packed into full words as needed
- unlinkedStaticConPtrs :: !(FlatBag BCOPtr), -- ptrs
- unlinkedStaticConIsUnlifted :: !Bool
- -}
- ]
+pprByteCodeObject :: Module -> UnlinkedBCO -> SDoc
+pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of
+ UnlinkedBCO {..}
+ -> entry (text "ordinary bytecode object" <+> ppr unlinkedBCOName) $
+ vcat [
+ pprArity $ unlinkedBCOArity,
+ pprInstructions $ unlinkedBCOInstrs,
+ pprBitmap $ unlinkedBCOBitmap,
+ pprLiterals currentModule $ unlinkedBCOLits,
+ pprPointers currentModule $ unlinkedBCOPtrs
+ ]
+ UnlinkedStaticCon {{-..-}}
+ -> entry (text "static constructor object:") $ --FIXME: Remove colon and add name.
+ vcat [
+ {-
+ unlinkedStaticConName :: !Name,
+ -- ^ The name to which this static constructor is bound, not to be
+ -- confused with the name of the static constructor itself
+ -- ('unlinkedStaticConDataConName')
+ unlinkedStaticConDataConName :: !Name,
+ unlinkedStaticConLits :: !(FlatBag BCONPtr),
+ -- ^ non-ptrs full words, where sub-word literals have already been
+ -- packed into full words as needed
+ unlinkedStaticConPtrs :: !(FlatBag BCOPtr), -- ptrs
+ unlinkedStaticConIsUnlifted :: !Bool
+ -}
+ ]
-- | […]
pprArity :: Int -> SDoc
@@ -143,30 +147,31 @@ pprBitmap :: BCOByteArray Word -> SDoc
pprBitmap = entry (text "bitmap:") . pprBCOByteArray
-- | […]
-pprLiterals :: FlatBag BCONPtr -> SDoc
-pprLiterals = entry (text "literals:") .
- vcatOrNone .
- map pprLiteral .
- elemsFlatBag
+pprLiterals :: Module -> FlatBag BCONPtr -> SDoc
+pprLiterals currentModule = entry (text "literals:") .
+ vcatOrNone .
+ map (pprLiteral currentModule) .
+ elemsFlatBag
-- | […]
-pprLiteral :: BCONPtr -> SDoc
-pprLiteral (BCONPtrWord word)
- = text "word" <+> pprFixedSizeNatural word
-pprLiteral (BCONPtrLbl label)
- = text "label" <+> ppr label
-pprLiteral (BCONPtrItbl infoTableName)
- = text "info table" <+> ppr infoTableName
-pprLiteral (BCONPtrAddr addrName)
- = text "address" <+> ppr addrName
-pprLiteral (BCONPtrStr encodedString)
- = text "top-level string" <+> pprByteString encodedString
-pprLiteral (BCONPtrFS string)
- = text "top-level string" <+> ppr string
-pprLiteral (BCONPtrFFIInfo ffiInfo)
- = text "foreign function" <+> pprFFIInfo ffiInfo
-pprLiteral (BCONPtrCostCentre breakpointID)
- = text "cost center" <+> pprBreakpointID breakpointID
+pprLiteral :: Module -> BCONPtr -> SDoc
+pprLiteral currentModule literal = case literal of
+ BCONPtrWord word
+ -> text "word" <+> pprFixedSizeNatural word
+ BCONPtrLbl label
+ -> text "label" <+> ppr label
+ BCONPtrItbl infoTableName
+ -> text "info table" <+> ppr infoTableName
+ BCONPtrAddr addrName
+ -> text "address" <+> ppr addrName
+ BCONPtrStr encodedString
+ -> text "top-level string" <+> pprByteString encodedString
+ BCONPtrFS string
+ -> text "top-level string" <+> ppr string
+ BCONPtrFFIInfo ffiInfo
+ -> text "foreign function" <+> pprFFIInfo ffiInfo
+ BCONPtrCostCentre breakpointID
+ -> text "cost center" <+> pprBreakpointID currentModule breakpointID
-- | […]
pprFFIInfo :: FFIInfo -> SDoc
@@ -182,13 +187,35 @@ pprFFIType ffiType = assert (take 3 ident == "FFI") $ text (drop 3 ident) where
ident = show ffiType
-- | […]
-pprBreakpointID :: InternalBreakpointId -> SDoc
-pprBreakpointID InternalBreakpointId {..} = ppr ibi_info_index
---FIXME: Either render the module also, or document why this is not necessary.
+pprBreakpointID :: Module -> InternalBreakpointId -> SDoc
+pprBreakpointID currentModule InternalBreakpointId {..}
+ | ibi_info_mod == currentModule = indexDoc
+ | otherwise = indexDoc <+>
+ text "in" <+>
+ ppr ibi_info_mod
+ where
+
+ indexDoc :: SDoc
+ indexDoc = ppr ibi_info_index
+
+-- | […]
+pprPointers :: Module -> FlatBag BCOPtr -> SDoc
+pprPointers currentModule = entry (text "pointers:") .
+ vcatOrNone .
+ map (pprPointer currentModule) .
+ elemsFlatBag
-- | […]
-pprPointers :: FlatBag BCOPtr -> SDoc
-pprPointers = pprPointers
+pprPointer :: Module -> BCOPtr -> SDoc
+pprPointer currentModule pointer = case pointer of
+ BCOPtrName name
+ -> text "name" <+> ppr name
+ BCOPtrPrimOp primOp
+ -> text "primitive operation" <+> ppr primOp
+ BCOPtrBCO byteCodeObject
+ -> pprByteCodeObject currentModule byteCodeObject
+ BCOPtrBreakArray breakArrayModule
+ -> text "break array of module" <+> ppr breakArrayModule
-- | […]
pprDataConstructorInfoTables :: [(Name, ConInfoTable)] -> SDoc
@@ -242,7 +269,7 @@ pprByteString :: ByteString -> SDoc
pprByteString = pprFixedSizeNaturalList . unpack
-- | […]
-pprBCOByteArray :: (Storable a, Integral a, FiniteBits a) =>
+pprBCOByteArray :: (Integral a, FiniteBits a, Storable a, IArray UArray a) =>
BCOByteArray a -> SDoc
pprBCOByteArray = pprFixedSizeNaturalList . elems . fromBCOByteArray
@@ -265,7 +292,7 @@ pprFixedSizeNatural num
-- | […]
entry :: SDoc -> SDoc -> SDoc
-entry title content = title $$ nest 2 content
+entry title content = hang title 2 content
-- | […]
vcatOrNone :: [SDoc] -> SDoc
=====================================
libraries/ghci/GHCi/ResolvedBCO.hs
=====================================
@@ -7,6 +7,7 @@ module GHCi.ResolvedBCO
, isLittleEndian
, BCOByteArray(..)
, mkBCOByteArray
+ , fromBCOByteArray
) where
#include "MachDeps.h"
@@ -20,7 +21,6 @@ import GHCi.BreakArray
import Control.Monad
import Data.Array.Base (foldrArray, listArray)
import Data.ByteString.Builder.Extra
-import Foreign.Storable
#endif
import Data.Binary (Binary(..))
@@ -32,6 +32,7 @@ import GHC.Generics
import GHC.Exts
import Data.Array.Base (UArray(..))
+import Foreign.Storable
import qualified GHC.Exts.Heap as Heap
#include "MachDeps.h"
@@ -91,13 +92,11 @@ data BCOByteArray a
getBCOByteArray :: !ByteArray#
}
-#if SIZEOF_HSWORD == 4
fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a
fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba#
where
len# = sizeofByteArray# ba#
n = (I# len#) `div` sizeOf (undefined :: a)
-#endif
mkBCOByteArray :: UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca5bf4543f1da4c29823302a570c52e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca5bf4543f1da4c29823302a570c52e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/cfg-perf-test] testsuite: fix CmmControlFlowPerf to actually compile the .cmm
by Simon Jakobi (＠sjakobi2) 03 Jun '26
by Simon Jakobi (＠sjakobi2) 03 Jun '26
03 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/cfg-perf-test at Glasgow Haskell Compiler / GHC
Commits:
7055fc01 by Simon Jakobi at 2026-06-03T17:57:11+02:00
testsuite: fix CmmControlFlowPerf to actually compile the .cmm
The test passed a bare module name as top_mod to multimod_compile, so
GHC ran `--make CmmControlFlowPerf` and failed to locate the module
(.cmm sources aren't resolved from a bare module name). Even with the
extension, `--make` links a non-existent main, and `-no-hs-main` does
not suppress that.
Use `compile` with the `cmm_src` setup instead: this resolves
CmmControlFlowPerf.cmm and compiles with `-c` (no link), which is all a
compiler perf test needs. Drop the now-unnecessary -no-hs-main.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
1 changed file:
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -830,10 +830,11 @@ test ('T26425',
test('CmmControlFlowPerf',
[ only_ways(['optasm']),
unless(have_ncg(), skip),
+ cmm_src,
collect_compiler_stats('bytes allocated', 5),
collect_compiler_residency(15),
pre_cmd('./genCmmControlFlowPerf'),
extra_files(['genCmmControlFlowPerf']),
],
- multimod_compile,
- ['CmmControlFlowPerf', '-O -v0 -no-hs-main'])
+ compile,
+ ['-O -v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7055fc01793352fa68cecd3c647adae…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7055fc01793352fa68cecd3c647adae…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: always keep response files
by David Eichmann (＠DavidEichmann) 03 Jun '26
by David Eichmann (＠DavidEichmann) 03 Jun '26
03 Jun '26
David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC
Commits:
e0ab52ce by David Eichmann at 2026-06-03T16:37:53+01:00
Hadrian: always keep response files
Now that response files are only used in a small number of cases, it's
resonable to keep all response files by default and simply remove the
-r / --keep-response-files command line options.
The response file paths are nolonger randomized. They are placed in the
`_build/rsp` directory.This ensures we reuse file paths when rebuilding
rather than leaving stale response files around.
- - - - -
5 changed files:
- − changelog.d/hadrian-response-files.md
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
Changes:
=====================================
changelog.d/hadrian-response-files.md deleted
=====================================
@@ -1,9 +0,0 @@
-section: packaging
-synopsis: Add a flag to tell Hadrian to keep response files
-issues: #27184
-mrs: !15906
-description:
- Hadrian can now be instructed to keep response files with the new
- --keep-response-files command line flag. This is helpful when debugging a
- build failure, as it allows re-running the failing command line invocation
- without an error due to a missing response file.
=====================================
hadrian/src/Builder.hs
=====================================
@@ -304,7 +304,7 @@ instance H.Builder Builder where
case builder of
Ar Pack stg -> do
useTempFile <- arSupportsAtFile stg
- if useTempFile then runAr path buildArgs buildInputs buildOptions
+ if useTempFile then runAr output path buildArgs buildInputs buildOptions
else runArWithoutTempFile path buildArgs buildInputs buildOptions
Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions
@@ -343,7 +343,7 @@ instance H.Builder Builder where
Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions
return ()
- Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Haddock BuildPackage -> runHaddock output path buildArgs buildInputs
Ghc _ _ ->
-- Use a response file for ghc invocations to avoid issues with command line
@@ -352,6 +352,7 @@ instance H.Builder Builder where
-- empty arguments (such as the -dep-suffix flag), but that isn't supported
-- yet due to #26560.
withResponseFileIfLongCmd
+ output
(toCmdArgument [path] <> toCmdArgument buildArgs)
buildInputs
(toCmdArgument buildOptions)
@@ -390,11 +391,13 @@ instance H.Builder Builder where
-- | Invoke @haddock@ given a path to it and a list of arguments. On Windows,
-- the input file arguments are passed as a response file.
-runHaddock :: FilePath -- ^ path to @haddock@
+runHaddock :: FilePath -- ^ output file path
+ -> FilePath -- ^ path to @haddock@
-> [String]
-> [FilePath] -- ^ input file paths
-> Action ()
-runHaddock haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+ outputFilePath
(toCmdArgument [haddockPath] <> toCmdArgument flagArgs)
fileInputs
(CmdArgument [])
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -3,8 +3,7 @@ module CommandLine (
lookupBignum,
cmdBignum, cmdProgressInfo, cmdCompleteSetting,
cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
- cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs,
- cmdKeepResponseFiles
+ cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs
) where
import Data.Either
@@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
-import Hadrian.Utilities hiding (buildRoot, keepResponseFiles)
+import Hadrian.Utilities hiding (buildRoot)
import Settings.Parser
import System.Console.GetOpt
import System.Environment
@@ -37,7 +36,6 @@ data CommandLineArgs = CommandLineArgs
, testArgs :: TestArgs
, docsArgs :: DocArgs
, docTargets :: DocTargets
- , keepResponseFiles :: Bool
, prefix :: Maybe FilePath
, changelogVersion :: Maybe String
, completeStg :: Maybe String }
@@ -58,7 +56,6 @@ defaultCommandLineArgs = CommandLineArgs
, testArgs = defaultTestArgs
, docsArgs = defaultDocArgs
, docTargets = Set.fromList [minBound..maxBound]
- , keepResponseFiles = False
, prefix = Nothing
, changelogVersion = Nothing
, completeStg = Nothing }
@@ -141,9 +138,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }
-readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs)
-readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True }
-
readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
readUnitIdHash = Right $ \flags ->
trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $
@@ -302,8 +296,6 @@ optDescrs =
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (ReqArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
- , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles)
- "Keep response files created during the build (for debugging)."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
, Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
@@ -382,7 +374,6 @@ cmdLineArgsMap = do
return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
- $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
$ insertExtra (docsArgs args) -- Accessed by Rules.Documentation
$ insertExtra allSettings -- Accessed by Settings
@@ -424,9 +415,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs
cmdBignum :: Action (Maybe String)
cmdBignum = bignum <$> cmdLineArgs
-cmdKeepResponseFiles :: Action Bool
-cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs
-
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -35,14 +35,16 @@ instance NFData ArMode
-- to be archived is passed via a temporary response file. Passing arguments
-- via a response file is not supported by some versions of @ar@, in which
-- case you should use 'runArWithoutTempFile' instead.
-runAr :: FilePath -- ^ path to @ar@
+runAr :: FilePath -- ^ output file path
+ -> FilePath -- ^ path to @ar@
-> [String] -- ^ other arguments
-> [FilePath] -- ^ input file paths
-> [CmdOption] -- ^ Additional options
-> Action ()
-runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
- writeFile' tmp $ unwords fileArgs
- cmd [arPath] flagArgs ('@' : tmp) buildOptions
+runAr outputFilePath arPath flagArgs fileArgs buildOptions = do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile $ unwords fileArgs
+ cmd [arPath] flagArgs ('@' : rspFile) buildOptions
-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
-- will be called multiple times if the list of files to be archived is too
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -16,7 +16,7 @@ module Hadrian.Utilities (
-- * Paths
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
- KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileIfLongCmd,
+ withResponseFileIfLongCmd, responseFilePath,
-- * File system operations
copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -49,10 +49,10 @@ import Data.Maybe
import Data.Typeable (TypeRep, typeOf)
import Development.Shake hiding (Normal)
import Development.Shake.Classes
+import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument))
import Development.Shake.FilePath
import GHC.ResponseFile (escapeArgs)
import System.Environment (lookupEnv)
-import System.IO (hClose, openTempFile)
import System.IO.Error (isPermissionError)
import qualified Data.ByteString as BS
@@ -62,7 +62,6 @@ import qualified System.Directory.Extra as IO
import qualified System.Info.Extra as IO
import qualified System.IO as IO
import qualified System.FilePath.Posix as Posix
-import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument))
-- | Extract a value from a singleton list, or terminate with an error message
-- if the list does not contain exactly one value.
@@ -323,59 +322,32 @@ buildRootRules = do
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show)
-
--- | Whether to retain response files after the build action that created them
--- completes. Mainly useful for debugging.
-keepResponseFiles :: Action Bool
-keepResponseFiles = do
- KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
- return keep
-
-- | Run an command with the given arguments. If the command is too long then the
-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@.
---
--- With @--keep-response-files@, the file is left on disk (if used)
withResponseFileIfLongCmd :: (CmdResult c) =>
- CmdArgument -- ^ Command and arguments before the response file arguments.
+ FilePath -- ^ Command output file path. The reponse file is placed in _build/rsp/<Command output file path>.
+ -> CmdArgument -- ^ Command and arguments before the response file arguments.
-> [String] -- ^ Response file aruguments.
-> CmdArgument -- ^ Command arguments after the response file arguments.
-> Action c
-withResponseFileIfLongCmd argsPre argsResp argsPost = do
+withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do
let cmdLineLengh = sum
[ 1 + length arg -- add one to account for space inbetween arguments
| let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost
, Right arg <- args
]
- if cmdLineLengh >= cmdLineLengthLimit
- then withResponseFile $ \tmp -> do
- writeFile' tmp (escapeArgs argsResp)
- cmd argsPre ['@' : tmp] argsPost
- else cmd argsPre argsResp argsPost
-
--- | Run an action with a response file path.
---
--- With @--keep-response-files@, the file is left on disk.
-withResponseFile :: (FilePath -> Action a) -> Action a
-withResponseFile action = do
- keep <- keepResponseFiles
- let putVerboseResponseFile tmp = do
- verbosity <- getVerbosity
- when (verbosity >= Verbose) $ do
- tmpContent <- liftIO (readFile tmp)
- putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent)
- if keep
- then do
- (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
- liftIO $ hClose h
- putInfo $ "Keeping response file: " ++ tmp
- result <- action tmp
- putVerboseResponseFile tmp
- return result
- else withTempFile $ \tmp -> do
- result <- action tmp
- putVerboseResponseFile tmp
- return result
+ if cmdLineLengh < cmdLineLengthLimit
+ then cmd argsPre argsResp argsPost
+ else do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile (escapeArgs argsResp)
+ cmd argsPre ['@' : rspFile] argsPost
+
+-- | Convert a command's output file path to a response file path to be used for that command.
+responseFilePath :: FilePath -> Action FilePath
+responseFilePath outputFilePath = do
+ buildDir <- buildRoot
+ return $ buildDir </> "rsp" </> outputFilePath
-- | Link a file tracking the link target. Create the target directory if
-- missing.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0ab52ceaf3f1e18c3a83ba215d01d9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0ab52ceaf3f1e18c3a83ba215d01d9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: always keep response files
by David Eichmann (＠DavidEichmann) 03 Jun '26
by David Eichmann (＠DavidEichmann) 03 Jun '26
03 Jun '26
David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC
Commits:
d1c29fb7 by David Eichmann at 2026-06-03T16:29:52+01:00
Hadrian: always keep response files
Now that response files are only used in a small number of cases, it's
resonable to keep all response files by default and simply remove the
-r / --keep-response-files command line options.
The response file paths are nolonger randomized. They are placed in the
`_build/rsp` directory.This ensures we reuse file paths when rebuilding
rather than leaving stale response files around.
- - - - -
5 changed files:
- − changelog.d/hadrian-response-files.md
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
Changes:
=====================================
changelog.d/hadrian-response-files.md deleted
=====================================
@@ -1,9 +0,0 @@
-section: packaging
-synopsis: Add a flag to tell Hadrian to keep response files
-issues: #27184
-mrs: !15906
-description:
- Hadrian can now be instructed to keep response files with the new
- --keep-response-files command line flag. This is helpful when debugging a
- build failure, as it allows re-running the failing command line invocation
- without an error due to a missing response file.
=====================================
hadrian/src/Builder.hs
=====================================
@@ -304,7 +304,7 @@ instance H.Builder Builder where
case builder of
Ar Pack stg -> do
useTempFile <- arSupportsAtFile stg
- if useTempFile then runAr path buildArgs buildInputs buildOptions
+ if useTempFile then runAr output path buildArgs buildInputs buildOptions
else runArWithoutTempFile path buildArgs buildInputs buildOptions
Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions
@@ -343,7 +343,7 @@ instance H.Builder Builder where
Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions
return ()
- Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Haddock BuildPackage -> runHaddock output path buildArgs buildInputs
Ghc _ _ ->
-- Use a response file for ghc invocations to avoid issues with command line
@@ -352,6 +352,7 @@ instance H.Builder Builder where
-- empty arguments (such as the -dep-suffix flag), but that isn't supported
-- yet due to #26560.
withResponseFileIfLongCmd
+ output
(toCmdArgument [path] <> toCmdArgument buildArgs)
buildInputs
(toCmdArgument buildOptions)
@@ -390,11 +391,13 @@ instance H.Builder Builder where
-- | Invoke @haddock@ given a path to it and a list of arguments. On Windows,
-- the input file arguments are passed as a response file.
-runHaddock :: FilePath -- ^ path to @haddock@
+runHaddock :: FilePath -- ^ output file path
+ -> FilePath -- ^ path to @haddock@
-> [String]
-> [FilePath] -- ^ input file paths
-> Action ()
-runHaddock haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+ outputFilePath
(toCmdArgument [haddockPath] <> toCmdArgument flagArgs)
fileInputs
(CmdArgument [])
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -3,8 +3,7 @@ module CommandLine (
lookupBignum,
cmdBignum, cmdProgressInfo, cmdCompleteSetting,
cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
- cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs,
- cmdKeepResponseFiles
+ cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs
) where
import Data.Either
@@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
-import Hadrian.Utilities hiding (buildRoot, keepResponseFiles)
+import Hadrian.Utilities hiding (buildRoot)
import Settings.Parser
import System.Console.GetOpt
import System.Environment
@@ -37,7 +36,6 @@ data CommandLineArgs = CommandLineArgs
, testArgs :: TestArgs
, docsArgs :: DocArgs
, docTargets :: DocTargets
- , keepResponseFiles :: Bool
, prefix :: Maybe FilePath
, changelogVersion :: Maybe String
, completeStg :: Maybe String }
@@ -58,7 +56,6 @@ defaultCommandLineArgs = CommandLineArgs
, testArgs = defaultTestArgs
, docsArgs = defaultDocArgs
, docTargets = Set.fromList [minBound..maxBound]
- , keepResponseFiles = False
, prefix = Nothing
, changelogVersion = Nothing
, completeStg = Nothing }
@@ -141,9 +138,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }
-readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs)
-readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True }
-
readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
readUnitIdHash = Right $ \flags ->
trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $
@@ -302,8 +296,6 @@ optDescrs =
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (ReqArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
- , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles)
- "Keep response files created during the build (for debugging)."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
, Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
@@ -382,7 +374,6 @@ cmdLineArgsMap = do
return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
- $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
$ insertExtra (docsArgs args) -- Accessed by Rules.Documentation
$ insertExtra allSettings -- Accessed by Settings
@@ -424,9 +415,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs
cmdBignum :: Action (Maybe String)
cmdBignum = bignum <$> cmdLineArgs
-cmdKeepResponseFiles :: Action Bool
-cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs
-
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -35,14 +35,16 @@ instance NFData ArMode
-- to be archived is passed via a temporary response file. Passing arguments
-- via a response file is not supported by some versions of @ar@, in which
-- case you should use 'runArWithoutTempFile' instead.
-runAr :: FilePath -- ^ path to @ar@
+runAr :: FilePath -- ^ output file path
+ -> FilePath -- ^ path to @ar@
-> [String] -- ^ other arguments
-> [FilePath] -- ^ input file paths
-> [CmdOption] -- ^ Additional options
-> Action ()
-runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
- writeFile' tmp $ unwords fileArgs
- cmd [arPath] flagArgs ('@' : tmp) buildOptions
+runAr outputFilePath arPath flagArgs fileArgs buildOptions = do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile $ unwords fileArgs
+ cmd [arPath] flagArgs ('@' : rspFile) buildOptions
-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
-- will be called multiple times if the list of files to be archived is too
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -16,7 +16,7 @@ module Hadrian.Utilities (
-- * Paths
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
- KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileIfLongCmd,
+ withResponseFileIfLongCmd, responseFilePath,
-- * File system operations
copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -52,7 +52,6 @@ import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.ResponseFile (escapeArgs)
import System.Environment (lookupEnv)
-import System.IO (hClose, openTempFile)
import System.IO.Error (isPermissionError)
import qualified Data.ByteString as BS
@@ -323,59 +322,35 @@ buildRootRules = do
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show)
-
--- | Whether to retain response files after the build action that created them
--- completes. Mainly useful for debugging.
-keepResponseFiles :: Action Bool
-keepResponseFiles = do
- KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
- return keep
-
-- | Run an command with the given arguments. If the command is too long then the
-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@.
--
-- With @--keep-response-files@, the file is left on disk (if used)
withResponseFileIfLongCmd :: (CmdResult c) =>
- CmdArgument -- ^ Command and arguments before the response file arguments.
+ FilePath -- ^ Command output file path. The reponse file is placed in _build/rsp/<Command output file path>.
+ -> CmdArgument -- ^ Command and arguments before the response file arguments.
-> [String] -- ^ Response file aruguments.
-> CmdArgument -- ^ Command arguments after the response file arguments.
-> Action c
-withResponseFileIfLongCmd argsPre argsResp argsPost = do
+withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do
let cmdLineLengh = sum
[ 1 + length arg -- add one to account for space inbetween arguments
| let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost
, Right arg <- args
]
- if cmdLineLengh >= cmdLineLengthLimit
- then withResponseFile $ \tmp -> do
- writeFile' tmp (escapeArgs argsResp)
- cmd argsPre ['@' : tmp] argsPost
- else cmd argsPre argsResp argsPost
-
--- | Run an action with a response file path.
---
--- With @--keep-response-files@, the file is left on disk.
-withResponseFile :: (FilePath -> Action a) -> Action a
-withResponseFile action = do
- keep <- keepResponseFiles
- let putVerboseResponseFile tmp = do
- verbosity <- getVerbosity
- when (verbosity >= Verbose) $ do
- tmpContent <- liftIO (readFile tmp)
- putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent)
- if keep
- then do
- (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
- liftIO $ hClose h
- putInfo $ "Keeping response file: " ++ tmp
- result <- action tmp
- putVerboseResponseFile tmp
- return result
- else withTempFile $ \tmp -> do
- result <- action tmp
- putVerboseResponseFile tmp
- return result
+ if cmdLineLengh < cmdLineLengthLimit
+ then cmd argsPre argsResp argsPost
+ else do
+ rspFile <- responseFilePath outputFilePath
+ writeFile' rspFile (escapeArgs argsResp)
+ cmd argsPre ['@' : rspFile] argsPost
+
+-- | Convert a command's output file to a response file path to be used
+-- for that command.
+responseFilePath :: FilePath -> Action FilePath
+responseFilePath outputFilePath = do
+ buildDir <- buildRoot
+ return $ buildDir </> "rsp" </> outputFilePath
-- | Link a file tracking the link target. Create the target directory if
-- missing.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1c29fb7dd61ce9a9c93ca0a6eb6a56…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1c29fb7dd61ce9a9c93ca0a6eb6a56…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/T26964] StgToCmm: only record primop name when -fcheck-prim-bounds is on
by Simon Jakobi (＠sjakobi2) 03 Jun '26
by Simon Jakobi (＠sjakobi2) 03 Jun '26
03 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/T26964 at Glasgow Haskell Compiler / GHC
Commits:
7ec0dc61 by Simon Jakobi at 2026-06-03T16:42:48+02:00
StgToCmm: only record primop name when -fcheck-prim-bounds is on
Recording the primop name for bounds-check error messages allocated a name
thunk and updated FCodeState on every primop compilation. Guard it on the flag
so the common unchecked case pays nothing.
Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
1 changed file:
- compiler/GHC/StgToCmm/Prim.hs
Changes:
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -96,9 +96,13 @@ cmmPrimOpApp cfg primop cmm_args mres_ty = do
-- if the result type isn't explicitly given, we directly use the
-- result type of the primop.
res_ty = fromMaybe (primOpResultType primop) mres_ty
- -- Record the primop name so that any -fcheck-prim-bounds failure handler
- -- emitted while compiling it can name it in the error message.
- withCurrentPrimOpName (occNameString (primOpOcc primop)) (f res_ty)
+ -- When -fcheck-prim-bounds is on, record the primop name so that any
+ -- bounds-check failure handler emitted while compiling it can name it in the
+ -- error message. Guarded by the flag so that the common (unchecked) case pays
+ -- nothing: no name thunk, no FCodeState update.
+ if stgToCmmDoBoundsCheck cfg
+ then withCurrentPrimOpName (occNameString (primOpOcc primop)) (f res_ty)
+ else f res_ty
externalPrimop :: PrimOp -> [CmmExpr] -> PrimopCmmEmit
externalPrimop primop args = outOfLinePrimop (callExternalPrimop primop args)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ec0dc614d5dce3e69fd73a85ea7e93…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ec0dc614d5dce3e69fd73a85ea7e93…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/T26964] 2 commits: Improve -fcheck-prim-bounds runtime error messages
by Simon Jakobi (＠sjakobi2) 03 Jun '26
by Simon Jakobi (＠sjakobi2) 03 Jun '26
03 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/T26964 at Glasgow Haskell Compiler / GHC
Commits:
48cb48ec by Simon Jakobi at 2026-06-03T15:45:15+02:00
Improve -fcheck-prim-bounds runtime error messages
When an array access instrumented by -fcheck-prim-bounds fails at runtime,
report the failing primop, the offending index and the array size, and exit
with a normal failure status. Previously the program aborted via barf with an
"internal error" framed as a GHC bug, even though such failures are almost
always caused by incorrect use of unsafe primops in user or library code.
The primop name is threaded to the failure handlers through a new fcs_prim_op
field in FCodeState, set once in cmmPrimOpApp, so the bounds-check sites
themselves are unchanged.
Fixes #26964, #24617.
Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
65ea8b42 by Simon Jakobi at 2026-06-03T15:45:23+02:00
rts: name the primop in DEBUG ASSERT_IN_BOUNDS failures
ASSERT_IN_BOUNDS passed the literal "array access" as the op name, which
collided with rtsOutOfBoundsAccess's own message text ("<op>: array access out
of bounds"), producing the redundant "array access: array access out of
bounds". Thread the real primop name (e.g. "casIntArray#") through the macro
instead, matching the native code generator's messages.
Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
12 changed files:
- + changelog.d/improve-check-prim-bounds-messages
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Prim.hs
- docs/users_guide/debugging.rst
- rts/PrimOps.cmm
- rts/RtsMessages.c
- rts/include/rts/Messages.h
- + testsuite/tests/codeGen/should_fail/T26964.hs
- + testsuite/tests/codeGen/should_fail/T26964.stderr
- + testsuite/tests/codeGen/should_fail/T26964b.hs
- + testsuite/tests/codeGen/should_fail/T26964b.stderr
- testsuite/tests/codeGen/should_fail/all.T
Changes:
=====================================
changelog.d/improve-check-prim-bounds-messages
=====================================
@@ -0,0 +1,13 @@
+section: codegen
+synopsis: Improve ``-fcheck-prim-bounds`` runtime error messages
+issues: #26964 #24617
+mrs: !16130
+
+description: {
+ When an array access instrumented by ``-fcheck-prim-bounds`` fails at
+ runtime, the program now reports the failing primop, the offending index and
+ the array size, and exits with a normal non-zero status. Previously it
+ aborted with an "internal error" framed as a GHC bug, even though such
+ failures are almost always caused by incorrect use of unsafe primops in user
+ or library code.
+}
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -42,6 +42,7 @@ module GHC.StgToCmm.Monad (
SelfLoopInfo(..),
setTickyCtrLabel, getTickyCtrLabel,
+ withCurrentPrimOpName, getCurrentPrimOpName,
tickScope, getTickScope,
withUpdFrameOff, getUpdFrameOff,
@@ -304,6 +305,9 @@ data FCodeState =
-- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr
, fcs_ticky :: !CLabel -- ^ Destination for ticky counts
, fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks
+ , fcs_prim_op :: Maybe String -- ^ Source name of the primop currently being
+ -- compiled, used by -fcheck-prim-bounds error
+ -- messages.
}
data HeapUsage -- See Note [Virtual and real heap pointers]
@@ -462,6 +466,7 @@ initFCodeState p =
, fcs_selfloop = Nothing
, fcs_ticky = mkTopTickyCtrLabel
, fcs_tickscope = GlobalScope
+ , fcs_prim_op = Nothing
}
getFCodeState :: FCode FCodeState
@@ -520,6 +525,20 @@ setTickyCtrLabel ticky code = do
fstate <- getFCodeState
withFCodeState code (fstate {fcs_ticky = ticky})
+-- ----------------------------------------------------------------------------
+-- Track the primop currently being compiled
+
+-- | The source name of the primop currently being compiled (e.g.
+-- @"writeArray#"@), if any. Used to produce informative @-fcheck-prim-bounds@
+-- error messages.
+getCurrentPrimOpName :: FCode (Maybe String)
+getCurrentPrimOpName = fcs_prim_op <$> getFCodeState
+
+withCurrentPrimOpName :: String -> FCode a -> FCode a
+withCurrentPrimOpName name code = do
+ fstate <- getFCodeState
+ withFCodeState code (fstate {fcs_prim_op = Just name})
+
-- ----------------------------------------------------------------------------
-- Manage tick scopes
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -25,11 +25,13 @@ import GHC.StgToCmm.Layout
import GHC.StgToCmm.Foreign
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
+import GHC.StgToCmm.Lit ( newStringCLit )
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Prof ( costCentreFrom )
import GHC.Types.Basic
+import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Literal.Floating
import GHC.Cmm.BlockId
import GHC.Cmm.Graph
@@ -94,7 +96,9 @@ cmmPrimOpApp cfg primop cmm_args mres_ty = do
-- if the result type isn't explicitly given, we directly use the
-- result type of the primop.
res_ty = fromMaybe (primOpResultType primop) mres_ty
- f res_ty
+ -- Record the primop name so that any -fcheck-prim-bounds failure handler
+ -- emitted while compiling it can name it in the error message.
+ withCurrentPrimOpName (occNameString (primOpOcc primop)) (f res_ty)
externalPrimop :: PrimOp -> [CmmExpr] -> PrimopCmmEmit
externalPrimop primop args = outOfLinePrimop (callExternalPrimop primop args)
@@ -3615,8 +3619,12 @@ emitCheckedMemcpyCall dst src n align = do
emitMemcpyCall dst src n align
where
doCheck platform = do
+ name <- fromMaybe "<unknown primop>" <$> getCurrentPrimOpName
+ nameLbl <- newStringCLit name
overlapCheckFailed <- getCode $
- emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) []
+ emitCCallNeverReturns []
+ (mkLblExpr mkMemcpyRangeOverlapLabel)
+ [ (CmmLit nameLbl, AddrHint) ]
emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False)
where
rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero
@@ -3728,6 +3736,25 @@ whenCheckBounds a = do
False -> pure ()
True -> a
+-- | Emit a call to the RTS @rtsOutOfBoundsAccess@ bounds-check failure
+-- handler, passing the offending index, the number of accessed elements and
+-- the array size, so that the runtime can produce an informative error
+-- message. The name of the offending primop is read from the code generator
+-- environment (see 'withCurrentPrimOpName').
+emitBoundsCheckFailed :: CmmExpr -- ^ accessed index
+ -> CmmExpr -- ^ number of accessed elements
+ -> CmmExpr -- ^ array size (in elements)
+ -> FCode ()
+emitBoundsCheckFailed idx count sz = do
+ name <- fromMaybe "<unknown primop>" <$> getCurrentPrimOpName
+ nameLbl <- newStringCLit name
+ emitCCallNeverReturns []
+ (mkLblExpr mkOutOfBoundsAccessLabel)
+ [ (idx, NoHint)
+ , (count, NoHint)
+ , (sz, NoHint)
+ , (CmmLit nameLbl, AddrHint) ]
+
emitBoundsCheck :: CmmExpr -- ^ accessed index
-> CmmExpr -- ^ array size (in elements)
-> FCode ()
@@ -3735,7 +3762,7 @@ emitBoundsCheck idx sz = do
assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig)
platform <- getPlatform
boundsCheckFailed <- getCode $
- emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []
+ emitBoundsCheckFailed idx (mkIntExpr platform 1) sz
let isOutOfBounds = cmmUGeWord platform idx sz
emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)
@@ -3754,7 +3781,7 @@ emitRangeBoundsCheck idx len arrSizeExpr = do
_ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $
cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing
boundsCheckFailed <- getCode $
- emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []
+ emitBoundsCheckFailed idx len arrSize
let
rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg)
lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg)
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -1167,10 +1167,25 @@ Checking for consistency
Typically primops operations like ``writeArray#`` exhibit unsafe behavior,
relying on the user to perform any bounds checking. This flag instructs the
code generator to instrument such operations with bound checking logic
- which aborts the program when an out-of-bounds access is detected.
+ which terminates the program when an out-of-bounds access is detected.
+
+ When a check fails, the program prints a message naming the offending
+ primop together with the offending index and the array size, and exits
+ with a non-zero status, for example::
+
+ myprog: writeArray#: array access out of bounds:
+ index 5 is not within [0, 3).
+ This is usually caused by incorrect use of unsafe primops in user or library code.
+
+ The message does not identify the enclosing function or module. To obtain a
+ backtrace pinpointing the failing call, build with profiling and run with
+ ``+RTS -xc`` (see :ref:`prof-time-options`), or use :ghc-flag:`-finfo-table-map`
+ together with ``+RTS -xc``.
Note that this is only intended to be used as a debugging measure, not as
- the primary means of catching out-of-bounds accesses.
+ the primary means of catching out-of-bounds accesses. Currently only the
+ native code generator is instrumented; the JavaScript backend is unaffected
+ by this flag.
.. ghc-flag:: -fcmm-thread-sanitizer
:shortdesc: Enable ThreadSanitizer instrumentation of memory accesses.
=====================================
rts/PrimOps.cmm
=====================================
@@ -88,10 +88,14 @@ import CLOSURE ghc_hs_iface;
#endif
#if defined(DEBUG)
-#define ASSERT_IN_BOUNDS(ind, sz) \
- if (ind >= sz) { ccall rtsOutOfBoundsAccess(); }
+// `op` is the source name of the primop being checked (e.g. "casIntArray#").
+// NB: in some callers `ind` is a byte offset rather than an element index, so
+// the index reported here may be in bytes. count is 1 since these checks cover
+// a single access.
+#define ASSERT_IN_BOUNDS(op, ind, sz) \
+ if (ind >= sz) { ccall rtsOutOfBoundsAccess(ind, 1, sz, op); }
#else
-#define ASSERT_IN_BOUNDS(ind, sz)
+#define ASSERT_IN_BOUNDS(op, ind, sz)
#endif
/*-----------------------------------------------------------------------------
@@ -336,7 +340,7 @@ stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new )
{
W_ p, h;
- ASSERT_IN_BOUNDS(ind + WDS(1) - 1, StgArrBytes_bytes(arr));
+ ASSERT_IN_BOUNDS("casIntArray#", ind + WDS(1) - 1, StgArrBytes_bytes(arr));
p = arr + SIZEOF_StgArrBytes + WDS(ind);
(h) = prim %cmpxchgW(p, old, new);
@@ -350,7 +354,7 @@ stg_casInt8Arrayzh( gcptr arr, W_ ind, I8 old, I8 new )
W_ p;
I8 h;
- ASSERT_IN_BOUNDS(ind, StgArrBytes_bytes(arr));
+ ASSERT_IN_BOUNDS("casInt8Array#", ind, StgArrBytes_bytes(arr));
p = arr + SIZEOF_StgArrBytes + ind;
(h) = prim %cmpxchg8(p, old, new);
@@ -364,7 +368,7 @@ stg_casInt16Arrayzh( gcptr arr, W_ ind, I16 old, I16 new )
W_ p;
I16 h;
- ASSERT_IN_BOUNDS(ind + 1, StgArrBytes_bytes(arr));
+ ASSERT_IN_BOUNDS("casInt16Array#", ind + 1, StgArrBytes_bytes(arr));
p = arr + SIZEOF_StgArrBytes + ind*2;
(h) = prim %cmpxchg16(p, old, new);
@@ -378,7 +382,7 @@ stg_casInt32Arrayzh( gcptr arr, W_ ind, I32 old, I32 new )
W_ p;
I32 h;
- ASSERT_IN_BOUNDS(ind + 3, StgArrBytes_bytes(arr));
+ ASSERT_IN_BOUNDS("casInt32Array#", ind + 3, StgArrBytes_bytes(arr));
p = arr + SIZEOF_StgArrBytes + ind*4;
(h) = prim %cmpxchg32(p, old, new);
@@ -392,7 +396,7 @@ stg_casInt64Arrayzh( gcptr arr, W_ ind, I64 old, I64 new )
W_ p;
I64 h;
- ASSERT_IN_BOUNDS(ind + 7, StgArrBytes_bytes(arr));
+ ASSERT_IN_BOUNDS("casInt64Array#", ind + 7, StgArrBytes_bytes(arr));
p = arr + SIZEOF_StgArrBytes + ind*8;
(h) = prim %cmpxchg64(p, old, new);
@@ -470,7 +474,7 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
gcptr h;
W_ p, len;
- ASSERT_IN_BOUNDS(ind, StgMutArrPtrs_ptrs(arr));
+ ASSERT_IN_BOUNDS("casArray#", ind, StgMutArrPtrs_ptrs(arr));
p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);
(h) = prim %cmpxchgW(p, old, new);
@@ -578,8 +582,8 @@ stg_copySmallArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n)
SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
- ASSERT_IN_BOUNDS(dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst));
- ASSERT_IN_BOUNDS(src_off + n - 1, StgSmallMutArrPtrs_ptrs(src));
+ ASSERT_IN_BOUNDS("copySmallArray#", dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst));
+ ASSERT_IN_BOUNDS("copySmallArray#", src_off + n - 1, StgSmallMutArrPtrs_ptrs(src));
dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off);
src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off);
bytes = WDS(n);
@@ -601,8 +605,8 @@ stg_copySmallMutableArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n
SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
- ASSERT_IN_BOUNDS(dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst));
- ASSERT_IN_BOUNDS(src_off + n - 1, StgSmallMutArrPtrs_ptrs(src));
+ ASSERT_IN_BOUNDS("copySmallMutableArray#", dst_off + n - 1, StgSmallMutArrPtrs_ptrs(dst));
+ ASSERT_IN_BOUNDS("copySmallMutableArray#", src_off + n - 1, StgSmallMutArrPtrs_ptrs(src));
dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off);
src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off);
bytes = WDS(n);
@@ -623,7 +627,7 @@ stg_casSmallArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
gcptr h;
W_ p, len;
- ASSERT_IN_BOUNDS(ind, StgSmallMutArrPtrs_ptrs(arr));
+ ASSERT_IN_BOUNDS("casSmallArray#", ind, StgSmallMutArrPtrs_ptrs(arr));
p = arr + SIZEOF_StgSmallMutArrPtrs + WDS(ind);
(h) = prim %cmpxchgW(p, old, new);
=====================================
rts/RtsMessages.c
=====================================
@@ -352,13 +352,32 @@ rtsBadAlignmentBarf(void)
}
void
-rtsOutOfBoundsAccess(void)
+rtsOutOfBoundsAccess(StgInt index, StgWord count, StgWord size, const char *op)
{
- barf("Encountered out of bounds array access.");
+ if (count <= 1) {
+ errorBelch("%s: array access out of bounds:\n"
+ " index %" FMT_Int " is not within [0, %" FMT_Word ").\n"
+ "This is usually caused by incorrect use of unsafe primops "
+ "in user or library code.",
+ op, index, size);
+ } else {
+ errorBelch("%s: array access out of bounds:\n"
+ " range of %" FMT_Word " elements starting at index %" FMT_Int
+ " is not within [0, %" FMT_Word ").\n"
+ "This is usually caused by incorrect use of unsafe primops "
+ "in user or library code.",
+ op, count, index, size);
+ }
+ stg_exit(EXIT_FAILURE);
}
void
-rtsMemcpyRangeOverlap(void)
+rtsMemcpyRangeOverlap(const char *op)
{
- barf("Encountered overlapping source/destination ranges in a memcpy-using op.");
+ errorBelch("%s: overlapping source and destination ranges in a "
+ "memcpy-using operation.\n"
+ "This is usually caused by incorrect use of unsafe primops "
+ "in user or library code.",
+ op);
+ stg_exit(EXIT_FAILURE);
}
=====================================
rts/include/rts/Messages.h
=====================================
@@ -108,5 +108,5 @@ extern RtsMsgFunction rtsSysErrorMsgFn;
/* Used by code generator */
void rtsBadAlignmentBarf(void) STG_NORETURN;
-void rtsOutOfBoundsAccess(void) STG_NORETURN;
-void rtsMemcpyRangeOverlap(void) STG_NORETURN;
+void rtsOutOfBoundsAccess(StgInt index, StgWord count, StgWord size, const char *op) STG_NORETURN;
+void rtsMemcpyRangeOverlap(const char *op) STG_NORETURN;
=====================================
testsuite/tests/codeGen/should_fail/T26964.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+-- Test that -fcheck-prim-bounds reports the failing primop, the offending
+-- index and the array size. The negative index also checks that it is reported
+-- as a signed number (e.g. -1, not a huge unsigned word).
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+ IO $ \s0 ->
+ case newSmallArray# 5# () s0 of
+ (# s1, marr #) -> readSmallArray# marr (-1#) s1
=====================================
testsuite/tests/codeGen/should_fail/T26964.stderr
=====================================
@@ -0,0 +1,3 @@
+readSmallArray#: array access out of bounds:
+ index -1 is not within [0, 5).
+This is usually caused by incorrect use of unsafe primops in user or library code.
=====================================
testsuite/tests/codeGen/should_fail/T26964b.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+-- Test that -fcheck-prim-bounds reports a failing *range* access (count > 1)
+-- with the "range of N elements starting at index" wording. The source range
+-- is in bounds, but the destination range [6, 10) overruns the 8-byte array.
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = IO $ \s0 ->
+ case newByteArray# 8# s0 of
+ (# s1, src #) ->
+ case newByteArray# 8# s1 of
+ (# s2, dst #) ->
+ case copyMutableByteArray# src 0# dst 6# 4# s2 of
+ s3 -> (# s3, () #)
=====================================
testsuite/tests/codeGen/should_fail/T26964b.stderr
=====================================
@@ -0,0 +1,3 @@
+copyMutableByteArray#: array access out of bounds:
+ range of 4 elements starting at index 6 is not within [0, 8).
+This is usually caused by incorrect use of unsafe primops in user or library code.
=====================================
testsuite/tests/codeGen/should_fail/all.T
=====================================
@@ -7,7 +7,7 @@ test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, ['-no-hs-main'])
def check_bounds_test(name):
""" A -fcheck-prim-bounds test that is expected to fail. """
test(name,
- [ignore_stderr, omit_ghci, exit_code(127 if opsys('mingw32') else 134)],
+ [ignore_stderr, omit_ghci, exit_code(1)],
compile_and_run, ['-fcheck-prim-bounds'])
check_bounds_test('CheckBoundsWriteArray') # Check past end
@@ -25,3 +25,17 @@ check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length
check_bounds_test('CheckOverlapCopyByteArray')
check_bounds_test('CheckOverlapCopyAddrToByteArray')
check_bounds_test('T26958')
+
+# Unlike the check_bounds_test cases above, these tests pin down the exact
+# -fcheck-prim-bounds error message. Drop the leading "<prog>: " prefix so the
+# tests don't depend on the binary's name/path (incl. Windows drive letters).
+def strip_prog_prefix(s):
+ return re.sub(r'(?m)^.*?(\w+#: array access)', r'\1', s)
+
+# T26964 checks the single-element message. T26964b checks the range variant.
+test('T26964',
+ [omit_ghci, exit_code(1), normalise_errmsg_fun(strip_prog_prefix)],
+ compile_and_run, ['-fcheck-prim-bounds'])
+test('T26964b',
+ [omit_ghci, exit_code(1), normalise_errmsg_fun(strip_prog_prefix)],
+ compile_and_run, ['-fcheck-prim-bounds'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/654c27a63ca1881cea8d695ce5f568…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/654c27a63ca1881cea8d695ce5f568…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: always keep response files
by David Eichmann (＠DavidEichmann) 03 Jun '26
by David Eichmann (＠DavidEichmann) 03 Jun '26
03 Jun '26
David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC
Commits:
ff6d11f9 by David Eichmann at 2026-06-03T15:03:06+01:00
Hadrian: always keep response files
Now that response files are only used in a small number of cases, it's
resonable to keep all response files by default and simply remove the
-r / --keep-response-files command line options.
The response file paths are nolonger randomized. They are placed in the
build directory next to command output files.This ensures we reuse
file paths when rebuilding rather than leaving stale response files
around.
- - - - -
4 changed files:
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
Changes:
=====================================
hadrian/src/Builder.hs
=====================================
@@ -304,7 +304,7 @@ instance H.Builder Builder where
case builder of
Ar Pack stg -> do
useTempFile <- arSupportsAtFile stg
- if useTempFile then runAr path buildArgs buildInputs buildOptions
+ if useTempFile then runAr output path buildArgs buildInputs buildOptions
else runArWithoutTempFile path buildArgs buildInputs buildOptions
Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions
@@ -343,7 +343,7 @@ instance H.Builder Builder where
Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions
return ()
- Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Haddock BuildPackage -> runHaddock output path buildArgs buildInputs
Ghc _ _ ->
-- Use a response file for ghc invocations to avoid issues with command line
@@ -352,6 +352,7 @@ instance H.Builder Builder where
-- empty arguments (such as the -dep-suffix flag), but that isn't supported
-- yet due to #26560.
withResponseFileIfLongCmd
+ output
(toCmdArgument [path] <> toCmdArgument buildArgs)
buildInputs
(toCmdArgument buildOptions)
@@ -390,11 +391,13 @@ instance H.Builder Builder where
-- | Invoke @haddock@ given a path to it and a list of arguments. On Windows,
-- the input file arguments are passed as a response file.
-runHaddock :: FilePath -- ^ path to @haddock@
+runHaddock :: FilePath -- ^ output file path
+ -> FilePath -- ^ path to @haddock@
-> [String]
-> [FilePath] -- ^ input file paths
-> Action ()
-runHaddock haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+ outputFilePath
(toCmdArgument [haddockPath] <> toCmdArgument flagArgs)
fileInputs
(CmdArgument [])
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -3,8 +3,7 @@ module CommandLine (
lookupBignum,
cmdBignum, cmdProgressInfo, cmdCompleteSetting,
cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
- cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs,
- cmdKeepResponseFiles
+ cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs
) where
import Data.Either
@@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
-import Hadrian.Utilities hiding (buildRoot, keepResponseFiles)
+import Hadrian.Utilities hiding (buildRoot)
import Settings.Parser
import System.Console.GetOpt
import System.Environment
@@ -37,7 +36,6 @@ data CommandLineArgs = CommandLineArgs
, testArgs :: TestArgs
, docsArgs :: DocArgs
, docTargets :: DocTargets
- , keepResponseFiles :: Bool
, prefix :: Maybe FilePath
, changelogVersion :: Maybe String
, completeStg :: Maybe String }
@@ -58,7 +56,6 @@ defaultCommandLineArgs = CommandLineArgs
, testArgs = defaultTestArgs
, docsArgs = defaultDocArgs
, docTargets = Set.fromList [minBound..maxBound]
- , keepResponseFiles = False
, prefix = Nothing
, changelogVersion = Nothing
, completeStg = Nothing }
@@ -141,9 +138,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }
-readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs)
-readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True }
-
readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
readUnitIdHash = Right $ \flags ->
trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $
@@ -302,8 +296,6 @@ optDescrs =
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (ReqArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
- , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles)
- "Keep response files created during the build (for debugging)."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
, Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
@@ -382,7 +374,6 @@ cmdLineArgsMap = do
return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
- $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
$ insertExtra (docsArgs args) -- Accessed by Rules.Documentation
$ insertExtra allSettings -- Accessed by Settings
@@ -424,9 +415,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs
cmdBignum :: Action (Maybe String)
cmdBignum = bignum <$> cmdLineArgs
-cmdKeepResponseFiles :: Action Bool
-cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs
-
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -23,6 +23,7 @@ import Development.Shake
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Utilities
+import System.FilePath ((<.>))
-- | We support packing and unpacking archives with @ar@.
data ArMode = Pack | Unpack deriving (Eq, Generic, Show)
@@ -35,14 +36,16 @@ instance NFData ArMode
-- to be archived is passed via a temporary response file. Passing arguments
-- via a response file is not supported by some versions of @ar@, in which
-- case you should use 'runArWithoutTempFile' instead.
-runAr :: FilePath -- ^ path to @ar@
+runAr :: FilePath -- ^ output file path
+ -> FilePath -- ^ path to @ar@
-> [String] -- ^ other arguments
-> [FilePath] -- ^ input file paths
-> [CmdOption] -- ^ Additional options
-> Action ()
-runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
- writeFile' tmp $ unwords fileArgs
- cmd [arPath] flagArgs ('@' : tmp) buildOptions
+runAr outputFilePath arPath flagArgs fileArgs buildOptions = do
+ let rspFile = outputFilePath <.> "rsp"
+ writeFile' rspFile $ unwords fileArgs
+ cmd [arPath] flagArgs ('@' : rspFile) buildOptions
-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
-- will be called multiple times if the list of files to be archived is too
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -16,7 +16,7 @@ module Hadrian.Utilities (
-- * Paths
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
- KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileIfLongCmd,
+ withResponseFileIfLongCmd,
-- * File system operations
copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -52,7 +52,6 @@ import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.ResponseFile (escapeArgs)
import System.Environment (lookupEnv)
-import System.IO (hClose, openTempFile)
import System.IO.Error (isPermissionError)
import qualified Data.ByteString as BS
@@ -323,59 +322,28 @@ buildRootRules = do
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show)
-
--- | Whether to retain response files after the build action that created them
--- completes. Mainly useful for debugging.
-keepResponseFiles :: Action Bool
-keepResponseFiles = do
- KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
- return keep
-
-- | Run an command with the given arguments. If the command is too long then the
-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@.
--
-- With @--keep-response-files@, the file is left on disk (if used)
withResponseFileIfLongCmd :: (CmdResult c) =>
- CmdArgument -- ^ Command and arguments before the response file arguments.
+ FilePath -- ^ Command output file. The reponse file is placed next to this
+ -> CmdArgument -- ^ Command and arguments before the response file arguments.
-> [String] -- ^ Response file aruguments.
-> CmdArgument -- ^ Command arguments after the response file arguments.
-> Action c
-withResponseFileIfLongCmd argsPre argsResp argsPost = do
+withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do
let cmdLineLengh = sum
[ 1 + length arg -- add one to account for space inbetween arguments
| let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost
, Right arg <- args
]
- if cmdLineLengh >= cmdLineLengthLimit
- then withResponseFile $ \tmp -> do
- writeFile' tmp (escapeArgs argsResp)
- cmd argsPre ['@' : tmp] argsPost
- else cmd argsPre argsResp argsPost
-
--- | Run an action with a response file path.
---
--- With @--keep-response-files@, the file is left on disk.
-withResponseFile :: (FilePath -> Action a) -> Action a
-withResponseFile action = do
- keep <- keepResponseFiles
- let putVerboseResponseFile tmp = do
- verbosity <- getVerbosity
- when (verbosity >= Verbose) $ do
- tmpContent <- liftIO (readFile tmp)
- putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent)
- if keep
- then do
- (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
- liftIO $ hClose h
- putInfo $ "Keeping response file: " ++ tmp
- result <- action tmp
- putVerboseResponseFile tmp
- return result
- else withTempFile $ \tmp -> do
- result <- action tmp
- putVerboseResponseFile tmp
- return result
+ if cmdLineLengh < cmdLineLengthLimit
+ then cmd argsPre argsResp argsPost
+ else do
+ let rspFile = outputFilePath <.> "rsp"
+ writeFile' rspFile (escapeArgs argsResp)
+ cmd argsPre ['@' : rspFile] argsPost
-- | Link a file tracking the link target. Create the target directory if
-- missing.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff6d11f9858c49dd70d4b01eed5e3b5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff6d11f9858c49dd70d4b01eed5e3b5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Make the current `base` buildable with GHC 9.14
by Marge Bot (＠marge-bot) 03 Jun '26
by Marge Bot (＠marge-bot) 03 Jun '26
03 Jun '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
5524ea0e by Wolfgang Jeltsch at 2026-06-03T08:01:26-04:00
Make the current `base` buildable with GHC 9.14
This comprises the following changes:
* Disable some imports into `GHC.Base` for GHC 9.14
* Disable some imports into `Prelude` for GHC 9.14
* Disable separate `ArrowLoop` import for GHC 9.14
* Disable `GHC.Internal.STM` import for GHC 9.14
* Disable `GHC.Internal.Unicode.Version` import for GHC 9.14
* Disable `GHC.Internal.TH.Monad` import for GHC 9.14
* Add alternative `fixIO` import for GHC 9.14
* Add alternative `unsafeCodeCoerce` import for GHC 9.14
* Disable hiding of imported SIMD operations for GHC 9.14
* Disable use of GHC 9.14’s `printToHandleFinalizerExceptionHandler`
* Enable use of `getFileHash` from `ghc-internal` for GHC 9.14
* Make `thenA` available for GHC 9.14
* Make `thenM` available for GHC 9.14
* Disable translation of `IoManagerFlagPoll` for GHC 9.14
* Add `hGetNewlineMode` for GHC 9.14
- - - - -
d3438055 by Enrico Maria De Angelis at 2026-06-03T08:02:17-04:00
Fix #27067 - Clarify haddocks on `minusNaturalMaybe`
- - - - -
8dbd192e by sheaf at 2026-06-03T09:36:27-04:00
Avoid mkTick in Core Prep breaking ANF
As discovered in #27182, mkTick can break ANF. This patch introduces a
variant of mkTick that skips the single optimisation that could break
ANF. This is preferrable over switching to the raw Tick constructor,
as the latter may introduce spurious cost centres in profiling reports.
This is a temporary measure until we more thoroughly refactor how
mkTick works (see #27141).
See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep.
Fixes #27182
- - - - -
bc8fcb44 by Artem Pelenitsyn at 2026-06-03T09:36:37-04:00
clarify comment for getSizeofMutableByteArray#: we get the size in bytes, not "elements"
- - - - -
25 changed files:
- + changelog.d/T27182.md
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- libraries/base/src/Control/Applicative.hs
- libraries/base/src/Control/Arrow.hs
- libraries/base/src/Control/Monad.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/Conc.hs
- libraries/base/src/GHC/Conc/Sync.hs
- libraries/base/src/GHC/Exts.hs
- libraries/base/src/GHC/Fingerprint.hs
- libraries/base/src/GHC/IO/Handle.hs
- libraries/base/src/GHC/RTS/Flags.hs
- libraries/base/src/GHC/Unicode.hs
- libraries/base/src/GHC/Weak.hs
- libraries/base/src/GHC/Weak/Finalize.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/System/Mem/Weak.hs
- libraries/ghc-internal/src/GHC/Internal/Natural.hs
- + testsuite/tests/profiling/should_compile/T27182.hs
- testsuite/tests/profiling/should_compile/all.T
Changes:
=====================================
changelog.d/T27182.md
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+issues: #27182
+mrs: !16003
+synopsis:
+ Fix `getStgArgFromTrivialArg` panic in CoreToStg
+description:
+ Avoid a `getStgArgFromTrivialArg` panic in CoreToStg due to a call to `mkTick`
+ in Core Prep which invalidated ANF.
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2149,7 +2149,7 @@ primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp
primop GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp
MutableByteArray# s -> State# s -> (# State# s, Int# #)
- {Return the number of elements in the array, correctly accounting for
+ {Return the number of bytes in the array, correctly accounting for
the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.
@since 0.5.0.0}
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Core.Utils (
-- * Constructing expressions
mkCast, mkCastMCo, mkPiMCo,
mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
+ mkTickCpe,
bindNonRec, needsCaseBinding, needsCaseBindingL,
mkAltExpr, mkDefaultCase, mkSingleAltCase,
@@ -319,7 +320,18 @@ mkCast expr co
-- * Split profiling ticks into counting/scoping parts so that the two parts
-- can be placed independently into the AST.
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
-mkTick t orig_expr = mkTick' orig_expr
+mkTick = mk_tick False
+
+-- | A version of 'mkTick' that preserves ANF, for use in Core Prep.
+--
+-- See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep.
+mkTickCpe :: CoreTickish -> CoreExpr -> CoreExpr
+mkTickCpe = mk_tick True
+
+-- | Internal function used to define both 'mkTick' and 'mkTickCpe'
+-- without duplication.
+mk_tick :: Bool -> CoreTickish -> CoreExpr -> CoreExpr
+mk_tick preserve_anf t orig_expr = mkTick' orig_expr
where
-- Some ticks (cost-centres) can be split in two, with the
-- non-counting part having laxer placement properties.
@@ -343,7 +355,7 @@ mkTick t orig_expr = mkTick' orig_expr
-- Push SCCs into lambdas.
-- See (PSCC2) in Note [Pushing SCCs inwards].
| can_split
- -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e
+ -> Tick (mkNoScope t) $ Lam x $ mk_tick preserve_anf (mkNoCount t) e
App f arg
-- All ticks float inwards through non-runtime arguments, as per
@@ -353,7 +365,9 @@ mkTick t orig_expr = mkTick' orig_expr
-- Push SCCs into saturated constructor applications.
-- See (PSCC3) in Note [Pushing SCCs inwards].
- | isSaturatedConApp expr
+ | not preserve_anf -- this optimisation breaks ANF;
+ -- see Note [mkTick breaks ANF] in GHC.CoreToStg.Prep
+ , isSaturatedConApp expr
, tickishPlace t == PlaceCostCentre || can_split
-> if tickishPlace t == PlaceCostCentre
then tickHNFArgs t expr
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -801,7 +801,9 @@ cpeBodyF env (Tick tickish expr)
; return (FloatTick tickish `consFloat` floats, body) }
| otherwise
= do { body <- cpeBody env expr
- ; return (emptyFloats, mkTick tickish' body) }
+ ; return (emptyFloats, mkTickCpe tickish' body) }
+ -- Use mkTickCpe and not mkTick, as the latter may break ANF (#27182).
+ -- See (TickANF2) in Note [mkTick breaks ANF].
where
tickish' | Breakpoint ext bid fvs <- tickish
-- See also 'substTickish'
@@ -905,6 +907,28 @@ cpeBodyF env (Case scrut bndr ty alts)
; rhs' <- cpeBody env2 rhs
; return (Alt con bs' rhs') }
+{- Note [mkTick breaks ANF]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+mkTick does not preserve the ANF property as required by Core Prep (see
+Note [CorePrep invariants]), as seen in #27182. Given:
+
+ mkTick scc<foo> (\ (eta :: Char -> Bool) -> BindP (p :: Int) eta)
+
+mkTick will push the SCC into the constructor application, resulting in:
+
+ \ (eta :: Char -> Bool) -> BindP (p :: Int) (scc<oneM> eta)
+
+To avoid this problem (at least until 'mkTick' is more thoroughly reworked to
+avoid this infelicity, see #27141), we define a variant of 'mkTick', called
+'mkTickCpe', which does not push ticks into constructor applications (this is
+the only optimisation done by 'mkTick' that can break ANF).
+
+We prefer using a small variant of 'mkTick' rather than using the 'Tick'
+constructor, as the latter can slightly degrade profiling reports by failing to
+combine ticks (can result in spurious cost centres with 0 entries appearing in
+profiling reports).
+-}
+
-- ---------------------------------------------------------------------------
-- CpeBody: produces a result satisfying CpeBody
-- ---------------------------------------------------------------------------
@@ -1207,7 +1231,7 @@ cpeApp top_env expr
rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of
-- See Note [Ticks and mandatory eta expansion]
_ | not (null rt_ticks), req_depth <= 0
- -> let tick_fun = foldr mkTick fun' rt_ticks
+ -> let tick_fun = foldr mkTickCpe fun' rt_ticks
in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth
AIApp (Type arg_ty)
@@ -2307,7 +2331,7 @@ wrapBinds floats body
mk_bind (UnsafeEqualityCase scrut b con bs) body
= mkSingleAltCase scrut b con bs body
mk_bind (FloatTick tickish) body
- = mkTick tickish body
+ = mkTickCpe tickish body
-- | Put floats at top-level
deFloatTop :: Floats -> [CoreBind]
@@ -2735,7 +2759,7 @@ newVar env ty
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks floats expr
| (floats1, ticks1) <- fold_fun go floats
- = (floats1, foldrOL mkTick expr ticks1)
+ = (floats1, foldrOL mkTickCpe expr ticks1)
where fold_fun f floats =
let (binds, ticks) = foldlOL f (nilOL,nilOL) (fs_binds floats)
in (floats { fs_binds = binds }, ticks)
@@ -2755,8 +2779,8 @@ wrapTicks floats expr
wrap t (Float bind bound info) = Float (wrapBind t bind) bound info
wrap _ f = pprPanic "Unexpected FloatingBind" (ppr f)
- wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
- wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)
+ wrapBind t (NonRec binder rhs) = NonRec binder (mkTickCpe t rhs)
+ wrapBind t (Rec pairs) = Rec (mapSnd (mkTickCpe t) pairs)
------------------------------------------------------------------------------
-- Numeric literals
=====================================
libraries/base/src/Control/Applicative.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -64,8 +65,13 @@ import GHC.Internal.Data.Data (Data)
import GHC.Internal.Base (
Alternative(..), Applicative(..), Functor(..), Monad(..), MonadPlus(..),
- ap, const, liftA, liftA3, liftM, liftM2, thenA, (.), (<**>),
+ ap, const, liftA, liftA3, liftM, liftM2, (.), (<**>),
)
+#if __GLASGOW_HASKELL__ < 1000
+import GHC.Internal.Base (id)
+#else
+import GHC.Internal.Base (thenA)
+#endif
import GHC.Internal.Functor.ZipList (ZipList(..))
import GHC.Internal.Types
import GHC.Generics
@@ -148,3 +154,19 @@ deriving instance (Typeable (a :: Type -> Type -> Type), Typeable b, Typeable c,
optional :: Alternative f => f a -> f (Maybe a)
optional v = Just <$> v <|> pure Nothing
+
+#if __GLASGOW_HASKELL__ < 1000
+
+-- | Sequence two `Applicative` actions, discarding the result of the first one.
+--
+-- Defined as `thenA fa fb = (id <$ fa) <*> fb`.
+--
+-- This can be used to explicitly define `(*>) = thenA`, which is the default
+-- definition.
+--
+-- @since 4.23.0.0
+thenA :: Applicative f => f a -> f b -> f b
+thenA fa fb = (id <$ fa) <*> fb
+{-# INLINEABLE thenA #-}
+
+#endif
=====================================
libraries/base/src/Control/Arrow.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
-- |
@@ -50,4 +51,6 @@ module Control.Arrow
) where
import GHC.Internal.Control.Arrow
+#if __GLASGOW_HASKELL__ >= 1000
import GHC.Internal.Control.Monad.Fix (ArrowLoop(..))
+#endif
=====================================
libraries/base/src/Control/Monad.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
-- |
@@ -63,6 +64,9 @@ module Control.Monad
) where
import GHC.Internal.Control.Monad
+#if __GLASGOW_HASKELL__ < 1000
+import Data.Function (const)
+#endif
{- $naming
@@ -88,3 +92,18 @@ The functions in this module use the following naming conventions:
> mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a
-}
+
+#if __GLASGOW_HASKELL__ < 1000
+
+-- | Sequence two monadic actions, discarding the result of the first one.
+--
+-- Defined as `thenM ma mb = ma >>= const mb`.
+--
+-- This can be used to define `(*>) = thenM`.
+--
+-- @since 4.23.0.0
+thenM :: (Monad m) => m a -> m b -> m b
+thenM ma mb = ma >>= const mb
+{-# INLINEABLE thenM #-}
+
+#endif
=====================================
libraries/base/src/Data/Array/Byte.hs
=====================================
@@ -8,6 +8,7 @@
--
-- Derived from @primitive@ package.
+{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeFamilies #-}
@@ -32,7 +33,9 @@ import GHC.Internal.Show (intToDigit)
import GHC.Internal.ST (ST(..), runST)
import GHC.Internal.Word (Word8(..))
import GHC.Internal.TH.Syntax
-import GHC.Internal.TH.Monad
+#if __GLASGOW_HASKELL__ >= 1000
+import GHC.Internal.TH.Monad (unsafeCodeCoerce)
+#endif
import GHC.Internal.TH.Lift
import GHC.Internal.ForeignPtr
import Prelude
=====================================
libraries/base/src/Data/Fixed.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
@@ -91,7 +92,11 @@ import GHC.Internal.TypeLits (KnownNat, natVal)
import GHC.Internal.Read
import GHC.Internal.Text.ParserCombinators.ReadPrec
import GHC.Internal.Text.Read.Lex
-import qualified GHC.Internal.TH.Monad as TH
+#if __GLASGOW_HASKELL__ < 1000
+import GHC.Internal.TH.Syntax (unsafeCodeCoerce)
+#else
+import GHC.Internal.TH.Monad (unsafeCodeCoerce)
+#endif
import qualified GHC.Internal.TH.Lift as TH
import Data.Typeable
import Prelude
@@ -147,7 +152,7 @@ instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where
-- @since template-haskell-2.19.0.0
-- @since base-4.21.0.0
instance TH.Lift (Fixed a) where
- liftTyped x = TH.unsafeCodeCoerce (TH.lift x)
+ liftTyped x = unsafeCodeCoerce (TH.lift x)
lift (MkFixed x) = [| MkFixed x |]
-- | Types which can be used as a resolution argument to the 'Fixed' type constructor must implement the 'HasResolution' typeclass.
=====================================
libraries/base/src/GHC/Base.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -139,10 +140,12 @@ module GHC.Base
) where
import GHC.Internal.Base hiding ( NonEmpty(..) )
+import GHC.Internal.Data.NonEmpty ( NonEmpty(..) )
+#if __GLASGOW_HASKELL__ >= 1000
import GHC.Internal.Classes
import GHC.Internal.CString
-import GHC.Internal.Data.NonEmpty ( NonEmpty(..) )
import GHC.Internal.Magic.Dict ( WithDict(..) )
+#endif
import GHC.Prim hiding
(
-- Hide dataToTag# ops because they are expected to break for
@@ -273,6 +276,7 @@ import GHC.Prim hiding
, minWord8X16#
, minWord8X32#
, minWord8X64#
+#if __GLASGOW_HASKELL__ >= 1000
-- Don't re-export vector logical primops
, andDoubleX2#
, andDoubleX4#
@@ -389,13 +393,16 @@ import GHC.Prim hiding
, sqrtDoubleX4#
, sqrtFloatX16#
, sqrtDoubleX8#
+#endif
)
import GHC.Prim.Ext
import GHC.Prim.PtrEq
import GHC.Internal.Err
import GHC.Internal.IO (seq#)
+#if __GLASGOW_HASKELL__ >= 1000
import GHC.Internal.Magic
+#endif
import GHC.Internal.Maybe
import GHC.Types hiding (
Unit#,
=====================================
libraries/base/src/GHC/Conc.hs
=====================================
@@ -119,7 +119,9 @@ module GHC.Conc
import GHC.Internal.Conc.IO
import GHC.Internal.Conc.Sync
+#if __GLASGOW_HASKELL__ >= 1000
import GHC.Internal.STM
+#endif
#if !defined(mingw32_HOST_OS)
import GHC.Internal.Conc.Signal
=====================================
libraries/base/src/GHC/Conc/Sync.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -89,4 +90,6 @@ module GHC.Conc.Sync
) where
import GHC.Internal.Conc.Sync
+#if __GLASGOW_HASKELL__ >= 1000
import GHC.Internal.STM
+#endif
=====================================
libraries/base/src/GHC/Exts.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -246,6 +247,7 @@ import GHC.Prim hiding
, minWord8X16#
, minWord8X32#
, minWord8X64#
+#if __GLASGOW_HASKELL__ >= 1000
-- Don't re-export vector logical primops
, andDoubleX2#
, andDoubleX4#
@@ -362,6 +364,7 @@ import GHC.Prim hiding
, sqrtDoubleX4#
, sqrtFloatX16#
, sqrtDoubleX8#
+#endif
)
import GHC.Prim.Ext
=====================================
libraries/base/src/GHC/Fingerprint.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
module GHC.Fingerprint (
@@ -10,6 +11,8 @@ module GHC.Fingerprint (
import GHC.Internal.Fingerprint
+#if __GLASGOW_HASKELL__ >= 1000
+
import Data.Function (($))
import Control.Monad (return, when)
import Data.Bool (not, (&&))
@@ -51,3 +54,5 @@ getFileHash path = withBinaryFile path ReadMode $ \ hdl ->
)
return (if isFinished then Just chunkSize else Nothing)
in fingerprintBufferedStream readChunk
+
+#endif
=====================================
libraries/base/src/GHC/IO/Handle.hs
=====================================
@@ -1,4 +1,10 @@
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ < 1000
+{-# LANGUAGE Trustworthy #-}
+#else
{-# LANGUAGE Safe #-}
+#endif
+{-# LANGUAGE RecordWildCards #-}
-- |
--
@@ -75,3 +81,19 @@ module GHC.IO.Handle
) where
import GHC.Internal.IO.Handle
+
+#if __GLASGOW_HASKELL__ < 1000
+
+import GHC.Internal.Base (($), IO, return)
+import GHC.Internal.IO.Handle.Types (Handle__ (..))
+import GHC.Internal.IO.Handle.Internals (withHandle_)
+
+-- | Return the current 'NewlineMode' for the specified 'Handle'.
+--
+-- @since 4.23.0.0
+hGetNewlineMode :: Handle -> IO NewlineMode
+hGetNewlineMode hdl =
+ withHandle_ "hGetNewlineMode" hdl $ \Handle__{..} ->
+ return NewlineMode{ inputNL = haInputNL, outputNL = haOutputNL }
+
+#endif
=====================================
libraries/base/src/GHC/RTS/Flags.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
@@ -388,11 +389,13 @@ internal_to_base_MiscFlags i@Internal.MiscFlags{..} =
internal_to_base_ioManager :: Internal.IoManagerFlag -> IoManagerFlag
internal_to_base_ioManager Internal.IoManagerFlagAuto = IoManagerFlagAuto
internal_to_base_ioManager Internal.IoManagerFlagSelect = IoManagerFlagSelect
+#if __GLASGOW_HASKELL__ >= 1000
internal_to_base_ioManager Internal.IoManagerFlagPoll = IoManagerFlagAuto
-- This is a lie, we cannot translate poll. We cannot translate
-- accurately because want to freeze the API of the the compat RTS flags
-- here. Using "auto" is the least bad translation.
-- https://github.com/haskell/core-libraries-committee/issues/362
+#endif
internal_to_base_ioManager Internal.IoManagerFlagMIO = IoManagerFlagMIO
internal_to_base_ioManager Internal.IoManagerFlagWinIO = IoManagerFlagWinIO
internal_to_base_ioManager Internal.IoManagerFlagWin32Legacy = IoManagerFlagWin32Legacy
=====================================
libraries/base/src/GHC/Unicode.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -44,4 +45,6 @@ module GHC.Unicode
) where
import GHC.Internal.Unicode
+#if __GLASGOW_HASKELL__ >= 1000
import GHC.Internal.Unicode.Version
+#endif
=====================================
libraries/base/src/GHC/Weak.hs
=====================================
@@ -25,9 +25,8 @@ module GHC.Weak
-- this handler will be ignored.
setFinalizerExceptionHandler,
getFinalizerExceptionHandler,
- printToHandleFinalizerExceptionHandler
+ GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler
) where
import GHC.Internal.Weak
-import GHC.Internal.Weak.Finalize
import GHC.Weak.Finalize
=====================================
libraries/base/src/GHC/Weak/Finalize.hs
=====================================
@@ -7,7 +7,7 @@ module GHC.Weak.Finalize
-- this handler will be ignored.
setFinalizerExceptionHandler
, getFinalizerExceptionHandler
- , printToHandleFinalizerExceptionHandler
+ , GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler
-- * Internal
, GHC.Weak.Finalize.runFinalizerBatch
) where
=====================================
libraries/base/src/Prelude.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ExplicitNamespaces #-}
@@ -176,14 +177,16 @@ import GHC.Internal.Data.Maybe
import GHC.Internal.Data.Traversable ( Traversable(..) )
import GHC.Internal.Data.Tuple
-import GHC.Internal.Base hiding ( foldr, mapM, sequence )
+#if __GLASGOW_HASKELL__ >= 1000
import GHC.Internal.Classes
import GHC.Internal.Err
+import GHC.Internal.Prim (seq)
+import GHC.Internal.Types
+#endif
+import GHC.Internal.Base hiding ( foldr, mapM, sequence )
import Text.Read
import GHC.Internal.Enum
import GHC.Internal.Num
-import GHC.Internal.Prim (seq)
import GHC.Internal.Real
import GHC.Internal.Float
import GHC.Internal.Show
-import GHC.Internal.Types
=====================================
libraries/base/src/System/IO.hs
=====================================
@@ -279,7 +279,11 @@ import GHC.IO.StdHandles
stdout,
stderr
)
+#if __GLASGOW_HASKELL__ < 1000
+import GHC.Internal.System.IO (fixIO)
+#else
import GHC.Internal.Control.Monad.Fix (fixIO)
+#endif
import Control.Monad (return, (>>=))
import Control.Exception (ioError)
import Data.Eq ((==))
=====================================
libraries/base/src/System/Mem/Weak.hs
=====================================
@@ -78,7 +78,7 @@ module System.Mem.Weak (
-- this handler will be ignored.
setFinalizerExceptionHandler,
getFinalizerExceptionHandler,
- printToHandleFinalizerExceptionHandler,
+ GHC.Weak.printToHandleFinalizerExceptionHandler,
-- * A precise semantics
=====================================
libraries/ghc-internal/src/GHC/Internal/Natural.hs
=====================================
@@ -93,7 +93,7 @@ plusNatural = N.naturalAdd
minusNatural :: Natural -> Natural -> Natural
minusNatural = N.naturalSubThrow
--- | 'Natural' subtraction. Returns 'Nothing's for non-positive results.
+-- | 'Natural' subtraction. Returns 'Nothing's for negative results.
--
-- @since base-4.8.0.0
minusNaturalMaybe :: Natural -> Natural -> Maybe Natural
=====================================
testsuite/tests/profiling/should_compile/T27182.hs
=====================================
@@ -0,0 +1,6 @@
+module T27182 ( oneM ) where
+
+data Parser = BindP Int ( Char -> Bool )
+
+oneM :: Int -> ( Char -> Bool ) -> Parser
+oneM p = BindP p
=====================================
testsuite/tests/profiling/should_compile/all.T
=====================================
@@ -22,3 +22,4 @@ test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main',
test('T20938', [test_opts], compile, ['-O -prof'])
test('T26056', [test_opts], compile, ['-O -prof'])
test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], multimod_compile, ['T27121', '-v0 -O -prof -fprof-auto'])
+test('T27182', [test_opts], compile, ['-O -prof -fprof-late'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/280cf7bb2db83d3a260cb42e2309c7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/280cf7bb2db83d3a260cb42e2309c7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Deleted branch wip/jeltsch/base-buildable-with-ghc-9-14
by Wolfgang Jeltsch (＠jeltsch) 03 Jun '26
by Wolfgang Jeltsch (＠jeltsch) 03 Jun '26
03 Jun '26
Wolfgang Jeltsch deleted branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC
--
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: avoid response files when command line is short enough
by David Eichmann (＠DavidEichmann) 03 Jun '26
by David Eichmann (＠DavidEichmann) 03 Jun '26
03 Jun '26
David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC
Commits:
6de63473 by David Eichmann at 2026-06-02T17:34:02+01:00
Hadrian: avoid response files when command line is short enough
This replaces the logic of always using response files on Windows.
With the new condition based on command line lenght, reponse files
can be avoided in many more cases (on windows).
- - - - -
2 changed files:
- hadrian/src/Builder.hs
- hadrian/src/Hadrian/Utilities.hs
Changes:
=====================================
hadrian/src/Builder.hs
=====================================
@@ -351,9 +351,10 @@ instance H.Builder Builder where
-- NB: we can't put the buildArgs in a response file, because some flags require
-- empty arguments (such as the -dep-suffix flag), but that isn't supported
-- yet due to #26560.
- withResponseFileOnWindows
- (\buildInputs' -> cmd [path] buildArgs buildInputs' buildOptions)
+ withResponseFileIfLongCmd
+ (toCmdArgument [path] <> toCmdArgument buildArgs)
buildInputs
+ (toCmdArgument buildOptions)
HsCpp -> captureStdout
@@ -393,9 +394,10 @@ runHaddock :: FilePath -- ^ path to @haddock@
-> [String]
-> [FilePath] -- ^ input file paths
-> Action ()
-runHaddock haddockPath flagArgs fileInputs = withResponseFileOnWindows
- (cmd [haddockPath] flagArgs)
+runHaddock haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
+ (toCmdArgument [haddockPath] <> toCmdArgument flagArgs)
fileInputs
+ (CmdArgument [])
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -1,4 +1,6 @@
+{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
+
module Hadrian.Utilities (
-- * List manipulation
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
@@ -14,7 +16,7 @@ module Hadrian.Utilities (
-- * Paths
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
- KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileOnWindows,
+ KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileIfLongCmd,
-- * File system operations
copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -50,7 +52,6 @@ import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.ResponseFile (escapeArgs)
import System.Environment (lookupEnv)
-import System.Info.Extra (isWindows)
import System.IO (hClose, openTempFile)
import System.IO.Error (isPermissionError)
@@ -61,6 +62,7 @@ import qualified System.Directory.Extra as IO
import qualified System.Info.Extra as IO
import qualified System.IO as IO
import qualified System.FilePath.Posix as Posix
+import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument))
-- | Extract a value from a singleton list, or terminate with an error message
-- if the list does not contain exactly one value.
@@ -330,20 +332,26 @@ keepResponseFiles = do
KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
return keep
--- | Run an action either with command arguments direcly or by, on Windows,
--- placing those arguments into a response file escaped with @GHC.ResponseFile.escapeArgs@.
+-- | Run an command with the given arguments. If the command is too long then the
+-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@.
--
-- With @--keep-response-files@, the file is left on disk (if used)
-withResponseFileOnWindows ::
- ([String] -> Action a) -- ^ Action to perform given arguments (of the form @["\@reponseFilePath"]@ on Windows)
- -> [String] -- ^ Command arguments
- -> Action a
-withResponseFileOnWindows action commandArgs = do
- if isWindows
+withResponseFileIfLongCmd :: (CmdResult c) =>
+ CmdArgument -- ^ Command and arguments before the response file arguments.
+ -> [String] -- ^ Response file aruguments.
+ -> CmdArgument -- ^ Command arguments after the response file arguments.
+ -> Action c
+withResponseFileIfLongCmd argsPre argsResp argsPost = do
+ let cmdLineLengh = sum
+ [ 1 + length arg -- add one to account for space inbetween arguments
+ | let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost
+ , Right arg <- args
+ ]
+ if cmdLineLengh >= cmdLineLengthLimit
then withResponseFile $ \tmp -> do
- writeFile' tmp (escapeArgs commandArgs)
- action ['@' : tmp]
- else action commandArgs
+ writeFile' tmp (escapeArgs argsResp)
+ cmd argsPre ['@' : tmp] argsPost
+ else cmd argsPre argsResp argsPost
-- | Run an action with a response file path.
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6de63473dad06e515a1b56be609442a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6de63473dad06e515a1b56be609442a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0