- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/T26848] Delete unecessary GHC.Internal.Data.Ix
by Teo Camarasu (＠teo) 30 Jan '26

30 Jan '26

Teo Camarasu pushed to branch wip/T26848 at Glasgow Haskell Compiler / GHC Commits: 770ccc9b by Teo Camarasu at 2026-01-30T13:42:19+00:00 Delete unecessary GHC.Internal.Data.Ix This module merely re-exports GHC.Internal.Ix. It was copied from `base` when `ghc-internal` was split, but there is no reason to have this now. So, let's delete it. Resolves #26848 - - - - - 7 changed files: - libraries/base/src/Data/Ix.hs - libraries/ghc-internal/ghc-internal.cabal.in - − libraries/ghc-internal/src/GHC/Internal/Data/Ix.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 Changes: ===================================== libraries/base/src/Data/Ix.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -42,4 +42,4 @@ module Data.Ix -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. ) where -import GHC.Internal.Data.Ix +import GHC.Internal.Ix ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -153,7 +153,6 @@ Library GHC.Internal.Data.Functor.Identity GHC.Internal.Data.Functor.Utils GHC.Internal.Data.IORef - GHC.Internal.Data.Ix GHC.Internal.Data.List GHC.Internal.Data.List.NonEmpty GHC.Internal.Data.Maybe ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted ===================================== @@ -1,64 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Data.Ix --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : stable --- Portability : portable --- --- The 'Ix' class is used to map a contiguous subrange of values in --- type onto integers. It is used primarily for array indexing --- (see the array package). 'Ix' uses row-major order. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Data.Ix - ( - -- * The 'Ix' class - Ix - ( range - , index - , inRange - , rangeSize - ) - -- Ix instances: - -- - -- Ix Char - -- Ix Int - -- Ix Integer - -- Ix Bool - -- Ix Ordering - -- Ix () - -- (Ix a, Ix b) => Ix (a, b) - -- ... - - -- * Deriving Instances of 'Ix' - -- | Derived instance declarations for the class 'Ix' are only possible - -- for enumerations (i.e. datatypes having only nullary constructors) - -- and single-constructor datatypes, including arbitrarily large tuples, - -- whose constituent types are instances of 'Ix'. - -- - -- * For an enumeration, the nullary constructors are assumed to be - -- numbered left-to-right with the indices being 0 to n-1 inclusive. This - -- is the same numbering defined by the 'Enum' class. For example, given - -- the datatype: - -- - -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet - -- - -- we would have: - -- - -- > range (Yellow,Blue) == [Yellow,Green,Blue] - -- > index (Yellow,Blue) Green == 1 - -- > inRange (Yellow,Blue) Red == False - -- - -- * For single-constructor datatypes, the derived instance declarations - -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report: - -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. - - ) where - -import GHC.Internal.Ix ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/770ccc9bfb7aed07cd37fea4c34dbcb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/770ccc9bfb7aed07cd37fea4c34dbcb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26848] Delete unecessary GHC.Internal.Data.Ix
by Teo Camarasu (＠teo) 30 Jan '26

30 Jan '26

Teo Camarasu pushed to branch wip/T26848 at Glasgow Haskell Compiler / GHC Commits: 5eacc532 by Teo Camarasu at 2026-01-30T13:41:16+00:00 Delete unecessary GHC.Internal.Data.Ix This is module merely re-exports GHC.Internal.Ix. It was copied from `base` when `ghc-internal` was split, but there is no reason to have this now. So, let's delete it. Resolves #26848 - - - - - 7 changed files: - libraries/base/src/Data/Ix.hs - libraries/ghc-internal/ghc-internal.cabal.in - − libraries/ghc-internal/src/GHC/Internal/Data/Ix.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 Changes: ===================================== libraries/base/src/Data/Ix.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -42,4 +42,4 @@ module Data.Ix -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. ) where -import GHC.Internal.Data.Ix +import GHC.Internal.Ix ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -153,7 +153,6 @@ Library GHC.Internal.Data.Functor.Identity GHC.Internal.Data.Functor.Utils GHC.Internal.Data.IORef - GHC.Internal.Data.Ix GHC.Internal.Data.List GHC.Internal.Data.List.NonEmpty GHC.Internal.Data.Maybe ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted ===================================== @@ -1,64 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Data.Ix --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : stable --- Portability : portable --- --- The 'Ix' class is used to map a contiguous subrange of values in --- type onto integers. It is used primarily for array indexing --- (see the array package). 'Ix' uses row-major order. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Data.Ix - ( - -- * The 'Ix' class - Ix - ( range - , index - , inRange - , rangeSize - ) - -- Ix instances: - -- - -- Ix Char - -- Ix Int - -- Ix Integer - -- Ix Bool - -- Ix Ordering - -- Ix () - -- (Ix a, Ix b) => Ix (a, b) - -- ... - - -- * Deriving Instances of 'Ix' - -- | Derived instance declarations for the class 'Ix' are only possible - -- for enumerations (i.e. datatypes having only nullary constructors) - -- and single-constructor datatypes, including arbitrarily large tuples, - -- whose constituent types are instances of 'Ix'. - -- - -- * For an enumeration, the nullary constructors are assumed to be - -- numbered left-to-right with the indices being 0 to n-1 inclusive. This - -- is the same numbering defined by the 'Enum' class. For example, given - -- the datatype: - -- - -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet - -- - -- we would have: - -- - -- > range (Yellow,Blue) == [Yellow,Green,Blue] - -- > index (Yellow,Blue) Green == 1 - -- > inRange (Yellow,Blue) Red == False - -- - -- * For single-constructor datatypes, the derived instance declarations - -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report: - -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. - - ) where - -import GHC.Internal.Ix ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5eacc5321ac81bf32641bf26505d0c6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5eacc5321ac81bf32641bf26505d0c6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26416] DmdAnal: Don't give an absent demand signature to an argument if the argument doesn't
by Zubin (＠wz1000) 30 Jan '26

30 Jan '26

