GitLab

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-shallow-clone),
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 <codex@openai.com>

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

 +{-# 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

	1	+1
	2	+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