September 2025 - ghc-commits

[Git][ghc/ghc][master] Don't use build CFLAGS and friends as target settings
by Marge Bot (＠marge-bot) 24 Sep '25

24 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 135242ca by Rodrigo Mesquita at 2025-09-24T17:07:44-04:00 Don't use build CFLAGS and friends as target settings In the GHC in tree configure, `CFLAGS`, `CXXFLAGS`, and similar tool configuration flags apply to the BUILD phase of the compiler, i.e. to the tools run to compile GHC itself. Notably, they should /not/ be carried over to the Target settings, i.e. these flags should /not/ apply to the tool which GHC invokes at runtime. Fixes #25637 - - - - - 3 changed files: - configure.ac - m4/fp_setup_windows_toolchain.m4 - m4/ghc_toolchain.m4 Changes: ===================================== configure.ac ===================================== @@ -43,12 +43,6 @@ dnl interprets build/host/target and how this interacts with $CC tests test -n "$target_alias" && ac_tool_prefix=$target_alias- dnl ---------------------------------------------------------- -dnl ** Store USER specified environment variables to pass them on to -dnl ** ghc-toolchain (in m4/ghc-toolchain.m4) -USER_CFLAGS="$CFLAGS" -USER_LDFLAGS="$LDFLAGS" -USER_LIBS="$LIBS" -USER_CXXFLAGS="$CXXFLAGS" dnl The lower-level/not user-facing environment variables that may still be set dnl by developers such as in ghc-wasm-meta USER_CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2" ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -146,11 +146,11 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[ dnl We override the USER_* flags here since the user delegated dnl configuration to the bundled windows toolchain, and these are the dnl options required by the bundled windows toolchain. - USER_CFLAGS="$CFLAGS" USER_CPP_ARGS="$CONF_CPP_OPTS_STAGE2" - USER_CXXFLAGS="$CXXFLAGS" USER_HS_CPP_ARGS="$HaskellCPPArgs" - USER_LDFLAGS="$CONF_GCC_LINKER_OPTS_STAGE2" + USER_CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2" + USER_CONF_CXX_OPTS_STAGE2="$CONF_CXX_OPTS_STAGE2" + USER_CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2" USER_JS_CPP_ARGS="$JavaScriptCPPArgs" USER_CMM_CPP_ARGS="$CmmCPPArgs" ]) ===================================== m4/ghc_toolchain.m4 ===================================== @@ -8,18 +8,6 @@ AC_DEFUN([ADD_GHC_TOOLCHAIN_ARG], done ]) -dnl $1 argument name -dnl $2 first variable to try -dnl $3 variable to add if the first variable is empty -AC_DEFUN([ADD_GHC_TOOLCHAIN_ARG_CHOOSE], -[ - if test -z "$2"; then - ADD_GHC_TOOLCHAIN_ARG([$1],[$3]) - else - ADD_GHC_TOOLCHAIN_ARG([$1],[$2]) - fi -]) - AC_DEFUN([ENABLE_GHC_TOOLCHAIN_ARG], [ if test "$2" = "YES"; then @@ -123,10 +111,9 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], ENABLE_GHC_TOOLCHAIN_ARG([dwarf-unwind], [$enable_dwarf_unwind]) dnl We store USER_* variants of all user-specified flags to pass them over to ghc-toolchain. - ADD_GHC_TOOLCHAIN_ARG_CHOOSE([cc-opt], [$USER_CONF_CC_OPTS_STAGE2], [$USER_CFLAGS]) - ADD_GHC_TOOLCHAIN_ARG_CHOOSE([cc-link-opt], [$USER_CONF_GCC_LINKER_OPTS_STAGE2], [$USER_LDFLAGS]) - ADD_GHC_TOOLCHAIN_ARG([cc-link-opt], [$USER_LIBS]) - ADD_GHC_TOOLCHAIN_ARG_CHOOSE([cxx-opt], [$USER_CONF_CXX_OPTS_STAGE2], [$USER_CXXFLAGS]) + ADD_GHC_TOOLCHAIN_ARG([cc-opt], [$USER_CONF_CC_OPTS_STAGE2]) + ADD_GHC_TOOLCHAIN_ARG([cc-link-opt], [$USER_CONF_GCC_LINKER_OPTS_STAGE2]) + ADD_GHC_TOOLCHAIN_ARG([cxx-opt], [$USER_CONF_CXX_OPTS_STAGE2]) ADD_GHC_TOOLCHAIN_ARG([cpp-opt], [$USER_CPP_ARGS]) ADD_GHC_TOOLCHAIN_ARG([hs-cpp-opt], [$USER_HS_CPP_ARGS]) ADD_GHC_TOOLCHAIN_ARG([js-cpp-opt], [$USER_JS_CPP_ARGS]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/135242ca53b0404db6fa44f068c113b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/135242ca53b0404db6fa44f068c113b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Allow disabling builtin rules (#20298)
by Marge Bot (＠marge-bot) 24 Sep '25

