- ghc-commits - Haskell.org

[Git][ghc/ghc] Deleted branch wip/juhp-disable-hadrian-selftest
by Jens Petersen (＠juhp) 02 May '26

02 May '26

Jens Petersen deleted branch wip/juhp-disable-hadrian-selftest at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch juhp-ghc-9.12-genSym-backports
by Jens Petersen (＠juhp) 02 May '26

02 May '26

Jens Petersen deleted branch juhp-ghc-9.12-genSym-backports at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26989] Wibbles
by Simon Peyton Jones (＠simonpj) 02 May '26

02 May '26

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 3925e6fb by Simon Peyton Jones at 2026-05-02T13:15:55+01:00 Wibbles - - - - - 4 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Data/List/SetOps.hs - compiler/GHC/Types/Id/Make.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2052,7 +2052,7 @@ Note [Avoiding simplifying repeatedly] One way in which we can get exponential behaviour is if we simplify a big expression, and then re-simplify it -- and then this happens in a deeply-nested way. So we must be jolly careful about re-simplifying -an expression (#26989). +an expression (#26989). Example: f BIG, where f has a RULE @@ -2359,7 +2359,8 @@ simplInId env var cont , isLazyDataConRep dc -- See Note [Fast path for lazy data constructors] = rebuild env (Var var) cont | otherwise - = case substId env var of + = assertPpr (not (isCoVar var)) (ppr var) $ + case substId env var of ContEx se e mco -> do { cont' <- pushCastMCo env mco cont ; simplExprF (se `setInScopeFromE` env) e cont' } ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -326,8 +326,7 @@ simple_opt_expr env expr = go expr (env', b') = subst_opt_bndr env b ---------------------- - go_co co = pprTrace "add_cast" (ppr (optCoercionEnabled $ so_co_opts (soe_opts env)) $$ ppr co) $ - optCoercion (so_co_opts (soe_opts env)) subst co + go_co co = optCoercion (so_co_opts (soe_opts env)) subst co ---------------------- go_alt env (Alt con bndrs rhs) ===================================== compiler/GHC/Data/List/SetOps.hs ===================================== @@ -40,7 +40,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Ord (comparing) import qualified Data.Set as S -getNth :: Outputable a => [a] -> Int -> a +getNth :: (HasDebugCallStack, Outputable a) => [a] -> Int -> a getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $ xs !! n ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -564,7 +564,7 @@ dictSelRule :: Name -> Arity -> Int -> CoreRule -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance -dictSelRule name val_index n_ty_args +dictSelRule name n_ty_args val_index = rule where rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` @@ -579,14 +579,25 @@ dictSelRule name val_index n_ty_args | (dict_arg : _) <- drop n_ty_args args , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe in_scope_env dict_arg , let meth_e = getNth con_args val_index - meth_id = mkTemplateLocal 1 (exprType meth_e) = Just (RM { rm_floats = floats - , rm_rhs = Lam meth_id (Var meth_id) - , rm_args = [meth_e] - , rm_rule = rule }) + , rm_rhs = mkIdLam (exprType meth_e) + , rm_args = [meth_e] + , rm_rule = rule }) | otherwise = Nothing + +mkIdLam :: Type -> CoreExpr +-- Make an identity lambda (\(x::ty).x), already occ-analysed +mkIdLam ty + = Lam x (varToCoreExpr x) + where + x = mkTemplateLocal 1 ty + `setIdOccInfo` OneOcc { occ_in_lam = NotInsideLam + , occ_n_br = 1 + , occ_int_cxt = NotInteresting + , occ_tail = NoTailCallInfo } + {- ************************************************************************ * * View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3925e6fb140ca7c3a22c8746b025ea3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3925e6fb140ca7c3a22c8746b025ea3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T27022] iserv: recover/getQ/putQ should behave same as internal interpreter
by Teo Camarasu (＠teo) 02 May '26

02 May '26

Teo Camarasu pushed to branch wip/T27022 at Glasgow Haskell Compiler / GHC Commits: ab0e7b30 by Teo Camarasu at 2026-05-02T12:24:44+01:00 iserv: recover/getQ/putQ should behave same as internal interpreter The internal and external interpreter should behave the same when handling `recover`, the exeception recovery method of Q. In practice, they diverge. In case of failure, the internal interpreter only restores error message state to before the computation, wheras the external interperter restores error message state *and* the state of putQ/getQ. As far as I can tell this is a simple mistake in the implementation. Note [TH recover with -fexternal-interpreter] describes the correct behaviour but the implementation doesn't mirror this. This change restores the correct behaviour by keeping the effects of putQ in the erroring computation. This is a breaking change since it modifies the behaviour of programs that rely on recover ignoring putQ from failling computations when used with the external interpreter. Although I highly doubt anyone relies on this behaviour. This divergence was first introduced in d00c308633fe7d216d31a1087e00e63532d87d6d. As far as I can tell this was unintentional and tha commit was trying to solve a different bug. Resolves #27022 - - - - - 4 changed files: - + changelog.d/T27022 - libraries/ghci/GHCi/TH.hs - + testsuite/tests/th/T27022.hs - testsuite/tests/th/all.T Changes: ===================================== changelog.d/T27022 ===================================== @@ -0,0 +1,11 @@ +section: compiler +synopsis: Fix a divergence in the interaction between ``recover`` and ``putQ`` between the internal and external interpreter +description: The ``recover`` method in TemplateHaskell now behaves the same + with the internal and external interpreter. + In the past, when an error was encountered in a computation in a ``recover`` block, + the external interpreter would discard any state changes from ``putQ``, + whereas the internal interpreter would not. + This was a long-standing error in the implementation of the external interpreter. + Both now keep state changes from ``putQ`` in ``recover`` blocks. +mr: !15994 +issues: #27022 ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -175,9 +175,7 @@ instance TH.Quasi GHCiQ where e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef remoteTHCall (qsPipe s) (EndRecover (isLeft e)) case e of - Left GHCiQException{} -> - -- in case of error, restore the state to the start of the `recover` block. - newIORef s >>= h + Left GHCiQException{} -> h sRef Right r -> return r qLookupName isType occ = ghcCmd (LookupName isType occ) qReify name = ghcCmd (Reify name) ===================================== testsuite/tests/th/T27022.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This tests the behaviour of TH's recover method. +-- It should behave the same in the internal and external interperter. +-- In the past, they have diverged, and the external interpreter would roll back the state of putQ/getQ whereas the internal interpreter would not. +module T27022 where + +import Language.Haskell.TH.Syntax +main = print $(putQ "0" >> recover (pure ()) (putQ "42" >> fail "oops") >> getQ @String >>= lift ) ===================================== testsuite/tests/th/all.T ===================================== @@ -650,3 +650,4 @@ test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-un test('T26099', normal, compile_fail, ['']) test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script']) test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script']) +test('T27022', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab0e7b306f6b009845c8f6a7f05a24f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab0e7b306f6b009845c8f6a7f05a24f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T27022] iserv: recover/getQ/putQ should behave same as internal interpreter
by Teo Camarasu (＠teo) 02 May '26