Zubin pushed to branch wip/26416 at Glasgow Haskell Compiler / GHC Commits: 31120f0e by Zubin Duggal at 2026-01-30T17:38:22+05:30 DmdAnal: Don't give an absent demand signature to an argument if the argument doesn't also have an absent demand signature in its unfolding. Otherwise, in some cases we might mark an argument as absent and generate a LitRubbish for it, but then the function might inline and turn out to actually use this argument, resulting in a run time crash. Partially addresses #26416. There may still be cases where an absent argument turns out to be used due to a rule firing. - - - - - 4 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - + testsuite/tests/dmdanal/should_run/M1.hs - + testsuite/tests/dmdanal/should_run/T26416.hs - testsuite/tests/dmdanal/should_run/all.T Changes: ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -1106,8 +1106,17 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs DmdType rhs_env rhs_dmds = rhs_dmd_ty + + -- See Note [Absence analysis for stable unfoldings and RULES] + -- If there's a stable unfolding, we need to combine argument demands + -- from the unfolding with those from the RHS, because the unfolding + -- might use arguments that the (optimised) RHS doesn't. + -- Any argument with a demand absent in one but not the other can + -- be problematic, see #26416 + combined_rhs_dmds = combineUnfoldingDmds env rhs_sd id rhs_dmds + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity - rhs_dmds (de_div rhs_env) rhs' + combined_rhs_dmds (de_div rhs_env) rhs' dmd_sig_arity = ww_arity + strictCallArity body_sd sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds) @@ -1144,6 +1153,28 @@ splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs +-- | If there is a stable unfolding, don't let any demand be absent that +-- is also not absent in the unfolding +-- See Note [Absence analysis for stable unfoldings and RULES], Wrinkle (W3). +combineUnfoldingDmds :: AnalEnv -> SubDemand -> Id -> [Demand] -> [Demand] +combineUnfoldingDmds env rhs_sd id rhs_dmds + | not (isStableUnfolding unf) + = rhs_dmds -- No stable unfolding, nothing to do + + | Just unf_body <- maybeUnfoldingTemplate unf + , let WithDmdType (DmdType _ unf_dmds) _ = dmdAnal env rhs_sd unf_body + , let result = go rhs_dmds unf_dmds + = -- pprTrace "lubUnfoldingDmds" (ppr id $$ ppr rhs_dmds $$ ppr unf_dmds $$ ppr result) $ + result + | otherwise = rhs_dmds + where + unf = realIdUnfolding id + go rhs [] = rhs + go [] _ = [] + go (AbsDmd:rhs) (u:unfs) = u : go rhs unfs + go (r:rhs) (AbsDmd:unfs) = r : go rhs unfs + go (r:rhs) (_:unfs) = r : go rhs unfs + -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type @@ -1523,6 +1554,25 @@ Wrinkles: for `sg`, failing to unleash the signature and hence observed an absent error instead of the `really important message`. + (W3) The SOLUTION above handles /free variables/ of stable unfoldings, but + what about /arguments/? Consider (#25965) + + fromVector :: (Storable a, KnownNat n) => Vector a -> Vector a + fromVector v = ... (uses Storable dictionary) ... + {-# INLINABLE fromVector #-} + + Suppose that the optimised RHS of `fromVector` somehow discards the use of + the Storable dictionary, but the stable unfolding still uses it. Then the + demand signature will say that the Storable dictionary argument is absent, + and worker/wrapper will replace it with `LitRubbish`. But when the + worker's unfolding is inlined, it will use that rubbish value as a real + dictionary, leading to a segfault! + + SOLUTION: in `dmdAnalRhsSig`, if the function has a stable unfolding, + analyse it and drop any AbsDmds which are not absent in the unfolding. + This is done by `combineUnfoldingDmds`. This ensures that if the unfolding + uses an argument, it won't be marked as absent. + Note [DmdAnal for DataCon wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We give DataCon wrappers a (necessarily flat) demand signature in @@ -2046,8 +2096,11 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs arg_triples :: [(Type, StrictnessMark, Demand)] arg_triples = take ww_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] + zipWith mk_triple + [ bndr | bndr <- bndrs, isRuntimeVar bndr ] + arg_dmds + where + mk_triple bndr dmd = (idType bndr, NotMarkedStrict, get_dmd dmd) arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds) -- If ww_arity < length arg_dmds, the leftover ones @@ -2063,12 +2116,10 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs -- This is the budget initialisation step of -- Note [Worker argument budget] - get_dmd :: Id -> Demand - get_dmd bndr + get_dmd :: Demand -> Demand + get_dmd dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv ===================================== testsuite/tests/dmdanal/should_run/M1.hs ===================================== @@ -0,0 +1,17 @@ +-- Short module name is essential, or else f doesn't inline +module M1 where +{-# INLINABLE [2] f #-} +f :: Int -> Int -> Float +f !dummy x = if times dummy 0 x == 1 + then 3.0 else 4.0 + +{-# INLINE [0] times #-} +times :: Int -> Int -> Int -> Int +times dummy 0 x = x `seq` ( 0 + big dummy ) +times _ a b = a * b + +{-# RULES "times" [1] forall dummy x. times dummy 0 x = 0 + big dummy #-} + +big :: Int -> Int +big x = succ . succ . succ . succ . succ . succ . succ . succ . succ $ x +{-# INLINE big #-} ===================================== testsuite/tests/dmdanal/should_run/T26416.hs ===================================== @@ -0,0 +1,3 @@ +module Main where +import M1 ( f ) +main = print (f 19 12) ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -34,3 +34,4 @@ test('T22475b', normal, compile_and_run, ['']) test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise']) test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208']) test('T25439', normal, compile_and_run, ['']) +test('T26416', normal, multimod_compile_and_run, ['T26416','M1.hs']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31120f0e97303ea88e7bbccd77a5126… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31120f0e97303ea88e7bbccd77a5126… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26854
by Simon Peyton Jones (＠simonpj) 30 Jan '26

30 Jan '26

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