24 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5ae89054 by Sylvain Henry at 2025-09-24T17:07:00-04:00 Allow disabling builtin rules (#20298) Add a way to disable built-in rules programmatically and with a debug flag. I also took the opportunity to add a debug flag to disable bignum rules, which was only possible programmatically (e.g. in a plugin). - - - - - 14 changed files: - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Rules/Config.hs - compiler/GHC/Driver/Config/Core/Rules.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - docs/users_guide/debugging.rst - + testsuite/tests/codeGen/should_compile/T20298a.hs - + testsuite/tests/codeGen/should_compile/T20298a.stderr - + testsuite/tests/codeGen/should_compile/T20298b.hs - + testsuite/tests/codeGen/should_compile/T20298b.stderr - + testsuite/tests/codeGen/should_compile/T20298c.hs - + testsuite/tests/codeGen/should_compile/T20298c.stderr - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2173,6 +2173,43 @@ builtinRules -- there is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. + + +{- Note [Built-in bignum rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have some built-in rules for operations on bignum types (Integer, Natural, +BigNat). These rules implement the same kind of constant folding as we have for +Int#/Word#/etc. primops. See builtinBignumRules. + +These rules are built-in because they can't be expressed as regular rules for +now. The reason is that due to the let-can-float invariant (see Note [Core +let-can-float invariant] in GHC.Core), GHC is too conservative with some bignum +operations and they don't match rules. For example: + + case integerAdd 1 x of r { _ -> integerAdd 1 r } + +doesn't constant-fold into `integerAdd 2 x` with a regular rule. That's because +GHC never floats in `integerAdd 1 x` to form `integerAdd 1 (integerAdd 1 x)` +because of the let-can-float invariant (it doesn't know if `integerAdd` +terminates). + +In the built-in rule for `integerAdd` we can access the unfolding of `r` and we +can perform the appropriate substitution. + +To support constant-folding, Bignum operations are not allowed to inline. As a +consequence, some codes that would benefit from inlining of bignum operations +don't. An idea to fix this was to only have built-in rules for BigNat# +operations and to allow Integer and Natural operations to inline. However these +operations are often too big to inline and we end up with broken +constant-folding and still no inlining. This issue is tracked in #20361 + +Bignum built-in rules can be disabled independently of other built-in rules by +passing the -dno-bignum-rules flag or programmatically with the `roBignumRules` field of +RuleOpts. + +-} + +-- | Built-in bignum rules (see Note [Built-in bignum rules]) builtinBignumRules :: [CoreRule] builtinBignumRules = [ -- conversions ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -65,6 +65,7 @@ import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) import GHC.Core.Make ( mkCoreLams ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr ) +import GHC.Core.Rules.Config (roBuiltinRules) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) @@ -708,10 +709,8 @@ matchRule :: HasDebugCallStack matchRule opts rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) --- Built-in rules can't be switched off, it seems - = case match_fn opts rule_env fn args of - Nothing -> Nothing - Just expr -> Just expr + | not (roBuiltinRules opts) = Nothing + | otherwise = match_fn opts rule_env fn args matchRule _ rule_env is_active _ args rough_args (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops ===================================== compiler/GHC/Core/Rules/Config.hs ===================================== @@ -14,6 +14,10 @@ data RuleOpts = RuleOpts , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled , roBignumRules :: !Bool - -- ^ Enable rules for bignums + -- ^ Enable built-in bignum rules (requires roBuiltinRules to be True too) + -- + -- See Note [Built-in bignum rules] in GHC.Core.Opt.ConstantFold + , roBuiltinRules :: !Bool + -- ^ Enable or disable all builtin rules (including bignum rules) } ===================================== compiler/GHC/Driver/Config/Core/Rules.hs ===================================== @@ -15,5 +15,6 @@ initRuleOpts dflags = RuleOpts { roPlatform = targetPlatform dflags , roNumConstantFolding = gopt Opt_NumConstantFolding dflags , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags - , roBignumRules = True + , roBignumRules = not (gopt Opt_NoBignumRules dflags) + , roBuiltinRules = not (gopt Opt_NoBuiltinRules dflags) } ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -592,6 +592,8 @@ data GeneralFlag | Opt_NoLlvmMangler -- hidden flag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds + | Opt_NoBuiltinRules + | Opt_NoBignumRules | Opt_DistinctConstructorTables | Opt_InfoTableMap @@ -973,6 +975,8 @@ codeGenFlags = EnumSet.fromList , Opt_ExposeAllUnfoldings , Opt_ExposeOverloadedUnfoldings , Opt_NoTypeableBinds + , Opt_NoBuiltinRules + , Opt_NoBignumRules , Opt_ObjectDeterminism , Opt_Haddock ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1660,6 +1660,10 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag , make_ord_flag defGhcFlag "dno-typeable-binds" (NoArg (setGeneralFlag Opt_NoTypeableBinds)) + , make_ord_flag defGhcFlag "dno-builtin-rules" + (NoArg (setGeneralFlag Opt_NoBuiltinRules)) + , make_ord_flag defGhcFlag "dno-bignum-rules" + (NoArg (setGeneralFlag Opt_NoBignumRules)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) , make_dep_flag defGhcFlag "ddump-json" ===================================== docs/users_guide/debugging.rst ===================================== @@ -1225,6 +1225,18 @@ Other compiler will panic if you try to use Typeable instances of things that you built with this flag. +.. ghc-flag:: -dno-builtin-rules + :shortdesc: Disable all built-in rewrite rules + :type: dynamic + + This disables all the built-in rewrite rules. Mostly useful for debugging. + +.. ghc-flag:: -dno-bignum-rules + :shortdesc: Disable bignum built-in rewrite rules + :type: dynamic + + This disables bignum built-in rewrite rules. Mostly useful for debugging. + .. ghc-flag:: -dtag-inference-checks :shortdesc: Affirm tag inference results are correct at runtime. :type: dynamic ===================================== testsuite/tests/codeGen/should_compile/T20298a.hs ===================================== @@ -0,0 +1,4 @@ +module T20298a where + +foo :: Integer +foo = 10 + 20 ===================================== testsuite/tests/codeGen/should_compile/T20298a.stderr ===================================== @@ -0,0 +1,9 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 3, types: 1, coercions: 0, joins: 0/0} + +foo = IS 30# + + + ===================================== testsuite/tests/codeGen/should_compile/T20298b.hs ===================================== @@ -0,0 +1,4 @@ +module T20298b where + +foo :: Integer +foo = 10 + 20 ===================================== testsuite/tests/codeGen/should_compile/T20298b.stderr ===================================== @@ -0,0 +1,13 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 10, types: 3, coercions: 0, joins: 0/0} + +foo2 = IS 10# + +foo1 = IS 20# + +foo = integerAdd foo2 foo1 + + + ===================================== testsuite/tests/codeGen/should_compile/T20298c.hs ===================================== @@ -0,0 +1,4 @@ +module T20298c where + +foo :: Integer +foo = 10 + 20 ===================================== testsuite/tests/codeGen/should_compile/T20298c.stderr ===================================== @@ -0,0 +1,13 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 11, types: 4, coercions: 0, joins: 0/0} + +foo2 = IS 10# + +foo1 = IS 20# + +foo = + $fNumInteger foo2 foo1 + + + ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -145,3 +145,7 @@ test('T25166', [req_cmm], makefile_test, []) test('T25177', normal, compile, ['-O2 -dno-typeable-binds -ddump-simpl -dsuppress-all -dsuppress-uniques -v0']) test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) + +test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) +test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) +test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ae89054d14c5dfd42ab5bc4fff8e50… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ae89054d14c5dfd42ab5bc4fff8e50… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/wasm-restore-fast-api-calls
by Cheng Shao (＠TerrorJack) 24 Sep '25

24 Sep '25

Cheng Shao pushed new branch wip/wasm-restore-fast-api-calls at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/wasm-restore-fast-api-calls You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/bomb_out] blub
by Andreas Klebinger (＠AndreasK) 24 Sep '25

