Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d4b1e353 by Simon Hengel at 2025-12-10T00:00:02-05:00 Fix syntax error in gadt_syntax.rst - - - - - 91cc8be6 by Cheng Shao at 2025-12-10T00:00:43-05:00 ci: fix "ci.sh clean" to address frequent out of space error on windows runners This patch fixes the `ci.sh clean` logic to address frequent out of space error on windows runners; previously it didn't clean up the inplace mingw blobs, which is the largest source of space leak on windows runners. See added comment for detailed explanation. - - - - - ea311591 by Recursion Ninja at 2025-12-10T00:33:12-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 - - - - - 935c9d27 by Recursion Ninja at 2025-12-10T00:33:12-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. - - - - - 12 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Hs/Type.hs - compiler/Language/Haskell/Syntax/Type.hs - docs/users_guide/exts/gadt_syntax.rst - + 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/ci.sh ===================================== @@ -275,7 +275,7 @@ function setup() { function fetch_ghc() { local should_fetch=false - + if [ ! -e "$GHC" ]; then if [ -z "${FETCH_GHC_VERSION:-}" ]; then fail "GHC not found at '$GHC' and FETCH_GHC_VERSION is not set" @@ -292,7 +292,7 @@ function fetch_ghc() { fi fi fi - + if [ "$should_fetch" = true ]; then local v="$FETCH_GHC_VERSION" @@ -887,8 +887,28 @@ function save_cache () { } function clean() { - rm -R tmp - run rm -Rf _build + # When CI_DISPOSABLE_ENVIRONMENT is not true (e.g. using shell + # executor on windows/macos), the project directory is not removed + # by gitlab runner automatically after each job. To mitigate the + # space leak, other than periodic cleaning on the runner host, we + # also must aggressively cleanup build products, otherwise we run + # into out of space errors too frequently. + # + # When CI_DISPOSABLE_ENVIRONMENT is true (using docker executor on + # linux), the runner will do proper cleanup, so no need to do + # anything here. + # + # The exclude list are the artifacts that we do expect to be + # uploaded. Keep in sync with `jobArtifacts` in + # `.gitlab/generate-ci/gen_ci.hs`! + if [[ "${CI_DISPOSABLE_ENVIRONMENT:-}" != true ]]; then + git submodule foreach --recursive git clean -xdf + git clean -xdf \ + --exclude=ci_timings.txt \ + --exclude=ghc-*.tar.xz \ + --exclude=junit.xml \ + --exclude=unexpected-test-output.tar.gz + fi } function run_hadrian() { ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -889,6 +889,8 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } , if testsuiteUsePerf buildConfig then "RUNTEST_ARGS" =: "--config perf_path=perf" else mempty ] + -- Keep in sync with the exclude list in `function clean()` in + -- `.gitlab/ci.sh`! jobArtifacts = Artifacts { junitReport = "junit.xml" , expireIn = "2 weeks" ===================================== 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 ===================================== docs/users_guide/exts/gadt_syntax.rst ===================================== @@ -387,6 +387,6 @@ type declarations. :: - infix 6 (:--:) + infix 6 :--: data T a where (:--:) :: Int -> Bool -> T Int ===================================== 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/82f7fa00ae0332b56b7c84dab54fc1d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82f7fa00ae0332b56b7c84dab54fc1d... You're receiving this email because of your account on gitlab.haskell.org.