December 2025 - ghc-commits

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Narrow before optimising MUL/DIV/REM into shifts
by Marge Bot (＠marge-bot) 10 Dec '25

10 Dec '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job 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. - - - - - 97db2d98 by sheaf at 2025-12-10T11:39:08-05:00 Quantify arg before mult in function arrows As noted in #23764, we expect quantification order to be left-to-right, so that in a type such as a %m -> b the inferred quantification order should be [a, m, b] and not [m, a, b]. This was addressed in commit d31fbf6c, but that commit failed to update some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType. This affects Haddock, as whether we print an explicit forall or not depends on whether the inferred quantification order matches the actual quantification order. - - - - - f8252a5a by sheaf at 2025-12-10T11:39:08-05:00 Haddock: improvements to ty-var quantification This commit makes several improvements to how Haddock deals with the quantification of type variables: 1. In pattern synonyms, Haddock used to jumble up universal and existential quantification. That is now fixed, fixing #26252. Tested in the 'PatternSyns2' haddock-html test. 2. The logic for computing whether to use an explicit kind annotation for a type variable quantified in a forall was not even wrong. This commit improves the heuristic, but it will always remain an imperfect heuristic (lest we actually run kind inference again). In the future (#26271), we hope to avoid reliance on this heuristic. - - - - - 28deff1e by Teo Camarasu at 2025-12-10T11:39:09-05:00 Add explicit export list to GHC.Num Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625 - - - - - 26 changed files: - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/Language/Haskell/Syntax/Type.hs - libraries/base/src/GHC/Num.hs - + testsuite/tests/cmm/opt/T25664.hs - + testsuite/tests/cmm/opt/T25664.stdout - testsuite/tests/cmm/opt/all.T - 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 - 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/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/html-test/ref/Bug1050.html - utils/haddock/html-test/ref/LinearTypes.html - utils/haddock/html-test/ref/PatternSyns.html - + utils/haddock/html-test/ref/PatternSyns2.html - utils/haddock/html-test/ref/TypeOperators.html - + utils/haddock/html-test/src/PatternSyns2.hs - utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex Changes: ===================================== 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/Core/TyCo/FVs.hs ===================================== @@ -635,7 +635,9 @@ tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_v -- See Note [Free vars and synonyms] tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc -tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc +tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = + -- As per #23764, if we have 'a %m -> b', quantification order should be [a,m,b] not [m,a,b]. + (tyCoFVsOfType arg `unionFV` tyCoFVsOfType w `unionFV` tyCoFVsOfType res) f bound_vars acc tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc @@ -958,7 +960,9 @@ invisibleVarsOfType = go = go ty' go (TyVarTy v) = go (tyVarKind v) go (AppTy f a) = go f `unionFV` go a - go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 + go (FunTy _ w ty1 ty2) = + -- As per #23764, order is: arg, mult, res. + go ty1 `unionFV` go w `unionFV` go ty2 go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` invisibleVarsOfTypes visibles where (invisibles, visibles) = partitionInvisibleTypes tc tys ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1984,7 +1984,9 @@ foldTyCo (TyCoFolder { tcf_view = view go_ty _ (LitTy {}) = mempty go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co go_ty env (CoercionTy co) = go_co env co - go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res + go_ty env (FunTy _ w arg res) = + -- As per #23764, ordering is [arg, w, res]. + go_ty env arg `mappend` go_ty env w `mappend` go_ty env res go_ty env (TyConApp _ tys) = go_tys env tys go_ty env (ForAllTy (Bndr tv vis) inner) = let !env' = tycobinder env tv vis -- Avoid building a thunk here ===================================== 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/GHC/Tc/Utils/TcMType.hs ===================================== @@ -1432,7 +1432,7 @@ collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty -- Uses accumulating-parameter style go dv (AppTy t1 t2) = foldlM go dv [t1, t2] go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys - go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] + go dv (FunTy _ w arg res) = foldlM go dv [arg, w, res] go dv (LitTy {}) = return dv go dv (CastTy ty co) = do { dv1 <- go dv ty ; collect_cand_qtvs_co orig_ty cur_lvl bound dv1 co } ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -1009,8 +1009,8 @@ tcTyFamInstsAndVisX = go go _ (LitTy {}) = [] go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) ++ go is_invis_arg ty - go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w - ++ go is_invis_arg ty1 + go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg ty1 + ++ go is_invis_arg w ++ go is_invis_arg ty2 go is_invis_arg ty@(AppTy _ _) = let (ty_head, ty_args) = splitAppTys ty ===================================== 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 ===================================== libraries/base/src/GHC/Num.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# OPTIONS_HADDOCK not-home #-} -- | @@ -16,11 +17,190 @@ module GHC.Num ( Num(..) , subtract , quotRemInteger - , module GHC.Num.Integer - , module GHC.Num.Natural + , integerFromNatural + , integerToNaturalClamp + , integerToNaturalThrow + , integerToNatural + , integerToWord# + , integerToInt# + , integerToWord64# + , integerToInt64# + , integerAdd + , integerMul + , integerSub + , integerNegate + , integerAbs + , integerPopCount# + , integerQuot + , integerRem + , integerDiv + , integerMod + , integerDivMod# + , integerQuotRem# + , integerEncodeFloat# + , integerEncodeDouble# + , integerGcd + , integerLcm + , integerAnd + , integerOr + , integerXor + , integerComplement + , integerBit# + , integerTestBit# + , integerShiftL# + , integerShiftR# + , integerFromWord# + , integerFromWord64# + , integerFromInt64# + , Integer(..) + , integerBit + , integerCheck + , integerCheck# + , integerCompare + , integerDecodeDouble# + , integerDivMod + , integerEncodeDouble + , integerEq + , integerEq# + , integerFromAddr + , integerFromAddr# + , integerFromBigNat# + , integerFromBigNatNeg# + , integerFromBigNatSign# + , integerFromByteArray + , integerFromByteArray# + , integerFromInt + , integerFromInt# + , integerFromWord + , integerFromWordList + , integerFromWordNeg# + , integerFromWordSign# + , integerGcde + , integerGcde# + , integerGe + , integerGe# + , integerGt + , integerGt# + , integerIsNegative + , integerIsNegative# + , integerIsOne + , integerIsPowerOf2# + , integerIsZero + , integerLe + , integerLe# + , integerLog2 + , integerLog2# + , integerLogBase + , integerLogBase# + , integerLogBaseWord + , integerLogBaseWord# + , integerLt + , integerLt# + , integerNe + , integerNe# + , integerOne + , integerPowMod# + , integerQuotRem + , integerRecipMod# + , integerShiftL + , integerShiftR + , integerSignum + , integerSignum# + , integerSizeInBase# + , integerSqr + , integerTestBit + , integerToAddr + , integerToAddr# + , integerToBigNatClamp# + , integerToBigNatSign# + , integerToInt + , integerToMutableByteArray + , integerToMutableByteArray# + , integerToWord + , integerZero + , naturalToWord# + , naturalPopCount# + , naturalShiftR# + , naturalShiftL# + , naturalAdd + , naturalSub + , naturalSubThrow + , naturalSubUnsafe + , naturalMul + , naturalQuotRem# + , naturalQuot + , naturalRem + , naturalAnd + , naturalAndNot + , naturalOr + , naturalXor + , naturalTestBit# + , naturalBit# + , naturalGcd + , naturalLcm + , naturalLog2# + , naturalLogBaseWord# + , naturalLogBase# + , naturalPowMod + , naturalSizeInBase# + , Natural(..) + , naturalBit + , naturalCheck + , naturalCheck# + , naturalClearBit + , naturalClearBit# + , naturalCompare + , naturalComplementBit + , naturalComplementBit# + , naturalEncodeDouble# + , naturalEncodeFloat# + , naturalEq + , naturalEq# + , naturalFromAddr + , naturalFromAddr# + , naturalFromBigNat# + , naturalFromByteArray# + , naturalFromWord + , naturalFromWord# + , naturalFromWord2# + , naturalFromWordList + , naturalGe + , naturalGe# + , naturalGt + , naturalGt# + , naturalIsOne + , naturalIsPowerOf2# + , naturalIsZero + , naturalLe + , naturalLe# + , naturalLog2 + , naturalLogBase + , naturalLogBaseWord + , naturalLt + , naturalLt# + , naturalNe + , naturalNe# + , naturalNegate + , naturalOne + , naturalPopCount + , naturalQuotRem + , naturalSetBit + , naturalSetBit# + , naturalShiftL + , naturalShiftR + , naturalSignum + , naturalSqr + , naturalTestBit + , naturalToAddr + , naturalToAddr# + , naturalToBigNat# + , naturalToMutableByteArray# + , naturalToWord + , naturalToWordClamp + , naturalToWordClamp# + , naturalToWordMaybe# + , naturalZero ) where import GHC.Internal.Num -import GHC.Num.Integer -import GHC.Num.Natural ===================================== 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 ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -8351,7 +8351,7 @@ module GHC.Natural where xorNatural :: Natural -> Natural -> Natural module GHC.Num where - -- Safety: None + -- Safety: Safe-Inferred type Integer :: * data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray# type Natural :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -11397,7 +11397,7 @@ module GHC.Natural where xorNatural :: Natural -> Natural -> Natural module GHC.Num where - -- Safety: None + -- Safety: Safe-Inferred type Integer :: * data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray# type Natural :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -8569,7 +8569,7 @@ module GHC.Natural where xorNatural :: Natural -> Natural -> Natural module GHC.Num where - -- Safety: None + -- Safety: Safe-Inferred type Integer :: * data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray# type Natural :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -8351,7 +8351,7 @@ module GHC.Natural where xorNatural :: Natural -> Natural -> Natural module GHC.Num where - -- Safety: None + -- Safety: Safe-Inferred type Integer :: * data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray# type Natural :: * ===================================== 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/Convert.hs ===================================== @@ -29,7 +29,7 @@ module Haddock.Convert import Control.DeepSeq (force) import Data.Either (lefts, partitionEithers, rights) -import Data.Maybe (catMaybes, mapMaybe, maybeToList) +import Data.Maybe (catMaybes, mapMaybe) import GHC.Builtin.Names ( boxedRepDataConKey , eqTyConKey @@ -140,7 +140,7 @@ tyThingToLHsDecl prr t = case t of hsq_explicit $ fdTyVars fd , feqn_fixity = fdFixity fd - , feqn_rhs = synifyType WithinType [] rhs + , feqn_rhs = synifyType WithinType emptyVarSet rhs } extractAtItem @@ -179,7 +179,7 @@ tyThingToLHsDecl prr t = case t of noLocA (MinimalSig (noAnn, NoSourceText) . noLocA $ classMinimalDef cl) : [ noLocA tcdSig | clsOp <- classOpItems cl - , tcdSig <- synifyTcIdSig vs clsOp + , tcdSig <- synifyTcIdSig (mkVarSet vs) clsOp ] , tcdMeths = [] -- ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: @@ -213,9 +213,9 @@ synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch{cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs}) = let name = synifyNameN tc args_types_only = filterOutInvisibleTypes tc args - typats = map (synifyType WithinType []) args_types_only + typats = map (synifyType WithinType emptyVarSet) args_types_only annot_typats = zipWith3 annotHsType args_poly args_types_only typats - hs_rhs = synifyType WithinType [] rhs + hs_rhs = synifyType WithinType emptyVarSet rhs outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} in -- TODO: this must change eventually FamEqn @@ -344,7 +344,7 @@ synifyTyCon _prr coax tc , tcdLName = synifyNameN tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = synifyFixity tc - , tcdRhs = synifyType WithinType [] ty + , tcdRhs = synifyType WithinType emptyVarSet ty } -- (closed) newtype and data | otherwise = do @@ -578,8 +578,8 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith ( \(Scaled mult ty) (HsSrcBang st unp str) -> - let tySyn = synifyType WithinType [] ty - multSyn = synifyMultRec [] mult + let tySyn = synifyType WithinType emptyVarSet ty + multSyn = synifyMultRec emptyVarSet mult in CDF (noAnn, st) unp str multSyn tySyn Nothing ) arg_tys @@ -620,7 +620,7 @@ synifyDataCon use_gadt_syntax dc = , con_inner_bndrs = inner_bndrs , con_mb_cxt = ctx , con_g_args = hat - , con_res_ty = synifyType WithinType [] res_ty + , con_res_ty = synifyType WithinType emptyVarSet res_ty , con_doc = Nothing } else do @@ -657,11 +657,11 @@ synifyIdSig -> SynifyTypeState -- ^ what to do with a 'forall' -> [TyVar] - -- ^ free variables in the type to convert + -- ^ type variables bound from an outer scope -> Id -- ^ the 'Id' from which to get the type signature -> Sig GhcRn -synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t) +synifyIdSig prr s boundTvs i = TypeSig noAnn [n] (synifySigWcType s boundTvs t) where !n = force $ synifyNameN i t = defaultType prr (varType i) @@ -669,18 +669,18 @@ synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t) -- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going -- to contain the synified 'ClassOpSig' as well (when appropriate) a default -- 'ClassOpSig'. -synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] -synifyTcIdSig vs (i, dm) = +synifyTcIdSig :: TyVarSet -> ClassOpItem -> [Sig GhcRn] +synifyTcIdSig boundTvs (i, dm) = [ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i))] ++ [ ClassOpSig noAnn True [noLocA dn] (defSig dt) | Just (dn, GenericDM dt) <- [dm] ] where - mainSig t = synifySigType DeleteTopLevelQuantification vs t - defSig t = synifySigType ImplicitizeForAll vs t + mainSig t = synifySigType DeleteTopLevelQuantification boundTvs t + defSig t = synifySigType ImplicitizeForAll boundTvs t synifyCtx :: [PredType] -> LHsContext GhcRn -synifyCtx ts = noLocA (map (synifyType WithinType []) ts) +synifyCtx ts = noLocA (map (synifyType WithinType emptyVarSet) ts) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = @@ -699,7 +699,7 @@ synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv -- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind --- signatures (even if they don't have the lifted type kind). +-- signatures (even if they don't have kind 'Type'). synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn synify_ty_var no_kinds flag tv = noLocA (HsTvb noAnn flag bndr_var bndr_kind) @@ -726,7 +726,7 @@ annotHsType _ _ hs_ty@(L _ (HsKindSig{})) = hs_ty annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty - hs_ki = synifyType WithinType [] ki + hs_ki = synifyType WithinType emptyVarSet ki in noLocA (HsKindSig noAnn hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty @@ -768,14 +768,15 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! DeleteTopLevelQuantification -synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn +synifySigType :: SynifyTypeState -> TyVarSet -> Type -> LHsSigType GhcRn -- The use of mkEmptySigType (which uses empty binders in OuterImplicit) -- is a bit suspicious; what if the type has free variables? -synifySigType s vs ty = mkEmptySigType (synifyType s vs ty) +synifySigType s boundTvs ty = mkEmptySigType (synifyType s boundTvs ty) synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s vs ty)) +synifySigWcType s vs ty = + mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s (mkVarSet vs) ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) @@ -791,13 +792,13 @@ defaultType HideRuntimeRep = defaultRuntimeRepVars synifyType :: SynifyTypeState -- ^ what to do with a 'forall' - -> [TyVar] - -- ^ free variables in the type to convert + -> TyVarSet + -- ^ bound type variables -> Type -- ^ the type to convert -> LHsType GhcRn synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (noUserRdr $ getName tv) -synifyType _ vs (TyConApp tc tys) = +synifyType _ boundTvs (TyConApp tc tys) = maybe_sig res_ty where res_ty :: LHsType GhcRn @@ -819,24 +820,24 @@ synifyType _ vs (TyConApp tc tys) = ConstraintTuple -> HsBoxedOrConstraintTuple UnboxedTuple -> HsUnboxedTuple ) - (map (synifyType WithinType vs) vis_tys) + (map (synifyType WithinType boundTvs) vis_tys) | isUnboxedSumTyCon tc = - noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys) + noLocA $ HsSumTy noAnn (map (synifyType WithinType boundTvs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys = - noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType vs) vis_tys) + noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType boundTvs) vis_tys) -- ditto for lists | getName tc == listTyConName , [ty] <- vis_tys = - noLocA $ HsListTy noAnn (synifyType WithinType vs ty) + noLocA $ HsListTy noAnn (synifyType WithinType boundTvs ty) | tc == promotedNilDataCon , [] <- vis_tys = noLocA $ HsExplicitListTy noExtField IsPromoted [] | tc == promotedConsDataCon , [ty1, ty2] <- vis_tys = - let hTy = synifyType WithinType vs ty1 - in case synifyType WithinType vs ty2 of + let hTy = synifyType WithinType boundTvs ty1 + in case synifyType WithinType boundTvs ty2 of tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') @@ -846,7 +847,7 @@ synifyType _ vs (TyConApp tc tys) = | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name = - noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty) + noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType boundTvs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = @@ -854,9 +855,9 @@ synifyType _ vs (TyConApp tc tys) = HsOpTy noExtField NotPromoted - (synifyType WithinType vs ty1) + (synifyType WithinType boundTvs ty1) (noLocA $ noUserRdr eqTyConName) - (synifyType WithinType vs ty2) + (synifyType WithinType boundTvs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1 : ty2 : tys_rest <- vis_tys = @@ -864,9 +865,9 @@ synifyType _ vs (TyConApp tc tys) = ( HsOpTy noExtField prom - (synifyType WithinType vs ty1) + (synifyType WithinType boundTvs ty1) (noLocA $ noUserRdr $ getName tc) - (synifyType WithinType vs ty2) + (synifyType WithinType boundTvs ty2) ) tys_rest -- Most TyCons: @@ -880,7 +881,7 @@ synifyType _ vs (TyConApp tc tys) = foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) (noLocA ty_app) - ( map (synifyType WithinType vs) $ + ( map (synifyType WithinType boundTvs) $ filterOut isCoercionTy ty_args ) @@ -891,56 +892,57 @@ synifyType _ vs (TyConApp tc tys) = maybe_sig ty' | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) - full_kind' = synifyType WithinType vs full_kind + full_kind' = synifyType WithinType boundTvs full_kind in noLocA $ HsKindSig noAnn ty' full_kind' | otherwise = ty' -synifyType _ vs ty@(AppTy{}) = +synifyType _ boundTvs ty@(AppTy{}) = let (ty_head, ty_args) = splitAppTys ty - ty_head' = synifyType WithinType vs ty_head + ty_head' = synifyType WithinType boundTvs ty_head ty_args' = - map (synifyType WithinType vs) $ + map (synifyType WithinType boundTvs) $ filterOut isCoercionTy $ filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args) ty_args in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args' -synifyType s vs funty@(FunTy af w t1 t2) - | isInvisibleFunArg af = synifySigmaType s vs funty +synifyType s boundTvs funty@(FunTy af w t1 t2) + | isInvisibleFunArg af = synifySigmaType s boundTvs funty | otherwise = noLocA $ HsFunTy noExtField w' s1 s2 where - s1 = synifyType WithinType vs t1 - s2 = synifyType WithinType vs t2 - w' = synifyMultArrow vs w -synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = + s1 = synifyType WithinType boundTvs t1 + s2 = synifyType WithinType boundTvs t2 + w' = synifyMultArrow boundTvs w +synifyType s boundTvs forallty@(ForAllTy (Bndr _ argf) _ty) = case argf of - Required -> synifyVisForAllType vs forallty - Invisible _ -> synifySigmaType s vs forallty + Required -> synifyVisForAllType boundTvs forallty + Invisible _ -> synifySigmaType s boundTvs forallty synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t -synifyType s vs (CastTy t _) = synifyType s vs t +synifyType s boundTvs (CastTy t _) = synifyType s boundTvs t synifyType _ _ (CoercionTy{}) = error "synifyType:Coercion" -- | Process a 'Type' which starts with a visible @forall@ into an 'HsType' synifyVisForAllType - :: [TyVar] - -- ^ free variables in the type to convert + :: TyVarSet + -- ^ bound type variables -> Type -- ^ the forall type to convert -> LHsType GhcRn -synifyVisForAllType vs ty = +synifyVisForAllType boundTvs ty = let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty - sTvs = map synifyTyVarBndr tvs + sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs + noKindSigTvs = noKindSigTyVars ty -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall - tvs' = orderedFVs (mkVarSet vs) [rho] + tvs' = orderedFVs boundTvs [rho] in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn sTvs , hst_xforall = noExtField - , hst_body = synifyType WithinType (tvs' ++ vs) rho + , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs') rho } -- | Process a 'Type' which starts with an invisible @forall@ or a constraint @@ -948,18 +950,18 @@ synifyVisForAllType vs ty = synifySigmaType :: SynifyTypeState -- ^ what to do with the 'forall' - -> [TyVar] - -- ^ free variables in the type to convert + -> TyVarSet + -- ^ bound type variables -> Type -- ^ the forall type to convert -> LHsType GhcRn -synifySigmaType s vs ty = +synifySigmaType s boundTvs ty = let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField - , hst_body = synifyType WithinType (tvs' ++ vs) tau + , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs' ) tau } sTy = @@ -969,49 +971,56 @@ synifySigmaType s vs ty = , hst_body = noLocA sPhi } - sTvs = map synifyTyVarBndr tvs + sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs + + noKindSigTvs = noKindSigTyVars ty -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall - tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) + tvs' = orderedFVs boundTvs (ctx ++ [tau]) in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (extendVarSetList boundTvs tvs') tau -- Put a forall in if there are any type variables WithinType | not (null tvs) -> noLocA sTy | otherwise -> noLocA sPhi - ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau + ImplicitizeForAll -> implicitForAll boundTvs tvs ctx (synifyType WithinType) tau --- | Put a forall in if there are any type variables which require --- explicit kind annotations or if the inferred type variable order --- would be different. +-- | Use an explicit forall if there are any type variables which require +-- explicit kind annotations or if the inferred type variable quantification +-- order would be different. implicitForAll - :: [TyCon] - -- ^ type constructors that determine their args kinds - -> [TyVar] - -- ^ free variables in the type to convert + :: TyVarSet + -- ^ bound type variables (e.g. bound from an outer scope) -> [InvisTVBinder] -- ^ type variable binders in the forall -> ThetaType -- ^ constraints right after the forall - -> ([TyVar] -> Type -> LHsType GhcRn) + -> (TyVarSet -> Type -> LHsType GhcRn) -- ^ how to convert the inner type -> Type -- ^ inner type -> LHsType GhcRn -implicitForAll tycons vs tvs ctx synInner tau - | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy - | tvs' /= (binderVars tvs) = noLocA sTy - | otherwise = noLocA sPhi +implicitForAll boundTvs tvbs ctx synInner tau + | any (isHsKindedTyVar . unLoc) sTvs + -- Explicit forall: some type variable needs an explicit kind annotation. + = noLocA sTy + | tvs /= inferredFreeTvs + -- Explicit forall: the inferred quantification order would be different. + = noLocA sTy + | otherwise + -- Implicit forall. + = noLocA sPhi where - sRho = synInner (tvs' ++ vs) tau + tvs = binderVars tvbs + sRho = synInner (extendVarSetList boundTvs inferredFreeTvs) tau sPhi | null ctx = unLoc sRho | otherwise = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField - , hst_body = synInner (tvs' ++ vs) tau + , hst_body = sRho } sTy = HsForAllTy @@ -1020,84 +1029,129 @@ implicitForAll tycons vs tvs ctx synInner tau , hst_body = noLocA sPhi } - no_kinds_needed = noKindTyVars tycons tau - sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs + no_kinds_needed = noKindSigTyVars tau + sTvs = map (synifyTyVarBndr' no_kinds_needed) tvbs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall - tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) + inferredFreeTvs = orderedFVs boundTvs (ctx ++ [tau]) --- | Find the set of type variables whose kind signatures can be properly --- inferred just from their uses in the type signature. This means the type --- variable to has at least one fully applied use @f x1 x2 ... xn@ where: +-- | Returns a subset of the free type variables of the given type whose kinds +-- can definitely be inferred from their occurrences in the type. -- --- * @f@ has a function kind where the arguments have the same kinds --- as @x1 x2 ... xn@. +-- This function is only a simple heuristic, which is used in order to avoid +-- needlessly cluttering Haddocks with explicit foralls that are not needed. +-- This function may return some type variables for which we aren't sure +-- (which will cause us to display the type with an explicit forall, just in +-- case). -- --- * @f@ has a function kind whose final return has lifted type kind -noKindTyVars - :: [TyCon] - -- ^ type constructors that determine their args kinds - -> Type +-- In the future, we hope to address the issue of whether to print a type with +-- an explicit forall by storing whether the user wrote the type with an +-- explicit forall in the first place (see GHC ticket #26271). +noKindSigTyVars + :: Type -- ^ type to inspect -> VarSet - -- ^ set of variables whose kinds can be inferred from uses in the type -noKindTyVars _ (TyVarTy var) - | isLiftedTypeKind (tyVarKind var) = unitVarSet var -noKindTyVars ts ty - | (f, xs) <- splitAppTys ty - , not (null xs) = - let args = map (noKindTyVars ts) xs - func = case f of - TyVarTy var - | (xsKinds, outKind) <- splitFunTys (tyVarKind var) - , map scaledThing xsKinds `eqTypes` map typeKind xs - , isLiftedTypeKind outKind -> - unitVarSet var - TyConApp t ks - | t `elem` ts - , all noFreeVarsOfType ks -> - mkVarSet [v | TyVarTy v <- xs] - _ -> noKindTyVars ts f - in unionVarSets (func : args) -noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t -noKindTyVars ts (FunTy _ w t1 t2) = - noKindTyVars ts w - `unionVarSet` noKindTyVars ts t1 - `unionVarSet` noKindTyVars ts t2 -noKindTyVars ts (CastTy t _) = noKindTyVars ts t -noKindTyVars _ _ = emptyVarSet - -synifyMultArrow :: [TyVar] -> Mult -> HsMultAnn GhcRn -synifyMultArrow vs t = case t of + -- ^ set of variables whose kinds can definitely be inferred from occurrences in the type +noKindSigTyVars ty + | Just ty' <- coreView ty + = noKindSigTyVars ty' + -- In a TyConApp 'T ty_1 ... ty_n', if 'ty_i = tv' is a type variable and the + -- i-th argument of the kind of 'T' is monomorphic, then the kind of 'tv' + -- is fully determined by its occurrence in the TyConApp. + | Just (tc, args) <- splitTyConApp_maybe ty + , let (tcArgBndrs, _tcResKi) = splitPiTys (tyConKind tc) + tcArgKis = map (\case { Named (Bndr b _) -> tyVarKind b; Anon (Scaled _ t) _ -> t}) tcArgBndrs + = mono_tvs tcArgKis args `unionVarSet` (mapUnionVarSet noKindSigTyVars args) + -- If we have 'f ty_1 ... ty_n' where 'f :: ki_1 -> ... -> ki_n -> Type' + -- then we can infer the kind of 'f' from the kinds of its arguments. + -- + -- This special case handles common examples involving functors, monads... + -- with type signatures such as '(a -> b) -> (f a -> f b)'. + | (TyVarTy fun, args) <- splitAppTys ty + , not (null args) + , (funArgKinds, funResKind) <- splitFunTys (tyVarKind fun) + , map scaledThing funArgKinds `eqTypes` map typeKind args + , isLiftedTypeKind funResKind + = ( `extendVarSet` fun ) $ mapUnionVarSet noKindSigTyVars args + where + mono_tvs :: [Type] -> [Type] -> VarSet + mono_tvs (tcArgKi:tcArgKis) (arg:args) + | TyVarTy arg_tv <- arg + , noFreeVarsOfType tcArgKi + = ( `extendVarSet` arg_tv ) $ mono_tvs tcArgKis args + | otherwise + = mono_tvs tcArgKis args + mono_tvs _ _ = emptyVarSet +noKindSigTyVars (ForAllTy _ t) = noKindSigTyVars t +noKindSigTyVars (CastTy t _) = noKindSigTyVars t +noKindSigTyVars _ = emptyVarSet + +synifyMultArrow :: TyVarSet -> Mult -> HsMultAnn GhcRn +synifyMultArrow boundTvs t = case t of OneTy -> HsLinearAnn noExtField ManyTy -> HsUnannotated noExtField - ty -> HsExplicitMult noExtField (synifyType WithinType vs ty) + ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty) -synifyMultRec :: [TyVar] -> Mult -> HsMultAnn GhcRn -synifyMultRec vs t = case t of +synifyMultRec :: TyVarSet -> Mult -> HsMultAnn GhcRn +synifyMultRec boundTvs t = case t of OneTy -> HsUnannotated noExtField - ty -> HsExplicitMult noExtField (synifyType WithinType vs ty) + ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty) synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = - let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps - ts = maybeToList (tyConAppTyCon_maybe res_ty) + let (univ_tvbs, req_theta, ex_tvbs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps + +{- Recall that pattern synonyms have both "required" and "provided" constraints, +e.g. + + pattern P :: forall a b c. req => forall e f g => prov => arg_ty1 -> ... -> res_ty + +Here: + + a, b, c are universal type variables + req are required constraints - -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", - -- i.e., an explicit empty context, which is what we need. This is not - -- possible by taking theta = [], as that will print no context at all + e, f, g are existential type variables + prov are provided constraints + +The first pair comes from the outside, while the second pair is obtained upon +a successful match on the pattern. + +Remarks: + + 1. Both foralls are optional. + + 2. If there is only one =>, we interpret the constraints as required. + Thus, if we want an empty set of required constraints and a non-empty set + of provided constraints, the type signature must be written like + + () => prov => res_ty +-} + + + -- Add an explicit "() => ..." when req_theta is empty but there are + -- existential variables or provided constraints. req_theta' | null req_theta - , not (null prov_theta && null ex_tvs) = + , not (null prov_theta && null ex_tvbs) = [unitTy] | otherwise = req_theta + univ_tvs = mkVarSet $ binderVars univ_tvbs + ex_tvs = mkVarSet $ binderVars ex_tvbs + + in implicitForAll - ts - [] - (univ_tvs ++ ex_tvs) + ex_tvs -- consider the ex_tvs non-free, so that we don't quantify over them here + univ_tvbs -- quantify only over the universals req_theta' - (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType)) + ( \_ -> + implicitForAll + univ_tvs -- the univ_tvs are already bound + ex_tvbs -- quantify only over the existentials + prov_theta + (synifyType WithinType) + ) (mkScaledFunTys arg_tys res_ty) synifyTyLit :: TyLit -> HsTyLit GhcRn @@ -1106,7 +1160,7 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c synifyKindSig :: Kind -> LHsKind GhcRn -synifyKindSig k = synifyType WithinType [] k +synifyKindSig k = synifyType WithinType emptyVarSet k stripKindSig :: LHsType GhcRn -> LHsType GhcRn stripKindSig (L _ (HsKindSig _ t _)) = t @@ -1119,7 +1173,7 @@ synifyInstHead (vs, preds, cls, types) associated_families = , ihdTypes = map unLoc annot_ts , ihdInstType = ClassInst - { clsiCtx = map (unLoc . synifyType WithinType []) preds + { clsiCtx = map (unLoc . synifyType WithinType emptyVarSet) preds , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ specialized_class_methods , clsiAssocTys = @@ -1132,7 +1186,7 @@ synifyInstHead (vs, preds, cls, types) associated_families = where cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types - ts' = map (synifyType WithinType vs) ts + ts' = map (synifyType WithinType $ mkVarSet vs) ts annot_ts = zipWith3 annotHsType args_poly ts ts' args_poly = tyConArgsPolyKinded cls_tycon synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs @@ -1151,7 +1205,7 @@ synifyFamInst fi opaque = do where ityp SynFamilyInst | opaque = return $ TypeInst Nothing ityp SynFamilyInst = - return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs + return . TypeInst . Just . unLoc $ synifyType WithinType emptyVarSet fam_rhs ityp (DataFamilyInst c) = DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c fam_tc = famInstTyCon fi @@ -1173,7 +1227,7 @@ synifyFamInst fi opaque = do fam_lhs ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs - synifyTypes = map (synifyType WithinType []) + synifyTypes = map (synifyType WithinType emptyVarSet) ts' = synifyTypes ts annot_ts = zipWith3 annotHsType args_poly ts ts' args_poly = tyConArgsPolyKinded fam_tc ===================================== 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 @@ -853,8 +856,8 @@ tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c tyCoFVsOfType' (LitTy{}) a b c = emptyFV a b c tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c tyCoFVsOfType' (FunTy _ w arg res) a b c = - ( tyCoFVsOfType' w - `unionFV` tyCoFVsOfType' res + ( tyCoFVsOfType' res + `unionFV` tyCoFVsOfType' w `unionFV` tyCoFVsOfType' arg ) a ===================================== utils/haddock/html-test/ref/Bug1050.html ===================================== @@ -99,11 +99,7 @@ >mkT</a > :: <span class="keyword" >forall</span - > {k} {f :: <span class="keyword" - >forall</span - > k1. k1 -> <a href="#" title="Data.Kind" - >Type</a - >} {a :: k}. f a -> <a href="#" title="Bug1050" + > {k} {f} {a :: k}. f a -> <a href="#" title="Bug1050" >T</a > f a <a href="#" class="selflink" >#</a ===================================== utils/haddock/html-test/ref/LinearTypes.html ===================================== @@ -64,11 +64,7 @@ ><li class="src short" ><a href="#" >poly</a - > :: <span class="keyword" - >forall</span - > a (m :: <a href="#" title="GHC.Exts" - >Multiplicity</a - >) b. a %m -> b</li + > :: a %m -> b</li ><li class="src short" ><span class="keyword" >data</span @@ -163,11 +159,7 @@ ><p class="src" ><a id="v:poly" class="def" >poly</a - > :: <span class="keyword" - >forall</span - > a (m :: <a href="#" title="GHC.Exts" - >Multiplicity</a - >) b. a %m -> b <a href="#" class="selflink" + > :: a %m -> b <a href="#" class="selflink" >#</a ></p ><div class="doc" ===================================== utils/haddock/html-test/ref/PatternSyns.html ===================================== @@ -132,7 +132,9 @@ >pattern</span > <a href="#" >E</a - > :: a <a href="#" title="PatternSyns" + > :: <span class="keyword" + >forall</span + > {k} {a} {b :: k}. a <a href="#" title="PatternSyns" >><</a > b</li ><li class="src short" @@ -335,7 +337,9 @@ >pattern</span > <a id="v:E" class="def" >E</a - > :: a <a href="#" title="PatternSyns" + > :: <span class="keyword" + >forall</span + > {k} {a} {b :: k}. a <a href="#" title="PatternSyns" >><</a > b <a href="#" class="selflink" >#</a ===================================== utils/haddock/html-test/ref/PatternSyns2.html ===================================== @@ -0,0 +1,160 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><meta name="viewport" content="width=device-width, initial-scale=1" + /><title + >PatternSyns2</title + ><link href="#" rel="stylesheet" type="text/css" title="Linuwial" + /><link rel="stylesheet" type="text/css" href="#" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script type="text/x-mathjax-config" + >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-…" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><span class="caption empty" + > </span + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ><tr + ><th + >Language</th + ><td + >Haskell2010</td + ></tr + ></table + ><p class="caption" + >PatternSyns2</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:P1" class="def" + >P1</a + > :: () => <a href="#" title="Prelude" + >Num</a + > a => a -> D <a href="#" title="Prelude" + >Num</a + > a <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:P2" class="def" + >P2</a + > :: <a href="#" title="Prelude" + >Num</a + > a => a -> a <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:P3" class="def" + >P3</a + > :: () => <span class="keyword" + >forall</span + > (e :: <a href="#" title="GHC.Exts" + >TYPE</a + > '<a href="#" title="GHC.Exts" + >DoubleRep</a + >). <span class="breakable" + >(<span class="unbreakable" + >PCIR a</span + >, <span class="unbreakable" + >PCDR e</span + >)</span + > => a -> e -> Q a <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:P4" class="def" + >P4</a + > :: RCIR a => <span class="keyword" + >forall</span + > (e :: <a href="#" title="GHC.Exts" + >TYPE</a + > '<a href="#" title="GHC.Exts" + >DoubleRep</a + >). <span class="breakable" + >(<span class="unbreakable" + >PCIR a</span + >, <span class="unbreakable" + >PCDR e</span + >)</span + > => a -> e -> Q a <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:P5" class="def" + >P5</a + > :: RCIR a => <span class="keyword" + >forall</span + > (e :: <a href="#" title="GHC.Exts" + >TYPE</a + > '<a href="#" title="GHC.Exts" + >DoubleRep</a + >). a -> e -> Q a <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:P" class="def" + >P</a + > :: () => <span class="keyword" + >forall</span + > k (a :: k) b. <a href="#" title="Prelude" + >Show</a + > b => <a href="#" title="Data.Proxy" + >Proxy</a + > a -> b -> A <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ></div + ></body + ></html +> ===================================== utils/haddock/html-test/ref/TypeOperators.html ===================================== @@ -185,17 +185,7 @@ ><p class="src" ><a id="v:biO" class="def" >biO</a - > :: <span class="keyword" - >forall</span - > (g :: <a href="#" title="Data.Kind" - >Type</a - > -> <a href="#" title="Data.Kind" - >Type</a - >) (f :: <a href="#" title="Data.Kind" - >Type</a - > -> <a href="#" title="Data.Kind" - >Type</a - >) a. <a href="#" title="TypeOperators" + > :: <a href="#" title="TypeOperators" >O</a > g f a <a href="#" class="selflink" >#</a ===================================== utils/haddock/html-test/src/PatternSyns2.hs ===================================== @@ -0,0 +1,60 @@ +{-# LANGUAGE Haskell2010 #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module PatternSyns2 + ( pattern P1, pattern P2, pattern P3, pattern P4, pattern P5 + , pattern P + ) + where + +import Data.Kind +import Data.Proxy +import GHC.Exts + +type D :: ( Type -> Constraint ) -> Type -> Type +data D c a where + MkD :: c a => a -> D c a + +pattern P1 :: () => Num a => a -> D Num a +pattern P1 a = MkD a + +pattern P2 :: Num a => () => a -> a +pattern P2 a = a + +type RCIR :: TYPE IntRep -> Constraint +class RCIR a where + +type PCIR :: TYPE IntRep -> Constraint +class PCIR a where + +type PCDR :: TYPE DoubleRep -> Constraint +class PCDR a where + +type Q :: TYPE IntRep -> Type +data Q a where + MkQ :: forall ( a :: TYPE IntRep ) ( e :: TYPE DoubleRep ) + . ( PCIR a, PCDR e ) + => a -> e -> Q a + +pattern P3 :: forall (a :: TYPE IntRep). () => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a +pattern P3 a e = MkQ a e + +pattern P4 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a +pattern P4 a e = MkQ a e + +pattern P5 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). () => a -> e -> Q a +pattern P5 a e <- MkQ a e + + +type A :: Type +data A where + MkA :: forall k (a ::k) b. ( Show b ) => Proxy a -> b -> A + +pattern P :: forall . () => forall k (a :: k) b. ( Show b ) => Proxy a -> b -> A +pattern P a b = MkA a b ===================================== utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex ===================================== @@ -24,7 +24,7 @@ Does something linear.\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -poly :: forall a (m :: Multiplicity) b. a {\char '45}m -> b +poly :: a {\char '45}m -> b \end{tabular}] {\haddockbegindoc Does something polymorphic.\par} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/935c9d27c767695f6839ca005f4b02… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/935c9d27c767695f6839ca005f4b02… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/windows-rts-dll] 6 commits: Add minimal dlltool support to ghc-toolchain
by Duncan Coutts (＠dcoutts) 10 Dec '25