24 Sep '25

Andreas Klebinger pushed to branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC Commits: b90a137c by Andreas Klebinger at 2025-09-24T20:02:56+02:00 blub - - - - - 1 changed file: - compiler/GHC/Core/Unfold.hs Changes: ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -573,6 +573,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr = size_up sizeZero expr where size_up :: ExprSize -> CoreExpr -> ExprSize + size_up (TooBig) !_ = TooBig + size_up (SizeIs !s _ _) _ + | s > bOMB_OUT_SIZE = TooBig size_up s (Cast e _) = size_up s e size_up s (Tick _ e) = size_up s e size_up s (Type _) = s -- Types cost nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b90a137c0b7b5db8baffcb5546d1354… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b90a137c0b7b5db8baffcb5546d1354… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/obtaining-os-handles] 3 commits: Move the new operations to a new module `System.IO.OS`
by Wolfgang Jeltsch (＠jeltsch) 24 Sep '25

24 Sep '25

Wolfgang Jeltsch pushed to branch wip/jeltsch/obtaining-os-handles at Glasgow Haskell Compiler / GHC Commits: 5dcfb400 by Wolfgang Jeltsch at 2025-09-24T20:58:18+03:00 Move the new operations to a new module `System.IO.OS` - - - - - 40318687 by Wolfgang Jeltsch at 2025-09-24T21:00:40+03:00 Resolve some documentation issues - - - - - 0a1ccf29 by Wolfgang Jeltsch at 2025-09-24T21:03:38+03:00 Make the documentation clearer - - - - - 3 changed files: - libraries/base/base.cabal.in - libraries/base/src/GHC/IO/Handle.hs - + libraries/base/src/System/IO/OS.hs Changes: ===================================== libraries/base/base.cabal.in ===================================== @@ -258,6 +258,7 @@ Library , System.Exit , System.IO , System.IO.Error + , System.IO.OS , System.Mem , System.Mem.StableName , System.Posix.Internals ===================================== libraries/base/src/GHC/IO/Handle.hs ===================================== @@ -1,6 +1,4 @@ {-# LANGUAGE Safe #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -- | -- @@ -16,8 +14,7 @@ -- module GHC.IO.Handle - (-- * Portable operations - Handle, + (Handle, BufferMode(..), mkFileHandle, mkDuplexHandle, @@ -73,337 +70,7 @@ module GHC.IO.Handle hGetBuf, hGetBufNonBlocking, hPutBuf, - hPutBufNonBlocking, - - -- * Obtaining file descriptors and Windows handles - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw - - -- ** Caveats - -- $with-ref-caveats -) where + hPutBufNonBlocking + ) where import GHC.Internal.IO.Handle - -import GHC.Internal.Control.Monad (return) -import GHC.Internal.Control.Concurrent.MVar (MVar) -import GHC.Internal.Control.Exception (mask) -import GHC.Internal.Data.Function (const, (.), ($)) -import GHC.Internal.Data.Functor (fmap) -#if defined(mingw32_HOST_OS) -import GHC.Internal.Data.Bool (otherwise) -#endif -import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) -#if defined(mingw32_HOST_OS) -import GHC.Internal.Data.Maybe (Maybe (Just)) -#endif -import GHC.Internal.Data.List ((++)) -import GHC.Internal.Data.String (String) -import GHC.Internal.Data.Typeable (Typeable, cast) -import GHC.Internal.System.IO (IO) -import GHC.Internal.IO.FD (fdFD) -#if defined(mingw32_HOST_OS) -import GHC.Internal.IO.Windows.Handle - ( - NativeHandle, - ConsoleHandle, - IoHandle, - toHANDLE - ) -#endif -import GHC.Internal.IO.Handle.Types - ( - Handle (FileHandle, DuplexHandle), - Handle__ (Handle__, haDevice) - ) -import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) -import GHC.Internal.IO.Exception - ( - IOErrorType (InappropriateType), - IOException (IOError), - ioException - ) -import GHC.Internal.Foreign.Ptr (Ptr) -import GHC.Internal.Foreign.C.Types (CInt) - --- * Obtaining POSIX file descriptors and Windows handles - -{-| - Obtains an operating-system handle that underlies a Haskell handle and - executes a user-provided action on it. Before the user-provided action is - run, user-defined perparation based on the handle state that contains the - operating-system handle is performed. While the user-provided action is - executed, further operations on the Haskell handle are blocked to a degree - that interference with this action is prevented. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withOSHandle :: String - -- ^ The name of the overall operation - -> (Handle -> MVar Handle__) - {-^ - Obtaining of the handle state variable that holds the - operating-system handle - -} - -> (forall d. Typeable d => d -> IO a) - -- ^ Conversion of a device into an operating-system handle - -> (Handle__ -> IO ()) - -- ^ The preparation - -> Handle - -- ^ The Haskell handle to use - -> (a -> IO r) - -- ^ The action to execute on the operating-system handle - -> IO r -withOSHandle opName handleStateVar getOSHandle prepare handle act - = mask $ \ withOriginalMaskingState -> - withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do - osHandle <- getOSHandle dev - prepare handleState - withOriginalMaskingState $ act osHandle - where - - withHandleState = withHandle_' opName handle (handleStateVar handle) -{- - The 'withHandle_'' operation, which we use here, already performs masking. - Still, we have to employ 'mask', in order do obtain the operation that - restores the original masking state. The user-provided action should be - executed with this original masking state, as there is no inherent reason to - generally perform it with masking in place. The masking that 'withHandle_'' - performs is only for safely accessing handle state and thus constitutes an - implementation detail; it has nothing to do with the user-provided action. --} -{- - The order of actions in 'withOSHandle' is such that any exception from - 'getOSHandle' is thrown before the flushing of the Haskell-managed buffers. --} - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for reading if the handle uses different state - variables for reading and writing. --} -handleStateVarReadingBiased :: Handle -> MVar Handle__ -handleStateVarReadingBiased (FileHandle _ var) = var -handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for writing if the handle uses different state - variables for reading and writing. --} -handleStateVarWritingBiased :: Handle -> MVar Handle__ -handleStateVarWritingBiased (FileHandle _ var) = var -handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar - -{-| - Yields the result of another operation if that operation succeeded, and - otherwise throws an exception that signals that the other operation failed - because some Haskell handle does not use an operating-system handle of a - required type. --} -requiringOSHandleOfType :: String - -- ^ The name of the operating-system handle type - -> Maybe a - {-^ - The result of the other operation if it succeeded - -} - -> IO a -requiringOSHandleOfType osHandleTypeName - = maybe (ioException osHandleOfTypeRequired) return - where - - osHandleOfTypeRequired :: IOException - osHandleOfTypeRequired - = IOError Nothing - InappropriateType - "" - ("handle does not use " ++ osHandleTypeName ++ "s") - Nothing - Nothing - -{-| - Obtains the POSIX file descriptor of a device if the device contains one, - and throws an exception otherwise. --} -getFileDescriptor :: Typeable d => d -> IO CInt -getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . - fmap fdFD . cast - -{-| - Obtains the Windows handle of a device if the device contains one, and - throws an exception otherwise. --} -getWindowsHandle :: Typeable d => d -> IO (Ptr ()) -getWindowsHandle = requiringOSHandleOfType "Windows handle" . - toMaybeWindowsHandle - where - - toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) -#if defined(mingw32_HOST_OS) - toMaybeWindowsHandle dev - | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) - = Just (toHANDLE nativeHandle) - | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) - = Just (toHANDLE consoleHandle) - | otherwise - = Nothing - {- - This is inspired by the implementation of - 'System.Win32.Types.withHandleToHANDLENative'. - -} -#else - toMaybeWindowsHandle _ = Nothing -#endif - -{-| - Obtains the POSIX file descriptor that underlies a handle or specifically - the POSIX file descriptor for reading if the handle uses different file - descriptors for reading and writing and executes a user-provided action on - it. The Haskell-managed buffers related to the file descriptor are flushed - before the user-provided action is run. While this action is executed, - further operations on the handle are blocked to a degree that interference - with this action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" - handleStateVarReadingBiased - getFileDescriptor - flushBuffer - -{-| - Obtains the POSIX file descriptor that underlies a handle or specifically - the POSIX file descriptor for writing if the handle uses different file - descriptors for reading and writing and executes a user-provided action on - it. The Haskell-managed buffers related to the file descriptor are flushed - before the user-provided action is run. While this action is executed, - further operations on the handle are blocked to a degree that interference - with this action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" - handleStateVarWritingBiased - getFileDescriptor - flushBuffer - -{-| - Obtains the Windows handle that underlies a Haskell handle or specifically - the Windows handle for reading if the Haskell handle uses different Windows - handles for reading and writing and executes a user-provided action on it. - The Haskell-managed buffers related to the Windows handle are flushed before - the user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" - handleStateVarReadingBiased - getWindowsHandle - flushBuffer - -{-| - Obtains the Windows handle that underlies a Haskell handle or specifically - the Windows handle for writing if the Haskell handle uses different Windows - handles for reading and writing and executes a user-provided action on it. - The Haskell-managed buffers related to the Windows handle are flushed before - the user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" - handleStateVarWritingBiased - getWindowsHandle - flushBuffer - -{-| - Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiasedRaw - = withOSHandle "withFileDescriptorReadingBiasedRaw" - handleStateVarReadingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiasedRaw - = withOSHandle "withFileDescriptorWritingBiasedRaw" - handleStateVarWritingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiasedRaw - = withOSHandle "withWindowsHandleReadingBiasedRaw" - handleStateVarReadingBiased - getWindowsHandle - (const $ return ()) - -{-| - Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiasedRaw - = withOSHandle "withWindowsHandleWritingBiasedRaw" - handleStateVarWritingBiased - getWindowsHandle - (const $ return ()) - --- ** Caveats - -{-$with-ref-caveats - #with-ref-caveats#There are the following caveats regarding the above - operations: - - * Flushing of buffers can fail if the given handle is readable but not - seekable. - - * If one of these operation is performed as part of an action executed by - 'unsafePerformIO', 'unsafeInterleaveIO', or one of their “dupable” - variants and the user-provided action receives an asychnchronous - exception and does not catch it, then the following happens: - - - Before the overall computation is suspended, the blocking of handle - operations is removed. - - - When the computation is later resumed due to another evaluation - attempt, the blocking of handle operations is reinstantiated, the - Haskell-managed buffers are flushed again, and the user-provided - action is run from the beginning. - - Repeating the previously executed part of the user-provided action - cannot be avoided apparently. See the @[async]@ note in the source code - of "GHC.Internal.IO.Handle.Internals" for further explanation. --} ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -0,0 +1,342 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +{-| + This module bridges between Haskell handles and underlying operating-system + features. +-} +module System.IO.OS +( + -- * Obtaining file descriptors and Windows handles + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased, + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + + -- ** Caveats + -- $with-ref-caveats +) +where + +import GHC.Internal.Control.Monad (return) +import GHC.Internal.Control.Concurrent.MVar (MVar) +import GHC.Internal.Control.Exception (mask) +import GHC.Internal.Data.Function (const, (.), ($)) +import GHC.Internal.Data.Functor (fmap) +#if defined(mingw32_HOST_OS) +import GHC.Internal.Data.Bool (otherwise) +#endif +import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import GHC.Internal.Data.Maybe (Maybe (Just)) +#endif +import GHC.Internal.Data.List ((++)) +import GHC.Internal.Data.String (String) +import GHC.Internal.Data.Typeable (Typeable, cast) +import GHC.Internal.System.IO (IO) +import GHC.Internal.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.Internal.IO.Windows.Handle + ( + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE + ) +#endif +import GHC.Internal.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.Internal.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import GHC.Internal.Foreign.Ptr (Ptr) +import GHC.Internal.Foreign.C.Types (CInt) + +-- * Obtaining POSIX file descriptors and Windows handles + +{-| + Executes a user-provided action on an operating-system handle that underlies + a Haskell handle. Before the user-provided action is run, user-defined + perparation based on the handle state that contains the operating-system + handle is performed. While the user-provided action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withOSHandle :: String + -- ^ The name of the overall operation + -> (Handle -> MVar Handle__) + {-^ + Obtaining of the handle state variable that holds the + operating-system handle + -} + -> (forall d. Typeable d => d -> IO a) + -- ^ Conversion of a device into an operating-system handle + -> (Handle__ -> IO ()) + -- ^ The preparation + -> Handle + -- ^ The Haskell handle to use + -> (a -> IO r) + -- ^ The action to execute on the operating-system handle + -> IO r +withOSHandle opName handleStateVar getOSHandle prepare handle act + = mask $ \ withOriginalMaskingState -> + withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do + osHandle <- getOSHandle dev + prepare handleState + withOriginalMaskingState $ act osHandle + where + + withHandleState = withHandle_' opName handle (handleStateVar handle) +{- + The 'withHandle_'' operation, which we use here, already performs masking. + Still, we have to employ 'mask', in order do obtain the operation that + restores the original masking state. The user-provided action should be + executed with this original masking state, as there is no inherent reason to + generally perform it with masking in place. The masking that 'withHandle_'' + performs is only for safely accessing handle state and thus constitutes an + implementation detail; it has nothing to do with the user-provided action. +-} +{- + The order of actions in 'withOSHandle' is such that any exception from + 'getOSHandle' is thrown before the flushing of the Haskell-managed buffers. +-} + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for reading if the handle uses different state + variables for reading and writing. +-} +handleStateVarReadingBiased :: Handle -> MVar Handle__ +handleStateVarReadingBiased (FileHandle _ var) = var +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for writing if the handle uses different state + variables for reading and writing. +-} +handleStateVarWritingBiased :: Handle -> MVar Handle__ +handleStateVarWritingBiased (FileHandle _ var) = var +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar + +{-| + Yields the result of another operation if that operation succeeded, and + otherwise throws an exception that signals that the other operation failed + because some Haskell handle does not use an operating-system handle of a + required type. +-} +requiringOSHandleOfType :: String + -- ^ The name of the operating-system handle type + -> Maybe a + {-^ + The result of the other operation if it succeeded + -} + -> IO a +requiringOSHandleOfType osHandleTypeName + = maybe (ioException osHandleOfTypeRequired) return + where + + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + InappropriateType + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing + +{-| + Obtains the POSIX file descriptor of a device if the device contains one, + and throws an exception otherwise. +-} +getFileDescriptor :: Typeable d => d -> IO CInt +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast + +{-| + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. +-} +getWindowsHandle :: Typeable d => d -> IO (Ptr ()) +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where + + toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) +#if defined(mingw32_HOST_OS) + toMaybeWindowsHandle dev + | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) + = Just (toHANDLE nativeHandle) + | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) + = Just (toHANDLE consoleHandle) + | otherwise + = Nothing + {- + This is inspired by the implementation of + 'System.Win32.Types.withHandleToHANDLENative'. + -} +#else + toMaybeWindowsHandle _ = Nothing +#endif + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for reading if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" + handleStateVarReadingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for writing if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" + handleStateVarWritingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for reading if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" + handleStateVarReadingBiased + getWindowsHandle + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for writing if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" + handleStateVarWritingBiased + getWindowsHandle + flushBuffer + +{-| + Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiasedRaw + = withOSHandle "withFileDescriptorReadingBiasedRaw" + handleStateVarReadingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiasedRaw + = withOSHandle "withFileDescriptorWritingBiasedRaw" + handleStateVarWritingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiasedRaw + = withOSHandle "withWindowsHandleReadingBiasedRaw" + handleStateVarReadingBiased + getWindowsHandle + (const $ return ()) + +{-| + Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiasedRaw + = withOSHandle "withWindowsHandleWritingBiasedRaw" + handleStateVarWritingBiased + getWindowsHandle + (const $ return ()) + +-- ** Caveats + +{-$with-ref-caveats + #with-ref-caveats#There are the following caveats regarding the above + operations: + + * Flushing of buffers can fail if the given handle is readable but not + seekable. + + * If one of these operations is performed as part of an action executed by + 'System.IO.Unsafe.unsafePerformIO', + 'System.IO.Unsafe.unsafeInterleaveIO', or one of their “dupable” + variants and the user-provided action receives an asychnchronous + exception and does not catch it, then the following happens: + + - Before the overall computation is suspended, the blocking of handle + operations is removed. + + - When the computation is later resumed due to another evaluation + attempt, the blocking of handle operations is reinstantiated, the + Haskell-managed buffers are flushed again, and the user-provided + action is run from the beginning. + + Repeating the previously executed part of the user-provided action + cannot be avoided apparently. See the @[async]@ note in the source code + of "GHC.Internal.IO.Handle.Internals" for further explanation. +-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f9dbc836f4cd02906321aa59268fb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f9dbc836f4cd02906321aa59268fb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/bomb_out] exprSize: Accumulate size as we go to allow early bomb out.
by Andreas Klebinger (＠AndreasK) 24 Sep '25

24 Sep '25

Andreas Klebinger pushed to branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC Commits: 76d7a6ad by Andreas Klebinger at 2025-09-24T19:54:36+02:00 exprSize: Accumulate size as we go to allow early bomb out. - - - - - 2 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Unfold.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2,7 +2,9 @@ {-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -fmax-worker-args=12 #-} +{-# OPTIONS_GHC -fmax-worker-args=12 -fprof-late #-} + +{-# OPTIONS_GHC -dumpdir dumps -ddump-to-file -ddump-simpl #-} -- The -fmax-worker-args=12 is there because the main functions -- are strict in the OccEnv, and it turned out that with the default settting -- some functions would unbox the OccEnv ad some would not, depending on how ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dumpdir dumps #-} + {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1994-1998 @@ -335,6 +337,7 @@ isValFun (Lam b e) | isRuntimeVar b = True | otherwise = isValFun e isValFun _ = False +{-# NOINLINE calcUnfoldingGuidance #-} calcUnfoldingGuidance :: UnfoldingOpts -> Bool -- Definitely a top-level, bottoming binding @@ -567,43 +570,43 @@ sizeExpr :: UnfoldingOpts -- Forcing bOMB_OUT_SIZE early prevents repeated -- unboxing of the Int argument. sizeExpr opts !bOMB_OUT_SIZE top_args expr - = size_up expr + = size_up sizeZero expr where - size_up (Cast e _) = size_up e - size_up (Tick _ e) = size_up e - size_up (Type _) = sizeZero -- Types cost nothing - size_up (Coercion _) = sizeZero - size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isZeroBitId f = sizeZero - -- Make sure we get constructor discounts even - -- on nullary constructors - | otherwise = size_up_call f [] 0 - - size_up (App fun arg) - | isTyCoArg arg = size_up fun - | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0) - - size_up (Lam b e) - | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) - | otherwise = size_up e - - size_up (Let (NonRec binder rhs) body) - = size_up_rhs (binder, rhs) `addSizeNSD` - size_up body `addSizeN` - size_up_alloc binder - - size_up (Let (Rec pairs) body) - = foldr (addSizeNSD . size_up_rhs) - (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) - pairs - - size_up (Case e _ _ alts) = case nonEmpty alts of - Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee + size_up :: ExprSize -> CoreExpr -> ExprSize + size_up s (Cast e _) = size_up s e + size_up s (Tick _ e) = size_up s e + size_up s (Type _) = s -- Types cost nothing + size_up s (Coercion _) = s + size_up s (Lit lit) = addSizeNSD (sizeN (litSize lit)) s + size_up s (Var f) | isZeroBitId f = s + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call s f [] 0 + + size_up s (App fun arg) + | isTyCoArg arg = size_up s fun + | otherwise = size_up_app (stripDiscounts $ size_up s arg) + fun [arg] (if isZeroBitExpr arg then 1 else 0) + + size_up s (Lam b e) + | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (addSizeN s 10) e) + | otherwise = size_up s e + + size_up s (Let (NonRec binder rhs) body) + = let rhs_s = size_up_rhs s (binder, rhs) + in size_up (stripDiscounts $ rhs_s `addSizeN` size_up_alloc binder) body + + + size_up s (Let (Rec pairs) body) + = size_up (stripDiscounts (foldr (flip size_up_rhs) s pairs)) + body + + size_up s (Case e _ _ alts) = case nonEmpty alts of + Nothing -> size_up s e -- case e of {} never returns, so take size of scrutinee Just alts | Just v <- is_top_arg e -> -- We are scrutinising an argument variable let - alt_sizes = NE.map size_up_alt alts + alt_sizes = NE.map (size_up_alt s) alts -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable @@ -625,18 +628,19 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr alts_size tot_size _ = tot_size in - alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty - (foldr1 maxSize alt_sizes) + s `addSizeNSD` alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself - | otherwise -> size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts + | otherwise -> let case_s = size_up s e `addSizeNSD` case_size + in foldr (addAltSize . size_up_alt case_s) case_s alts where is_top_arg (Var v) | v `elem` top_args = Just v is_top_arg (Cast e _) = is_top_arg e + is_top_arg (Tick _t e) = is_top_arg e is_top_arg _ = Nothing where @@ -675,44 +679,52 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr | otherwise = False - size_up_rhs (bndr, rhs) + size_up_rhs :: ExprSize -> (Id, CoreExpr) -> ExprSize + size_up_rhs s (bndr, rhs) | JoinPoint join_arity <- idJoinPointHood bndr -- Skip arguments to join point , (_bndrs, body) <- collectNBinders join_arity rhs - = size_up body + = size_up s body | otherwise - = size_up rhs + = size_up s rhs ------------ -- size_up_app is used when there's ONE OR MORE value args - size_up_app (App fun arg) args voids - | isTyCoArg arg = size_up_app fun args voids - | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1) - | otherwise = size_up arg `addSizeNSD` - size_up_app fun (arg:args) voids - size_up_app (Var fun) args voids = size_up_call fun args voids - size_up_app (Tick _ expr) args voids = size_up_app expr args voids - size_up_app (Cast expr _) args voids = size_up_app expr args voids - size_up_app other args voids = size_up other `addSizeN` - callSize (length args) voids + size_up_app :: ExprSize -> CoreExpr -> [CoreExpr] -> Int -> ExprSize + size_up_app s (App fun arg) args voids + | isTyCoArg arg = size_up_app s fun args voids + | isZeroBitExpr arg = size_up_app s fun (arg:args) (voids + 1) + | otherwise = let arg_size = stripDiscounts $ size_up s arg + in size_up_app arg_size fun (arg:args) voids + size_up_app s (Var fun) args voids = size_up_call s fun args voids + size_up_app s (Tick _ expr) args voids = size_up_app s expr args voids + size_up_app s (Cast expr _) args voids = size_up_app s expr args voids + size_up_app s other args voids = size_up (s `addSizeN` callSize (length args) voids) other + -- if the lhs is not an App or a Var, or an invisible thing like a -- Tick or Cast, then we should charge for a complete call plus the -- size of the lhs itself. ------------ - size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize - size_up_call fun val_args voids - = case idDetails fun of - FCallId _ -> sizeN (callSize (length val_args) voids) - DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op _ -> primOpSize op (length val_args) - ClassOpId cls _ -> classOpSize opts cls top_args val_args - _ | fun `hasKey` buildIdKey -> buildSize - | fun `hasKey` augmentIdKey -> augmentSize - | otherwise -> funSize opts top_args fun (length val_args) voids + size_up_call :: ExprSize -> Id -> [CoreExpr] -> Int -> ExprSize + size_up_call s fun val_args voids + = let call_size = case idDetails fun of + FCallId _ -> sizeN (callSize (length val_args) voids) + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op _ -> primOpSize op (length val_args) + ClassOpId cls _ -> classOpSize opts cls top_args val_args + _ | fun `hasKey` buildIdKey -> buildSize + | fun `hasKey` augmentIdKey -> augmentSize + | otherwise -> funSize opts top_args fun (length val_args) voids + in s `addSizeNSD` call_size ------------ - size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 + -- size_up_alt returns on the alternatives size, not including the accumulated size passed in unless we reach TooBig + size_up_alt TooBig _ = TooBig + size_up_alt (SizeIs {_es_size_is=s}) (Alt _con _bndrs rhs) = + size_up (sizeN $ s + 10) rhs + `addSizeN` (-s) -- Why add and then subtract s? If the expression is already large we will bomb out early this way. + -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- @@ -753,6 +765,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr (xs `unionBags` ys) d2 -- Ignore d1 + stripDiscounts TooBig = TooBig + stripDiscounts (SizeIs n xs _) = (SizeIs n xs 0) + -- don't count expressions such as State# RealWorld -- exclude join points, because they can be rep-polymorphic -- and typePrimRep will crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76d7a6adeee40491157a2f90aa70c11… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76d7a6adeee40491157a2f90aa70c11… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/bomb_out
by Andreas Klebinger (＠AndreasK) 24 Sep '25

24 Sep '25

Andreas Klebinger pushed new branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/bomb_out 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: User's guide: clarify optimisation of INLINABLE unfoldings
by Marge Bot (＠marge-bot) 24 Sep '25

24 Sep '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a7f15858 by sheaf at 2025-09-24T09:49:53-04:00 User's guide: clarify optimisation of INLINABLE unfoldings This updates the user's guide section on INLINABLE pragmas to explain how the unfoldings of inlineable functions are optimised. The user's guide incorrectly stated that the RHS was not optimised at all, but this is not true. Instead, GHC is careful about phase control to optmise the RHS while retaining the guarantee that GHC behaves as if the original RHS had been written. - - - - - 495886d9 by Rodrigo Mesquita at 2025-09-24T09:50:35-04:00 cleanup: Delete historical artifact of COMPILING_WINDOWS_DLL Namely, drop the obsolete - DLL_IMPORT_RTS - DLL_IMPORT_DATA_VAR - DLL_IMPORT_DATA_VARNAME - DLL_IMPORT_DATA_REF These macros were not doing anything and placed inconsistently Looking at the git logs reveal these macros were used to support dynamic libraries on Win32, a feature that was dropped in b8cfa8f741729ef123569fb321c4b2ab4a1a941c This allows us to get rid of the rts/DLL.h file too. - - - - - 23fa7357 by Sylvain Henry at 2025-09-24T12:26:27-04:00 Allow disabling builtin rules (#20298) Add a way to disable built-in rules programmatically and with a debug flag. I also took the opportunity to add a debug flag to disable bignum rules, which was only possible programmatically (e.g. in a plugin). - - - - - 807f5c86 by Rodrigo Mesquita at 2025-09-24T12:26:28-04:00 Don't use build CFLAGS and friends as target settings In the GHC in tree configure, `CFLAGS`, `CXXFLAGS`, and similar tool configuration flags apply to the BUILD phase of the compiler, i.e. to the tools run to compile GHC itself. Notably, they should /not/ be carried over to the Target settings, i.e. these flags should /not/ apply to the tool which GHC invokes at runtime. Fixes #25637 - - - - - 31 changed files: - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Rules/Config.hs - compiler/GHC/Driver/Config/Core/Rules.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - configure.ac - docs/users_guide/debugging.rst - docs/users_guide/exts/pragmas.rst - m4/fp_setup_windows_toolchain.m4 - m4/ghc_toolchain.m4 - rts/CloneStack.h - rts/Prelude.h - rts/RtsSymbols.c - rts/include/Rts.h - rts/include/RtsAPI.h - rts/include/Stg.h - rts/include/rts/Flags.h - rts/include/rts/NonMoving.h - rts/include/rts/StableName.h - rts/include/rts/StablePtr.h - − rts/include/stg/DLL.h - rts/include/stg/MiscClosures.h - rts/rts.cabal - + testsuite/tests/codeGen/should_compile/T20298a.hs - + testsuite/tests/codeGen/should_compile/T20298a.stderr - + testsuite/tests/codeGen/should_compile/T20298b.hs - + testsuite/tests/codeGen/should_compile/T20298b.stderr - + testsuite/tests/codeGen/should_compile/T20298c.hs - + testsuite/tests/codeGen/should_compile/T20298c.stderr - testsuite/tests/codeGen/should_compile/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/73cefd08cbdc2975b5bf08a104546c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/73cefd08cbdc2975b5bf08a104546c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/romes/17157
by Rodrigo Mesquita (＠alt-romes) 24 Sep '25

24 Sep '25

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

1 0

[Git][ghc/ghc][wip/T26415] Fix tabs in string gaps (#26415)
by Brandon Chinn (＠brandonchinn178) 24 Sep '25

24 Sep '25

Brandon Chinn pushed to branch wip/T26415 at Glasgow Haskell Compiler / GHC Commits: 2c046e35 by Brandon Chinn at 2025-09-24T09:07:43-07:00 Fix tabs in string gaps (#26415) Tabs in string gaps were broken in bb030d0d because previously, string gaps were manually parsed, but now it's lexed by the usual Alex grammar and post-processed after successful lexing. It broke because of a discrepancy between GHC's lexer grammar and the Haskell Report. The Haskell Report includes tabs in whitechar: whitechar → newline | vertab | space | tab | uniWhite $whitechar used to include tabs until 18 years ago, when it was removed in order to exclude tabs from $white_no_nl in order to warn on tabs: 6e202120. In this MR, I'm adding \t back into $whitechar, and explicitly excluding \t from the $white_no_nl+ rule ignoring all whitespace in source code, which more accurately colocates the "ignore all whitespace except tabs, which is handled in the next line" logic. As a side effect of this MR, tabs are now allowed in pragmas; currently, a pragma written as {-# \t LANGUAGE ... #-} is interpreted as the tab character being the pragma name, and GHC warns "Unrecognized pragma". With this change, tabs are ignored as whitespace, which more closely matches the Report anyway. - - - - - 5 changed files: - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/Lexer/String.x - + testsuite/tests/parser/should_run/T26415.hs - + testsuite/tests/parser/should_run/T26415.stdout - testsuite/tests/parser/should_run/all.T Changes: ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -145,7 +145,7 @@ import GHC.Parser.String $unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $nl = [\n\r\f] $space = [\ $unispace] -$whitechar = [$nl \v $space] +$whitechar = [$nl \t \v $space] $white_no_nl = $whitechar # \n -- TODO #8424 $tab = \t @@ -248,7 +248,7 @@ haskell :- -- Alex "Rules" -- everywhere: skip whitespace -$white_no_nl+ ; +($white_no_nl # \t)+ ; $tab { warnTab } -- Everywhere: deal with nested comments. We explicitly rule out ===================================== compiler/GHC/Parser/Lexer/String.x ===================================== @@ -25,7 +25,7 @@ import GHC.Utils.Panic (panic) $unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $nl = [\n\r\f] $space = [\ $unispace] -$whitechar = [$nl \v $space] +$whitechar = [$nl \t \v $space] $tab = \t $ascdigit = 0-9 ===================================== testsuite/tests/parser/should_run/T26415.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE MultilineStrings #-} + +main :: IO () +main = do + -- The below strings contain the characters ['\\', '\t', '\\'] + print "\ \" + print """\ \""" ===================================== testsuite/tests/parser/should_run/T26415.stdout ===================================== @@ -0,0 +1,2 @@ +"" +"" ===================================== testsuite/tests/parser/should_run/all.T ===================================== @@ -27,6 +27,7 @@ test('RecordDotSyntax4', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compil test('RecordDotSyntax5', normal, compile_and_run, ['']) test('ListTuplePunsConstraints', extra_files(['ListTuplePunsConstraints.hs']), ghci_script, ['ListTuplePunsConstraints.script']) test('T25937', normal, compile_and_run, ['']) +test('T26415', normal, compile_and_run, ['']) # Multiline strings test('MultilineStrings', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c046e35c3ae5b135ee32a1e3df5759… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c046e35c3ae5b135ee32a1e3df5759… You're receiving this email because of your account on gitlab.haskell.org.

1 0