1 0

[Git][ghc/ghc][wip/andreask/linker_fix] webbles: Always output debugBelch linker errors
by Andreas Klebinger (＠AndreasK) 30 Jan '26

30 Jan '26

Andreas Klebinger pushed to branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC Commits: 7030f509 by Andreas Klebinger at 2026-01-30T11:31:42+01:00 webbles: Always output debugBelch linker errors - - - - - 3 changed files: - rts/Linker.c - rts/LinkerInternals.h - rts/linker/LoadArchive.c Changes: ===================================== rts/Linker.c ===================================== @@ -1444,6 +1444,7 @@ preloadObjectFile (pathchar *path) oc = mkOc(STATIC_OBJECT, path, image, fileSize, true, NULL, misalignment); if (!verifyAndInitOc(oc)) { + freePreloadObjectFile(oc); freeObjectCode(oc); debugBelch("loadObj: Failed to verify oc.\n"); return NULL; ===================================== rts/LinkerInternals.h ===================================== @@ -385,7 +385,7 @@ extern Elf_Word shndx_table_uninit_label; ) #define ocDebugBelch(oc, s, ...) \ - debugBelch("%s(%" PATH_FMT ": " s, \ + errorBelch("%s(%" PATH_FMT ": " s, \ __func__, \ OC_INFORMATIVE_FILENAME(oc), \ ##__VA_ARGS__) ===================================== rts/linker/LoadArchive.c ===================================== @@ -627,8 +627,9 @@ HsInt loadArchive_ (pathchar *path) if(!verifyAndInitOc( oc )) { - freeObjectCode( oc ); IF_DEBUG(linker, ocDebugBelch(oc, "Faild to verify ... skipping.")); + errorBelch("Faild to verify ... skipping."); + freeObjectCode( oc ); continue; } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7030f5099b18eb299471e21142f1ebf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7030f5099b18eb299471e21142f1ebf… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26848] Delete unecessary GHC.Internal.Data.Ix
by Teo Camarasu (＠teo) 30 Jan '26

30 Jan '26

Teo Camarasu pushed to branch wip/T26848 at Glasgow Haskell Compiler / GHC Commits: a3e5a884 by Teo Camarasu at 2026-01-30T10:10:02+00:00 Delete unecessary GHC.Internal.Data.Ix - - - - - 7 changed files: - libraries/base/src/Data/Ix.hs - libraries/ghc-internal/ghc-internal.cabal.in - − libraries/ghc-internal/src/GHC/Internal/Data/Ix.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 Changes: ===================================== libraries/base/src/Data/Ix.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -42,4 +42,4 @@ module Data.Ix -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. ) where -import GHC.Internal.Data.Ix +import GHC.Internal.Ix ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -153,7 +153,6 @@ Library GHC.Internal.Data.Functor.Identity GHC.Internal.Data.Functor.Utils GHC.Internal.Data.IORef - GHC.Internal.Data.Ix GHC.Internal.Data.List GHC.Internal.Data.List.NonEmpty GHC.Internal.Data.Maybe ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted ===================================== @@ -1,64 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Data.Ix --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : stable --- Portability : portable --- --- The 'Ix' class is used to map a contiguous subrange of values in --- type onto integers. It is used primarily for array indexing --- (see the array package). 'Ix' uses row-major order. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Data.Ix - ( - -- * The 'Ix' class - Ix - ( range - , index - , inRange - , rangeSize - ) - -- Ix instances: - -- - -- Ix Char - -- Ix Int - -- Ix Integer - -- Ix Bool - -- Ix Ordering - -- Ix () - -- (Ix a, Ix b) => Ix (a, b) - -- ... - - -- * Deriving Instances of 'Ix' - -- | Derived instance declarations for the class 'Ix' are only possible - -- for enumerations (i.e. datatypes having only nullary constructors) - -- and single-constructor datatypes, including arbitrarily large tuples, - -- whose constituent types are instances of 'Ix'. - -- - -- * For an enumeration, the nullary constructors are assumed to be - -- numbered left-to-right with the indices being 0 to n-1 inclusive. This - -- is the same numbering defined by the 'Enum' class. For example, given - -- the datatype: - -- - -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet - -- - -- we would have: - -- - -- > range (Yellow,Blue) == [Yellow,Green,Blue] - -- > index (Yellow,Blue) Green == 1 - -- > inRange (Yellow,Blue) Red == False - -- - -- * For single-constructor datatypes, the derived instance declarations - -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report: - -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. - - ) where - -import GHC.Internal.Ix ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3e5a884d80af598e7a6734ffe77be8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3e5a884d80af598e7a6734ffe77be8… 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: PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC
by Marge Bot (＠marge-bot) 30 Jan '26