10 Dec '25

Duncan Coutts pushed to branch wip/dcoutts/windows-rts-dll at Glasgow Haskell Compiler / GHC Commits: fd2954cd by Duncan Coutts at 2025-12-10T14:59:29+00:00 Add minimal dlltool support to ghc-toolchain We will need dlltool to build ghc itself dynamically on windows, and probably we will end up needing dlltool for ghc to build Haskell packages dynamically as well. The dlltool is a tool that can create dll import libraries from .def files. These .def files list the exported symbols of dlls. Its somewhat like gnu linker scripts, but more limited. - - - - - df3d4fab by Duncan Coutts at 2025-12-10T14:59:29+00:00 Add minimal dlltool support into ./configure Find dlltool, and hopefully support finding it within the bundled llvm toolchain on windows. - - - - - 0855b657 by Duncan Coutts at 2025-12-10T14:59:29+00:00 Update the default host and target files for dlltool support - - - - - 371dfa49 by Duncan Coutts at 2025-12-10T14:59:29+00:00 Add dlltool as a hadrian builder Optional except on windows. - - - - - 2818cd89 by Duncan Coutts at 2025-12-10T14:59:29+00:00 Update and generate libHSghc-internal.def from .def.in file The only symbol that the rts imports from the ghc-internal package now is init_ghc_hs_iface. So the rts only needs an import lib that defines that one symbol. Also, remove the libHSghc-prim.def because it is redundant. The rts no longer imports anything from ghc-prim. Keep libHSffi.def for now. We may yet need it once it is clear how libffi is going to be built/used for ghc. - - - - - d22ed63b by Duncan Coutts at 2025-12-10T14:59:29+00:00 Add rule to build libHSghc-internal.dll.a and link into the rts On windows only, with dynamic linking. This is needed because on windows, all symbols in dlls must be resolved. No dangling symbols allowed. References to external symbols must be explicit. We resolve this with an import library. We create an import library for ghc-internal, a .dll.a file. This is a static archive containing .o files that define the symbols we need, and crucially have ".idata" sections that specifies the symbols the dll imports and from where. Note that we do not install this libHSghc-internal.dll.a, and it does not need to list all the symbols exported by that package. We create a special purpose import lib and only use it when linking the rts dll, so it only has to list the symbols that the rts uses from ghc-internal (which is exactly one symbol: init_ghc_hs_iface). - - - - - 15 changed files: - configure.ac - hadrian/cfg/default.host.target.in - hadrian/cfg/default.target.in - hadrian/src/Builder.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Rts.hs - m4/fp_setup_windows_toolchain.m4 - m4/ghc_toolchain.m4 - m4/prep_target_file.m4 - − rts/win32/libHSghc-internal.def - + rts/win32/libHSghc-internal.def.in - − rts/win32/libHSghc-prim.def - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs Changes: ===================================== configure.ac ===================================== @@ -320,13 +320,16 @@ else AC_CHECK_TOOL([RANLIB],[ranlib]) AC_CHECK_TOOL([OBJDUMP],[objdump]) AC_CHECK_TOOL([WindresCmd],[windres]) + AC_CHECK_TOOL([DlltoolCmd],[dlltool]) AC_CHECK_TOOL([Genlib],[genlib]) if test "$HostOS" = "mingw32"; then AC_CHECK_TARGET_TOOL([WindresCmd],[windres]) + AC_CHECK_TARGET_TOOL([DlltoolCmd],[dlltool]) AC_CHECK_TARGET_TOOL([OBJDUMP],[objdump]) WindresCmd="$(cygpath -m $WindresCmd)" + DlltoolCmd="$(cygpath -m $DlltoolCmd)" if test "$Genlib" != ""; then GenlibCmd="$(cygpath -m $Genlib)" @@ -1042,6 +1045,7 @@ echo "\ otool : $OtoolCmd install_name_tool : $InstallNameToolCmd windres : $WindresCmd + dlltool : $DlltoolCmd genlib : $GenlibCmd Happy : $HappyCmd ($HappyVersion) Alex : $AlexCmd ($AlexVersion) ===================================== hadrian/cfg/default.host.target.in ===================================== @@ -44,6 +44,7 @@ Target , tgtOpt = Nothing , tgtLlvmAs = Nothing , tgtWindres = Nothing +, tgtDlltool = Nothing , tgtOtool = Nothing , tgtInstallNameTool = Nothing } ===================================== hadrian/cfg/default.target.in ===================================== @@ -44,6 +44,7 @@ Target , tgtOpt = @OptCmdMaybeProg@ , tgtLlvmAs = @LlvmAsCmdMaybeProg@ , tgtWindres = @WindresCmdMaybeProg@ +, tgtDlltool = @DlltoolCmdMaybeProg@ , tgtOtool = @OtoolCmdMaybeProg@ , tgtInstallNameTool = @InstallNameToolCmdMaybeProg@ } ===================================== hadrian/src/Builder.hs ===================================== @@ -17,7 +17,7 @@ import Development.Shake.Classes import Development.Shake.Command import Development.Shake.FilePath import GHC.Generics -import GHC.Platform.ArchOS (ArchOS(..), Arch(..)) +import GHC.Platform.ArchOS (ArchOS(..), Arch(..), OS(..)) import qualified Hadrian.Builder as H import Hadrian.Builder hiding (Builder) import Hadrian.Builder.Ar @@ -183,6 +183,7 @@ data Builder = Alex | Objdump | Python | Ranlib + | Dlltool | Testsuite TestMode | Sphinx SphinxMode | Tar TarMode @@ -418,6 +419,7 @@ isOptional target = \case Alex -> True -- Most ar implemententions no longer need ranlib, but some still do Ranlib -> not $ Toolchain.arNeedsRanlib (tgtAr target) + Dlltool -> archOS_OS (tgtArchOs target) /= OSMinGW32 JsCpp -> not $ (archOS_arch . tgtArchOs) target == ArchJavaScript -- ArchWasm32 too? _ -> False @@ -451,6 +453,7 @@ systemBuilderPath builder = case builder of Objdump -> fromKey "objdump" Python -> fromKey "python" Ranlib -> fromTargetTC "ranlib" (maybeProg Toolchain.ranlibProgram . tgtRanlib) + Dlltool -> fromTargetTC "dlltool" (maybeProg id . tgtDlltool) Testsuite _ -> fromKey "python" Sphinx _ -> fromKey "sphinx-build" Tar _ -> fromKey "tar" ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -382,6 +382,7 @@ templateRules = do , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1 , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2 ] + templateRule "rts/win32/libHSghc-internal.def" projectVersion templateRule "docs/index.html" $ packageUnitIds Stage1 templateRule "docs/users_guide/ghc_config.py" $ mconcat [ projectVersion ===================================== hadrian/src/Rules/Library.hs ===================================== @@ -4,6 +4,8 @@ import Hadrian.BuildPath import Hadrian.Haskell.Cabal import Hadrian.Haskell.Cabal.Type import qualified Text.Parsec as Parsec +import GHC.Platform.ArchOS (ArchOS(archOS_OS), OS(..)) +import GHC.Toolchain.Target (Target(tgtArchOs)) import Base import Context @@ -205,9 +207,13 @@ jsObjects context = do srcs <- interpretInContext context (getContextData jsSrcs) mapM (objectPath context) srcs --- | Return extra object files needed to build the given library context. The --- resulting list is currently non-empty only when the package from the --- 'Context' is @ghc-internal@ built with in-tree GMP backend. +-- | Return extra object files needed to build the given library context. +-- +-- This is non-empty for: +-- +-- * @ghc-internal@ when built with in-tree GMP backend +-- * @rts@ on windows when linking dynamically +-- extraObjects :: Context -> Action [FilePath] extraObjects context | package context == ghcInternal = do @@ -215,6 +221,12 @@ extraObjects context "gmp" -> gmpObjects (stage context) _ -> return [] + | package context == rts = do + target <- interpretInContext context getStagedTarget + builddir <- buildPath context + return [ builddir -/- "libHSghc-internal.dll.a" + | archOS_OS (tgtArchOs target) == OSMinGW32 + , Dynamic `wayUnit` way context ] | otherwise = return [] -- | Return all the object files to be put into the library we're building for ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -43,6 +43,10 @@ rtsRules = priority 3 $ do buildPath -/- "libffi*.so*" %> copyLibffiDynamicUnix stage ".so" buildPath -/- "libffi*.dll*" %> copyLibffiDynamicWin stage + -- Not libffi: an import lib for the ghc-internal dll, to be linked + -- into the rts dll (windows only). + buildPath -/- "libHSghc-internal.dll.a" %> buildGhcInternalImportLib + withLibffi :: Stage -> (FilePath -> FilePath -> Action a) -> Action a withLibffi stage action = needLibffi stage >> (join $ action <$> libffiBuildPath stage @@ -154,6 +158,17 @@ needRtsLibffiTargets stage = do mapM (rtsLibffiLibrary stage) (Set.toList ways) return $ concat [ headers, dynLibffis, libffis_libs ] + +-- Solve the recursive dependency between rts and ghc-internal on +-- windows by creating an import lib for the ghc-internal dll, to be +-- linked into the rts dll. +buildGhcInternalImportLib :: FilePath -> Action () +buildGhcInternalImportLib target = do + let input = "rts/win32/libHSghc-internal.def" + output = target -- the .dll.a import lib + need [input] + runBuilder Dlltool ["-d", input, "-l", output] [input] [output] + -- Need symlinks generated by rtsRules. needRtsSymLinks :: Stage -> Set.Set Way -> Action () needRtsSymLinks stage rtsWays ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -131,8 +131,8 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[ AR="${mingwbin}llvm-ar.exe" RANLIB="${mingwbin}llvm-ranlib.exe" OBJDUMP="${mingwbin}llvm-objdump.exe" - DLLTOOL="${mingwbin}llvm-dlltool.exe" WindresCmd="${mingwbin}llvm-windres.exe" + DlltoolCmd="${mingwbin}llvm-dlltool.exe" LLC="${mingwbin}llc.exe" OPT="${mingwbin}opt.exe" LLVMAS="${mingwbin}clang.exe" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -95,6 +95,7 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--merge-objs=$MergeObjsCmd" >> acargs echo "--readelf=$READELF" >> acargs echo "--windres=$WindresCmd" >> acargs + echo "--dlltool=$DlltoolCmd" >> acargs echo "--llc=$LlcCmd" >> acargs echo "--opt=$OptCmd" >> acargs echo "--llvm-as=$LlvmAsCmd" >> acargs ===================================== m4/prep_target_file.m4 ===================================== @@ -190,6 +190,7 @@ AC_DEFUN([PREP_TARGET_FILE],[ PREP_MAYBE_SIMPLE_PROGRAM([OptCmd]) PREP_MAYBE_PROGRAM([LlvmAsCmd], [LlvmAsFlags]) PREP_MAYBE_SIMPLE_PROGRAM([WindresCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([DlltoolCmd]) PREP_MAYBE_SIMPLE_PROGRAM([OtoolCmd]) PREP_MAYBE_SIMPLE_PROGRAM([InstallNameToolCmd]) PREP_MAYBE_STRING([TargetVendor_CPP]) ===================================== rts/win32/libHSghc-internal.def deleted ===================================== @@ -1,49 +0,0 @@ - -LIBRARY "libHSghc-internal-@LibVersion@-ghc@ProjectVersion@.dll" - -EXPORTS - ghczminternal_GHCziInternalziInt_I8zh_con_info - ghczminternal_GHCziInternalziInt_I16zh_con_info - ghczminternal_GHCziInternalziInt_I32zh_con_info - ghczminternal_GHCziInternalziInt_I64zh_con_info - - ghczminternal_GHCziInternalziWord_W8zh_con_info - ghczminternal_GHCziInternalziWord_W16zh_con_info - ghczminternal_GHCziInternalziWord_W32zh_con_info - ghczminternal_GHCziInternalziWord_W64zh_con_info - - ghczminternal_GHCziInternalziStable_StablePtr_con_info - - ghczminternal_GHCziInternalziPack_unpackCString_closure - - ghczminternal_GHCziInternalziTopHandler_runIO_closure - ghczminternal_GHCziInternalziTopHandler_runNonIO_closure - - ghczminternal_GHCziInternalziIOziException_stackOverflow_closure - ghczminternal_GHCziInternalziIOziException_heapOverflow_closure - - ghczminternal_GHCziInternalziPtr_Ptr_con_info - ghczminternal_GHCziInternalziPtr_FunPtr_con_info - - ghczminternal_GHCziInternalziConcziIO_ensureIOManagerIsRunning_closure - ghczminternal_GHCziInternalziConcziIO_interruptIOManager_closure - ghczminternal_GHCziInternalziConcziIO_ioManagerCapabilitiesChanged_closure - ghczminternal_GHCziInternalziConcziSync_runSparks_closure - ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure - - ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure - - ghczminternal_GHCziInternalziWeakziFinalizze_runFinalizzerBatch_closure - ghczminternal_GHCziInternalziPack_unpackCString_closure - ghczminternal_GHCziInternalziIOziException_blockedIndefinitelyOnMVar_closure - ghczminternal_GHCziInternalziIOziException_blockedIndefinitelyOnSTM_closure - ghczminternal_GHCziInternalziIOziException_allocationLimitExceeded_closure - ghczminternal_GHCziInternalziIOziException_stackOverflow_closure - ghczminternal_GHCziInternalziIOziException_cannotCompactFunction_closure - ghczminternal_GHCziInternalziIOziException_cannotCompactPinned_closure - ghczminternal_GHCziInternalziIOziException_cannotCompactMutable_closure - ghczminternal_GHCziInternalziControlziExceptionziBase_nonTermination_closure - ghczminternal_GHCziInternalziControlziExceptionziBase_nestedAtomically_closure - ghczminternal_GHCziInternalziExceptionziType_divZZeroException_closure - ghczminternal_GHCziInternalziExceptionziType_underflowException_closure - ghczminternal_GHCziInternalziExceptionziType_overflowException_closure ===================================== rts/win32/libHSghc-internal.def.in ===================================== @@ -0,0 +1,4 @@ +LIBRARY libHSghc-internal-@ProjectVersionForLib@.0-ghc@ProjectVersion@.dll + +EXPORTS + init_ghc_hs_iface ===================================== rts/win32/libHSghc-prim.def deleted ===================================== @@ -1,14 +0,0 @@ - -LIBRARY "libHSghc-internal-@LibVersion@-ghc@ProjectVersion@.dll" - -EXPORTS - - ghczminternal_GHCziInternalziTypes_True_closure - ghczminternal_GHCziInternalziTypes_False_closure - ghczminternal_GHCziInternalziTypes_Czh_con_info - ghczminternal_GHCziInternalziTypes_Izh_con_info - ghczminternal_GHCziInternalziTypes_Fzh_con_info - ghczminternal_GHCziInternalziTypes_Dzh_con_info - ghczminternal_GHCziInternalziTypes_Wzh_con_info - ghczminternal_GHCziInternalziTypes_Czh_static_info - ghczminternal_GHCziInternalziTypes_Izh_static_info ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -56,6 +56,7 @@ data Opts = Opts , optOpt :: ProgOpt , optLlvmAs :: ProgOpt , optWindres :: ProgOpt + , optDlltool :: ProgOpt , optOtool :: ProgOpt , optInstallNameTool :: ProgOpt -- Note we don't actually configure LD into anything but @@ -114,6 +115,7 @@ emptyOpts = Opts , optOpt = po0 , optLlvmAs = po0 , optWindres = po0 + , optDlltool = po0 , optLd = po0 , optOtool = po0 , optInstallNameTool = po0 @@ -132,7 +134,7 @@ emptyOpts = Opts _optCc, _optCxx, _optCpp, _optHsCpp, _optJsCpp, _optCmmCpp, _optCcLink, _optAr, _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optLlc, _optOpt, _optLlvmAs, - _optWindres, _optLd, _optOtool, _optInstallNameTool + _optWindres, _optDlltool, _optLd, _optOtool, _optInstallNameTool :: Lens Opts ProgOpt _optCc = Lens optCc (\x o -> o {optCc=x}) _optCxx = Lens optCxx (\x o -> o {optCxx=x}) @@ -150,6 +152,7 @@ _optLlc = Lens optLlc (\x o -> o {optLlc=x}) _optOpt = Lens optOpt (\x o -> o {optOpt=x}) _optLlvmAs = Lens optLlvmAs (\x o -> o {optLlvmAs=x}) _optWindres = Lens optWindres (\x o -> o {optWindres=x}) +_optDlltool = Lens optDlltool (\x o -> o {optDlltool=x}) _optLd = Lens optLd (\x o -> o {optLd=x}) _optOtool = Lens optOtool (\x o -> o {optOtool=x}) _optInstallNameTool = Lens optInstallNameTool (\x o -> o {optInstallNameTool=x}) @@ -218,6 +221,7 @@ options = , progOpts "opt" "LLVM opt utility" _optOpt , progOpts "llvm-as" "Assembler used for LLVM backend (typically clang)" _optLlvmAs , progOpts "windres" "windres utility" _optWindres + , progOpts "dlltool" "Windows dll utility" _optDlltool , progOpts "ld" "linker" _optLd , progOpts "otool" "otool utility" _optOtool , progOpts "install-name-tool" "install-name-tool utility" _optInstallNameTool @@ -481,12 +485,13 @@ mkTarget opts = do llvmAs <- optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] -- Windows-specific utilities - windres <- + (windres, dlltool) <- case archOS_OS archOs of OSMinGW32 -> do - windres <- findProgram "windres" (optWindres opts) ["windres"] - return (Just windres) - _ -> return Nothing + windres <- findProgram "windres" (optWindres opts) ["windres", "llvm-windres"] + dlltool <- findProgram "dlltool" (optDlltool opts) ["dlltool", "llvm-dlltool"] + return (Just windres, Just dlltool) + _ -> return (Nothing, Nothing) -- Darwin-specific utilities (otool, installNameTool) <- @@ -541,6 +546,7 @@ mkTarget opts = do , tgtOpt = opt , tgtLlvmAs = llvmAs , tgtWindres = windres + , tgtDlltool = dlltool , tgtOtool = otool , tgtInstallNameTool = installNameTool , tgtWordSize ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -93,6 +93,7 @@ data Target = Target -- Windows-specific tools , tgtWindres :: Maybe Program + , tgtDlltool :: Maybe Program -- Darwin-specific tools , tgtOtool :: Maybe Program @@ -150,6 +151,7 @@ instance Show Target where , ", tgtOpt = " ++ show tgtOpt , ", tgtLlvmAs = " ++ show tgtLlvmAs , ", tgtWindres = " ++ show tgtWindres + , ", tgtDlltool = " ++ show tgtDlltool , ", tgtOtool = " ++ show tgtOtool , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da41a1a5a5771e410fc423808a5857… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da41a1a5a5771e410fc423808a5857… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ci-note-treeless] 3 commits: Narrow before optimising MUL/DIV/REM into shifts
by Cheng Shao (＠TerrorJack) 10 Dec '25

10 Dec '25

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-…) 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(a)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 ===================================== @@ -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/81ecc47698539ef7480d7cb831c26e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/81ecc47698539ef7480d7cb831c26e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26664
by Peter Trommler (＠trommler) 10 Dec '25

10 Dec '25

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

1 0

[Git][ghc/ghc][master] Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic'
by Marge Bot (＠marge-bot) 10 Dec '25

10 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 5 changed files: - compiler/GHC/Hs/Type.hs - compiler/Language/Haskell/Syntax/Type.hs - 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: ===================================== 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 ===================================== 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/-/commit/06c2349c41e4fba7ca80ee97506b226… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06c2349c41e4fba7ca80ee97506b226… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Narrow before optimising MUL/DIV/REM into shifts
by Marge Bot (＠marge-bot) 10 Dec '25

10 Dec '25

Marge Bot pushed to branch master 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 - - - - - 4 changed files: - compiler/GHC/Cmm/Opt.hs - + testsuite/tests/cmm/opt/T25664.hs - + testsuite/tests/cmm/opt/T25664.stdout - testsuite/tests/cmm/opt/all.T Changes: ===================================== 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). ===================================== 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe2b79f4f21acf077738eb9ae9868c6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe2b79f4f21acf077738eb9ae9868c6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/mod-origin-hidden-reexports-message-fix
by Torsten Schmits (＠torsten.schmits) 10 Dec '25

10 Dec '25

Torsten Schmits pushed new branch wip/torsten.schmits/mod-origin-hidden-reexports-message-fix at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/mod-origin-hi… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ci-note-treeless
by Cheng Shao (＠TerrorJack) 10 Dec '25

10 Dec '25

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

1 0

[Git][ghc/ghc][wip/T23162-part2] More improvements in error reporting
by Simon Peyton Jones (＠simonpj) 10 Dec '25

10 Dec '25

Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC Commits: 4475b266 by Simon Peyton Jones at 2025-12-10T13:01:13+00:00 More improvements in error reporting - - - - - 5 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -87,7 +87,7 @@ import qualified GHC.Data.Strict as Strict import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Control.Monad ( unless, when, foldM, forM_ ) +import Control.Monad ( when, foldM, forM_ ) import Data.Bifunctor ( bimap ) import Data.Foldable ( toList ) import Data.Function ( on ) @@ -482,12 +482,15 @@ mkErrorItem ct CIrredCan (IrredCt { ir_reason = reason }) -> Just reason _ -> Nothing - ; return $ Just $ EI { ei_pred = ctPred ct - , ei_evdest = m_evdest - , ei_flavour = flav - , ei_loc = loc - , ei_m_reason = m_reason - , ei_suppress = suppress }} + insoluble_ct = insolubleCt ct + + ; return $ Just $ EI { ei_pred = ctPred ct + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_loc = loc + , ei_m_reason = m_reason + , ei_insoluble = insoluble_ct + , ei_suppress = suppress }} -- | Actually report this 'ErrorItem'. unsuppressErrorItem :: ErrorItem -> ErrorItem @@ -648,7 +651,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) - , ("Insoluble fundeps", is_insoluble_fundep, True, mkGroupReporter mkDictErr) + , ("Insoluble fundeps", is_insoluble, True, mkGroupReporter mkDictErr) ] -- report2: we suppress these if there are insolubles elsewhere in the tree @@ -666,9 +669,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- I think all given residuals are equalities -- Constraints that have insoluble functional dependencies - is_insoluble_fundep item _ = case ei_m_reason item of - Just InsolubleFunDepReason -> True - _ -> False + is_insoluble item _ = ei_insoluble item -- Things like (Int ~N Bool) utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 @@ -1305,18 +1306,30 @@ maybeReportError :: SolverReportErrCtxt maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important , sr_supplementary = supp , sr_hints = hints }) - = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic - || all ei_suppress items) $ - -- if they're all to be suppressed, report nothing - -- if at least one is not suppressed, do report: - -- the function that generates the error message - -- should look for an unsuppressed error item - do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag - | otherwise = cec_defer_type_errors ctxt - -- See Note [No deferring for multiplicity errors] - diag = TcRnSolverReport important reason - msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints - reportDiagnostic msg + | suppress_group = return () + | otherwise = do { msg <- mkErrorReport loc_env diag (Just ctxt) supp hints + ; reportDiagnostic msg } + where + reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag + | otherwise = cec_defer_type_errors ctxt + -- See Note [No deferring for multiplicity errors] + diag = TcRnSolverReport important reason + loc_env = ctLocEnv (errorItemCtLoc item1) + + suppress_group + | all ei_suppress items + = True -- If they are all suppressed (notably, have been rewritten by another unsolved wanted) + -- report nothing. (If at least one is not suppressed, do report: the function that + -- generates the error message should look for an unsuppressed error item.) + + | any ei_insoluble items + = False -- Don't suppress insolubles even if cec_suppress is True + + | cec_suppress ctxt + = True -- Some earlier error has occurred, so suppress this diagnostic + + | otherwise + = False addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM () addSolverDeferredBinding err item = @@ -2089,7 +2102,7 @@ misMatchOrCND :: SolverReportErrCtxt -> ErrorItem -> TcType -> TcType -> TcM MismatchMsg -- If oriented then ty1 is actual, ty2 is expected misMatchOrCND ctxt item ty1 ty2 - | insoluble_item -- See Note [Insoluble mis-match] + | ei_insoluble item -- See Note [Insoluble mis-match] || (isRigidTy ty1 && isRigidTy ty2) || (ei_flavour item == Given) || null givens @@ -2101,10 +2114,6 @@ misMatchOrCND ctxt item ty1 ty2 = mkCouldNotDeduceErr givens (item :| []) (Just $ CND_ExpectedActual level ty1 ty2) where - insoluble_item = case ei_m_reason item of - Nothing -> False - Just r -> isInsolubleReason r - level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] -- Keep only UserGivens that have some equalities. ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -5438,7 +5438,10 @@ data ErrorItem , ei_loc :: CtLoc , ei_m_reason :: Maybe CtIrredReason -- If this ErrorItem was made from a -- CtIrred, this stores the reason - , ei_suppress :: Bool -- Suppress because of + , ei_insoluble :: Bool -- True if the constraint is defdinitely insoluble + -- Cache of `insolubleCt` + + , ei_suppress :: Bool -- Suppress because of -- Note [Wanteds rewrite Wanteds: rewriter-sets] -- in GHC.Tc.Constraint } ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -723,28 +723,46 @@ they can still be solved: -} tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) --- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely --- contradictory. +-- ^ Return (Just new_inerts) if the Givens are satisfiable, +-- Nothing if definitely contradictory. +-- So Nothing says something definite; if in doubt return Just -- -- See Note [Pattern match warnings with insoluble Givens] above. -tcCheckGivens inerts given_ids = do - mb_res <- tryM $ runTcSInerts inerts $ do - traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) - lcl_env <- TcS.getLclEnv - let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) - let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - solveSimpleGivens given_cts - insols <- getInertInsols - insols <- try_harder insols - traceTcS "checkGivens }" (ppr insols) - return (isEmptyBag insols) - case mb_res of - Left _ -> return (Just inerts) - Right (sat, new_inerts) - | sat -> return (Just new_inerts) - | otherwise -> return Nothing -- Definitely unsatisfiable +tcCheckGivens inerts given_ids + = do { traceTc "checkGivens {" (ppr inerts <+> ppr given_ids) + + ; lcl_env <- TcM.getLclEnv + ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + given_cts = mkGivens given_loc (bagToList given_ids) + -- See Note [Superclasses and satisfiability] + + ; mb_res <- tryM $ -- try_to_solve may throw an exception; + -- e.g. reduction stack overflow + discardErrs $ -- An exception id not an error; + -- just means "not definitely unsat" + runTcSInerts inerts $ + try_to_solve given_cts + + -- If mb_res = Left err, solving threw an exception, e.g. reduction stack + -- overflow. So return the original incoming inerts to say "not definitely + -- unsatisfiable". + ; let res = case mb_res of + Right res -> res + Left {} -> Just inerts + + ; traceTc "checkGivens }" (ppr res) + ; return res } + where + try_to_solve :: [Ct] -> TcS (Maybe InertSet) + try_to_solve given_cts + = do { solveSimpleGivens given_cts + ; insols <- getInertInsols + ; insols <- try_harder insols + ; if isEmptyBag insols + then do { new_inerts <- getInertSet; return (Just new_inerts) } + else return Nothing } -- Definitely unsatisfiable + try_harder :: Cts -> TcS Cts -- Maybe we have to search up the superclass chain to find -- an unsatisfiable constraint. Example: pmcheck/T3927b. @@ -760,27 +778,25 @@ tcCheckGivens inerts given_ids = do tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool -- ^ Return True if the Wanteds are soluble, False if not -tcCheckWanteds inerts wanteds = do - cts <- newWanteds PatCheckOrigin wanteds - (sat, _new_inerts) <- runTcSInerts inerts $ do - traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) - -- See Note [Superclasses and satisfiability] - wcs <- solveWanteds (mkSimpleWC cts) - traceTcS "checkWanteds }" (ppr wcs) - return (isSolvedWC wcs) - return sat +tcCheckWanteds inerts wanteds + = do { cts <- newWanteds PatCheckOrigin wanteds + ; runTcSInerts inerts $ + do { traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) + -- See Note [Superclasses and satisfiability] + ; wcs <- solveWanteds (mkSimpleWC cts) + ; traceTcS "checkWanteds }" (ppr wcs) + ; return (isSolvedWC wcs) } } -- | Normalise a type as much as possible using the given constraints. -- See @Note [tcNormalise]@. tcNormalise :: InertSet -> Type -> TcM Type tcNormalise inerts ty = do { norm_loc <- getCtLocM PatCheckOrigin Nothing - ; (res, _new_inerts) <- runTcSInerts inerts $ - do { traceTcS "tcNormalise {" (ppr inerts) - ; ty' <- rewriteType norm_loc ty - ; traceTcS "tcNormalise }" (ppr ty') - ; pure ty' } - ; return res } + ; runTcSInerts inerts $ + do { traceTcS "tcNormalise {" (ppr inerts) + ; ty' <- rewriteType norm_loc ty + ; traceTcS "tcNormalise }" (ppr ty') + ; pure ty' } } {- Note [Superclasses and satisfiability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1170,15 +1170,12 @@ runTcSEqualities thing_inside -- | A variant of 'runTcS' that takes and returns an 'InertSet' for -- later resumption of the 'TcS' session. -runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) -runTcSInerts inerts tcs +runTcSInerts :: InertSet -> TcS a -> TcM a +runTcSInerts inerts thing_inside = do { ev_binds_var <- TcM.newTcEvBinds ; runTcSWithEvBinds' (vanillaTcSMode { tcsmResumable = True }) ev_binds_var $ - do { setInertSet inerts - ; a <- tcs - ; new_inerts <- getInertSet - ; return (a, new_inerts) } } + do { setInertSet inerts; thing_inside } } runTcSWithEvBinds :: EvBindsVar -> TcS a ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -11,7 +11,7 @@ -- getters...). module GHC.Tc.Utils.Monad( -- * Initialisation - initTc, initTcWithGbl, initTcInteractive, initTcRnIf, + initTc, initTcInteractive, initTcRnIf, -- * Simple accessors discardResult, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4475b2662c3f88136e4eafe961b0bb4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4475b2662c3f88136e4eafe961b0bb4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/remove-legacy-define-in-foreign-stub] compiler: remove unused CPP code in foreign stub
by Cheng Shao (＠TerrorJack) 10 Dec '25

10 Dec '25

Cheng Shao pushed to branch wip/remove-legacy-define-in-foreign-stub at Glasgow Haskell Compiler / GHC Commits: 05e25647 by Cheng Shao at 2025-12-10T12:27:13+01:00 compiler: remove unused CPP code in foreign stub This patch removes unused CPP code in the generated foreign stub: - `#define IN_STG_CODE 0` is not needed, since `Rts.h` already includes this definition - The `if defined(__cplusplus)` code paths are not needed in the `.c` file, since we don't generate C++ stubs and don't include C++ headers in our stubs. But it still needs to be present in the `.h` header since it might be later included into C++ source files. - - - - - 1 changed file: - compiler/GHC/Driver/CodeOutput.hs Changes: ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -329,15 +329,8 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs stub_c_file_exists <- outputForeignStubs_help stub_c stub_c_output_w - ("#define IN_STG_CODE 0\n" ++ - "#include <Rts.h>\n" ++ - rts_includes ++ - ffi_includes ++ - cplusplus_hdr) - cplusplus_ftr - -- We're adding the default hc_header to the stub file, but this - -- isn't really HC code, so we need to define IN_STG_CODE==0 to - -- avoid the register variables etc. being enabled. + (rts_includes ++ + ffi_includes) "" return (stub_h_file_exists, if stub_c_file_exists then Just stub_c View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05e25647f72bc102061af3f20478aa7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05e25647f72bc102061af3f20478aa7… You're receiving this email because of your account on gitlab.haskell.org.

1 0