02 May '26

Teo Camarasu pushed to branch wip/T27022 at Glasgow Haskell Compiler / GHC Commits: 9369b573 by Teo Camarasu at 2026-05-02T12:17:42+01:00 iserv: recover/getQ/putQ should behave same as internal interpreter The internal and external interpreter should behave the same when handling `recover`, the exeception recovery method of Q. In practice, they diverge. In case of failure, the internal interpreter only restores error message state to before the computation, wheras the external interperter restores error message state *and* the state of putQ/getQ. As far as I can tell this is a simple mistake in the implementation. Note [TH recover with -fexternal-interpreter] describes the correct behaviour but the implementation doesn't mirror this. This change restores the correct behaviour by keeping the effects of putQ in the erroring computation. This is a breaking change since it modifies the behaviour of programs that rely on recover ignoring putQ from failling computations when used with the external interpreter. Although I highly doubt anyone relies on this behaviour. Resolves #27022 - - - - - 4 changed files: - + changelog.d/T27022 - libraries/ghci/GHCi/TH.hs - + testsuite/tests/th/T27022.hs - testsuite/tests/th/all.T Changes: ===================================== changelog.d/T27022 ===================================== @@ -0,0 +1,11 @@ +section: compiler +synopsis: Fix a divergence in the interaction between ``recover`` and ``putQ`` between the internal and external interpreter +description: The ``recover`` method in TemplateHaskell now behaves the same + with the internal and external interpreter. + In the past, when an error was encountered in a computation in a ``recover`` block, + the external interpreter would discard any state changes from ``putQ``, + whereas the internal interpreter would not. + This was a long-standing error in the implementation of the external interpreter. + Both now keep state changes from ``putQ`` in ``recover`` blocks. +mr: !15994 +issues: #27022 ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -175,9 +175,7 @@ instance TH.Quasi GHCiQ where e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef remoteTHCall (qsPipe s) (EndRecover (isLeft e)) case e of - Left GHCiQException{} -> - -- in case of error, restore the state to the start of the `recover` block. - newIORef s >>= h + Left GHCiQException{} -> h sRef Right r -> return r qLookupName isType occ = ghcCmd (LookupName isType occ) qReify name = ghcCmd (Reify name) ===================================== testsuite/tests/th/T27022.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This tests the behaviour of TH's recover method. +-- It should behave the same in the internal and external interperter. +-- In the past, they have diverged, and the external interpreter would roll back the state of putQ/getQ whereas the internal interpreter would not. +module T27022 where + +import Language.Haskell.TH.Syntax +main = print $(putQ "0" >> recover (pure ()) (putQ "42" >> fail "oops") >> getQ @String >>= lift ) ===================================== testsuite/tests/th/all.T ===================================== @@ -650,3 +650,4 @@ test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-un test('T26099', normal, compile_fail, ['']) test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script']) test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script']) +test('T27022', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9369b5739826150b0fd067ac8bc1b00… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9369b5739826150b0fd067ac8bc1b00… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T27022
by Teo Camarasu (＠teo) 02 May '26

02 May '26

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

1 0

[Git][ghc/ghc][master] Fix name of Note [Structure of dep_boot_mods]
by Marge Bot (＠marge-bot) 02 May '26

02 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3b75cccd by fendor at 2026-05-02T03:40:14-04:00 Fix name of Note [Structure of dep_boot_mods] - - - - - 2 changed files: - compiler/GHC/Unit/Module/Deps.hs - testsuite/tests/linters/notes.stdout Changes: ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -96,7 +96,7 @@ data Dependencies = Deps , dep_boot_mods_ :: Set (UnitId, ModuleNameWithIsBoot) -- ^ All modules which have boot files below this one, and whether we -- should use the boot file or not. - -- This information is only used to populate the eps_is_boot field. + -- This information is only used to populate the 'eps_is_boot' field. -- See Note [Structure of dep_boot_mods] , dep_orphs_ :: [Module] @@ -605,7 +605,7 @@ hash of the module. The export hash is computed in `GHC.Iface.Recomp.addFingerpr -} {- -Note [Structure of dep_boot_deps] +Note [Structure of dep_boot_mods] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In `-c` mode we always need to know whether to load the normal or boot version of ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -27,7 +27,6 @@ ref compiler/GHC/Tc/Solver/Rewrite.hs:1020:7: Note [Stability of rewritin ref compiler/GHC/Tc/TyCl.hs:1662:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics] ref compiler/GHC/Types/Demand.hs:304:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:97:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:415:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:206:31: Note [fun_id in Match] ref configure.ac:205:10: Note [Linking ghc-bin against threaded stage0 RTS] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b75cccdd3fd27b1d2544f729ed62d0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b75cccdd3fd27b1d2544f729ed62d0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: testsuite: fix flaky foundation Divisible / mulIntMayOflo# tests (#27222)
by Marge Bot (＠marge-bot) 02 May '26

02 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5c4c3bf4 by Sylvain Henry at 2026-05-02T03:39:28-04:00 testsuite: fix flaky foundation Divisible / mulIntMayOflo# tests (#27222) Since the LCG was widened to 64 bits and the seed randomised per CI run (commit 2d30f7d3400 "Vendor mini-QuickCheck for testsuite"), two latent bugs in the foundation test surface stochastically: * The Divisible property `(x `div` y) * y + (x `mod` y) == x` raises ArithException(Overflow) when (a, b) = (minBound, -1) for fixed-width signed Integral types. Split testNumber/testDivisible into Bounded and unbounded variants and skip just that one pair, gated by `(minBound :: a) < 0` so unsigned types lose no coverage. * The `mulIntMayOflo#` test compared raw Int# bit-for-bit, but the primop is only specified to return 0/non-zero -- the exact non-zero indicator legitimately differs between backends and inlining choices. Add a dedicated `testPrimopMayOflo` helper that only compares zero / non-zero. Also fix the long-standing typo "Dividible" -> "Divisible" in identifiers. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - e242ce4f by Sylvain Henry at 2026-05-02T03:39:28-04:00 testsuite: catch and display exceptions in MiniQuickCheck Exceptions raised while evaluating a property are now caught and reported as a normal failure (with arguments and seed), instead of aborting the test. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 2 changed files: - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/numeric/should_run/foundation.hs Changes: ===================================== testsuite/tests/MiniQuickCheck.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | A minimal QuickCheck-like property testing framework for use in the GHC @@ -52,6 +53,8 @@ module MiniQuickCheck ) where -- base +import Control.Exception + ( SomeException, displayException, evaluate, try ) import Control.Monad.IO.Class ( liftIO ) import Data.Bits @@ -181,16 +184,39 @@ nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a nest c = local (\s -> s { depth = depth s + 1, context = c : context s }) runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result -runPropertyCheck (PropertyBinaryOp ok desc s1 s2) = - if ok - then return Success - else do - ctx <- context <$> ask - let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2 - putMsg msg - return (Failure [msg : ctx]) -runPropertyCheck (PropertyAnd a b) = - (<>) <$> runPropertyCheck a <*> runPropertyCheck b +runPropertyCheck pcThunk = do + -- See Note [Catching exceptions in property evaluation]. + pcRes <- liftIO $ try @SomeException (evaluate pcThunk) + case pcRes of + Left e -> reportFailure ("Failure: exception: " ++ displayException e) + Right (PropertyAnd a b) -> + (<>) <$> runPropertyCheck a <*> runPropertyCheck b + Right (PropertyBinaryOp ok desc s1 s2) -> do + okRes <- liftIO $ try @SomeException (evaluate ok) + case okRes of + Right True -> return Success + Right False -> reportFailure ("Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2) + Left e -> reportFailure ("Failure: exception: " ++ displayException e) + +reportFailure :: String -> ReaderT RunS IO Result +reportFailure msg = do + ctx <- context <$> ask + putMsg msg + return (Failure [msg : ctx]) + +-- Note [Catching exceptions in property evaluation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A property like `\a b -> let !r = a `div` 0 in r === b` builds a +-- `PropertyCheck` thunk whose forcing raises an exception -- in this case +-- already at the `PropertyBinaryOp` constructor, before its `ok` field is +-- ever inspected. Other properties may force `ok = (s1 == s2)` instead and +-- raise from there. +-- +-- To handle both, we `evaluate` first the `PropertyCheck` thunk and then +-- the `ok` field, each inside `try`, and report any exception through the +-- normal `reportFailure` path. The surrounding loop then still prints +-- "With arguments ... (Seed: ...)" and the test driver continues with +-- subsequent properties instead of aborting. runProperty :: Iterations -> Property -> ReaderT RunS IO Result runProperty (Iterations iters) (Prop p) = do ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -77,13 +77,42 @@ testMultiplicative _ = Group "Multiplicative" , Property "a * b == Integer(a) * Integer(b)" $ \(a :: a) (b :: a) -> a * b === fromInteger (toInteger a * toInteger b) ] -testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a) +-- | Divisibility test for Bounded Integral types (Int, Int{8,16,32,64}, +-- Word, Word{8,16,32,64}). +testDivisible :: forall a . (Show a, Eq a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a) => Proxy a -> Test -testDividible _ = Group "Divisible" +testDivisible _ = Group "Divisible" + [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) -> + -- See Note [Skipping minBound `div` (-1)]. + if (minBound :: a) < 0 && a == minBound && b == (-1) + then True === True + else a === (a `div` b) * b + (a `mod` b) + ] + +-- | Divisibility test for unbounded Integral types (Integer). No overflow +-- can occur here, so the property holds without exception for all NonZero b. +testDivisibleUnbounded :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a) + => Proxy a -> Test +testDivisibleUnbounded _ = Group "Divisible" [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) -> a === (a `div` b) * b + (a `mod` b) ] +-- Note [Skipping minBound `div` (-1)] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For a fixed-width *signed* Integral type, `minBound `div` (-1)` raises +-- ArithException(Overflow) because `-minBound` is not representable in the +-- type (e.g., for Int8, `-(-128)` would be 128, out of range). The div/mod +-- identity property cannot hold there, so we skip exactly that one pair. +-- +-- We detect "signed Bounded" with `(minBound :: a) < 0`: True for Int{N}, +-- False for Word{N}. This way unsigned Bounded types lose no coverage, +-- and only the genuine overflow sample is skipped for signed types. +-- +-- For the unbounded `Integer`, no overflow can occur and we use a separate +-- 'testDivisibleUnbounded' (without the Bounded constraint or the skip). +-- See #27222. + testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) => Proxy a -> Test testOperatorPrecedence _ = Group "Precedence" @@ -101,14 +130,26 @@ testOperatorPrecedence _ = Group "Precedence" ] -testNumber :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) +testNumber :: (Show a, Eq a, Prelude.Num a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a) => String -> Proxy a -> Test testNumber name proxy = Group name [ testIntegral proxy , testEqOrd proxy , testAdditive proxy , testMultiplicative proxy - , testDividible proxy + , testDivisible proxy + , testOperatorPrecedence proxy + ] + +-- | Variant of 'testNumber' for unbounded Integral types (e.g., Integer). +testNumberUnbounded :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) + => String -> Proxy a -> Test +testNumberUnbounded name proxy = Group name + [ testIntegral proxy + , testEqOrd proxy + , testAdditive proxy + , testMultiplicative proxy + , testDivisibleUnbounded proxy , testOperatorPrecedence proxy ] @@ -119,7 +160,7 @@ testNumberRefs = Group "ALL" , testNumber "Int16" (Proxy :: Proxy Int16) , testNumber "Int32" (Proxy :: Proxy Int32) , testNumber "Int64" (Proxy :: Proxy Int64) - , testNumber "Integer" (Proxy :: Proxy Integer) + , testNumberUnbounded "Integer" (Proxy :: Proxy Integer) , testNumber "Word" (Proxy :: Proxy Word) , testNumber "Word8" (Proxy :: Proxy Word8) , testNumber "Word16" (Proxy :: Proxy Word16) @@ -399,7 +440,7 @@ testPrimops = Group "primop" , testPrimop "-#" (Primop.-#) (Wrapper.-#) , testPrimop "*#" (Primop.*#) (Wrapper.*#) , testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2# - , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo# + , testPrimopMayOflo "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo# , testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt# , testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt# , testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt# @@ -497,6 +538,31 @@ instance TestPrimop (Int# -> Int# -> Int#) where testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift)) +-- | Compare two 'mulIntMayOflo#'-like primops only on whether their result +-- is zero. See Note [Comparing mulIntMayOflo# results]. +testPrimopMayOflo :: String + -> (Int# -> Int# -> Int#) + -> (Int# -> Int# -> Int#) + -> Test +testPrimopMayOflo s l r = + Property s $ \ (uInt# -> x0) (uInt# -> x1) -> + (wInt# (l x0 x1) == 0) === (wInt# (r x0 x1) == 0) + +-- Note [Comparing mulIntMayOflo# results] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The 'mulIntMayOflo#' primop is only specified to return 0 if the signed +-- multiplication does not overflow, and a non-zero value if it /may/ +-- overflow (see Note [MO_S_MulMayOflo significant width] in +-- GHC.Cmm.MachOp). The exact non-zero value is unspecified and legitimately +-- differs between backends and between inlined vs. non-inlined call sites +-- (e.g., the LLVM backend's `isSMulOK` returns `sext_signbit(low) - high`, +-- which is some arbitrary non-zero word on overflow). +-- +-- Comparing the raw Int# results bit-for-bit is therefore too strict and +-- causes spurious test failures whenever the random arguments happen to +-- overflow. We compare zero/non-zero instead, which matches the spec. +-- See #27222. + instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/391413435eb02d9d8ed8bb85946de2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/391413435eb02d9d8ed8bb85946de2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add Bounded instances for Double, Float, CDouble and CFloat
by Marge Bot (＠marge-bot) 02 May '26

02 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 39141343 by Alice Rixte at 2026-05-01T14:09:32+02:00 Add Bounded instances for Double, Float, CDouble and CFloat - - - - - 7 changed files: - libraries/base/changelog.md - libraries/ghc-internal/include/CTypes.h - libraries/ghc-internal/src/GHC/Internal/Float.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/391413435eb02d9d8ed8bb85946de2d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/391413435eb02d9d8ed8bb85946de2d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26989] Make builtin rules return arguments
by Simon Peyton Jones (＠simonpj) 01 May '26