30 Jan '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: ce2d62fb by Jessica Clarke at 2026-01-29T19:48:51-05:00 PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC There is no native instruction for this, and even if there were a register pair version we could use, the implementation here is assuming the values fit in a single register, and we end up only using / defining the low halves of the registers. Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes") Fixes: #23969 - - - - - 43d97761 by Michael Karcher at 2026-01-29T19:49:43-05:00 NCG for PPC: add pattern for CmmRegOff to iselExpr64 Closes #26828 - - - - - e8675d88 by Matthew Pickering at 2026-01-30T05:02:23-05:00 determinism: Use deterministic map for Strings in TyLitMap When generating typeable evidence the types we need evidence for all cached in a TypeMap, the order terms are retrieved from a type map determines the order the bindings appear in the program. A TypeMap is quite diligent to use deterministic maps, apart from in the TyLitMap, which uses a UniqFM for storing strings, whose ordering depends on the Unique of the FastString. This can cause non-deterministic .hi and .o files. An unexpected side-effect is the error message but RecordDotSyntaxFail8 changing. I looked into this with Sam and this change caused the constraints to be solved in a different order which results in a slightly different error message. I have accepted the new test, since the output before was non-deterministic and the new output is consistent with the other messages in that file. Fixes #26846 - - - - - 9a996fae by Andrew Lelechenko at 2026-01-30T05:02:23-05:00 Upgrade text submodule to 2.1.4 - - - - - 6 changed files: - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/Core/Map/Type.hs - libraries/text - + testsuite/tests/ghc-api/TypeMapStringLiteral.hs - testsuite/tests/ghc-api/all.T - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr Changes: ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -180,7 +180,7 @@ stmtToInstrs stmt = do format = cmmTypeFormat ty CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args + -> genCCall platform target result_regs args CmmBranch id -> genBranch id CmmCondBranch arg true false prediction -> do @@ -338,6 +338,8 @@ iselExpr64 (CmmReg (CmmLocal local_reg)) = do let Reg64 hi lo = localReg64 local_reg return (RegCode64 nilOL hi lo) +iselExpr64 regoff@(CmmRegOff _ _) = iselExpr64 $ mangleIndexTree regoff + iselExpr64 (CmmLit (CmmInt i _)) = do Reg64 rhi rlo <- getNewReg64 let @@ -1183,24 +1185,25 @@ genCondJump id bool prediction = do -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. -genCCall :: ForeignTarget -- function to call +genCCall :: Platform + -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall (PrimTarget MO_AcquireFence) _ _ +genCCall _ (PrimTarget MO_AcquireFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_ReleaseFence) _ _ +genCCall _ (PrimTarget MO_ReleaseFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_SeqCstFence) _ _ +genCCall _ (PrimTarget MO_SeqCstFence) _ _ = return $ unitOL HWSYNC -genCCall (PrimTarget MO_Touch) _ _ +genCCall _ (PrimTarget MO_Touch) _ _ = return $ nilOL -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ +genCCall _ (PrimTarget (MO_Prefetch_Data _)) _ _ = return $ nilOL -genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] +genCCall _ (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do let fmt = intFormat width reg_dst = getLocalRegReg dst (instr, n_code) <- case amop of @@ -1250,7 +1253,7 @@ genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] (n_reg, n_code) <- getSomeReg n return (op dst dst (RIReg n_reg), n_code) -genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] +genCCall _ (PrimTarget (MO_AtomicRead width _)) [dst] [addr] = do let fmt = intFormat width reg_dst = getLocalRegReg dst form = if widthInBits width == 64 then DS else D @@ -1277,12 +1280,12 @@ genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] -- This is also what gcc does. -genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do +genCCall _ (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do code <- assignMem_IntCode (intFormat width) addr val return $ unitOL HWSYNC `appOL` code -genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] - | width == W32 || width == W64 +genCCall platform (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] + | width == W32 || (width == W64 && not (target32Bit platform)) = do (old_reg, old_code) <- getSomeReg old (new_reg, new_code) <- getSomeReg new @@ -1311,9 +1314,8 @@ genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] format = intFormat width -genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Clz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do RegCode64 code vr_hi vr_lo <- iselExpr64 src @@ -1361,9 +1363,8 @@ genCCall (PrimTarget (MO_Clz width)) [dst] [src] let cntlz = unitOL (CNTLZ format reg_dst reg) return $ s_code `appOL` pre `appOL` cntlz `appOL` post -genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Ctz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do let format = II32 @@ -1425,9 +1426,8 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src] , SUBFC dst r' (RIImm (ImmInt (format_bits))) ] -genCCall target dest_regs argsAndHints - = do platform <- getPlatform - case target of +genCCall platform target dest_regs argsAndHints + = do case target of PrimTarget (MO_S_QuotRem width) -> divOp1 True width dest_regs argsAndHints PrimTarget (MO_U_QuotRem width) -> divOp1 False width ===================================== compiler/GHC/Core/Map/Type.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Var import GHC.Types.Var.Env -import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM import GHC.Utils.Outputable import GHC.Utils.Panic @@ -365,14 +365,14 @@ filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a - , tlm_string :: UniqFM FastString a + , tlm_string :: UniqDFM FastString a , tlm_char :: Map.Map Char a } -- TODO(22292): derive instance Functor TyLitMap where fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM - { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } + { tlm_number = Map.map f tn, tlm_string = mapUDFM f ts, tlm_char = Map.map f tc } instance TrieMap TyLitMap where type Key TyLitMap = TyLit @@ -384,34 +384,34 @@ instance TrieMap TyLitMap where mapMaybeTM = mpTyLit emptyTyLitMap :: TyLitMap a -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUDFM, tlm_char = Map.empty } lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l = case l of NumTyLit n -> tlm_number >.> Map.lookup n - StrTyLit n -> tlm_string >.> (`lookupUFM` n) + StrTyLit n -> tlm_string >.> (`lookupUDFM` n) CharTyLit n -> tlm_char >.> Map.lookup n xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a xtTyLit l f m = case l of NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) } - StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n } + StrTyLit n -> m { tlm_string = alterUDFM f (tlm_string m) n } CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) } foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b -foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m) +foldTyLit l m = flip (foldUDFM l) (tlm_string m) . flip (Map.foldr l) (tlm_number m) . flip (Map.foldr l) (tlm_char m) filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) - = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc } + = TLM { tlm_number = Map.filter f tn, tlm_string = filterUDFM f ts, tlm_char = Map.filter f tc } mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) - = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc } + = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUDFM f ts, tlm_char = Map.mapMaybe f tc } ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this ===================================== libraries/text ===================================== @@ -1 +1 @@ -Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67 +Subproject commit 423fd981e576bd17a8b5fa48d0ad6b9a0c370e77 ===================================== testsuite/tests/ghc-api/TypeMapStringLiteral.hs ===================================== @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Monad (unless) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Short as SBS +import Data.Char (ord) +import Data.List (foldl') +import GHC.Core.Map.Type (TypeMap, emptyTypeMap, extendTypeMap, foldTypeMap) +import GHC.Core.Type (Type, mkStrLitTy) +import GHC.Data.FastString (FastString (..), FastZString (..)) +import GHC.Utils.Encoding (zEncodeString) + +main :: IO () +main = do + let logicalEntries = + [ ("alpha", "payload-alpha") + , ("beta", "payload-beta") + , ("gamma", "payload-gamma") + ] + uniquesOne = [1, 2, 3] + uniquesTwo = [200, 100, 500] + + tmOne = buildMap logicalEntries uniquesOne + tmTwo = buildMap logicalEntries uniquesTwo + + foldedOne = foldValues tmOne + foldedTwo = foldValues tmTwo + + assert "foldTypeMap order independent of FastString uniques" $ + foldedOne == foldedTwo + + +buildMap :: [(String, a)] -> [Int] -> TypeMap a +buildMap entries uniques = + foldl' insertEntry emptyTypeMap (zip uniques entries) + where + insertEntry :: TypeMap a -> (Int, (String, a)) -> TypeMap a + insertEntry tm (u, (txt, payload)) = + extendTypeMap tm (strLiteralWithUnique u txt) payload + +foldValues :: TypeMap a -> [a] +foldValues tm = foldTypeMap (:) [] tm + +strLiteralWithUnique :: Int -> String -> Type +strLiteralWithUnique u = mkStrLitTy . fakeFastString u + +fakeFastString :: Int -> String -> FastString +fakeFastString u s = FastString + { uniq = u + , n_chars = length s + , fs_sbs = SBS.pack (map (fromIntegral . ord) s) + , fs_zenc = error "unused" + } + +assert :: String -> Bool -> IO () +assert label condition = unless condition $ + error ("TypeMap string literal test failed: " ++ label) ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -74,3 +74,4 @@ test('T25577', [ extra_run_opts(f'"{config.libdir}"') test('T26120', [], compile_and_run, ['-package ghc']) test('T26264', normal, compile_and_run, ['-package ghc']) +test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr ===================================== @@ -30,7 +30,13 @@ RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999] • No instance for ‘HasField "quux3" Quux r0’ arising from selecting the field ‘quux3’ NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. - • In the expression: ....bar.baz.quux3 - In the second argument of ‘($)’, namely ‘....baz.quux3.wob’ + • In the second argument of ‘($)’, namely ‘....baz.quux3.wob’ In a stmt of a 'do' block: print @Bool $ ....quux3.wob + In the expression: + do let a = Foo {foo = ...} + print @Quux $ ....quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/347d114194b2d02d88ee8b4e236e33… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/347d114194b2d02d88ee8b4e236e33… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26772] 5 commits: PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC
by Simon Peyton Jones (＠simonpj) 30 Jan '26

30 Jan '26

Simon Peyton Jones pushed to branch wip/T26772 at Glasgow Haskell Compiler / GHC Commits: ce2d62fb by Jessica Clarke at 2026-01-29T19:48:51-05:00 PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC There is no native instruction for this, and even if there were a register pair version we could use, the implementation here is assuming the values fit in a single register, and we end up only using / defining the low halves of the registers. Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes") Fixes: #23969 - - - - - 43d97761 by Michael Karcher at 2026-01-29T19:49:43-05:00 NCG for PPC: add pattern for CmmRegOff to iselExpr64 Closes #26828 - - - - - eea3ecd1 by Simon Peyton Jones at 2026-01-30T09:27:40+00:00 Fix subtle bug in GHC.Core.Utils.mkTick This patch fixes a decade-old bug in `mkTick`, which could generate type-incorrect code! See the diagnosis in #26772. The new code is simpler and easier to understand. (As #26772 says, I think it could be improved further.) - - - - - f24081f7 by Simon Peyton Jones at 2026-01-30T09:27:40+00:00 Modify a debug-trace in the Simplifier ...just to show a bit more information. - - - - - 355626a5 by Simon Peyton Jones at 2026-01-30T09:27:40+00:00 Fix long-standing interaction between ticks and casts The code for Note [Eliminate Identity Cases] was simply wrong when ticks and casts interacted. This patch fixes the interaction. It was shown up when validating #26772, although it's not the exactly the bug that's reported by #26772. Nor is it easy to reproduce, hence no regression test. - - - - - 10 changed files: - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Evidence.hs - testsuite/tests/ghci.debugger/scripts/T26042b.stdout - testsuite/tests/ghci.debugger/scripts/T26042c.stdout - testsuite/tests/ghci.debugger/scripts/T26042d2.stdout - testsuite/tests/ghci.debugger/scripts/T26042f2.stdout Changes: ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -180,7 +180,7 @@ stmtToInstrs stmt = do format = cmmTypeFormat ty CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args + -> genCCall platform target result_regs args CmmBranch id -> genBranch id CmmCondBranch arg true false prediction -> do @@ -338,6 +338,8 @@ iselExpr64 (CmmReg (CmmLocal local_reg)) = do let Reg64 hi lo = localReg64 local_reg return (RegCode64 nilOL hi lo) +iselExpr64 regoff@(CmmRegOff _ _) = iselExpr64 $ mangleIndexTree regoff + iselExpr64 (CmmLit (CmmInt i _)) = do Reg64 rhi rlo <- getNewReg64 let @@ -1183,24 +1185,25 @@ genCondJump id bool prediction = do -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. -genCCall :: ForeignTarget -- function to call +genCCall :: Platform + -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall (PrimTarget MO_AcquireFence) _ _ +genCCall _ (PrimTarget MO_AcquireFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_ReleaseFence) _ _ +genCCall _ (PrimTarget MO_ReleaseFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_SeqCstFence) _ _ +genCCall _ (PrimTarget MO_SeqCstFence) _ _ = return $ unitOL HWSYNC -genCCall (PrimTarget MO_Touch) _ _ +genCCall _ (PrimTarget MO_Touch) _ _ = return $ nilOL -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ +genCCall _ (PrimTarget (MO_Prefetch_Data _)) _ _ = return $ nilOL -genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] +genCCall _ (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do let fmt = intFormat width reg_dst = getLocalRegReg dst (instr, n_code) <- case amop of @@ -1250,7 +1253,7 @@ genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] (n_reg, n_code) <- getSomeReg n return (op dst dst (RIReg n_reg), n_code) -genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] +genCCall _ (PrimTarget (MO_AtomicRead width _)) [dst] [addr] = do let fmt = intFormat width reg_dst = getLocalRegReg dst form = if widthInBits width == 64 then DS else D @@ -1277,12 +1280,12 @@ genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] -- This is also what gcc does. -genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do +genCCall _ (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do code <- assignMem_IntCode (intFormat width) addr val return $ unitOL HWSYNC `appOL` code -genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] - | width == W32 || width == W64 +genCCall platform (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] + | width == W32 || (width == W64 && not (target32Bit platform)) = do (old_reg, old_code) <- getSomeReg old (new_reg, new_code) <- getSomeReg new @@ -1311,9 +1314,8 @@ genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] format = intFormat width -genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Clz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do RegCode64 code vr_hi vr_lo <- iselExpr64 src @@ -1361,9 +1363,8 @@ genCCall (PrimTarget (MO_Clz width)) [dst] [src] let cntlz = unitOL (CNTLZ format reg_dst reg) return $ s_code `appOL` pre `appOL` cntlz `appOL` post -genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Ctz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do let format = II32 @@ -1425,9 +1426,8 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src] , SUBFC dst r' (RIImm (ImmInt (format_bits))) ] -genCCall target dest_regs argsAndHints - = do platform <- getPlatform - case target of +genCCall platform target dest_regs argsAndHints + = do case target of PrimTarget (MO_S_QuotRem width) -> divOp1 True width dest_regs argsAndHints PrimTarget (MO_U_QuotRem width) -> divOp1 False width ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1713,6 +1713,7 @@ simplCast env body co0 cont0 , sc_hole_ty = coercionLKind co }) } -- NB! As the cast goes past, the -- type of the hole changes (#16312) + -- (f |> co) e ===> (f (e |> co1)) |> co2 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 @@ -1838,7 +1839,7 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] not (exprIsTrivial arg) && not (isDeadOcc (idOccInfo bndr)) ) - -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $ + -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> text ":=" <+> ppr arg $$ ppr (seIdSubst env)) $ tick (PreInlineUnconditionally bndr) ; simplLam env' body cont } ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Types.Tickish import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Types.Name.Env import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -81,9 +82,9 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic -import Control.Monad ( when ) +import Control.Monad ( guard, when ) import Data.List ( sortBy ) -import GHC.Types.Name.Env +import Data.Maybe import Data.Graph {- ********************************************************************* @@ -2543,7 +2544,27 @@ Note [Eliminate Identity Case] True -> True; False -> False -and similar friends. +and similar friends. There are some tricky wrinkles: + +(EIC1) Casts. We've seen this: + case e of x { _ -> x `cast` c } + And we definitely want to eliminate this case, to give + e `cast` c +(EIC2) Ticks. Similarly + case e of x { _ -> Tick t x } + At least if the tick is 'floatable' we want to eliminate the case + to give + Tick t e + +So `check_eq` strips off enclosing casts and ticks from the RHS of the +alternative, returning a wrapper function that will rebuild them around +the scrutinee if case-elim is successful. + +(EIC3) What if there are many alternatives, all identities. If casts + are involved they must be the same cast, to make the types line up. + In principle there could be different ticks in each RHS, but we just + pick the ticks from the first alternative. (In the common case there + is only one alternative.) Note [Scrutinee Constant Folding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2737,45 +2758,47 @@ mkCase mode scrut outer_bndr alts_ty alts -- See Note [Eliminate Identity Case] -------------------------------------------------- -mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case - | all identity_alt alts +mkCase1 _mode scrut case_bndr _ (alt1 : alts) -- Identity case + | Just wrap <- identity_alt alt1 -- `wrap`: see (EIC1) and (EIC2) + , all (isJust . identity_alt) alts -- See (EIC3) in Note [Eliminate Identity Case] = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } + ; return (wrap scrut) } where - ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts' - identity_alt (Alt con args rhs) = check_eq rhs con args - - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args - - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False + identity_alt :: CoreAlt -> Maybe (CoreExpr -> CoreExpr) + identity_alt (Alt con args rhs) = check_eq con args rhs + + check_eq :: AltCon -> [Var] -> CoreExpr -> Maybe (CoreExpr -> CoreExpr) + -- (check_eq con args e) return True if + -- e looks like (Tick (Cast (Tick (con args)))) + -- where (con args) is the LHS of the alternative + -- In that case it returns (\e. Tick (Cast (Tick e))), + -- a wrapper function that can rebuild the tick/cast stuff + -- See (EIC1) and (EIC2) in Note [Eliminate Identity Case] + check_eq alt_con args (Cast e co) -- See (EIC1) + = do { guard (not (any (`elemVarSet` tyCoVarsOfCo co) args)) + ; wrap <- check_eq alt_con args e + ; return (flip mkCast co . wrap) } + check_eq alt_con args (Tick t e) -- See (EIC2) + = do { guard (tickishFloatable t) + ; wrap <- check_eq alt_con args e + ; return (Tick t . wrap) } + check_eq alt_con args e + | is_id alt_con args e = Just (\e -> e) + | otherwise = Nothing + + is_id :: AltCon -> [Var] -> CoreExpr -> Bool + is_id _ _ (Var v) | v == case_bndr = True + is_id (LitAlt lit') _ (Lit lit) = lit == lit' + is_id (DataAlt con) args rhs + | Var v <- rhs -- Optimisation only + , null arg_tys + , null args = v == dataConWorkId con + | otherwise = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + is_id _ _ _ = False arg_tys = tyConAppArgs (idType case_bndr) - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut - mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -252,7 +252,7 @@ applyTypeToArgs op_ty args mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr mkCastMCo e MRefl = e -mkCastMCo e (MCo co) = Cast e co +mkCastMCo e (MCo co) = mkCast e co -- We are careful to use (MCo co) only when co is not reflexive -- Hence (Cast e co) rather than (mkCast e co) @@ -305,40 +305,41 @@ mkCast expr co -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id id orig_expr +mkTick t orig_expr = mkTick' id orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- mkTick' handles floating of ticks *into* the expression. - -- In this function, `top` is applied after adding the tick, and `rest` before. - -- This will result in applications that look like (top $ Tick t $ rest expr). - -- If we want to push the tick deeper, we pre-compose `top` with a function - -- adding the tick. - mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) - -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) - -> CoreExpr -- current expression + mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) + -- Always a composition of (Tick t) wrappers + -> CoreExpr -- Current expression -> CoreExpr - mkTick' top rest expr = case expr of + -- So in the call (mkTick' rest e), the expression + -- (rest e) + -- has the same type as e + -- Returns an expression equivalent to (Tick t (rest e)) + mkTick' rest expr = case expr of -- Float ticks into unsafe coerce the same way we would do with a cast. Case scrut bndr ty alts@[Alt ac abs _rhs] | Just rhs <- isUnsafeEqualityCase scrut bndr alts - -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs + -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)] -- Cost centre ticks should never be reordered relative to each -- other. Therefore we can stop whenever two collide. Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr -- Otherwise we assume that ticks of different placements float -- through each other. - | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e -- For annotations this is where we make sure to not introduce -- redundant ticks. - | tickishContains t t2 -> mkTick' top rest e - | tickishContains t2 t -> orig_expr - | otherwise -> mkTick' top (rest . Tick t2) e + | tickishContains t t2 -> mkTick' rest e -- Drop t2 + | tickishContains t2 t -> rest e -- Drop t + | otherwise -> mkTick' (rest . Tick t2) e -- Ticks don't care about types, so we just float all ticks -- through them. Note that it's not enough to check for these @@ -346,14 +347,14 @@ mkTick t orig_expr = mkTick' id id orig_expr -- expressions below ticks, such constructs can be the result of -- unfoldings. We therefore make an effort to put everything into -- the right place no matter what we start with. - Cast e co -> mkTick' (top . flip Cast co) rest e - Coercion co -> Coercion co + Cast e co -> mkCast (mkTick' rest e) co + Coercion co -> Tick t $ rest (Coercion co) Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> mkTick' (top . Lam x) rest e + -> Lam x $ mkTick' rest e -- If it is both counting and scoped, we split the tick into its -- two components, often allowing us to keep the counting tick on @@ -362,25 +363,25 @@ mkTick t orig_expr = mkTick' id id orig_expr -- floated, and the lambda may then be in a position to be -- beta-reduced. | canSplit - -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e App f arg -- Always float through type applications. | not (isRuntimeArg arg) - -> mkTick' (top . flip App arg) rest f + -> App (mkTick' rest f) arg -- We can also float through constructor applications, placement -- permitting. Again we can split. | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) -> if tickishPlace t == PlaceCostCentre - then top $ rest $ tickHNFArgs t expr - else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then rest $ tickHNFArgs t expr + else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr Var x | notFunction && tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t | notFunction && canSplit - -> top $ Tick (mkNoScope t) $ rest expr + -> Tick (mkNoScope t) $ rest expr where -- SCCs can be eliminated on variables provided the variable -- is not a function. In these cases the SCC makes no difference: @@ -392,10 +393,10 @@ mkTick t orig_expr = mkTick' id id orig_expr Lit{} | tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t -- Catch-all: Annotate where we stand - _any -> top $ Tick t $ rest expr + _any -> Tick t $ rest expr mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -49,6 +49,7 @@ import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core.Utils( mkCast ) import GHC.Core ( Expr(..), mkConApp ) import GHC.StgToCmm.Closure ( isSmallFamily ) @@ -455,7 +456,7 @@ matchWithDict [cls_ty, mty] = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ Var k `App` (evUnaryDictAppE cls dict_args meth_arg) where - meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr) + meth_arg = Var sv `mkCast` mkSubCo (evExprCoercion ev_expr) ; let mk_ev [c] = evDictApp wd_cls [cls_ty, mty] [evWithDict c] mk_ev e = pprPanic "matchWithDict" (ppr e) @@ -657,7 +658,7 @@ matchDataToTag dataToTagClass [levity, dty] = do (mkReflCo Representational intPrimTy) -> do { addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3 ; let mk_ev _ = evDictApp dataToTagClass [levity, dty] $ - [methodRep `Cast` methodCo] + [methodRep `mkCast` methodCo] ; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.) , cir_mk_ev = mk_ev , cir_canonical = EvCanonical ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Tc.Utils.TcType import GHC.Core import GHC.Core.Coercion.Axiom import GHC.Core.Coercion +import GHC.Core.Utils( mkCast ) import GHC.Core.Ppr () -- Instance OutputableBndr TyVar import GHC.Core.Predicate import GHC.Core.Type @@ -930,7 +931,7 @@ evCastE ee co | assertPpr (coercionRole co == Representational) (vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $ isReflCo co = ee - | otherwise = Cast ee co + | otherwise = mkCast ee co evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm -- Dictionary instance application, including when the "dictionary function" ===================================== testsuite/tests/ghci.debugger/scripts/T26042b.stdout ===================================== @@ -22,30 +22,18 @@ _result :: -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, Int #) = _ Stopped in Main.foo, T26042b.hs:14:3-18 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ 13 y = 4 14 n <- bar (x + y) ^^^^^^^^^^^^^^^^ 15 return n -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ Stopped in Main.main, T26042b.hs:5:3-26 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 4 main = do 5 a <- foo False undefined ^^^^^^^^^^^^^^^^^^^^^^^^ 6 print a -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 14 14 ===================================== testsuite/tests/ghci.debugger/scripts/T26042c.stdout ===================================== @@ -1,18 +1,12 @@ Breakpoint 0 activated at T26042c.hs:10:15-22 Stopped in Main.foo, T26042c.hs:10:15-22 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ 9 foo :: Bool -> Int -> IO Int 10 foo True i = return i ^^^^^^^^ 11 foo False _ = do Stopped in Main.main, T26042c.hs:5:3-26 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 4 main = do 5 a <- foo False undefined ^^^^^^^^^^^^^^^^^^^^^^^^ ===================================== testsuite/tests/ghci.debugger/scripts/T26042d2.stdout ===================================== @@ -1,10 +1,7 @@ Breakpoint 0 activated at T26042d2.hs:11:3-21 hello1 Stopped in Main.f, T26042d2.hs:11:3-21 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 10 f = do 11 putStrLn "hello2.1" ^^^^^^^^^^^^^^^^^^^ ===================================== testsuite/tests/ghci.debugger/scripts/T26042f2.stdout ===================================== @@ -1,6 +1,6 @@ Breakpoint 0 activated at T26042f.hs:(20,7)-(21,14) Stopped in T8.t, T26042f.hs:(20,7)-(21,14) -_result :: Int = _ +_result :: Identity Int = _ x :: Int = 450 19 t :: Int -> Identity Int vv @@ -18,12 +18,12 @@ _result :: Identity Int = _ ^^^^^^^^^^^^ 15 n <- pure (a+a) Stopped in T8.f, T26042f.hs:8:3-14 -_result :: Identity Int = _ +_result :: Int = _ x :: Int = 15 7 f x = do 8 b <- g (x*x) ^^^^^^^^^^^^ 9 y <- pure (b+b) x :: Int = 15 -_result :: Identity Int = _ +_result :: Int = _ 7248 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed30e6b8700c1f412cc0ef53b24800… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed30e6b8700c1f412cc0ef53b24800… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] NCG for PPC: add pattern for CmmRegOff to iselExpr64
by Marge Bot (＠marge-bot) 30 Jan '26

30 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 43d97761 by Michael Karcher at 2026-01-29T19:49:43-05:00 NCG for PPC: add pattern for CmmRegOff to iselExpr64 Closes #26828 - - - - - 1 changed file: - compiler/GHC/CmmToAsm/PPC/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -338,6 +338,8 @@ iselExpr64 (CmmReg (CmmLocal local_reg)) = do let Reg64 hi lo = localReg64 local_reg return (RegCode64 nilOL hi lo) +iselExpr64 regoff@(CmmRegOff _ _) = iselExpr64 $ mangleIndexTree regoff + iselExpr64 (CmmLit (CmmInt i _)) = do Reg64 rhi rlo <- getNewReg64 let View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43d977619de65c0cf87695fa5d86f1a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43d977619de65c0cf87695fa5d86f1a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC
by Marge Bot (＠marge-bot) 30 Jan '26

30 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ce2d62fb by Jessica Clarke at 2026-01-29T19:48:51-05:00 PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC There is no native instruction for this, and even if there were a register pair version we could use, the implementation here is assuming the values fit in a single register, and we end up only using / defining the low halves of the registers. Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes") Fixes: #23969 - - - - - 1 changed file: - compiler/GHC/CmmToAsm/PPC/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -180,7 +180,7 @@ stmtToInstrs stmt = do format = cmmTypeFormat ty CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args + -> genCCall platform target result_regs args CmmBranch id -> genBranch id CmmCondBranch arg true false prediction -> do @@ -1183,24 +1183,25 @@ genCondJump id bool prediction = do -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. -genCCall :: ForeignTarget -- function to call +genCCall :: Platform + -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall (PrimTarget MO_AcquireFence) _ _ +genCCall _ (PrimTarget MO_AcquireFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_ReleaseFence) _ _ +genCCall _ (PrimTarget MO_ReleaseFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_SeqCstFence) _ _ +genCCall _ (PrimTarget MO_SeqCstFence) _ _ = return $ unitOL HWSYNC -genCCall (PrimTarget MO_Touch) _ _ +genCCall _ (PrimTarget MO_Touch) _ _ = return $ nilOL -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ +genCCall _ (PrimTarget (MO_Prefetch_Data _)) _ _ = return $ nilOL -genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] +genCCall _ (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do let fmt = intFormat width reg_dst = getLocalRegReg dst (instr, n_code) <- case amop of @@ -1250,7 +1251,7 @@ genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] (n_reg, n_code) <- getSomeReg n return (op dst dst (RIReg n_reg), n_code) -genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] +genCCall _ (PrimTarget (MO_AtomicRead width _)) [dst] [addr] = do let fmt = intFormat width reg_dst = getLocalRegReg dst form = if widthInBits width == 64 then DS else D @@ -1277,12 +1278,12 @@ genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] -- This is also what gcc does. -genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do +genCCall _ (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do code <- assignMem_IntCode (intFormat width) addr val return $ unitOL HWSYNC `appOL` code -genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] - | width == W32 || width == W64 +genCCall platform (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] + | width == W32 || (width == W64 && not (target32Bit platform)) = do (old_reg, old_code) <- getSomeReg old (new_reg, new_code) <- getSomeReg new @@ -1311,9 +1312,8 @@ genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] format = intFormat width -genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Clz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do RegCode64 code vr_hi vr_lo <- iselExpr64 src @@ -1361,9 +1361,8 @@ genCCall (PrimTarget (MO_Clz width)) [dst] [src] let cntlz = unitOL (CNTLZ format reg_dst reg) return $ s_code `appOL` pre `appOL` cntlz `appOL` post -genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Ctz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do let format = II32 @@ -1425,9 +1424,8 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src] , SUBFC dst r' (RIImm (ImmInt (format_bits))) ] -genCCall target dest_regs argsAndHints - = do platform <- getPlatform - case target of +genCCall platform target dest_regs argsAndHints + = do case target of PrimTarget (MO_S_QuotRem width) -> divOp1 True width dest_regs argsAndHints PrimTarget (MO_U_QuotRem width) -> divOp1 False width View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce2d62fba69d2ea0c74c46c50628feb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce2d62fba69d2ea0c74c46c50628feb… You're receiving this email because of your account on gitlab.haskell.org.

1 0