Cheng Shao pushed to branch wip/ci-note-treeless at Glasgow Haskell Compiler / GHC Commits: fe2b79f4 by Recursion Ninja at 2025-12-10T08:34:18-05:00 Narrow before optimising MUL/DIV/REM into shifts The MUL/DIV/REM operations can be optimised into shifts when one of the operands is a constant power of 2. However, as literals in Cmm are stored as 'Integer', for this to be correct we first need to narrow the literal to the appropriate width before checking whether the literal is a power of 2. Fixes #25664 - - - - - 06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00 Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic' - Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type' - Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic' - Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'. - Replace all call sites of the original 'hsQTvExplicit' definition with either: 1. 'hsQTvExplicit' updated definition 2. 'hsQTvExplicitBinders' All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible. These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed. - - - - - f510de08 by Cheng Shao at 2025-12-10T15:55:06+01:00 ci: use treeless fetch for perf notes This patch improves the ci logic for fetching perf notes by using treeless fetch (https://github.blog/open-source/git/get-up-to-speed-with-partial-clone-and-s...), to avoid downloading all blobs of the perf notes repo at once, and only fetch the actually required blobs on-demand when needed. This makes the initial `test-metrics.sh pull` operation much faster, and also more robust, since we are seeing an increasing rate of 504 errors in CI when fetching all perf notes at once, which is a major source of CI flakiness at this point. Co-authored-by: Codex - - - - - 10 changed files: - .gitlab/test-metrics.sh - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Hs/Type.hs - compiler/Language/Haskell/Syntax/Type.hs - + testsuite/tests/cmm/opt/T25664.hs - + testsuite/tests/cmm/opt/T25664.stdout - testsuite/tests/cmm/opt/all.T - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs Changes: ===================================== .gitlab/test-metrics.sh ===================================== @@ -17,12 +17,15 @@ fail() { function pull() { local ref="refs/notes/$REF" - # 2023-10-04: `git fetch` started failing, first on Darwin in CI and then on - # Linux locally, both using git version 2.40.1. See #24055. One workaround is - # to set a larger http.postBuffer, although this is definitely a workaround. - # The default should work just fine. The error could be in git, GitLab, or - # perhaps the networking tube (including all proxies etc) between the two. - run git -c http.postBuffer=2097152 fetch -f "$NOTES_ORIGIN" "$ref:$ref" + + # Fetch performance notes from a dedicated promisor remote using a + # treeless filter, so that individual note blobs are fetched lazily + # as needed. + git remote add perf-notes "$NOTES_ORIGIN" || true + git config fetch.recurseSubmodules false + git config remote.perf-notes.promisor true + git config remote.perf-notes.partialclonefilter tree:0 + run git fetch --force perf-notes "$ref:$ref" echo "perf notes ref $ref is $(git rev-parse $ref)" } @@ -81,4 +84,3 @@ case $1 in pull) pull ;; *) fail "Invalid mode $1" ;; esac - ===================================== compiler/GHC/Cmm/Opt.hs ===================================== @@ -395,26 +395,39 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))] one = CmmLit (CmmInt 1 (wordWidth platform)) -- Now look for multiplication/division by powers of 2 (integers). - -cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))] +-- +-- Naively this is as simple a matter as left/right bit shifts, +-- but the Cmm representation if integral values quickly complicated the matter. +-- +-- We must carefully narrow the value to be within the range of values for the +-- type's logical bit-width. However, Cmm only represents values as *signed* +-- integers internally yet the logical type may be unsigned. If we are dealing +-- with a negative integer type at width @_w@, the only negative number that +-- wraps around to be a positive power of 2 after calling narrowU is -2^(_w - 1) +-- which wraps round to 2^(_w - 1), and multiplying by -2^(_w - 1) is indeed +-- the same as a left shift by (w - 1), so this is OK. +-- +-- ToDo: See #25664 (comment 605821) describing a change to the Cmm literal representation. +-- When/If this is completed, this code must be refactored to account for the explicit width sizes. +cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _w))] = case mop of MO_Mul rep - | Just p <- exactLog2 n -> + | Just p <- exactLog2 (narrowU rep n) -> Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) MO_U_Quot rep - | Just p <- exactLog2 n -> + | Just p <- exactLog2 (narrowU rep n) -> Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)]) MO_U_Rem rep - | Just _ <- exactLog2 n -> + | Just _ <- exactLog2 (narrowU rep n) -> Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)]) MO_S_Quot rep - | Just p <- exactLog2 n, + | Just p <- exactLog2 (narrowS rep n), CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require -- it is a reg. FIXME: remove this restriction. Just $! (cmmMachOpFold platform (MO_S_Shr rep) [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)]) MO_S_Rem rep - | Just p <- exactLog2 n, + | Just p <- exactLog2 (narrowS rep n), CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require -- it is a reg. FIXME: remove this restriction. -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p). ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -640,6 +640,9 @@ hsLTyVarName = hsTyVarName . unLoc hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] hsLTyVarNames = mapMaybe hsLTyVarName +hsQTvExplicit :: LHsQTyVars (GhcPass p) -> [LHsTyVarBndr (HsBndrVis (GhcPass p)) (GhcPass p)] +hsQTvExplicit = hsq_explicit + hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)] hsForAllTelescopeBndrs (HsForAllVis _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -55,7 +55,6 @@ module Language.Haskell.Syntax.Type ( FieldOcc(..), LFieldOcc, mapHsOuterImplicit, - hsQTvExplicit, isHsKindedTyVar ) where @@ -68,7 +67,6 @@ import Language.Haskell.Syntax.Specificity import GHC.Hs.Doc (LHsDoc) import GHC.Data.FastString (FastString) -import GHC.Utils.Panic( panic ) import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Maybe @@ -326,10 +324,6 @@ data LHsQTyVars pass -- See Note [HsType binders] } | XLHsQTyVars !(XXLHsQTyVars pass) -hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass] -hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs -hsQTvExplicit (XLHsQTyVars {}) = panic "hsQTvExplicit" - ------------------------------------------------ -- HsOuterTyVarBndrs -- Used to quantify the outermost type variable binders of a type that obeys ===================================== testsuite/tests/cmm/opt/T25664.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -O -fno-full-laziness #-} +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import GHC.Int + +mb8 :: Int8 -> Int8 +{-# OPAQUE mb8 #-} +mb8 (I8# i) = I8# (i `quotInt8#` (noinline intToInt8# 128#)) + +mb16 :: Int16 -> Int16 +{-# OPAQUE mb16 #-} +mb16 (I16# i) = I16# (i `quotInt16#` (noinline intToInt16# 32768#)) + +main :: IO () +main = print (mb8 minBound) >> print (mb16 minBound) + ===================================== testsuite/tests/cmm/opt/T25664.stdout ===================================== @@ -0,0 +1,2 @@ +1 +1 ===================================== testsuite/tests/cmm/opt/all.T ===================================== @@ -12,3 +12,6 @@ test('T25771', [cmm_src, only_ways(['optasm']), grep_errmsg(r'(12\.345|0\.6640625)',[1]), ], compile, ['-ddump-cmm']) + +# Cmm should correctly account for word size when performing MUL/DIV/REM by a power of 2 optimization. +test('T25664', normal, compile_and_run, ['']) \ No newline at end of file ===================================== utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs ===================================== @@ -435,7 +435,7 @@ ppFamHeader | associated = id | otherwise = (<+> keyword "family") - famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) + famName = ppAppDocNameTyVarBndrs unicode name (hsQTvExplicitBinders tvs) famSig = case result of NoSig _ -> empty @@ -644,7 +644,7 @@ ppTyVars :: RenderableBndrFlag flag => Bool -> [LHsTyVarBndr flag DocNameI] -> [ ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs tyvarNames :: LHsQTyVars DocNameI -> [Maybe Name] -tyvarNames = map (fmap getName . hsLTyVarNameI) . hsQTvExplicit +tyvarNames = map (fmap getName . hsLTyVarNameI) . hsQTvExplicitBinders declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX declWithDoc decl doc = ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -468,7 +468,7 @@ ppTySyn hdr = hsep ( [keyword "type", ppBinder summary occ] - ++ ppTyVars unicode qual (hsQTvExplicit ltyvars) + ++ ppTyVars unicode qual (hsQTvExplicitBinders ltyvars) ) full = hdr <+> def def = case unLoc ltype of @@ -595,7 +595,7 @@ ppFamHeader qual = hsep [ ppFamilyLeader associated info - , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs) + , ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicitBinders tvs) , ppResultSig result unicode qual , injAnn , whereBit @@ -760,7 +760,7 @@ ppClassHdr ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) - <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) + <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicitBinders tvs) <+> ppFds fds unicode qual ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html @@ -1656,7 +1656,7 @@ ppDataHeader ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b - ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs) + ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicitBinders tvs) <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -333,9 +333,12 @@ lHsQTyVarsToTypes tvs = [ HsValArg noExtField $ noLocA (case hsLTyVarName tv of Nothing -> HsWildCardTy noExtField Just nm -> HsTyVar noAnn NotPromoted (noLocA $ noUserRdr nm)) - | tv <- hsQTvExplicit tvs + | tv <- hsq_explicit tvs ] +hsQTvExplicitBinders :: LHsQTyVars DocNameI -> [LHsTyVarBndr (HsBndrVis DocNameI) DocNameI] +hsQTvExplicitBinders = hsq_explicit + -------------------------------------------------------------------------------- -- * Making abstract declarations View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/81ecc47698539ef7480d7cb831c26e3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/81ecc47698539ef7480d7cb831c26e3... You're receiving this email because of your account on gitlab.haskell.org.