- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: always keep response files
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

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

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

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

[Git][ghc/ghc][master] Fix #27067 - Clarify haddocks on `minusNaturalMaybe`
by Marge Bot (＠marge-bot) 03 Jun '26

03 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d3438055 by Enrico Maria De Angelis at 2026-06-03T08:02:17-04:00 Fix #27067 - Clarify haddocks on `minusNaturalMaybe` - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Natural.hs Changes: ===================================== 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d34380557828151abe8e1826e526d48… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d34380557828151abe8e1826e526d48… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Make the current `base` buildable with GHC 9.14
by Marge Bot (＠marge-bot) 03 Jun '26

03 Jun '26

Marge Bot pushed to branch master 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 - - - - - 18 changed files: - 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 Changes: ===================================== 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5524ea0e434b1eb38395256b8e0076b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5524ea0e434b1eb38395256b8e0076b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] fix typo : compete with performance, not complete
by Marge Bot (＠marge-bot) 03 Jun '26

03 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f2f5c6ba by Nikita Efremov at 2026-06-02T16:04:54+00:00 fix typo : compete with performance, not complete - - - - - 1 changed file: - docs/users_guide/javascript.rst Changes: ===================================== docs/users_guide/javascript.rst ===================================== @@ -430,7 +430,7 @@ format. In other cases, C functions are used for performance. For these cases, pure-Haskell implementations are the preferred first step for compatibility with the JavaScript backend since it would be more future-proof against changes to the RTS data format. -Depending on the use case, compiler-optimised JS code might be hard to complete with +Depending on the use case, compiler-optimised JS code might be hard to compete with using hand-written JavaScript. Generally, the most likely performance gains from hand-written JavaScript come from functions with data that stays as JavaScript primitive types for a long time, especially strings. For this, ``JSVal`` allows View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2f5c6bacc820fa14296ce1d0b35dd5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2f5c6bacc820fa14296ce1d0b35dd5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27322
by Simon Jakobi (＠sjakobi2) 03 Jun '26

03 Jun '26

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

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T26964
by Simon Jakobi (＠sjakobi2) 03 Jun '26

03 Jun '26

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

1 0

[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_3] WIP
by David Eichmann (＠DavidEichmann) 03 Jun '26

03 Jun '26

David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_3 at Glasgow Haskell Compiler / GHC Commits: 66396313 by David Eichmann at 2026-06-03T11:39:45+01:00 WIP - - - - - 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,8 @@ 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)) +import Extra (isWindows) -- | Extract a value from a singleton list, or terminate with an error message -- if the list does not contain exactly one value. @@ -330,20 +333,21 @@ 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 +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 if isWindows 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/66396313d4b7462c2ba484d7d3e52ae… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66396313d4b7462c2ba484d7d3e52ae… You're receiving this email because of your account on gitlab.haskell.org.

1 0