01 May '26

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 74d3772d by Simon Peyton Jones at 2026-05-02T00:55:09+01:00 Make builtin rules return arguments - - - - - 11 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/Types/Id/Make.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -84,9 +84,13 @@ module GHC.Core ( IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, -- * Core rule data types - CoreRule(..), + CoreRule(..), RuleMatch(..), RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, + -- * Floats + FloatBind(..), FloatBinds, emptyFloatBinds, isEmptyFloatBinds, + floatBinders, floatsBinders, + -- ** Operations on 'CoreRule's ruleArity, ruleName, ruleIdName, ruleActivation, setRuleIdName, ruleModule, @@ -116,6 +120,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Data.OrdList + import Data.Data hiding (TyCon) import Data.Int import Data.List.NonEmpty (nonEmpty) @@ -1574,7 +1580,25 @@ data CoreRule } -- See Note [Extra args in the target] in GHC.Core.Rules -type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type RuleFun = RuleOpts -> InScopeEnv + -> Id -> [CoreExpr] -- Function applied to these arguments + -> Maybe RuleMatch + +data RuleMatch + = RM { rm_rule :: CoreRule + , rm_rhs :: CoreExpr -- Rhs of the rule + , rm_args :: [CoreExpr] -- The args of the RHS + , rm_floats :: FloatBinds -- Floated let-bindings + -- See Note [Matching lets] + } + -- E.g. match r = RULE forall x,y. f (Just (y,x)) = g x y True + -- target f (let v = ev in Just (ey, ex)) ez + -- We get the RuleMatch + -- RMM { rm_rule = r, rm_rhs = \xy. g x y True + -- , rm_args = [ex, ey] + -- , rm_floats = Let v=ev } + -- The leftover `ez` is not returned; the caller is responsible for + -- counting (ruleArity r) arguments -- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are -- currently in scope. See Note [The InScopeSet invariant]. @@ -1622,6 +1646,37 @@ isLocalRule (Rule { ru_local = is_local }) = is_local setRuleIdName :: Name -> CoreRule -> CoreRule setRuleIdName nm ru = ru { ru_fn = nm } +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +type FloatBinds = OrdList FloatBind + +emptyFloatBinds :: FloatBinds +emptyFloatBinds = nilOL + +isEmptyFloatBinds :: FloatBinds -> Bool +isEmptyFloatBinds = isNilOL + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr CoreBndr AltCon [CoreBndr] + -- case e of y { C ys -> ... } + -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels + | FloatTick CoreTickish + +floatsBinders :: FloatBinds -> [Var] +floatsBinders fs = foldr ((++) . floatBinders) [] fs + +floatBinders :: FloatBind -> [Var] +floatBinders (FloatLet bnd) = bindersOf bnd +floatBinders (FloatCase _ b _ bs) = b:bs +floatBinders (FloatTick {}) = [] + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -18,11 +18,6 @@ module GHC.Core.Make ( mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, MkStringIds (..), getMkStringIds, - -- * Floats - FloatBind(..), FloatBinds, - wrapFloat, wrapFloats, floatBindings, - emptyFloatBinds, isEmptyFloatBinds, - -- * Constructing small tuples mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum, mkCoreTupBoxity, unitExpr, @@ -43,6 +38,9 @@ module GHC.Core.Make ( -- * Constructing Maybe expressions mkNothingExpr, mkJustExpr, + -- * Floats + wrapFloat, wrapFloats, + -- * Error Ids mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, rEC_CON_ERROR_ID, @@ -63,7 +61,6 @@ import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Types.Demand import GHC.Types.Name hiding ( varName ) import GHC.Types.Literal -import GHC.Types.Tickish import GHC.Types.Unique.Supply import GHC.Core @@ -740,54 +737,6 @@ mkSmallTupleCase vars body scrut_var scrut = Case scrut scrut_var (exprType body) [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] -{- -************************************************************************ -* * - Floats -* * -************************************************************************ --} - -type FloatBinds = OrdList FloatBind - -emptyFloatBinds :: FloatBinds -emptyFloatBinds = nilOL - -isEmptyFloatBinds :: FloatBinds -> Bool -isEmptyFloatBinds = isNilOL - -data FloatBind - = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels - | FloatTick CoreTickish - -instance Outputable FloatBind where - ppr (FloatTick t) = text "TICK" <+> ppr t - ppr (FloatLet b) = text "LET" <+> ppr b - ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) - 2 (ppr c <+> ppr bs) - -wrapFloat :: FloatBind -> CoreExpr -> CoreExpr -wrapFloat (FloatTick t) body = mkTick t body -wrapFloat (FloatLet defns) body = Let defns body -wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body - --- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] --- u = let b1 in let b2 in … in let bn in u@ -wrapFloats :: FloatBinds -> CoreExpr -> CoreExpr -wrapFloats floats expr = foldrOL wrapFloat expr floats - -bindBindings :: CoreBind -> [Var] -bindBindings (NonRec b _) = [b] -bindBindings (Rec bnds) = map fst bnds - -floatBindings :: FloatBind -> [Var] -floatBindings (FloatLet bnd) = bindBindings bnd -floatBindings (FloatCase _ b _ bs) = b:bs -floatBindings (FloatTick {}) = [] - {- ************************************************************************ * * @@ -867,6 +816,25 @@ mkJustExpr :: Type -> CoreExpr -> CoreExpr mkJustExpr ty val = mkConApp justDataCon [Type ty, val] +{- +************************************************************************ +* * + Manipulating Floats +* * +************************************************************************ +-} + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatTick t) body = mkTick t body +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body + +-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] +-- u = let b1 in let b2 in … in let bn in u@ +wrapFloats :: FloatBinds -> CoreExpr -> CoreExpr +wrapFloats floats expr = foldrOL wrapFloat expr floats + + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -870,7 +870,7 @@ primOpRules nm = \case -- useful shorthands mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) +mkPrimOpRule nm arity rules = Just $ mkBasicRule1 nm arity (msum rules) mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) -> [RuleM CoreExpr] -> Maybe CoreRule @@ -1679,16 +1679,35 @@ but that is only a historical accident. ************************************************************************ -} -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +mkBasicRule1 :: Name -> Int -> RuleM CoreExpr -> CoreRule -- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = runRuleM rm } - -newtype RuleM r = RuleM - { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } +mkBasicRule1 op_name n_args rm + = mkBasicRule (occNameFS (nameOccName op_name)) op_name n_args rm + +mkBasicRule :: RuleName -> Name -> Int -> RuleM CoreExpr -> CoreRule +-- The Builtin rules in this module all produce an expression +-- with no args; hence rm_args = []. The `rm_rhs` is the complete +-- result of the rule rewrite. This is OK because it's always +-- small (I think). +mkBasicRule rule_name op_name n_args rm + = rule + where + rule = BuiltinRule { ru_name = rule_name + , ru_fn = op_name + , ru_nargs = n_args + , ru_try = try } + + try opts in_scope fn args + = case runRuleM rm opts in_scope fn args of + Nothing -> Nothing + Just rhs -> Just (RM { rm_rule = rule + , rm_rhs = rhs + , rm_args = [] + , rm_floats = emptyFloatBinds }) + +type CFRuleFun r = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r + +newtype RuleM r = RuleM { runRuleM :: CFRuleFun r } deriving (Functor) instance Applicative RuleM where @@ -2132,28 +2151,16 @@ is fine. builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [BuiltinRule { ru_name = fsLit "CStringFoldrLit", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_C }, - BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8", - ru_fn = unpackCStringFoldrUtf8Name, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 }, - BuiltinRule { ru_name = fsLit "CStringAppendLit", - ru_fn = unpackCStringAppendName, - ru_nargs = 2, ru_try = match_cstring_append_lit_C }, - BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8", - ru_fn = unpackCStringAppendUtf8Name, - ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, - ru_nargs = 1, ru_try = match_cstring_length }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - - mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, - - mkBasicRule divIntName 2 $ msum + = [ mkBasicRule1 unpackCStringFoldrName 4 (RuleM match_cstring_foldr_lit_C) + , mkBasicRule1 unpackCStringFoldrUtf8Name 4 (RuleM match_cstring_foldr_lit_utf8) + , mkBasicRule1 unpackCStringAppendName 2 (RuleM match_cstring_append_lit_C) + , mkBasicRule1 unpackCStringAppendUtf8Name 2 (RuleM match_cstring_append_lit_utf8) + , mkBasicRule1 eqStringName 2 (RuleM match_eq_string) + , mkBasicRule1 cstringLengthName 1 (RuleM match_cstring_length) + , mkBasicRule1 inlineIdName 2 (RuleM match_inline) + , mkBasicRule1 unsafeEqualityProofName 3 unsafeEqualityProofRule + + , mkBasicRule1 divIntName 2 $ msum [ nonZeroLit 1 >> binaryLit (intOp2 div) , leftZero , do @@ -2161,9 +2168,9 @@ builtinRules Just n <- return $ exactLog2 d platform <- getPlatform return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n - ], + ] - mkBasicRule modIntName 2 $ msum + , mkBasicRule1 modIntName 2 $ msum [ nonZeroLit 1 >> binaryLit (intOp2 mod) , leftZero , do @@ -2322,15 +2329,9 @@ builtinBignumRules = encodeLitDouble LitDouble ] where - mkRule str name nargs f = BuiltinRule - { ru_name = fsLit str - , ru_fn = name - , ru_nargs = nargs - , ru_try = runRuleM $ do - env <- getRuleOpts - guard (roBignumRules env) - f - } + mkRule str name nargs f = mkBasicRule (fsLit str) name nargs rm + where + rm = do { env <- getRuleOpts; guard (roBignumRules env); f } integer_to_lit str name convert = mkRule str name 1 $ do [a0] <- getArgs @@ -2506,15 +2507,15 @@ builtinBignumRules = -- -- CString version -match_cstring_append_lit_C :: RuleFun +match_cstring_append_lit_C :: CFRuleFun CoreExpr match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey -- CStringUTF8 version -match_cstring_append_lit_utf8 :: RuleFun +match_cstring_append_lit_utf8 :: CFRuleFun CoreExpr match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey {-# INLINE match_cstring_append_lit #-} -match_cstring_append_lit :: Unique -> Unique -> RuleFun +match_cstring_append_lit :: Unique -> Unique -> CFRuleFun CoreExpr match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2] | Just (LitString s1) <- exprIsLiteral_maybe env lit1 , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2 @@ -2540,15 +2541,15 @@ match_cstring_append_lit _ _ _ _ _ _ = Nothing -- See also Note [String literals in GHC] in CString.hs -- CString version -match_cstring_foldr_lit_C :: RuleFun +match_cstring_foldr_lit_C :: CFRuleFun CoreExpr match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey -- CStringUTF8 version -match_cstring_foldr_lit_utf8 :: RuleFun +match_cstring_foldr_lit_utf8 :: CFRuleFun CoreExpr match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey {-# INLINE match_cstring_foldr_lit #-} -match_cstring_foldr_lit :: Unique -> RuleFun +match_cstring_foldr_lit :: Unique -> CFRuleFun CoreExpr match_cstring_foldr_lit foldVariant _ env _ [ Type ty1 , lit1 @@ -2595,7 +2596,7 @@ stripStrTopTicksT e = stripTicksTopT tickishFloatable e -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 -- Also matches unpackCStringUtf8# -match_eq_string :: RuleFun +match_eq_string :: CFRuleFun CoreExpr match_eq_string _ env _ [e1, e2] | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1 , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2 @@ -2628,7 +2629,7 @@ match_eq_string _ _ _ _ = Nothing -- helpful when using OverloadedStrings to create a ByteString since the -- function computing the length of such ByteStrings can often be constant -- folded. -match_cstring_length :: RuleFun +match_cstring_length :: CFRuleFun CoreExpr match_cstring_length rule_env env _ [lit1] | Just (LitString str) <- exprIsLiteral_maybe env lit1 -- If elemIndex returns Just, it has the index of the first embedded NUL @@ -2676,8 +2677,8 @@ The moving parts are simple: Also, don't forget about 'inline's type argument! -} -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) = go e +match_inline :: CFRuleFun CoreExpr +match_inline _ _ _ (Type _ : e : _) = go e -- Maybe Monad ahead: where go (Var f) = -- Ignore the IdUnfoldingFun here! @@ -2689,7 +2690,7 @@ match_inline (Type _ : e : _) = go e go (Tick t e) = do { app <- go e; pure (Tick t app) } go _ = Nothing -match_inline _ = Nothing +match_inline _ _ _ _ = Nothing -------------------------------------------------------- -- Note [Constant folding through nested expressions] ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) -import GHC.Core.Rules ( RuleMatch(..), lookupRule, getRules ) +import GHC.Core.Rules ( lookupRule, getRules ) import GHC.Core.Multiplicity import GHC.Hs.Extension @@ -2486,11 +2486,11 @@ simplOutId env fun cont else return Nothing ; case mb_match of { Just (RM { rm_rule = rule, rm_rhs = rhs - , rm_args = rhs_args, rm_binds = wrap }) + , rm_args = rhs_args, rm_floats = float_bs }) -> simplExprF env rhs' $ dropContArgs (ruleArity rule) cont where - rhs' = GHC.Core.Make.wrapFloats wrap $ + rhs' = GHC.Core.Make.wrapFloats float_bs $ mkApps rhs rhs_args ; Nothing -> @@ -2765,15 +2765,15 @@ fireRuleAFTER :: SimplEnv -> RuleMatch -> SimplM (SimplFloats, CoreExpr) fireRuleAFTER env rule_match arg_specs cont | RM { rm_rule = rule, rm_rhs = rhs, rm_args = rhs_args - , rm_binds = wrap, rm_bndrs = bndrs } <- rule_match - = do { let env' = env `addNewInScopeIds` bndrs + , rm_floats = float_bs } <- rule_match + = do { let env' = env `addNewInScopeIds` floatsBinders float_bs ; (floats, e') <- simplExprF env' rhs $ pushOutArgs (exprType rhs) rhs_args $ pushArgSpecs (drop (ruleArity rule) arg_specs) cont ; return $ - if isEmptyFloatBinds wrap -- Not very pretty + if isEmptyFloatBinds float_bs -- Not very pretty then (floats, e') - else (emptyFloats env', GHC.Core.Make.wrapFloats wrap $ + else (emptyFloats env', GHC.Core.Make.wrapFloats float_bs $ wrapFloats floats e') } @@ -3895,10 +3895,10 @@ wrapDataConFloats env wfloats case_bndr cont thing_inside -- scale_float scales case-floats by the multiplicity of the continuation hole -- (see Note [Scaling in case-of-case]). -- Let floats are _not_ scaled, because they are aliases anyway. - scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) - = GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) - scale_float flt(a)(GHC.Core.Make.FloatLet {}) = flt - scale_float flt(a)(GHC.Core.Make.FloatTick {}) = flt + scale_float (GHC.Core.FloatCase scrut case_bndr con vars) + = GHC.Core.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float flt(a)(GHC.Core.FloatLet {}) = flt + scale_float flt(a)(GHC.Core.FloatTick {}) = flt scale_id id = scaleVarBy holeScaling id ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -2906,8 +2906,8 @@ betterPat is (CP { cp_qvars = vs1, cp_args = as1 }) (CP { cp_qvars = vs2, cp_args = as2 }) | equalLength as1 as2 = case matchExprs ise vs1 as1 as2 of - Just (ms,_,_) -> all exprIsTrivial ms - Nothing -> False + Just (ms,_) -> all exprIsTrivial ms + Nothing -> False | otherwise -- We must handle patterns of unequal length separately (#24282) = False -- For the pattern with more args, the last arg is "interesting" ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1823,8 +1823,8 @@ specLookupRule env fn args is_active rules | otherwise = case lookupRule ropts in_scope_env is_active fn args rules of Just (RM { rm_rule = rule, rm_rhs = rule_rhs - , rm_binds = wrap, rm_args = rule_args }) - -> Just (rule, wrapFloats wrap (mkApps rule_rhs rule_args)) + , rm_floats = float_bs, rm_args = rule_args }) + -> Just (rule, wrapFloats float_bs (mkApps rule_rhs rule_args)) Nothing -> Nothing where dflags = se_dflags env ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -80,6 +80,12 @@ instance OutputableBndr b => Outputable (Expr b) where instance OutputableBndr b => Outputable (Alt b) where ppr expr = pprCoreAlt expr +instance Outputable FloatBind where + ppr (FloatTick t) = text "TICK" <+> ppr t + ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) + 2 (ppr c <+> ppr bs) + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -543,22 +543,6 @@ map. ************************************************************************ -} -data RuleMatch - = RM { rm_rule :: CoreRule - , rm_rhs :: CoreExpr - , rm_args :: [CoreExpr] - , rm_binds :: FloatBinds -- Floated let-bindings - -- See Note [Matching lets] - , rm_bndrs :: [Var] -- Binders of rm_binds - } - -- E.g. match r = RULE forall x,y. f (Just (y,x)) = g x y True - -- target f (let v = ev in Just (ey, ex)) ez - -- We get the RuleMatch - -- RMM { rm_rule = r, rm_rhs = \xy. g x y True - -- , rm_args = [ex, ey] - -- , rm_binds = Let v=ev, rm_bndrs = [v] ) - -- The leftover `ez` is not returned; the caller is responsible for - -- counting (ruleArity r) arguments -- | The main rule matching function. Attempts to apply all (active) -- supplied rules to this instance of an application in a given @@ -592,7 +576,7 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules go ms [] = ms go ms (r:rs) | Just rm <- matchRule opts rule_env is_active fn args' rough_args r - = go (rm { rm_binds = toOL (map FloatTick ticks) `appOL` rm_binds rm } : ms) rs + = go (rm { rm_floats = toOL (map FloatTick ticks) `appOL` rm_floats rm } : ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, maybeUnfoldingTemplate unf) @@ -741,14 +725,9 @@ matchRule :: HasDebugCallStack -- of the actual arguments. matchRule opts rule_env _is_active fn args _rough_args - rule@(BuiltinRule { ru_try = match_fn }) + (BuiltinRule { ru_try = match_fn }) = do { guard (roBuiltinRules opts) - ; rhs <- match_fn opts rule_env fn args - ; return (RM { rm_rule = rule - , rm_rhs = rhs - , rm_args = [] - , rm_binds = emptyFloatBinds - , rm_bndrs = [] }) } + ; match_fn opts rule_env fn args } matchRule _opts rule_env is_active _fn target_es rough_args rule@(Rule { ru_act = act, ru_rough = tpl_tops @@ -758,25 +737,22 @@ matchRule _opts rule_env is_active _fn target_es rough_args | ruleCantMatch tpl_tops rough_args = Nothing | otherwise - = do { (matched_es, bind_wrapper, wrap_bndrs) - <- matchExprs rule_env tpl_vars tpl_args target_es - + = do { (matched_es, float_bs) <- matchExprs rule_env tpl_vars tpl_args target_es ; return (RM { rm_rule = rule , rm_rhs = mkLams tpl_vars rhs , rm_args = matched_es - , rm_binds = bind_wrapper - , rm_bndrs = wrap_bndrs }) } + , rm_floats = float_bs }) } matchExprs :: HasDebugCallStack => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] - -> Maybe ( [CoreExpr] -- 1-1 with the incoming [Var] - , FloatBinds, [Var]) -- Floated binds + -> Maybe ( [CoreExpr] -- 1-1 with the incoming [Var] + , FloatBinds ) -- Floated binds matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 - ; return (matched_es, rs_binds rule_subst, rs_bndrs rule_subst) } + ; return (matched_es, rs_binds rule_subst) } where (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars -- See Note [Cloning the template binders] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -32,9 +32,9 @@ import GHC.Builtin.Types.Prim import GHC.Core.Utils import GHC.Core.Opt.Arity import GHC.Core.Lint ( EndPassConfig(..), endPassIO ) -import GHC.Core +import GHC.Core hiding( FloatBind(..) ) import GHC.Core.Subst -import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here +import GHC.Core.Make import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCon @@ -2108,6 +2108,8 @@ instance Outputable FloatInfo where -- See Note [Floating in CorePrep] -- and Note [BindInfo and FloatInfo] +-- This data type is very like GHC.Core.FloatBind, +-- but with extra info on the let-bindings data FloatingBind = Float !CoreBind !BindInfo !FloatInfo -- Never a join-point binding | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr] ===================================== compiler/GHC/HsToCore/Pmc/Solver.hs ===================================== @@ -65,7 +65,7 @@ import GHC.Core.Map.Expr import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred) import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) -import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr, isEmptyFloatBinds) +import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr) import GHC.Data.FastString import GHC.Types.SrcLoc ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -513,11 +513,7 @@ mkDictSelId name clas -- This is the built-in rule that goes -- op (dfT d1 d2) ---> opT d1 d2 - rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` - occNameFS (getOccName name) - , ru_fn = name - , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args } + rule = dictSelRule name n_ty_args val_index -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting @@ -561,20 +557,35 @@ mkDictSelRhs clas val_index -- varToCoreExpr needed for equality superclass selectors -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } -dictSelRule :: Int -> Arity -> RuleFun +dictSelRule :: Name -> Arity -> Int -> CoreRule -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance -dictSelRule val_index n_ty_args _ in_scope_env _ args - | (dict_arg : _) <- drop n_ty_args args - , Just (_, floats, _, _, con_args) - <- exprIsConApp_maybe in_scope_env dict_arg - = Just (wrapFloats floats $ getNth con_args val_index) - | otherwise - = Nothing +dictSelRule name val_index n_ty_args + = rule + where + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = try } + + + try :: RuleFun + try _opts in_scope_env _fn args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe in_scope_env dict_arg + , let meth_e = getNth con_args val_index + meth_id = mkTemplateLocal 1 (exprType meth_e) + = Just (RM { rm_floats = floats + , rm_rhs = Lam meth_id (Var meth_id) + , rm_args = [meth_e] + , rm_rule = rule }) + | otherwise + = Nothing {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74d3772d054e96fd2a25f3b81030796… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74d3772d054e96fd2a25f3b81030796… You're receiving this email because of your account on gitlab.haskell.org.

1 0