28 Aug '25
Simon Peyton Jones pushed to branch wip/T26331 at Glasgow Haskell Compiler / GHC
Commits:
64b8f6a0 by Simon Peyton Jones at 2025-08-28T10:54:31+01:00
Fix deep subsumption again
This commit fixed #26255:
commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1
Author: sheaf <sam.derbyshire(a)gmail.com>
Date: Mon Aug 11 15:50:47 2025 +0200
Improve deep subsumption
This commit improves the DeepSubsumption sub-typing implementation
in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back
to unification.
But alas it still wasn't quite right for view patterns: #26331
This MR does a generalisation to fix it. A bit of a sledgehammer to crack
a nut, but nice.
* Add a field `ir_inst :: InferInstFlag` to `InferResult`, where
```
data InferInstFlag = IIF_Sigma | IIF_ShallowRho | IIF_DeepRho
```
* The flag says exactly how much `fillInferResult` should instantiate
before filling the hole.
* We can also use this to replace the previous very ad-hoc `tcInferSigma`
that was used to implement GHCi's `:type` command.
- - - - -
15 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- + testsuite/tests/patsyn/should_compile/T26331.hs
- + testsuite/tests/patsyn/should_compile/T26331a.hs
- testsuite/tests/patsyn/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -16,7 +16,6 @@
module GHC.Tc.Gen.App
( tcApp
- , tcInferSigma
, tcExprPrag ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
@@ -165,26 +164,6 @@ Note [Instantiation variables are short lived]
-}
-{- *********************************************************************
-* *
- tcInferSigma
-* *
-********************************************************************* -}
-
-tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
--- Used only to implement :type; see GHC.Tc.Module.tcRnExpr
--- True <=> instantiate -- return a rho-type
--- False <=> don't instantiate -- return a sigma-type
-tcInferSigma inst (L loc rn_expr)
- = addExprCtxt rn_expr $
- setSrcSpanA loc $
- do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
- ; do_ql <- wantQuickLook rn_fun
- ; (tc_fun, fun_sigma) <- tcInferAppHead fun
- ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
- ; _ <- tcValArgs do_ql inst_args
- ; return app_res_sigma }
-
{- *********************************************************************
* *
Typechecking n-ary applications
@@ -219,7 +198,7 @@ using the application chain route, and we can just recurse to tcExpr.
A "head" has three special cases (for which we can infer a polytype
using tcInferAppHead_maybe); otherwise is just any old expression (for
-which we can infer a rho-type (via tcInfer).
+which we can infer a rho-type (via runInferExpr).
There is no special treatment for HsHole (HsVar ...), HsOverLit, etc, because
we can't get a polytype from them.
@@ -403,13 +382,22 @@ tcApp rn_expr exp_res_ty
-- Step 2: Infer the type of `fun`, the head of the application
; (tc_fun, fun_sigma) <- tcInferAppHead fun
; let tc_head = (tc_fun, fun_ctxt)
+ -- inst_final: top-instantiate the result type of the application,
+ -- EXCEPT if we are trying to infer a sigma-type
+ inst_final = case exp_res_ty of
+ Check {} -> True
+ Infer (IR {ir_inst=iif}) ->
+ case iif of
+ IIF_ShallowRho -> True
+ IIF_DeepRho -> True
+ IIF_Sigma -> False
-- Step 3: Instantiate the function type (taking a quick look at args)
; do_ql <- wantQuickLook rn_fun
; (inst_args, app_res_rho)
<- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in
-- Note [tcApp: typechecking applications]
- tcInstFun do_ql True tc_head fun_sigma rn_args
+ tcInstFun do_ql inst_final tc_head fun_sigma rn_args
; case do_ql of
NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)
@@ -420,6 +408,7 @@ tcApp rn_expr exp_res_ty
app_res_rho exp_res_ty
-- Step 4.2: typecheck the arguments
; tc_args <- tcValArgs NoQL inst_args
+
-- Step 4.3: wrap up
; finishApp tc_head tc_args app_res_rho res_wrap }
@@ -427,15 +416,18 @@ tcApp rn_expr exp_res_ty
-- Step 5.1: Take a quick look at the result type
; quickLookResultType app_res_rho exp_res_ty
+
-- Step 5.2: typecheck the arguments, and monomorphise
-- any un-unified instantiation variables
; tc_args <- tcValArgs DoQL inst_args
+
-- Step 5.3: zonk to expose the polymophism hidden under
-- QuickLook instantiation variables in `app_res_rho`
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
+
-- Step 5.4: subsumption check against the expected type
; res_wrap <- checkResultTy rn_expr tc_head inst_args
- app_res_rho exp_res_ty
+ app_res_rho exp_res_ty
-- Step 5.5: wrap up
; finishApp tc_head tc_args app_res_rho res_wrap } }
@@ -470,32 +462,12 @@ checkResultTy :: HsExpr GhcRn
-> (HsExpr GhcTc, AppCtxt) -- Head
-> [HsExprArg p] -- Arguments, just error messages
-> TcRhoType -- Inferred type of the application; zonked to
- -- expose foralls, but maybe not deeply instantiated
+ -- expose foralls, but maybe not /deeply/ instantiated
-> ExpRhoType -- Expected type; this is deeply skolemised
-> TcM HsWrapper
checkResultTy rn_expr _fun _inst_args app_res_rho (Infer inf_res)
- = fillInferResultDS (exprCtOrigin rn_expr) app_res_rho inf_res
- -- See Note [Deeply instantiate in checkResultTy when inferring]
-
-{- Note [Deeply instantiate in checkResultTy when inferring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-To accept the following program (T26225b) with -XDeepSubsumption, we need to
-deeply instantiate when inferring in checkResultTy:
-
- f :: Int -> (forall a. a->a)
- g :: Int -> Bool -> Bool
-
- test b =
- case b of
- True -> f
- False -> g
-
-If we don't deeply instantiate in the branches of the case expression, we will
-try to unify the type of 'f' with that of 'g', which fails. If we instead
-deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha'
-which then successfully unifies with the type of 'g' when we come to fill the
-'InferResult' hole a second time for the second case branch.
--}
+ = fillInferResult (exprCtOrigin rn_expr) app_res_rho inf_res
+ -- fillInferResult does deep instantiation if DeepSubsumption is on
checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty)
-- Unify with expected type from the context
@@ -651,18 +623,16 @@ quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
********************************************************************* -}
tcInstFun :: QLFlag
- -> Bool -- False <=> Instantiate only /inferred/ variables at the end
+ -> Bool -- False <=> Instantiate only /top-level, inferred/ variables;
-- so may return a sigma-type
- -- True <=> Instantiate all type variables at the end:
- -- return a rho-type
- -- The /only/ call site that passes in False is the one
- -- in tcInferSigma, which is used only to implement :type
- -- Otherwise we do eager instantiation; in Fig 5 of the paper
+ -- True <=> Instantiate /top-level, invisible/ type variables;
+ -- always return a rho-type (but not a deep-rho type)
+ -- Generally speaking we pass in True; in Fig 5 of the paper
-- |-inst returns a rho-type
-> (HsExpr GhcTc, AppCtxt)
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( [HsExprArg 'TcpInst]
- , TcSigmaType )
+ , TcSigmaType ) -- Does not instantiate trailing invisible foralls
-- This crucial function implements the |-inst judgement in Fig 4, plus the
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
@@ -704,13 +674,9 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
_ -> False
inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
- -- True <=> instantiate a tyvar with this ForAllTyFlag
+ -- True <=> instantiate a tyvar that has this ForAllTyFlag
inst_fun [] | inst_final = isInvisibleForAllTyFlag
| otherwise = const False
- -- Using `const False` for `:type` avoids
- -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b`
- -- turning into `forall a {r2} (b :: TYPE r2). a -> b`.
- -- See #21088.
inst_fun (EValArg {} : _) = isInvisibleForAllTyFlag
inst_fun _ = isInferredForAllTyFlag
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -1305,8 +1305,8 @@ tcMonoBinds is_rec sig_fn no_gen
do { mult <- newMultiplicityVar
; ((co_fn, matches'), rhs_ty')
- <- tcInferFRR (FRRBinder name) $ \ exp_ty ->
- -- tcInferFRR: the type of a let-binder must have
+ <- runInferRhoFRR (FRRBinder name) $ \ exp_ty ->
+ -- runInferRhoFRR: the type of a let-binder must have
-- a fixed runtime rep. See #23176
tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
-- We extend the error context even for a non-recursive
@@ -1333,8 +1333,8 @@ tcMonoBinds is_rec sig_fn no_gen
= addErrCtxt (PatMonoBindsCtxt pat grhss) $
do { mult <- tcMultAnnOnPatBind mult_ann
- ; (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty ->
- -- tcInferFRR: the type of each let-binder must have
+ ; (grhss', pat_ty) <- runInferRhoFRR FRRPatBind $ \ exp_ty ->
+ -- runInferRhoFRR: the type of each let-binder must have
-- a fixed runtime rep. See #23176
tcGRHSsPat mult grhss exp_ty
@@ -1522,7 +1522,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_a
-- See Note [Typechecking pattern bindings]
; ((pat', nosig_mbis), pat_ty)
<- addErrCtxt (PatMonoBindsCtxt pat grhss) $
- tcInferFRR FRRPatBind $ \ exp_ty ->
+ runInferSigmaFRR FRRPatBind $ \ exp_ty ->
tcLetPat inst_sig_fun no_gen pat (Scaled mult exp_ty) $
-- The above inferred type get an unrestricted multiplicity. It may be
-- worth it to try and find a finer-grained multiplicity here
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -19,7 +19,7 @@ module GHC.Tc.Gen.Expr
( tcCheckPolyExpr, tcCheckPolyExprNC,
tcCheckMonoExpr, tcCheckMonoExprNC,
tcMonoExpr, tcMonoExprNC,
- tcInferRho, tcInferRhoNC,
+ tcInferExpr, tcInferSigma, tcInferRho, tcInferRhoNC,
tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
@@ -233,17 +233,24 @@ tcPolyExprCheck expr res_ty
* *
********************************************************************* -}
+tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
+tcInferSigma = tcInferExpr IIF_Sigma
+
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-- Infer a *rho*-type. The return type is always instantiated.
-tcInferRho (L loc expr)
- = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
+tcInferRho = tcInferExpr IIF_DeepRho
+tcInferRhoNC = tcInferExprNC IIF_DeepRho
+
+tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
+tcInferExpr iif (L loc expr)
+ = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
addExprCtxt expr $ -- Note [Error contexts in generated code]
- do { (expr', rho) <- tcInfer (tcExpr expr)
+ do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)
; return (L loc expr', rho) }
-tcInferRhoNC (L loc expr)
- = setSrcSpanA loc $
- do { (expr', rho) <- tcInfer (tcExpr expr)
+tcInferExprNC iif (L loc expr)
+ = setSrcSpanA loc $
+ do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)
; return (L loc expr', rho) }
---------------
@@ -878,7 +885,7 @@ tcInferTupArgs boxity args
; return (Missing (Scaled mult arg_ty), arg_ty) }
tc_infer_tup_arg i (Present x lexpr@(L l expr))
= do { (expr', arg_ty) <- case boxity of
- Unboxed -> tcInferFRR (FRRUnboxedTuple i) (tcPolyExpr expr)
+ Unboxed -> runInferRhoFRR (FRRUnboxedTuple i) (tcPolyExpr expr)
Boxed -> do { arg_ty <- newFlexiTyVarTy liftedTypeKind
; L _ expr' <- tcCheckPolyExpr lexpr arg_ty
; return (expr', arg_ty) }
=====================================
compiler/GHC/Tc/Gen/Expr.hs-boot
=====================================
@@ -1,8 +1,8 @@
module GHC.Tc.Gen.Expr where
import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn
, SyntaxExprTc )
-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR
- , SyntaxOpType
+import GHC.Tc.Utils.TcType ( TcType, TcRhoType, TcSigmaType, TcSigmaTypeFRR
+ , SyntaxOpType, InferInstFlag
, ExpType, ExpRhoType, ExpSigmaType )
import GHC.Tc.Types ( TcM )
import GHC.Tc.Types.BasicTypes( TcCompleteSig )
@@ -33,6 +33,8 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcInferRho, tcInferRhoNC ::
LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
+tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
+
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType] -- ^ shape of syntax operator arguments
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -556,7 +556,7 @@ tcInferAppHead (fun,ctxt)
do { mb_tc_fun <- tcInferAppHead_maybe fun
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
- Nothing -> tcInfer (tcExpr fun) }
+ Nothing -> runInferRho (tcExpr fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1063,9 +1063,9 @@ tc_infer_lhs_type mode (L span ty)
-- | Infer the kind of a type and desugar. This is the "up" type-checker,
-- as described in Note [Bidirectional type checking]
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
-
tc_infer_hs_type mode rn_ty
- = tcInfer $ \exp_kind -> tcHsType mode rn_ty exp_kind
+ = runInferKind $ \exp_kind ->
+ tcHsType mode rn_ty exp_kind
{-
Note [Typechecking HsCoreTys]
@@ -1985,7 +1985,7 @@ checkExpKind rn_ty ty ki (Check ki') =
checkExpKind _rn_ty ty ki (Infer cell) = do
-- NB: do not instantiate.
-- See Note [Do not always instantiate eagerly in types]
- co <- fillInferResult ki cell
+ co <- fillInferResultNoInst ki cell
pure (ty `mkCastTy` co)
---------------------------
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1034,7 +1034,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
; tcExtendIdEnv tup_ids $ do
{ ((stmts', (ret_op', tup_rets)), stmts_ty)
- <- tcInfer $ \ exp_ty ->
+ <- runInferRho $ \ exp_ty ->
tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names
(map mkCheckExpType tup_elt_tys)
@@ -1046,7 +1046,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
; return (ret_op', tup_rets) }
; ((_, mfix_op'), mfix_res_ty)
- <- tcInfer $ \ exp_ty ->
+ <- runInferRho $ \ exp_ty ->
tcSyntaxOp DoOrigin mfix_op
[synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $
\ _ _ -> return ()
@@ -1172,7 +1172,7 @@ tcApplicativeStmts
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { body_ty <- newFlexiTyVarTy liftedTypeKind
; let arity = length pairs
- ; ts <- replicateM (arity-1) $ newInferExpType
+ ; ts <- replicateM (arity-1) $ newInferExpType IIF_DeepRho
; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; let fun_ty = mkVisFunTysMany pat_tys body_ty
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -26,7 +26,7 @@ where
import GHC.Prelude
-import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )
+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferExpr )
import GHC.Hs
import GHC.Hs.Syn.Type
@@ -220,7 +220,7 @@ tcInferPat :: FixedRuntimeRepContext
-> TcM a
-> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)
tcInferPat frr_orig ctxt pat thing_inside
- = tcInferFRR frr_orig $ \ exp_ty ->
+ = runInferSigmaFRR frr_orig $ \ exp_ty ->
tc_lpat (unrestricted exp_ty) penv pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
@@ -694,15 +694,17 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-- restriction need to be put in place, if any, for linear view
-- patterns to desugar to type-correct Core.
- ; (expr',expr_ty) <- tcInferRho expr
- -- Note [View patterns and polymorphism]
+ ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr
+ -- IIF_ShallowRho: do not perform deep instantiation, regardless of
+ -- DeepSubsumption (Note [View patterns and polymorphism])
+ -- But we must do top-instantiation to expose the arrow to matchActualFunTy
-- Expression must be a function
; let herald = ExpectedFunTyViewPat $ unLoc expr
; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)
- <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty
+ <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
-- See Note [View patterns and polymorphism]
- -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma)
+ -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
-- Check that overall pattern is more polymorphic than arg type
; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
@@ -715,18 +717,18 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
; pat_ty <- readExpType h_pat_ty
; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
(Scaled w pat_ty) inf_res_sigma
- -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
- -- (pat_ty -> inf_res_sigma)
- -- NB: pat_ty comes from matchActualFunTy, so it has a
- -- fixed RuntimeRep, as needed to call mkWpFun.
- ; let
+ -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
+ -- (pat_ty -> inf_res_sigma)
+ -- NB: pat_ty comes from matchActualFunTy, so it has a
+ -- fixed RuntimeRep, as needed to call mkWpFun.
+
expr_wrap = expr_wrap2' <.> expr_wrap1
; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
{- Note [View patterns and polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this exotic example:
+Consider this exotic example (test T26331a):
pair :: forall a. Bool -> a -> forall b. b -> (a,b)
f :: Int -> blah
@@ -735,11 +737,15 @@ Consider this exotic example:
The expression (pair True) should have type
pair True :: Int -> forall b. b -> (Int,b)
so that it is ready to consume the incoming Int. It should be an
-arrow type (t1 -> t2); hence using (tcInferRho expr).
+arrow type (t1 -> t2); and we must not instantiate that `forall b`,
+/even with DeepSubsumption/. Hence using `IIF_ShallowRho`; this is the only
+place where `IIF_ShallowRho` is used.
Then, when taking that arrow apart we want to get a *sigma* type
(forall b. b->(Int,b)), because that's what we want to bind 'x' to.
Fortunately that's what matchActualFunTy returns anyway.
+
+Another example is #26331.
-}
-- Type signatures in patterns
@@ -768,8 +774,7 @@ Fortunately that's what matchActualFunTy returns anyway.
penv pats thing_inside
; pat_ty <- readExpType (scaledThing pat_ty)
; return (mkHsWrapPat coi
- (ListPat elt_ty pats') pat_ty, res)
-}
+ (ListPat elt_ty pats') pat_ty, res) }
TuplePat _ pats boxity -> do
{ let arity = length pats
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -62,7 +62,6 @@ import GHC.Tc.Gen.Match
import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )
import GHC.Tc.Zonk.Type
import GHC.Tc.Gen.Expr
-import GHC.Tc.Gen.App( tcInferSigma )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Export
import GHC.Tc.Types.Evidence
@@ -2628,10 +2627,11 @@ tcRnExpr hsc_env mode rdr_expr
failIfErrsM ;
-- Typecheck the expression
- ((tclvl, res_ty), lie)
+ ((tclvl, (_tc_expr, res_ty)), lie)
<- captureTopConstraints $
pushTcLevelM $
- tcInferSigma inst rn_expr ;
+ (if inst then tcInferRho rn_expr
+ else tcInferSigma rn_expr);
-- Generalise
uniq <- newUnique ;
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -65,7 +65,7 @@ module GHC.Tc.Utils.TcMType (
-- Expected types
ExpType(..), ExpSigmaType, ExpRhoType,
mkCheckExpType, newInferExpType, newInferExpTypeFRR,
- tcInfer, tcInferFRR,
+ runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR,
readExpType, readExpType_maybe, readScaledExpType,
expTypeToType, scaledExpTypeToType,
checkingExpType_maybe, checkingExpType,
@@ -438,30 +438,29 @@ See test case T21325.
-- actual data definition is in GHC.Tc.Utils.TcType
-newInferExpType :: TcM ExpType
-newInferExpType = new_inferExpType Nothing
+newInferExpType :: InferInstFlag -> TcM ExpType
+newInferExpType iif = new_inferExpType iif IFRR_Any
-newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR
-newInferExpTypeFRR frr_orig
+newInferExpTypeFRR :: InferInstFlag -> FixedRuntimeRepContext -> TcM ExpTypeFRR
+newInferExpTypeFRR iif frr_orig
= do { th_lvl <- getThLevel
- ; if
- -- See [Wrinkle: Typed Template Haskell]
- -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | TypedBrack _ <- th_lvl
- -> new_inferExpType Nothing
+ ; let mb_frr = case th_lvl of
+ TypedBrack {} -> IFRR_Any
+ _ -> IFRR_Check frr_orig
+ -- mb_frr: see [Wrinkle: Typed Template Haskell]
+ -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | otherwise
- -> new_inferExpType (Just frr_orig) }
+ ; new_inferExpType iif mb_frr }
-new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType
-new_inferExpType mb_frr_orig
+new_inferExpType :: InferInstFlag -> InferFRRFlag -> TcM ExpType
+new_inferExpType iif ifrr
= do { u <- newUnique
; tclvl <- getTcLevel
; traceTc "newInferExpType" (ppr u <+> ppr tclvl)
; ref <- newMutVar Nothing
; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl
- , ir_ref = ref
- , ir_frr = mb_frr_orig })) }
+ , ir_inst = iif, ir_frr = ifrr
+ , ir_ref = ref })) }
-- | Extract a type out of an ExpType, if one exists. But one should always
-- exist. Unless you're quite sure you know what you're doing.
@@ -515,12 +514,12 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
where
-- See Note [TcLevel of ExpType]
new_meta = case mb_frr of
- Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
+ IFRR_Any -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) }
- Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy
- ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
- ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
- ; return tau }
+ IFRR_Check frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy
+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
+ ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
+ ; return tau }
{- Note [inferResultToType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -537,20 +536,31 @@ Note [fillInferResult] in GHC.Tc.Utils.Unify.
-- | Infer a type using a fresh ExpType
-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType"
--
--- Use 'tcInferFRR' if you require the type to have a fixed
+-- Use 'runInferFRR' if you require the type to have a fixed
-- runtime representation.
-tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
-tcInfer = tc_infer Nothing
+runInferSigma :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+runInferSigma = runInfer IIF_Sigma IFRR_Any
--- | Like 'tcInfer', except it ensures that the resulting type
+runInferRho :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)
+runInferRho = runInfer IIF_DeepRho IFRR_Any
+
+runInferKind :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+-- Used for kind-checking types, where we never want deep instantiation,
+-- nor FRR checkes
+runInferKind = runInfer IIF_Sigma IFRR_Any
+
+-- | Like 'tcInferExpr', except it ensures that the resulting type
-- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in
-- GHC.Tc.Utils.Concrete.
-tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)
-tcInferFRR frr_orig = tc_infer (Just frr_orig)
+runInferRhoFRR :: FixedRuntimeRepContext -> (ExpRhoTypeFRR -> TcM a) -> TcM (a, TcRhoTypeFRR)
+runInferRhoFRR frr_orig = runInfer IIF_DeepRho (IFRR_Check frr_orig)
+
+runInferSigmaFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)
+runInferSigmaFRR frr_orig = runInfer IIF_Sigma (IFRR_Check frr_orig)
-tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
-tc_infer mb_frr tc_check
- = do { res_ty <- new_inferExpType mb_frr
+runInfer :: InferInstFlag -> InferFRRFlag -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+runInfer iif mb_frr tc_check
+ = do { res_ty <- new_inferExpType iif mb_frr
; result <- tc_check res_ty
; res_ty <- readExpType res_ty
; return (result, res_ty) }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -24,14 +24,14 @@ module GHC.Tc.Utils.TcType (
--------------------------------
-- Types
TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR,
- TcRhoType, TcTauType, TcPredType, TcThetaType,
+ TcRhoType, TcRhoTypeFRR, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder,
TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied,
- ExpType(..), ExpKind, InferResult(..),
+ ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..),
ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,
- ExpRhoType,
+ ExpRhoType, ExpRhoTypeFRR,
mkCheckExpType,
checkingExpType_maybe, checkingExpType,
@@ -380,6 +380,7 @@ type TcSigmaType = TcType
-- See Note [Return arguments with a fixed RuntimeRep.
type TcSigmaTypeFRR = TcSigmaType
-- TODO: consider making this a newtype.
+type TcRhoTypeFRR = TcRhoType
type TcRhoType = TcType -- Note [TcRhoType]
type TcTauType = TcType
@@ -408,9 +409,13 @@ data InferResult
, ir_lvl :: TcLevel
-- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType
- , ir_frr :: Maybe FixedRuntimeRepContext
+ , ir_frr :: InferFRRFlag
-- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType
+ , ir_inst :: InferInstFlag
+ -- ^ True <=> when DeepSubsumption is on, deeply instantiate before filling,
+ -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify
+
, ir_ref :: IORef (Maybe TcType) }
-- ^ The type that fills in this hole should be a @Type@,
-- that is, its kind should be @TYPE rr@ for some @rr :: RuntimeRep@.
@@ -419,26 +424,48 @@ data InferResult
-- @rr@ must be concrete, in the sense of Note [Concrete types]
-- in GHC.Tc.Utils.Concrete.
-type ExpSigmaType = ExpType
+data InferFRRFlag
+ = IFRR_Check -- Check that the result type has a fixed runtime rep
+ FixedRuntimeRepContext -- Typically used for function arguments and lambdas
+
+ | IFRR_Any -- No need to check for fixed runtime-rep
+
+data InferInstFlag -- Specifies whether the inference should return an uninstantiated
+ -- SigmaType, or a (possibly deeply) instantiated RhoType
+ -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify
+
+ = IIF_Sigma -- Trying to infer a SigmaType
+ -- Don't instantiate at all, regardless of DeepSubsumption
+ -- Typically used when inferring the type of a pattern
+
+ | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top)
+ -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole
+ -- Typically used when inferring the type of an expression
+
+ | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption)
+ -- If DeepSubsumption is off, same as IIF_ShallowRho
+ -- If DeepSubsumption is on, instantiate deeply before filling the hole
+
+type ExpSigmaType = ExpType
+type ExpRhoType = ExpType
+ -- Invariant: in ExpRhoType, if -XDeepSubsumption is on,
+ -- and we are in checking mode (i.e. the ExpRhoType is (Check rho)),
+ -- then the `rho` is deeply skolemised
-- | An 'ExpType' which has a fixed RuntimeRep.
--
-- For a 'Check' 'ExpType', the stored 'TcType' must have
-- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr'
--- field must be of the form @Just frr_orig@.
-type ExpTypeFRR = ExpType
+-- field must be of the form @IFRR_Check frr_orig@.
+type ExpTypeFRR = ExpType
-- | Like 'TcSigmaTypeFRR', but for an expected type.
--
-- See 'ExpTypeFRR'.
type ExpSigmaTypeFRR = ExpTypeFRR
+type ExpRhoTypeFRR = ExpTypeFRR
-- TODO: consider making this a newtype.
-type ExpRhoType = ExpType
- -- Invariant: if -XDeepSubsumption is on,
- -- and we are checking (i.e. the ExpRhoType is (Check rho)),
- -- then the `rho` is deeply skolemised
-
-- | Like 'ExpType', but on kind level
type ExpKind = ExpType
@@ -447,12 +474,17 @@ instance Outputable ExpType where
ppr (Infer ir) = ppr ir
instance Outputable InferResult where
- ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr })
- = text "Infer" <> mb_frr_text <> braces (ppr u <> comma <> ppr lvl)
+ ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr, ir_inst = inst })
+ = text "Infer" <> parens (pp_inst <> pp_frr)
+ <> braces (ppr u <> comma <> ppr lvl)
where
- mb_frr_text = case mb_frr of
- Just _ -> text "FRR"
- Nothing -> empty
+ pp_inst = case inst of
+ IIF_Sigma -> text "Sigma"
+ IIF_ShallowRho -> text "ShallowRho"
+ IIF_DeepRho -> text "DeepRho"
+ pp_frr = case mb_frr of
+ IFRR_Check {} -> text ",FRR"
+ IFRR_Any -> empty
-- | Make an 'ExpType' suitable for checking.
mkCheckExpType :: TcType -> ExpType
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Tc.Utils.Unify (
-- Skolemisation
DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS,
tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType,
- deeplyInstantiate,
+ dsInstantiate,
-- Various unifications
unifyType, unifyKind, unifyInvisibleType,
@@ -40,7 +40,6 @@ module GHC.Tc.Utils.Unify (
--------------------------------
-- Holes
- tcInfer,
matchExpectedListTy,
matchExpectedTyConApp,
matchExpectedAppTy,
@@ -60,7 +59,7 @@ module GHC.Tc.Utils.Unify (
simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..),
- fillInferResult, fillInferResultDS
+ fillInferResult, fillInferResultNoInst
) where
import GHC.Prelude
@@ -801,13 +800,13 @@ matchExpectedFunTys :: forall a.
-- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{}
matchExpectedFunTys herald _ctxt arity (Infer inf_res) thing_inside
= do { arg_tys <- mapM (new_infer_arg_ty herald) [1 .. arity]
- ; res_ty <- newInferExpType
+ ; res_ty <- newInferExpType (ir_inst inf_res)
; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty
; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys
; res_ty <- readExpType res_ty
-- NB: mkScaledFunTys arg_tys res_ty does not contain any foralls
-- (even nested ones), so no need to instantiate.
- ; co <- fillInferResult (mkScaledFunTys arg_tys res_ty) inf_res
+ ; co <- fillInferResultNoInst (mkScaledFunTys arg_tys res_ty) inf_res
; return (mkWpCastN co, result) }
matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
@@ -914,10 +913,10 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty
; return (mkWpCastN co, result) }
-new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR)
+new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR)
new_infer_arg_ty herald arg_pos -- position for error messages only
= do { mult <- newFlexiTyVarTy multiplicityTy
- ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)
+ ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos)
; return (mkScaled mult inf_hole) }
new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)
@@ -1075,18 +1074,6 @@ matchExpectedAppTy orig_ty
*
********************************************************************** -}
-{- Note [inferResultToType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-expTypeToType and inferResultType convert an InferResult to a monotype.
-It must be a monotype because if the InferResult isn't already filled in,
-we fill it in with a unification variable (hence monotype). So to preserve
-order-independence we check for mono-type-ness even if it *is* filled in
-already.
-
-See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and
-Note [fillInferResult].
--}
-
-- | Fill an 'InferResult' with the given type.
--
-- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@,
@@ -1098,14 +1085,14 @@ Note [fillInferResult].
-- The stored type @t2@ is at the same level as given by the
-- 'ir_lvl' field.
-- - FRR invariant.
--- Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed
+-- Whenever the 'ir_frr' field is `IFRR_Check`, @t2@ is guaranteed
-- to have a syntactically fixed RuntimeRep, in the sense of
-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-fillInferResult :: TcType -> InferResult -> TcM TcCoercionN
-fillInferResult act_res_ty (IR { ir_uniq = u
- , ir_lvl = res_lvl
- , ir_frr = mb_frr
- , ir_ref = ref })
+fillInferResultNoInst :: TcType -> InferResult -> TcM TcCoercionN
+fillInferResultNoInst act_res_ty (IR { ir_uniq = u
+ , ir_lvl = res_lvl
+ , ir_frr = mb_frr
+ , ir_ref = ref })
= do { mb_exp_res_ty <- readTcRef ref
; case mb_exp_res_ty of
Just exp_res_ty
@@ -1126,7 +1113,7 @@ fillInferResult act_res_ty (IR { ir_uniq = u
ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty
; cur_lvl <- getTcLevel
; unless (cur_lvl `sameDepthAs` res_lvl) $
- ensureMonoType act_res_ty
+ ensureMonoType act_res_ty -- See (FIR1)
; unifyType Nothing act_res_ty exp_res_ty }
Nothing
-> do { traceTc "Filling inferred ExpType" $
@@ -1140,16 +1127,28 @@ fillInferResult act_res_ty (IR { ir_uniq = u
-- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing').
; (frr_co, act_res_ty) <-
case mb_frr of
- Nothing -> return (mkNomReflCo act_res_ty, act_res_ty)
- Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty
+ IFRR_Any -> return (mkNomReflCo act_res_ty, act_res_ty)
+ IFRR_Check frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty
-- Compose the two coercions.
; let final_co = prom_co `mkTransCo` frr_co
; writeTcRef ref (Just act_res_ty)
- ; return final_co }
- }
+ ; return final_co } }
+
+fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper
+-- See Note [Instantiation of InferResult]
+fillInferResult ct_orig res_ty ires@(IR { ir_inst = iif })
+ = case iif of
+ IIF_Sigma -> do { co <- fillInferResultNoInst res_ty ires
+ ; return (mkWpCastN co) }
+ IIF_ShallowRho -> do { (wrap, res_ty') <- topInstantiate ct_orig res_ty
+ ; co <- fillInferResultNoInst res_ty' ires
+ ; return (mkWpCastN co <.> wrap) }
+ IIF_DeepRho -> do { (wrap, res_ty') <- dsInstantiate ct_orig res_ty
+ ; co <- fillInferResultNoInst res_ty' ires
+ ; return (mkWpCastN co <.> wrap) }
{- Note [fillInferResult]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1210,39 +1209,96 @@ For (2), we simply look to see if the hole is filled already.
- if it is filled, we simply unify with the type that is
already there
-There is one wrinkle. Suppose we have
- case e of
- T1 -> e1 :: (forall a. a->a) -> Int
- G2 -> e2
-where T1 is not GADT or existential, but G2 is a GADT. Then suppose the
-T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.
-But now the G2 alternative must not *just* unify with that else we'd risk
-allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first
-we'd have filled the hole with a unification variable, which enforces a
-monotype.
-
-So if we check G2 second, we still want to emit a constraint that restricts
-the RHS to be a monotype. This is done by ensureMonoType, and it works
-by simply generating a constraint (alpha ~ ty), where alpha is a fresh
+(FIR1) There is one wrinkle. Suppose we have
+ case e of
+ T1 -> e1 :: (forall a. a->a) -> Int
+ G2 -> e2
+ where T1 is not GADT or existential, but G2 is a GADT. Then suppose the
+ T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.
+ But now the G2 alternative must not *just* unify with that else we'd risk
+ allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first
+ we'd have filled the hole with a unification variable, which enforces a
+ monotype.
+
+ So if we check G2 second, we still want to emit a constraint that restricts
+ the RHS to be a monotype. This is done by ensureMonoType, and it works
+ by simply generating a constraint (alpha ~ ty), where alpha is a fresh
unification variable. We discard the evidence.
--}
+Note [Instantiation of InferResult]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking expressions (not types, not patterns), we always almost
+always instantiate before filling in `InferResult`, so that the result is a
+TcRhoType. This behaviour is controlled by the `ir_inst :: InferInstFlag`
+field of `InferResult`.
--- | A version of 'fillInferResult' that also performs deep instantiation
--- when deep subsumption is enabled.
---
--- See also Note [Instantiation of InferResult].
-fillInferResultDS :: CtOrigin -> TcRhoType -> InferResult -> TcM HsWrapper
-fillInferResultDS ct_orig rho inf_res
- = do { massertPpr (isRhoTy rho) $
- vcat [ text "fillInferResultDS: input type is not a rho-type"
- , text "ty:" <+> ppr rho ]
- ; ds_flag <- getDeepSubsumptionFlag
- ; case ds_flag of
- Shallow -> mkWpCastN <$> fillInferResult rho inf_res
- Deep -> do { (inst_wrap, rho') <- deeplyInstantiate ct_orig rho
- ; co <- fillInferResult rho' inf_res
- ; return (mkWpCastN co <.> inst_wrap) } }
+If we do instantiate (ir_inst = IIF_DeepRho), and DeepSubsumption is enabled,
+we instantiate deeply. See `tcInferResult`.
+
+Usually this field is `IIF_DeepRho` meaning "return a (possibly deep) rho-type".
+Why is this the common case? See #17173 for discussion. Here are some examples
+of why:
+
+1. Consider
+ f x = (*)
+ We want to instantiate the type of (*) before returning, else we
+ will infer the type
+ f :: forall {a}. a -> forall b. Num b => b -> b -> b
+ This is surely confusing for users.
+
+ And worse, the monomorphism restriction won't work properly. The MR is
+ dealt with in simplifyInfer, and simplifyInfer has no way of
+ instantiating. This could perhaps be worked around, but it may be
+ hard to know even when instantiation should happen.
+
+2. Another reason. Consider
+ f :: (?x :: Int) => a -> a
+ g y = let ?x = 3::Int in f
+ Here want to instantiate f's type so that the ?x::Int constraint
+ gets discharged by the enclosing implicit-parameter binding.
+
+3. Suppose one defines plus = (+). If we instantiate lazily, we will
+ infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism
+ restriction compels us to infer
+ plus :: Integer -> Integer -> Integer
+ (or similar monotype). Indeed, the only way to know whether to apply
+ the monomorphism restriction at all is to instantiate
+
+HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning
+"return a sigma-type":
+
+* IIF_Sigma: In GHC.Tc.Module.tcRnExpr, which implements GHCi's :type
+ command, we want to return a completely uninstantiated type.
+ See Note [Implementing :type] in GHC.Tc.Module.
+
+* IIF_Sigma: In types we can't lambda-abstract, so we must be careful not to instantiate
+ at all. See calls to `runInferHsType`
+
+* IIF_Sigma: in patterns we don't want to instantiate at all. See the use of
+ `runInferSigmaFRR` in GHC.Tc.Gen.Pat
+
+* IIF_ShallowRho: in the expression part of a view pattern, we must top-instantiate
+ but /not/ deeply instantiate (#26331). See Note [View patterns and polymorphism]
+ in GHC.Tc.Gen.Pat. This the only place we use IIF_ShallowRho.
+
+Why do we want to deeply instantiate, ever? Why isn't top-instantiation enough?
+Answer: to accept the following program (T26225b) with -XDeepSubsumption, we
+need to deeply instantiate when inferring in checkResultTy:
+
+ f :: Int -> (forall a. a->a)
+ g :: Int -> Bool -> Bool
+
+ test b =
+ case b of
+ True -> f
+ False -> g
+
+If we don't deeply instantiate in the branches of the case expression, we will
+try to unify the type of 'f' with that of 'g', which fails. If we instead
+deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha'
+which then successfully unifies with the type of 'g' when we come to fill the
+'InferResult' hole a second time for the second case branch.
+-}
{-
************************************************************************
@@ -1276,7 +1332,7 @@ Consider
Does `f` have an ambiguous type? The ambiguity check usually checks
that this definition of f' would typecheck, where f' has the exact same
type as f:
- f' :: (forall b. Eq b => a -> a) -> Intp
+p f' :: (forall b. Eq b => a -> a) -> Intp
f' = f
This will be /rejected/ with DeepSubsumption but /accepted/ with
@@ -1337,7 +1393,7 @@ tcSubTypeMono rn_expr act_ty exp_ty
, text "act_ty:" <+> ppr act_ty
, text "rn_expr:" <+> ppr rn_expr]) $
case exp_ty of
- Infer inf_res -> fillInferResult act_ty inf_res
+ Infer inf_res -> fillInferResultNoInst act_ty inf_res
Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty
------------------------
@@ -1351,7 +1407,7 @@ tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected
= tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected
tcSubTypePat _ _ (Infer inf_res) ty_expected
- = do { co <- fillInferResult ty_expected inf_res
+ = do { co <- fillInferResultNoInst ty_expected inf_res
-- In patterns we do not instantatiate
; return (mkWpCastN (mkSymCo co)) }
@@ -1377,7 +1433,7 @@ tcSubTypeDS rn_expr act_rho exp_rho
-- | Checks that the 'actual' type is more polymorphic than the 'expected' type.
tcSubType :: CtOrigin -- ^ Used when instantiating
-> UserTypeCtxt -- ^ Used when skolemising
- -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)
+ -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)
-> TcSigmaType -- ^ Actual type
-> ExpRhoType -- ^ Expected type
-> TcM HsWrapper
@@ -1386,10 +1442,7 @@ tcSubType inst_orig ctxt m_thing ty_actual res_ty
Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt
ty_actual ty_expected
- Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual
- -- See Note [Instantiation of InferResult]
- ; inst <- fillInferResultDS inst_orig rho inf_res
- ; return (inst <.> wrap) }
+ Infer inf_res -> fillInferResult inst_orig ty_actual inf_res
---------------
tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we
@@ -1428,47 +1481,6 @@ addSubTypeCtxt ty_actual ty_expected thing_inside
; return (tidy_env, SubTypeCtxt ty_expected ty_actual) }
-{- Note [Instantiation of InferResult]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typechecking expressions (not types, not patterns), we always instantiate
-before filling in InferResult, so that the result is a TcRhoType.
-See #17173 for discussion.
-
-For example:
-
-1. Consider
- f x = (*)
- We want to instantiate the type of (*) before returning, else we
- will infer the type
- f :: forall {a}. a -> forall b. Num b => b -> b -> b
- This is surely confusing for users.
-
- And worse, the monomorphism restriction won't work properly. The MR is
- dealt with in simplifyInfer, and simplifyInfer has no way of
- instantiating. This could perhaps be worked around, but it may be
- hard to know even when instantiation should happen.
-
-2. Another reason. Consider
- f :: (?x :: Int) => a -> a
- g y = let ?x = 3::Int in f
- Here want to instantiate f's type so that the ?x::Int constraint
- gets discharged by the enclosing implicit-parameter binding.
-
-3. Suppose one defines plus = (+). If we instantiate lazily, we will
- infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism
- restriction compels us to infer
- plus :: Integer -> Integer -> Integer
- (or similar monotype). Indeed, the only way to know whether to apply
- the monomorphism restriction at all is to instantiate
-
-There is one place where we don't want to instantiate eagerly,
-namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type
-command. See Note [Implementing :type] in GHC.Tc.Module.
-
-This also means that, if DeepSubsumption is enabled, we should also instantiate
-deeply; we do this by using fillInferResultDS.
--}
-
---------------
tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify
-> CtOrigin -- Used when instantiating
@@ -2133,7 +2145,17 @@ deeplySkolemise skol_info ty
= return (idHsWrapper, [], [], substTy subst ty)
-- substTy is a quick no-op on an empty substitution
+dsInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)
+-- Do topInstantiate or deeplyInstantiate, depending on -XDeepSubsumption
+dsInstantiate orig ty
+ = do { ds_flag <- getDeepSubsumptionFlag
+ ; case ds_flag of
+ Shallow -> topInstantiate orig ty
+ Deep -> deeplyInstantiate orig ty }
+
deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)
+-- Instantiate invisible foralls, even ones nested
+-- (to the right) under arrows
deeplyInstantiate orig ty
= go init_subst ty
where
=====================================
testsuite/tests/patsyn/should_compile/T26331.hs
=====================================
@@ -0,0 +1,47 @@
+{-# LANGUAGE DeepSubsumption #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module T26331 where
+
+import Data.Kind (Constraint, Type)
+
+type Apply :: (k1 ~> k2) -> k1 -> k2
+type family Apply (f :: k1 ~> k2) (x :: k1) :: k2
+
+type (~>) :: Type -> Type -> Type
+type a ~> b = TyFun a b -> Type
+infixr 0 ~>
+
+data TyFun :: Type -> Type -> Type
+
+type Sing :: k -> Type
+type family Sing @k :: k -> Type
+
+type SingFunction2 :: (a1 ~> a2 ~> b) -> Type
+type SingFunction2 (f :: a1 ~> a2 ~> b) =
+ forall t1 t2. Sing t1 -> Sing t2 -> Sing (f `Apply` t1 `Apply` t2)
+
+unSingFun2 :: forall f. Sing f -> SingFunction2 f
+-- unSingFun2 :: forall f. Sing f -> forall t1 t2. blah
+unSingFun2 sf x = error "urk"
+
+singFun2 :: forall f. SingFunction2 f -> Sing f
+singFun2 f = error "urk"
+
+-------- This is the tricky bit -------
+pattern SLambda2 :: forall f. SingFunction2 f -> Sing f
+pattern SLambda2 x <- (unSingFun2 -> x) -- We want to push down (SingFunction2 f)
+ -- /uninstantiated/ into the pattern `x`
+ where
+ SLambda2 lam2 = singFun2 lam2
+
=====================================
testsuite/tests/patsyn/should_compile/T26331a.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE DeepSubsumption #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+
+module T26331a where
+
+pair :: forall a. Bool -> a -> forall b. b -> (a,b)
+pair = error "urk"
+
+f :: Int -> ((Int,Bool),(Int,Char))
+f (pair True -> x) = (x True, x 'c') -- (x :: forall b. b -> (Int,b))
=====================================
testsuite/tests/patsyn/should_compile/all.T
=====================================
@@ -85,3 +85,5 @@ test('T21531', [ grep_errmsg(r'INLINE') ], compile, ['-ddump-ds'])
test('T22521', normal, compile, [''])
test('T23038', normal, compile_fail, [''])
test('T22328', normal, compile, [''])
+test('T26331', normal, compile, [''])
+test('T26331a', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b8f6a09c35142b5ce9bb812c5af8fā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b8f6a09c35142b5ce9bb812c5af8fā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
28 Aug '25
Simon Peyton Jones pushed to branch wip/T26331 at Glasgow Haskell Compiler / GHC
Commits:
299b483c by Simon Peyton Jones at 2025-08-28T10:56:11+01:00
Fix deep subsumption again
This commit fixed #26255:
commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1
Author: sheaf <sam.derbyshire(a)gmail.com>
Date: Mon Aug 11 15:50:47 2025 +0200
Improve deep subsumption
This commit improves the DeepSubsumption sub-typing implementation
in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back
to unification.
But alas it still wasn't quite right for view patterns: #26331
This MR does a generalisation to fix it. A bit of a sledgehammer to crack
a nut, but nice.
* Add a field `ir_inst :: InferInstFlag` to `InferResult`, where
```
data InferInstFlag = IIF_Sigma | IIF_ShallowRho | IIF_DeepRho
```
* The flag says exactly how much `fillInferResult` should instantiate
before filling the hole.
* We can also use this to replace the previous very ad-hoc `tcInferSigma`
that was used to implement GHCi's `:type` command.
- - - - -
15 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- + testsuite/tests/patsyn/should_compile/T26331.hs
- + testsuite/tests/patsyn/should_compile/T26331a.hs
- testsuite/tests/patsyn/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -16,7 +16,6 @@
module GHC.Tc.Gen.App
( tcApp
- , tcInferSigma
, tcExprPrag ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
@@ -165,26 +164,6 @@ Note [Instantiation variables are short lived]
-}
-{- *********************************************************************
-* *
- tcInferSigma
-* *
-********************************************************************* -}
-
-tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
--- Used only to implement :type; see GHC.Tc.Module.tcRnExpr
--- True <=> instantiate -- return a rho-type
--- False <=> don't instantiate -- return a sigma-type
-tcInferSigma inst (L loc rn_expr)
- = addExprCtxt rn_expr $
- setSrcSpanA loc $
- do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
- ; do_ql <- wantQuickLook rn_fun
- ; (tc_fun, fun_sigma) <- tcInferAppHead fun
- ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
- ; _ <- tcValArgs do_ql inst_args
- ; return app_res_sigma }
-
{- *********************************************************************
* *
Typechecking n-ary applications
@@ -219,7 +198,7 @@ using the application chain route, and we can just recurse to tcExpr.
A "head" has three special cases (for which we can infer a polytype
using tcInferAppHead_maybe); otherwise is just any old expression (for
-which we can infer a rho-type (via tcInfer).
+which we can infer a rho-type (via runInferExpr).
There is no special treatment for HsHole (HsVar ...), HsOverLit, etc, because
we can't get a polytype from them.
@@ -403,13 +382,22 @@ tcApp rn_expr exp_res_ty
-- Step 2: Infer the type of `fun`, the head of the application
; (tc_fun, fun_sigma) <- tcInferAppHead fun
; let tc_head = (tc_fun, fun_ctxt)
+ -- inst_final: top-instantiate the result type of the application,
+ -- EXCEPT if we are trying to infer a sigma-type
+ inst_final = case exp_res_ty of
+ Check {} -> True
+ Infer (IR {ir_inst=iif}) ->
+ case iif of
+ IIF_ShallowRho -> True
+ IIF_DeepRho -> True
+ IIF_Sigma -> False
-- Step 3: Instantiate the function type (taking a quick look at args)
; do_ql <- wantQuickLook rn_fun
; (inst_args, app_res_rho)
<- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in
-- Note [tcApp: typechecking applications]
- tcInstFun do_ql True tc_head fun_sigma rn_args
+ tcInstFun do_ql inst_final tc_head fun_sigma rn_args
; case do_ql of
NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)
@@ -420,6 +408,7 @@ tcApp rn_expr exp_res_ty
app_res_rho exp_res_ty
-- Step 4.2: typecheck the arguments
; tc_args <- tcValArgs NoQL inst_args
+
-- Step 4.3: wrap up
; finishApp tc_head tc_args app_res_rho res_wrap }
@@ -427,15 +416,18 @@ tcApp rn_expr exp_res_ty
-- Step 5.1: Take a quick look at the result type
; quickLookResultType app_res_rho exp_res_ty
+
-- Step 5.2: typecheck the arguments, and monomorphise
-- any un-unified instantiation variables
; tc_args <- tcValArgs DoQL inst_args
+
-- Step 5.3: zonk to expose the polymophism hidden under
-- QuickLook instantiation variables in `app_res_rho`
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
+
-- Step 5.4: subsumption check against the expected type
; res_wrap <- checkResultTy rn_expr tc_head inst_args
- app_res_rho exp_res_ty
+ app_res_rho exp_res_ty
-- Step 5.5: wrap up
; finishApp tc_head tc_args app_res_rho res_wrap } }
@@ -470,32 +462,12 @@ checkResultTy :: HsExpr GhcRn
-> (HsExpr GhcTc, AppCtxt) -- Head
-> [HsExprArg p] -- Arguments, just error messages
-> TcRhoType -- Inferred type of the application; zonked to
- -- expose foralls, but maybe not deeply instantiated
+ -- expose foralls, but maybe not /deeply/ instantiated
-> ExpRhoType -- Expected type; this is deeply skolemised
-> TcM HsWrapper
checkResultTy rn_expr _fun _inst_args app_res_rho (Infer inf_res)
- = fillInferResultDS (exprCtOrigin rn_expr) app_res_rho inf_res
- -- See Note [Deeply instantiate in checkResultTy when inferring]
-
-{- Note [Deeply instantiate in checkResultTy when inferring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-To accept the following program (T26225b) with -XDeepSubsumption, we need to
-deeply instantiate when inferring in checkResultTy:
-
- f :: Int -> (forall a. a->a)
- g :: Int -> Bool -> Bool
-
- test b =
- case b of
- True -> f
- False -> g
-
-If we don't deeply instantiate in the branches of the case expression, we will
-try to unify the type of 'f' with that of 'g', which fails. If we instead
-deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha'
-which then successfully unifies with the type of 'g' when we come to fill the
-'InferResult' hole a second time for the second case branch.
--}
+ = fillInferResult (exprCtOrigin rn_expr) app_res_rho inf_res
+ -- fillInferResult does deep instantiation if DeepSubsumption is on
checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty)
-- Unify with expected type from the context
@@ -651,18 +623,16 @@ quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
********************************************************************* -}
tcInstFun :: QLFlag
- -> Bool -- False <=> Instantiate only /inferred/ variables at the end
+ -> Bool -- False <=> Instantiate only /top-level, inferred/ variables;
-- so may return a sigma-type
- -- True <=> Instantiate all type variables at the end:
- -- return a rho-type
- -- The /only/ call site that passes in False is the one
- -- in tcInferSigma, which is used only to implement :type
- -- Otherwise we do eager instantiation; in Fig 5 of the paper
+ -- True <=> Instantiate /top-level, invisible/ type variables;
+ -- always return a rho-type (but not a deep-rho type)
+ -- Generally speaking we pass in True; in Fig 5 of the paper
-- |-inst returns a rho-type
-> (HsExpr GhcTc, AppCtxt)
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( [HsExprArg 'TcpInst]
- , TcSigmaType )
+ , TcSigmaType ) -- Does not instantiate trailing invisible foralls
-- This crucial function implements the |-inst judgement in Fig 4, plus the
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
@@ -704,13 +674,9 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
_ -> False
inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
- -- True <=> instantiate a tyvar with this ForAllTyFlag
+ -- True <=> instantiate a tyvar that has this ForAllTyFlag
inst_fun [] | inst_final = isInvisibleForAllTyFlag
| otherwise = const False
- -- Using `const False` for `:type` avoids
- -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b`
- -- turning into `forall a {r2} (b :: TYPE r2). a -> b`.
- -- See #21088.
inst_fun (EValArg {} : _) = isInvisibleForAllTyFlag
inst_fun _ = isInferredForAllTyFlag
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -1305,8 +1305,8 @@ tcMonoBinds is_rec sig_fn no_gen
do { mult <- newMultiplicityVar
; ((co_fn, matches'), rhs_ty')
- <- tcInferFRR (FRRBinder name) $ \ exp_ty ->
- -- tcInferFRR: the type of a let-binder must have
+ <- runInferRhoFRR (FRRBinder name) $ \ exp_ty ->
+ -- runInferRhoFRR: the type of a let-binder must have
-- a fixed runtime rep. See #23176
tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
-- We extend the error context even for a non-recursive
@@ -1333,8 +1333,8 @@ tcMonoBinds is_rec sig_fn no_gen
= addErrCtxt (PatMonoBindsCtxt pat grhss) $
do { mult <- tcMultAnnOnPatBind mult_ann
- ; (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty ->
- -- tcInferFRR: the type of each let-binder must have
+ ; (grhss', pat_ty) <- runInferRhoFRR FRRPatBind $ \ exp_ty ->
+ -- runInferRhoFRR: the type of each let-binder must have
-- a fixed runtime rep. See #23176
tcGRHSsPat mult grhss exp_ty
@@ -1522,7 +1522,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_a
-- See Note [Typechecking pattern bindings]
; ((pat', nosig_mbis), pat_ty)
<- addErrCtxt (PatMonoBindsCtxt pat grhss) $
- tcInferFRR FRRPatBind $ \ exp_ty ->
+ runInferSigmaFRR FRRPatBind $ \ exp_ty ->
tcLetPat inst_sig_fun no_gen pat (Scaled mult exp_ty) $
-- The above inferred type get an unrestricted multiplicity. It may be
-- worth it to try and find a finer-grained multiplicity here
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -19,7 +19,7 @@ module GHC.Tc.Gen.Expr
( tcCheckPolyExpr, tcCheckPolyExprNC,
tcCheckMonoExpr, tcCheckMonoExprNC,
tcMonoExpr, tcMonoExprNC,
- tcInferRho, tcInferRhoNC,
+ tcInferExpr, tcInferSigma, tcInferRho, tcInferRhoNC,
tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
@@ -233,17 +233,24 @@ tcPolyExprCheck expr res_ty
* *
********************************************************************* -}
+tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
+tcInferSigma = tcInferExpr IIF_Sigma
+
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-- Infer a *rho*-type. The return type is always instantiated.
-tcInferRho (L loc expr)
- = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
+tcInferRho = tcInferExpr IIF_DeepRho
+tcInferRhoNC = tcInferExprNC IIF_DeepRho
+
+tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
+tcInferExpr iif (L loc expr)
+ = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
addExprCtxt expr $ -- Note [Error contexts in generated code]
- do { (expr', rho) <- tcInfer (tcExpr expr)
+ do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)
; return (L loc expr', rho) }
-tcInferRhoNC (L loc expr)
- = setSrcSpanA loc $
- do { (expr', rho) <- tcInfer (tcExpr expr)
+tcInferExprNC iif (L loc expr)
+ = setSrcSpanA loc $
+ do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)
; return (L loc expr', rho) }
---------------
@@ -878,7 +885,7 @@ tcInferTupArgs boxity args
; return (Missing (Scaled mult arg_ty), arg_ty) }
tc_infer_tup_arg i (Present x lexpr@(L l expr))
= do { (expr', arg_ty) <- case boxity of
- Unboxed -> tcInferFRR (FRRUnboxedTuple i) (tcPolyExpr expr)
+ Unboxed -> runInferRhoFRR (FRRUnboxedTuple i) (tcPolyExpr expr)
Boxed -> do { arg_ty <- newFlexiTyVarTy liftedTypeKind
; L _ expr' <- tcCheckPolyExpr lexpr arg_ty
; return (expr', arg_ty) }
=====================================
compiler/GHC/Tc/Gen/Expr.hs-boot
=====================================
@@ -1,8 +1,8 @@
module GHC.Tc.Gen.Expr where
import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn
, SyntaxExprTc )
-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR
- , SyntaxOpType
+import GHC.Tc.Utils.TcType ( TcType, TcRhoType, TcSigmaType, TcSigmaTypeFRR
+ , SyntaxOpType, InferInstFlag
, ExpType, ExpRhoType, ExpSigmaType )
import GHC.Tc.Types ( TcM )
import GHC.Tc.Types.BasicTypes( TcCompleteSig )
@@ -33,6 +33,8 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcInferRho, tcInferRhoNC ::
LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
+tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
+
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType] -- ^ shape of syntax operator arguments
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -556,7 +556,7 @@ tcInferAppHead (fun,ctxt)
do { mb_tc_fun <- tcInferAppHead_maybe fun
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
- Nothing -> tcInfer (tcExpr fun) }
+ Nothing -> runInferRho (tcExpr fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1063,9 +1063,9 @@ tc_infer_lhs_type mode (L span ty)
-- | Infer the kind of a type and desugar. This is the "up" type-checker,
-- as described in Note [Bidirectional type checking]
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
-
tc_infer_hs_type mode rn_ty
- = tcInfer $ \exp_kind -> tcHsType mode rn_ty exp_kind
+ = runInferKind $ \exp_kind ->
+ tcHsType mode rn_ty exp_kind
{-
Note [Typechecking HsCoreTys]
@@ -1985,7 +1985,7 @@ checkExpKind rn_ty ty ki (Check ki') =
checkExpKind _rn_ty ty ki (Infer cell) = do
-- NB: do not instantiate.
-- See Note [Do not always instantiate eagerly in types]
- co <- fillInferResult ki cell
+ co <- fillInferResultNoInst ki cell
pure (ty `mkCastTy` co)
---------------------------
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1034,7 +1034,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
; tcExtendIdEnv tup_ids $ do
{ ((stmts', (ret_op', tup_rets)), stmts_ty)
- <- tcInfer $ \ exp_ty ->
+ <- runInferRho $ \ exp_ty ->
tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names
(map mkCheckExpType tup_elt_tys)
@@ -1046,7 +1046,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
; return (ret_op', tup_rets) }
; ((_, mfix_op'), mfix_res_ty)
- <- tcInfer $ \ exp_ty ->
+ <- runInferRho $ \ exp_ty ->
tcSyntaxOp DoOrigin mfix_op
[synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $
\ _ _ -> return ()
@@ -1172,7 +1172,7 @@ tcApplicativeStmts
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { body_ty <- newFlexiTyVarTy liftedTypeKind
; let arity = length pairs
- ; ts <- replicateM (arity-1) $ newInferExpType
+ ; ts <- replicateM (arity-1) $ newInferExpType IIF_DeepRho
; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; let fun_ty = mkVisFunTysMany pat_tys body_ty
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -26,7 +26,7 @@ where
import GHC.Prelude
-import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )
+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferExpr )
import GHC.Hs
import GHC.Hs.Syn.Type
@@ -220,7 +220,7 @@ tcInferPat :: FixedRuntimeRepContext
-> TcM a
-> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)
tcInferPat frr_orig ctxt pat thing_inside
- = tcInferFRR frr_orig $ \ exp_ty ->
+ = runInferSigmaFRR frr_orig $ \ exp_ty ->
tc_lpat (unrestricted exp_ty) penv pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
@@ -694,15 +694,17 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-- restriction need to be put in place, if any, for linear view
-- patterns to desugar to type-correct Core.
- ; (expr',expr_ty) <- tcInferRho expr
- -- Note [View patterns and polymorphism]
+ ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr
+ -- IIF_ShallowRho: do not perform deep instantiation, regardless of
+ -- DeepSubsumption (Note [View patterns and polymorphism])
+ -- But we must do top-instantiation to expose the arrow to matchActualFunTy
-- Expression must be a function
; let herald = ExpectedFunTyViewPat $ unLoc expr
; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)
- <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty
+ <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
-- See Note [View patterns and polymorphism]
- -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma)
+ -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
-- Check that overall pattern is more polymorphic than arg type
; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
@@ -715,18 +717,18 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
; pat_ty <- readExpType h_pat_ty
; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
(Scaled w pat_ty) inf_res_sigma
- -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
- -- (pat_ty -> inf_res_sigma)
- -- NB: pat_ty comes from matchActualFunTy, so it has a
- -- fixed RuntimeRep, as needed to call mkWpFun.
- ; let
+ -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
+ -- (pat_ty -> inf_res_sigma)
+ -- NB: pat_ty comes from matchActualFunTy, so it has a
+ -- fixed RuntimeRep, as needed to call mkWpFun.
+
expr_wrap = expr_wrap2' <.> expr_wrap1
; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
{- Note [View patterns and polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this exotic example:
+Consider this exotic example (test T26331a):
pair :: forall a. Bool -> a -> forall b. b -> (a,b)
f :: Int -> blah
@@ -735,11 +737,15 @@ Consider this exotic example:
The expression (pair True) should have type
pair True :: Int -> forall b. b -> (Int,b)
so that it is ready to consume the incoming Int. It should be an
-arrow type (t1 -> t2); hence using (tcInferRho expr).
+arrow type (t1 -> t2); and we must not instantiate that `forall b`,
+/even with DeepSubsumption/. Hence using `IIF_ShallowRho`; this is the only
+place where `IIF_ShallowRho` is used.
Then, when taking that arrow apart we want to get a *sigma* type
(forall b. b->(Int,b)), because that's what we want to bind 'x' to.
Fortunately that's what matchActualFunTy returns anyway.
+
+Another example is #26331.
-}
-- Type signatures in patterns
@@ -768,8 +774,7 @@ Fortunately that's what matchActualFunTy returns anyway.
penv pats thing_inside
; pat_ty <- readExpType (scaledThing pat_ty)
; return (mkHsWrapPat coi
- (ListPat elt_ty pats') pat_ty, res)
-}
+ (ListPat elt_ty pats') pat_ty, res) }
TuplePat _ pats boxity -> do
{ let arity = length pats
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -62,7 +62,6 @@ import GHC.Tc.Gen.Match
import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )
import GHC.Tc.Zonk.Type
import GHC.Tc.Gen.Expr
-import GHC.Tc.Gen.App( tcInferSigma )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Export
import GHC.Tc.Types.Evidence
@@ -2628,10 +2627,11 @@ tcRnExpr hsc_env mode rdr_expr
failIfErrsM ;
-- Typecheck the expression
- ((tclvl, res_ty), lie)
+ ((tclvl, (_tc_expr, res_ty)), lie)
<- captureTopConstraints $
pushTcLevelM $
- tcInferSigma inst rn_expr ;
+ (if inst then tcInferRho rn_expr
+ else tcInferSigma rn_expr);
-- Generalise
uniq <- newUnique ;
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -65,7 +65,7 @@ module GHC.Tc.Utils.TcMType (
-- Expected types
ExpType(..), ExpSigmaType, ExpRhoType,
mkCheckExpType, newInferExpType, newInferExpTypeFRR,
- tcInfer, tcInferFRR,
+ runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR,
readExpType, readExpType_maybe, readScaledExpType,
expTypeToType, scaledExpTypeToType,
checkingExpType_maybe, checkingExpType,
@@ -438,30 +438,29 @@ See test case T21325.
-- actual data definition is in GHC.Tc.Utils.TcType
-newInferExpType :: TcM ExpType
-newInferExpType = new_inferExpType Nothing
+newInferExpType :: InferInstFlag -> TcM ExpType
+newInferExpType iif = new_inferExpType iif IFRR_Any
-newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR
-newInferExpTypeFRR frr_orig
+newInferExpTypeFRR :: InferInstFlag -> FixedRuntimeRepContext -> TcM ExpTypeFRR
+newInferExpTypeFRR iif frr_orig
= do { th_lvl <- getThLevel
- ; if
- -- See [Wrinkle: Typed Template Haskell]
- -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | TypedBrack _ <- th_lvl
- -> new_inferExpType Nothing
+ ; let mb_frr = case th_lvl of
+ TypedBrack {} -> IFRR_Any
+ _ -> IFRR_Check frr_orig
+ -- mb_frr: see [Wrinkle: Typed Template Haskell]
+ -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | otherwise
- -> new_inferExpType (Just frr_orig) }
+ ; new_inferExpType iif mb_frr }
-new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType
-new_inferExpType mb_frr_orig
+new_inferExpType :: InferInstFlag -> InferFRRFlag -> TcM ExpType
+new_inferExpType iif ifrr
= do { u <- newUnique
; tclvl <- getTcLevel
; traceTc "newInferExpType" (ppr u <+> ppr tclvl)
; ref <- newMutVar Nothing
; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl
- , ir_ref = ref
- , ir_frr = mb_frr_orig })) }
+ , ir_inst = iif, ir_frr = ifrr
+ , ir_ref = ref })) }
-- | Extract a type out of an ExpType, if one exists. But one should always
-- exist. Unless you're quite sure you know what you're doing.
@@ -515,12 +514,12 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
where
-- See Note [TcLevel of ExpType]
new_meta = case mb_frr of
- Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
+ IFRR_Any -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) }
- Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy
- ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
- ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
- ; return tau }
+ IFRR_Check frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy
+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
+ ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
+ ; return tau }
{- Note [inferResultToType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -537,20 +536,31 @@ Note [fillInferResult] in GHC.Tc.Utils.Unify.
-- | Infer a type using a fresh ExpType
-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType"
--
--- Use 'tcInferFRR' if you require the type to have a fixed
+-- Use 'runInferFRR' if you require the type to have a fixed
-- runtime representation.
-tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
-tcInfer = tc_infer Nothing
+runInferSigma :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+runInferSigma = runInfer IIF_Sigma IFRR_Any
--- | Like 'tcInfer', except it ensures that the resulting type
+runInferRho :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)
+runInferRho = runInfer IIF_DeepRho IFRR_Any
+
+runInferKind :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+-- Used for kind-checking types, where we never want deep instantiation,
+-- nor FRR checks
+runInferKind = runInfer IIF_Sigma IFRR_Any
+
+-- | Like 'runInferRho', except it ensures that the resulting type
-- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in
-- GHC.Tc.Utils.Concrete.
-tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)
-tcInferFRR frr_orig = tc_infer (Just frr_orig)
+runInferRhoFRR :: FixedRuntimeRepContext -> (ExpRhoTypeFRR -> TcM a) -> TcM (a, TcRhoTypeFRR)
+runInferRhoFRR frr_orig = runInfer IIF_DeepRho (IFRR_Check frr_orig)
+
+runInferSigmaFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)
+runInferSigmaFRR frr_orig = runInfer IIF_Sigma (IFRR_Check frr_orig)
-tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
-tc_infer mb_frr tc_check
- = do { res_ty <- new_inferExpType mb_frr
+runInfer :: InferInstFlag -> InferFRRFlag -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+runInfer iif mb_frr tc_check
+ = do { res_ty <- new_inferExpType iif mb_frr
; result <- tc_check res_ty
; res_ty <- readExpType res_ty
; return (result, res_ty) }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -24,14 +24,14 @@ module GHC.Tc.Utils.TcType (
--------------------------------
-- Types
TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR,
- TcRhoType, TcTauType, TcPredType, TcThetaType,
+ TcRhoType, TcRhoTypeFRR, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder,
TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied,
- ExpType(..), ExpKind, InferResult(..),
+ ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..),
ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,
- ExpRhoType,
+ ExpRhoType, ExpRhoTypeFRR,
mkCheckExpType,
checkingExpType_maybe, checkingExpType,
@@ -380,6 +380,7 @@ type TcSigmaType = TcType
-- See Note [Return arguments with a fixed RuntimeRep.
type TcSigmaTypeFRR = TcSigmaType
-- TODO: consider making this a newtype.
+type TcRhoTypeFRR = TcRhoType
type TcRhoType = TcType -- Note [TcRhoType]
type TcTauType = TcType
@@ -408,9 +409,13 @@ data InferResult
, ir_lvl :: TcLevel
-- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType
- , ir_frr :: Maybe FixedRuntimeRepContext
+ , ir_frr :: InferFRRFlag
-- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType
+ , ir_inst :: InferInstFlag
+ -- ^ True <=> when DeepSubsumption is on, deeply instantiate before filling,
+ -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify
+
, ir_ref :: IORef (Maybe TcType) }
-- ^ The type that fills in this hole should be a @Type@,
-- that is, its kind should be @TYPE rr@ for some @rr :: RuntimeRep@.
@@ -419,26 +424,48 @@ data InferResult
-- @rr@ must be concrete, in the sense of Note [Concrete types]
-- in GHC.Tc.Utils.Concrete.
-type ExpSigmaType = ExpType
+data InferFRRFlag
+ = IFRR_Check -- Check that the result type has a fixed runtime rep
+ FixedRuntimeRepContext -- Typically used for function arguments and lambdas
+
+ | IFRR_Any -- No need to check for fixed runtime-rep
+
+data InferInstFlag -- Specifies whether the inference should return an uninstantiated
+ -- SigmaType, or a (possibly deeply) instantiated RhoType
+ -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify
+
+ = IIF_Sigma -- Trying to infer a SigmaType
+ -- Don't instantiate at all, regardless of DeepSubsumption
+ -- Typically used when inferring the type of a pattern
+
+ | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top)
+ -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole
+ -- Typically used when inferring the type of an expression
+
+ | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption)
+ -- If DeepSubsumption is off, same as IIF_ShallowRho
+ -- If DeepSubsumption is on, instantiate deeply before filling the hole
+
+type ExpSigmaType = ExpType
+type ExpRhoType = ExpType
+ -- Invariant: in ExpRhoType, if -XDeepSubsumption is on,
+ -- and we are in checking mode (i.e. the ExpRhoType is (Check rho)),
+ -- then the `rho` is deeply skolemised
-- | An 'ExpType' which has a fixed RuntimeRep.
--
-- For a 'Check' 'ExpType', the stored 'TcType' must have
-- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr'
--- field must be of the form @Just frr_orig@.
-type ExpTypeFRR = ExpType
+-- field must be of the form @IFRR_Check frr_orig@.
+type ExpTypeFRR = ExpType
-- | Like 'TcSigmaTypeFRR', but for an expected type.
--
-- See 'ExpTypeFRR'.
type ExpSigmaTypeFRR = ExpTypeFRR
+type ExpRhoTypeFRR = ExpTypeFRR
-- TODO: consider making this a newtype.
-type ExpRhoType = ExpType
- -- Invariant: if -XDeepSubsumption is on,
- -- and we are checking (i.e. the ExpRhoType is (Check rho)),
- -- then the `rho` is deeply skolemised
-
-- | Like 'ExpType', but on kind level
type ExpKind = ExpType
@@ -447,12 +474,17 @@ instance Outputable ExpType where
ppr (Infer ir) = ppr ir
instance Outputable InferResult where
- ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr })
- = text "Infer" <> mb_frr_text <> braces (ppr u <> comma <> ppr lvl)
+ ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr, ir_inst = inst })
+ = text "Infer" <> parens (pp_inst <> pp_frr)
+ <> braces (ppr u <> comma <> ppr lvl)
where
- mb_frr_text = case mb_frr of
- Just _ -> text "FRR"
- Nothing -> empty
+ pp_inst = case inst of
+ IIF_Sigma -> text "Sigma"
+ IIF_ShallowRho -> text "ShallowRho"
+ IIF_DeepRho -> text "DeepRho"
+ pp_frr = case mb_frr of
+ IFRR_Check {} -> text ",FRR"
+ IFRR_Any -> empty
-- | Make an 'ExpType' suitable for checking.
mkCheckExpType :: TcType -> ExpType
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Tc.Utils.Unify (
-- Skolemisation
DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS,
tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType,
- deeplyInstantiate,
+ dsInstantiate,
-- Various unifications
unifyType, unifyKind, unifyInvisibleType,
@@ -40,7 +40,6 @@ module GHC.Tc.Utils.Unify (
--------------------------------
-- Holes
- tcInfer,
matchExpectedListTy,
matchExpectedTyConApp,
matchExpectedAppTy,
@@ -60,7 +59,7 @@ module GHC.Tc.Utils.Unify (
simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..),
- fillInferResult, fillInferResultDS
+ fillInferResult, fillInferResultNoInst
) where
import GHC.Prelude
@@ -801,13 +800,13 @@ matchExpectedFunTys :: forall a.
-- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{}
matchExpectedFunTys herald _ctxt arity (Infer inf_res) thing_inside
= do { arg_tys <- mapM (new_infer_arg_ty herald) [1 .. arity]
- ; res_ty <- newInferExpType
+ ; res_ty <- newInferExpType (ir_inst inf_res)
; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty
; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys
; res_ty <- readExpType res_ty
-- NB: mkScaledFunTys arg_tys res_ty does not contain any foralls
-- (even nested ones), so no need to instantiate.
- ; co <- fillInferResult (mkScaledFunTys arg_tys res_ty) inf_res
+ ; co <- fillInferResultNoInst (mkScaledFunTys arg_tys res_ty) inf_res
; return (mkWpCastN co, result) }
matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
@@ -914,10 +913,10 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty
; return (mkWpCastN co, result) }
-new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR)
+new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR)
new_infer_arg_ty herald arg_pos -- position for error messages only
= do { mult <- newFlexiTyVarTy multiplicityTy
- ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)
+ ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos)
; return (mkScaled mult inf_hole) }
new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)
@@ -1075,18 +1074,6 @@ matchExpectedAppTy orig_ty
*
********************************************************************** -}
-{- Note [inferResultToType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-expTypeToType and inferResultType convert an InferResult to a monotype.
-It must be a monotype because if the InferResult isn't already filled in,
-we fill it in with a unification variable (hence monotype). So to preserve
-order-independence we check for mono-type-ness even if it *is* filled in
-already.
-
-See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and
-Note [fillInferResult].
--}
-
-- | Fill an 'InferResult' with the given type.
--
-- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@,
@@ -1098,14 +1085,14 @@ Note [fillInferResult].
-- The stored type @t2@ is at the same level as given by the
-- 'ir_lvl' field.
-- - FRR invariant.
--- Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed
+-- Whenever the 'ir_frr' field is `IFRR_Check`, @t2@ is guaranteed
-- to have a syntactically fixed RuntimeRep, in the sense of
-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-fillInferResult :: TcType -> InferResult -> TcM TcCoercionN
-fillInferResult act_res_ty (IR { ir_uniq = u
- , ir_lvl = res_lvl
- , ir_frr = mb_frr
- , ir_ref = ref })
+fillInferResultNoInst :: TcType -> InferResult -> TcM TcCoercionN
+fillInferResultNoInst act_res_ty (IR { ir_uniq = u
+ , ir_lvl = res_lvl
+ , ir_frr = mb_frr
+ , ir_ref = ref })
= do { mb_exp_res_ty <- readTcRef ref
; case mb_exp_res_ty of
Just exp_res_ty
@@ -1126,7 +1113,7 @@ fillInferResult act_res_ty (IR { ir_uniq = u
ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty
; cur_lvl <- getTcLevel
; unless (cur_lvl `sameDepthAs` res_lvl) $
- ensureMonoType act_res_ty
+ ensureMonoType act_res_ty -- See (FIR1)
; unifyType Nothing act_res_ty exp_res_ty }
Nothing
-> do { traceTc "Filling inferred ExpType" $
@@ -1140,16 +1127,28 @@ fillInferResult act_res_ty (IR { ir_uniq = u
-- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing').
; (frr_co, act_res_ty) <-
case mb_frr of
- Nothing -> return (mkNomReflCo act_res_ty, act_res_ty)
- Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty
+ IFRR_Any -> return (mkNomReflCo act_res_ty, act_res_ty)
+ IFRR_Check frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty
-- Compose the two coercions.
; let final_co = prom_co `mkTransCo` frr_co
; writeTcRef ref (Just act_res_ty)
- ; return final_co }
- }
+ ; return final_co } }
+
+fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper
+-- See Note [Instantiation of InferResult]
+fillInferResult ct_orig res_ty ires@(IR { ir_inst = iif })
+ = case iif of
+ IIF_Sigma -> do { co <- fillInferResultNoInst res_ty ires
+ ; return (mkWpCastN co) }
+ IIF_ShallowRho -> do { (wrap, res_ty') <- topInstantiate ct_orig res_ty
+ ; co <- fillInferResultNoInst res_ty' ires
+ ; return (mkWpCastN co <.> wrap) }
+ IIF_DeepRho -> do { (wrap, res_ty') <- dsInstantiate ct_orig res_ty
+ ; co <- fillInferResultNoInst res_ty' ires
+ ; return (mkWpCastN co <.> wrap) }
{- Note [fillInferResult]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1210,39 +1209,96 @@ For (2), we simply look to see if the hole is filled already.
- if it is filled, we simply unify with the type that is
already there
-There is one wrinkle. Suppose we have
- case e of
- T1 -> e1 :: (forall a. a->a) -> Int
- G2 -> e2
-where T1 is not GADT or existential, but G2 is a GADT. Then suppose the
-T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.
-But now the G2 alternative must not *just* unify with that else we'd risk
-allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first
-we'd have filled the hole with a unification variable, which enforces a
-monotype.
-
-So if we check G2 second, we still want to emit a constraint that restricts
-the RHS to be a monotype. This is done by ensureMonoType, and it works
-by simply generating a constraint (alpha ~ ty), where alpha is a fresh
+(FIR1) There is one wrinkle. Suppose we have
+ case e of
+ T1 -> e1 :: (forall a. a->a) -> Int
+ G2 -> e2
+ where T1 is not GADT or existential, but G2 is a GADT. Then suppose the
+ T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.
+ But now the G2 alternative must not *just* unify with that else we'd risk
+ allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first
+ we'd have filled the hole with a unification variable, which enforces a
+ monotype.
+
+ So if we check G2 second, we still want to emit a constraint that restricts
+ the RHS to be a monotype. This is done by ensureMonoType, and it works
+ by simply generating a constraint (alpha ~ ty), where alpha is a fresh
unification variable. We discard the evidence.
--}
+Note [Instantiation of InferResult]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking expressions (not types, not patterns), we always almost
+always instantiate before filling in `InferResult`, so that the result is a
+TcRhoType. This behaviour is controlled by the `ir_inst :: InferInstFlag`
+field of `InferResult`.
--- | A version of 'fillInferResult' that also performs deep instantiation
--- when deep subsumption is enabled.
---
--- See also Note [Instantiation of InferResult].
-fillInferResultDS :: CtOrigin -> TcRhoType -> InferResult -> TcM HsWrapper
-fillInferResultDS ct_orig rho inf_res
- = do { massertPpr (isRhoTy rho) $
- vcat [ text "fillInferResultDS: input type is not a rho-type"
- , text "ty:" <+> ppr rho ]
- ; ds_flag <- getDeepSubsumptionFlag
- ; case ds_flag of
- Shallow -> mkWpCastN <$> fillInferResult rho inf_res
- Deep -> do { (inst_wrap, rho') <- deeplyInstantiate ct_orig rho
- ; co <- fillInferResult rho' inf_res
- ; return (mkWpCastN co <.> inst_wrap) } }
+If we do instantiate (ir_inst = IIF_DeepRho), and DeepSubsumption is enabled,
+we instantiate deeply. See `tcInferResult`.
+
+Usually this field is `IIF_DeepRho` meaning "return a (possibly deep) rho-type".
+Why is this the common case? See #17173 for discussion. Here are some examples
+of why:
+
+1. Consider
+ f x = (*)
+ We want to instantiate the type of (*) before returning, else we
+ will infer the type
+ f :: forall {a}. a -> forall b. Num b => b -> b -> b
+ This is surely confusing for users.
+
+ And worse, the monomorphism restriction won't work properly. The MR is
+ dealt with in simplifyInfer, and simplifyInfer has no way of
+ instantiating. This could perhaps be worked around, but it may be
+ hard to know even when instantiation should happen.
+
+2. Another reason. Consider
+ f :: (?x :: Int) => a -> a
+ g y = let ?x = 3::Int in f
+ Here want to instantiate f's type so that the ?x::Int constraint
+ gets discharged by the enclosing implicit-parameter binding.
+
+3. Suppose one defines plus = (+). If we instantiate lazily, we will
+ infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism
+ restriction compels us to infer
+ plus :: Integer -> Integer -> Integer
+ (or similar monotype). Indeed, the only way to know whether to apply
+ the monomorphism restriction at all is to instantiate
+
+HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning
+"return a sigma-type":
+
+* IIF_Sigma: In GHC.Tc.Module.tcRnExpr, which implements GHCi's :type
+ command, we want to return a completely uninstantiated type.
+ See Note [Implementing :type] in GHC.Tc.Module.
+
+* IIF_Sigma: In types we can't lambda-abstract, so we must be careful not to instantiate
+ at all. See calls to `runInferHsType`
+
+* IIF_Sigma: in patterns we don't want to instantiate at all. See the use of
+ `runInferSigmaFRR` in GHC.Tc.Gen.Pat
+
+* IIF_ShallowRho: in the expression part of a view pattern, we must top-instantiate
+ but /not/ deeply instantiate (#26331). See Note [View patterns and polymorphism]
+ in GHC.Tc.Gen.Pat. This the only place we use IIF_ShallowRho.
+
+Why do we want to deeply instantiate, ever? Why isn't top-instantiation enough?
+Answer: to accept the following program (T26225b) with -XDeepSubsumption, we
+need to deeply instantiate when inferring in checkResultTy:
+
+ f :: Int -> (forall a. a->a)
+ g :: Int -> Bool -> Bool
+
+ test b =
+ case b of
+ True -> f
+ False -> g
+
+If we don't deeply instantiate in the branches of the case expression, we will
+try to unify the type of 'f' with that of 'g', which fails. If we instead
+deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha'
+which then successfully unifies with the type of 'g' when we come to fill the
+'InferResult' hole a second time for the second case branch.
+-}
{-
************************************************************************
@@ -1337,7 +1393,7 @@ tcSubTypeMono rn_expr act_ty exp_ty
, text "act_ty:" <+> ppr act_ty
, text "rn_expr:" <+> ppr rn_expr]) $
case exp_ty of
- Infer inf_res -> fillInferResult act_ty inf_res
+ Infer inf_res -> fillInferResultNoInst act_ty inf_res
Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty
------------------------
@@ -1351,7 +1407,7 @@ tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected
= tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected
tcSubTypePat _ _ (Infer inf_res) ty_expected
- = do { co <- fillInferResult ty_expected inf_res
+ = do { co <- fillInferResultNoInst ty_expected inf_res
-- In patterns we do not instantatiate
; return (mkWpCastN (mkSymCo co)) }
@@ -1377,7 +1433,7 @@ tcSubTypeDS rn_expr act_rho exp_rho
-- | Checks that the 'actual' type is more polymorphic than the 'expected' type.
tcSubType :: CtOrigin -- ^ Used when instantiating
-> UserTypeCtxt -- ^ Used when skolemising
- -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)
+ -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)
-> TcSigmaType -- ^ Actual type
-> ExpRhoType -- ^ Expected type
-> TcM HsWrapper
@@ -1386,10 +1442,7 @@ tcSubType inst_orig ctxt m_thing ty_actual res_ty
Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt
ty_actual ty_expected
- Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual
- -- See Note [Instantiation of InferResult]
- ; inst <- fillInferResultDS inst_orig rho inf_res
- ; return (inst <.> wrap) }
+ Infer inf_res -> fillInferResult inst_orig ty_actual inf_res
---------------
tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we
@@ -1428,47 +1481,6 @@ addSubTypeCtxt ty_actual ty_expected thing_inside
; return (tidy_env, SubTypeCtxt ty_expected ty_actual) }
-{- Note [Instantiation of InferResult]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typechecking expressions (not types, not patterns), we always instantiate
-before filling in InferResult, so that the result is a TcRhoType.
-See #17173 for discussion.
-
-For example:
-
-1. Consider
- f x = (*)
- We want to instantiate the type of (*) before returning, else we
- will infer the type
- f :: forall {a}. a -> forall b. Num b => b -> b -> b
- This is surely confusing for users.
-
- And worse, the monomorphism restriction won't work properly. The MR is
- dealt with in simplifyInfer, and simplifyInfer has no way of
- instantiating. This could perhaps be worked around, but it may be
- hard to know even when instantiation should happen.
-
-2. Another reason. Consider
- f :: (?x :: Int) => a -> a
- g y = let ?x = 3::Int in f
- Here want to instantiate f's type so that the ?x::Int constraint
- gets discharged by the enclosing implicit-parameter binding.
-
-3. Suppose one defines plus = (+). If we instantiate lazily, we will
- infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism
- restriction compels us to infer
- plus :: Integer -> Integer -> Integer
- (or similar monotype). Indeed, the only way to know whether to apply
- the monomorphism restriction at all is to instantiate
-
-There is one place where we don't want to instantiate eagerly,
-namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type
-command. See Note [Implementing :type] in GHC.Tc.Module.
-
-This also means that, if DeepSubsumption is enabled, we should also instantiate
-deeply; we do this by using fillInferResultDS.
--}
-
---------------
tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify
-> CtOrigin -- Used when instantiating
@@ -2133,7 +2145,17 @@ deeplySkolemise skol_info ty
= return (idHsWrapper, [], [], substTy subst ty)
-- substTy is a quick no-op on an empty substitution
+dsInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)
+-- Do topInstantiate or deeplyInstantiate, depending on -XDeepSubsumption
+dsInstantiate orig ty
+ = do { ds_flag <- getDeepSubsumptionFlag
+ ; case ds_flag of
+ Shallow -> topInstantiate orig ty
+ Deep -> deeplyInstantiate orig ty }
+
deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)
+-- Instantiate invisible foralls, even ones nested
+-- (to the right) under arrows
deeplyInstantiate orig ty
= go init_subst ty
where
=====================================
testsuite/tests/patsyn/should_compile/T26331.hs
=====================================
@@ -0,0 +1,47 @@
+{-# LANGUAGE DeepSubsumption #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module T26331 where
+
+import Data.Kind (Constraint, Type)
+
+type Apply :: (k1 ~> k2) -> k1 -> k2
+type family Apply (f :: k1 ~> k2) (x :: k1) :: k2
+
+type (~>) :: Type -> Type -> Type
+type a ~> b = TyFun a b -> Type
+infixr 0 ~>
+
+data TyFun :: Type -> Type -> Type
+
+type Sing :: k -> Type
+type family Sing @k :: k -> Type
+
+type SingFunction2 :: (a1 ~> a2 ~> b) -> Type
+type SingFunction2 (f :: a1 ~> a2 ~> b) =
+ forall t1 t2. Sing t1 -> Sing t2 -> Sing (f `Apply` t1 `Apply` t2)
+
+unSingFun2 :: forall f. Sing f -> SingFunction2 f
+-- unSingFun2 :: forall f. Sing f -> forall t1 t2. blah
+unSingFun2 sf x = error "urk"
+
+singFun2 :: forall f. SingFunction2 f -> Sing f
+singFun2 f = error "urk"
+
+-------- This is the tricky bit -------
+pattern SLambda2 :: forall f. SingFunction2 f -> Sing f
+pattern SLambda2 x <- (unSingFun2 -> x) -- We want to push down (SingFunction2 f)
+ -- /uninstantiated/ into the pattern `x`
+ where
+ SLambda2 lam2 = singFun2 lam2
+
=====================================
testsuite/tests/patsyn/should_compile/T26331a.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE DeepSubsumption #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+
+module T26331a where
+
+pair :: forall a. Bool -> a -> forall b. b -> (a,b)
+pair = error "urk"
+
+f :: Int -> ((Int,Bool),(Int,Char))
+f (pair True -> x) = (x True, x 'c') -- (x :: forall b. b -> (Int,b))
=====================================
testsuite/tests/patsyn/should_compile/all.T
=====================================
@@ -85,3 +85,5 @@ test('T21531', [ grep_errmsg(r'INLINE') ], compile, ['-ddump-ds'])
test('T22521', normal, compile, [''])
test('T23038', normal, compile_fail, [''])
test('T22328', normal, compile, [''])
+test('T26331', normal, compile, [''])
+test('T26331a', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/299b483c9e86a26467ab3e460c13717ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/299b483c9e86a26467ab3e460c13717ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/9.12.3-backports] 74 commits: LLVM: account for register type in funPrologue
by Zubin (ļ¼ wz1000) 28 Aug '25
by Zubin (ļ¼ wz1000) 28 Aug '25
28 Aug '25
Zubin pushed to branch wip/9.12.3-backports at Glasgow Haskell Compiler / GHC
Commits:
153ffd53 by sheaf at 2025-08-28T15:00:11+05:30
LLVM: account for register type in funPrologue
We were not properly accounting for the live register type of
global registers in GHC.CmmToLlvm.CodeGen.funPrologue. This meant that
we could allocated a register at type <4 x i32> but try to write to it
at type <8 x i16>, which LLVM doesn't much like.
This patch fixes that by inserting intermerdiate casts when necessary.
Fixes #25730
(cherry picked from commit 33aca30fbff67188fd5692cf40f1e2542663bfec)
- - - - -
f8451a02 by Cheng Shao at 2025-08-28T15:00:11+05:30
libffi: update to 3.4.7
Bumps libffi submodule.
(cherry picked from commit c318be56f69eb87f1cbb219dd660f09498857ece)
- - - - -
96e12616 by sheaf at 2025-08-28T15:00:11+05:30
Propagate long distance info to guarded let binds
This commit ensures that we propagate the enclosing long distance
information to let bindings inside guards, in order to get accurate
pattern-match checking warnings, in particular incomplete record
selector warnings.
Example:
data D = K0 | K1 { fld :: Int }
f :: D -> Int
f d@(K1 {})
| let i = fld d
= i
f _ = 3
We now correctly recognise that the field selector 'fld' cannot fail,
due to the outer pattern match which guarantees that the value 'd' has
the field 'fld'.
Fixes #25749
(cherry picked from commit 0f2241e9758e8b74fedfe52269a8fb1ff17858cb)
- - - - -
f3e9739f by Fangyi Zhou at 2025-08-28T15:00:11+05:30
wasm: use primitive opcodes for fabs and sqrt
- Add new `WasmInstr` constructor `WasmSqrt` for sqrt, corresponding to
primitivie operations in wasm.
- When lowering CallishMachOp, use `WasmAbs` and `WasmSqrt` for F32 and
F64 fabs and sqrt.
(cherry picked from commit 64b0d4d061902c0f7443355fa4877ff6aad946d5)
- - - - -
551a0efe by Cheng Shao at 2025-08-28T15:00:11+05:30
ghc-heap: fix HalfWord incompatible Binary instances for cross GHC
ghc-heap defines HalfWord as Word32/Word16 depending on host word
size. For cross GHC with different host/target word sizes, the Binary
instances are incompatible and breaks iserv serialization of any
message type that involves HalfWord, breaking the ghci debugger. This
patch fixes the issue and has been tested to fix ghci debugger
functionality of the wasm backend. Fixes #25420 #25781.
(cherry picked from commit b228fcb5313e82895493a6ef7f0a2e803695de02)
- - - - -
a4c912f6 by Andreas Klebinger at 2025-08-28T15:00:11+05:30
cmmMachOpFoldM: Add missing pattern matches for bitcasts.
Fixes #25771
(cherry picked from commit 9c1647d1557834f277fe9d4040789c60c9ef8e3d)
- - - - -
432772e0 by Teo Camarasu at 2025-08-28T15:00:11+05:30
ghc-boot-th: expose all TH packages from proper GHC.Boot.* modules
Previously we defined some modules here in the GHC.Internal namespace.
Others were merely re-exposed from GHC.Internal.
Re-exposed modules weren't handled correctly by Haddock, so the
Haddocks for the `template-haskell` library couldn't see them.
This change also makes the home package of these modules a bit clearer.
Work towards #25705
(cherry picked from commit f2d43e11302d7f0133c025f7847ac924b6e9303c)
- - - - -
53bdefeb by Teo Camarasu at 2025-08-28T15:00:11+05:30
ghc-boot-th: fix synopsis formatting
`@...@` syntax doesn't seem to work in synposes and is just kept by
Haddock verbatim.
(cherry picked from commit 91ef82df3b15bd35c660d6ca0882d7a19c93b3a1)
- - - - -
dcad4750 by Brandon Chinn at 2025-08-28T15:00:11+05:30
Collapse string gaps as \& (#25784)
In 9.10, "\65\ \0" would result in "A0", but in 9.12, it results in
"\650", due to the string refactoring I did in !13128. Previously, we
were resolving escape codes and collapsing string gaps as we come across
them, but after the refactor, string processing is broken out into
phases, which is both more readable and useful for multiline strings.
(cherry picked from commit eb9fe1ec0a1b35e4a9ceeafd7943dc95b3180fc3)
- - - - -
daa2c5b8 by Brandon Chinn at 2025-08-28T15:00:11+05:30
Fix lexing "\^\" (#25937)
This broke in the refactor in !13128, where the old code parsed escape
codes and collapsed string gaps at the same time, but the new code
collapsed gaps first, then resolved escape codes. The new code used a
naive heuristic to skip escaped backslashes, but didn't account for
"\^\".
(cherry picked from commit 6467d61ee8cdd6b611e035b72cbe356cbf90fa35)
- - - - -
0dcc4f2a by Matthew Craven at 2025-08-28T15:00:11+05:30
Cmm: Add surface syntax for Word/Float bitcast ops
(cherry picked from commit 1d4c9824bb3cb4b16cbab786021aad1576a65d7e)
- - - - -
1378d2a3 by Matthew Craven at 2025-08-28T15:00:11+05:30
Cmm: Add constant-folding for Word->Float bitcasts
(cherry picked from commit 25c4a2a236060232c929bf7f039f5f59d108f869)
- - - - -
bd8f5fa9 by Matthew Craven at 2025-08-28T15:00:11+05:30
Add tests for #25771
(cherry picked from commit 30bdea67fcd9755619b1f513d199f2122591b28e)
- - - - -
3dc59fc0 by Vladislav Zavialov at 2025-08-28T15:00:11+05:30
Error message with EmptyCase and RequiredTypeArguments (#25004)
Fix a panic triggered by a combination of \case{} and forall t ->
ghci> let f :: forall (xs :: Type) -> (); f = \case {}
panic! (the 'impossible' happened)
GHC version 9.10.1:
Util: only
The new error message looks like this:
ghci> let f :: forall (xs :: Type) -> (); f = \case {}
<interactive>:5:41: error: [GHC-48010]
ā¢ Empty list of alternatives in \case expression
checked against a forall-type: forall xs -> ...
This is achieved as follows:
* A new data type, BadEmptyCaseReason, is now used to describe
why an empty case has been rejected. Used in TcRnEmptyCase.
* HsMatchContextRn is passed to tcMatches, so that the type checker
can attach the syntactic context to the error message.
* tcMatches now rejects type arguments if the list of alternatives is
empty. This is what fixes the bug.
(cherry picked from commit cce869ea2439bb16c284ce7ed71a173d54a8c9ad)
(cherry picked from commit 41db0a0bea41679875fc392a45927419c182c1d9)
- - - - -
7aa3de4b by Simon Peyton Jones at 2025-08-28T15:00:11+05:30
We can't UNPACK multi-constructor GADTs
This MR fixes #25672
See Note [Unpacking GADTs and existentials] in GHC.Types.Id.Make
(cherry picked from commit b6d5b09103dea97351774c5ab34082165504b997)
- - - - -
d8816e24 by sheaf at 2025-08-28T15:00:12+05:30
user's guide: consolidate defaulting documentation
This commit adds a new section on defaulting, which consolidates various
parts of documentation surrounding defaulting into one central place.
It explains type class defaulting in detail, extensions to it with
OverloadedStrings, NamedDefaults and ExtendedDefaultRules, as well
as other defaulting mechanisms (e.g. kind-based defaulting such as
RuntimeRep defaulting, and defaulting of equalities).
(cherry picked from commit 37d8b50b6de8ee69ea26196fd3869fe0a83e5802)
- - - - -
314267e3 by sheaf at 2025-08-28T15:00:12+05:30
user's guide: flesh out XOverloadedStrings docs
This commit extends the documentation of the OverloadedStrings extension
with some usage information, in particular suggestions to:
- use default declarations, such as `default (Text)` or
`default IsString(Text)` (with the NamedDefaults extension),
- enable the ExtendedDefaultRules extension to relax the requirement
that a defaultable type variable must only appear in unary standard
classes
Fixes #23388
(cherry picked from commit 0c9fd8d48ab018739ac146420c474367c98d9ab1)
- - - - -
bf063686 by sheaf at 2025-08-28T15:00:12+05:30
user's guide: NamedDefaults vs ExtendedDefaultRules
This commit clarifies the defaulting rules with NamedDefaults,
in particular in situations where a type variable appears in other
constraints than standard/unary constraints.
(cherry picked from commit 2df171d40b93c666a3aa8b616a47c9acf13f7189)
- - - - -
2960ffa0 by Teo Camarasu at 2025-08-28T15:00:12+05:30
template-haskell: Add explicit exports lists to all remaining modules
(cherry picked from commit 8eae151de9eb8f8fd0a41c1a33e25c63b1e1bb11)
- - - - -
9baeb3e7 by sheaf at 2025-08-28T15:00:12+05:30
Don't report used duplicate record fields as unused
This commit fixes the bug reported in #24035 in which the import of a
duplicate record field could be erroneously reported as unused.
The issue is that an import of the form "import M (fld)" can import
several different 'Name's, and we should only report an error if ALL
of those 'Name's are unused, not if ANY are.
Note [Reporting unused imported duplicate record fields]
in GHC.Rename.Names explains the solution to this problem.
Fixes #24035
(cherry picked from commit 0cb1db9270e11469f11a2ccf323219e032c2a312)
- - - - -
c7dce9fd by ARATA Mizuki at 2025-08-28T15:00:12+05:30
Fix code generation for SSE vector operations
The new implementation generates correct code
even if the registers overlap.
Closes #25859
(cherry picked from commit 25850b22e76a2c23f549caff38ccd0da134051de)
- - - - -
979ecd67 by sheaf at 2025-08-28T15:00:12+05:30
Don't cache solved [W] HasCallStack constraints
This commit ensures we do not add solved Wanted constraints that mention
HasCallStack or HasExceptionContext constraints to the set of solved
Wanted dictionary constraints: caching them is invalid, because re-using
such cached dictionaries means using an old call-stack instead of
constructing a new one, as was reported in #25529.
Fixes #25529.
(cherry picked from commit 256ac29c8df4f17a1d50ea243408d506ebf395d6)
(cherry picked from commit 3b1ef0ae473c9ae52c1280f9f1577a7cbacdf5d4)
- - - - -
fd643c3a by Zubin Duggal at 2025-08-28T15:00:12+05:30
In commit "Don't cache solved [W] HasCallStack constraints" (256ac29c8df4f17a1d50ea243408d506ebf395d6),
we attempt to use `tryM` to avoid errors when looking up certain known-key names like CallStack while
compiling ghc-prim and ghc-internal.
Unfortunately, `tryM` doesn't catch module lookup errors. This manifests as a failure to build ghc-prim
in `--make` mode on the GHC 9.10 branch.
Instead, we explicitly avoid doing lookups when we are compiling ghc-prim or ghc-internal instead of
relying on catching the exception.
(cherry picked from commit 7492d00749488b628139d5c3bd5fa4b33cc2e4ad)
(cherry picked from commit efe1efedca6633a09e6999e25231716f9870745e)
- - - - -
061105e4 by sheaf at 2025-08-28T15:00:12+05:30
LLVM: fix typo in padLiveArgs
This commit fixes a serious bug in the padLiveArgs function, which
was incorrectly computing too many padding registers. This caused
segfaults, e.g. in the UnboxedTuples test.
Fixes #25770
Fixes #25773
(cherry picked from commit 044a6e08c2aee23ef18c60a036e01d3b77168830)
- - - - -
c1546376 by sheaf at 2025-08-28T15:00:12+05:30
GHC settings: always unescape escaped spaces
In #25204, it was noted that GHC didn't properly deal with having
spaces in its executable path, as it would compute an invalid path
for the C compiler.
The original fix in 31bf85ee49fe2ca0b17eaee0774e395f017a9373 used a
trick: escape spaces before splitting up flags into a list. This fixed
the behaviour with extra flags (e.g. -I), but forgot to also unescape
for non-flags, e.g. for an executable path (such as the C compiler).
This commit rectifies this oversight by consistently unescaping the
spaces that were introduced in order to split up argument lists.
Fixes #25204
(cherry picked from commit aa1e3b8b5c9a92592b6a49783083da37dfc69375)
(cherry picked from commit cf5d5a31e3033fc2beeab8578056f096cce0eaef)
- - - - -
8fe9b012 by Andreas Klebinger at 2025-08-28T15:00:12+05:30
NCG: AArch64 - Add -finter-module-far-jumps.
When enabled the arm backend will assume jumps to targets outside of the
current module are further than 128MB away.
This will allow for code to work if:
* The current module results in less than 128MB of code.
* The whole program is loaded within a 4GB memory region.
We have seen a few reports of broken linkers (#24648) where this flag might allow
a program to compile/run successfully at a very small performance cost.
-------------------------
Metric Increase:
T783
-------------------------
(cherry picked from commit f32d6c2b468c67fed619f2fa1fb97eb012afbb6e)
- - - - -
905f682c by Adam Gundry at 2025-08-28T15:00:12+05:30
user's guide: update specification of overlapping/incoherent instances
The description of the instance resolution algorithm in the user's
guide was slightly out of date, because it mentioned in-scope given
constraints only at the end, whereas the implementation checks for
their presence before any of the other steps.
This also adds a warning to the user's guide about the impact of
incoherent instances on specialisation, and more clearly documents
some of the other effects of `-XIncoherentInstances`.
(cherry picked from commit eec96527b7482fe8ee37dbab740f69804d063497)
- - - - -
9597102b by Adam Gundry at 2025-08-28T15:00:12+05:30
Fix specialisation of incoherent instances (fixes #25883)
GHC normally assumes that class constraints are canonical, meaning that
the specialiser is allowed to replace one dictionary argument with another
provided that they have the same type. The `-fno-specialise-incoherents`
flag alters INCOHERENT instance definitions so that they will prevent
specialisation in some cases, by inserting `nospec`.
This commit fixes a bug in 7124e4ad76d98f1fc246ada4fd7bf64413ff2f2e, which
treated some INCOHERENT instance matches as if `-fno-specialise-incoherents`
was in effect, thereby unnecessarily preventing specialisation. In addition
it updates the relevant `Note [Rules for instance lookup]` and adds a new
`Note [Canonicity for incoherent matches]`.
(cherry picked from commit 6caa6508ed43a8842fc410f7125258e84cb912b9)
- - - - -
ad59a011 by Adam Gundry at 2025-08-28T15:00:12+05:30
Add regression test for #23429
(cherry picked from commit 0426fd6c67dba2c1695c272e1c7bfb92789453c5)
- - - - -
cab81394 by Matthew Craven at 2025-08-28T15:00:12+05:30
Fix bytecode generation for `tagToEnum# <LITERAL>`
Fixes #25975.
(cherry picked from commit a00eeaec8f0b98ec2b8c4630f359fdeb3a6ce04e)
(cherry picked from commit 873c0cdcd45466f5c73c0dc1544e1b6663db25ce)
- - - - -
769e650a by Matthew Pickering at 2025-08-28T15:00:12+05:30
ghci: Use loadInterfaceForModule rather than loadSrcInterface in mkTopLevEnv
loadSrcInterface takes a user given `ModuleName` and resolves it to the
module which needs to be loaded (taking into account module
renaming/visibility etc).
loadInterfaceForModule takes a specific module and loads it.
The modules in `ImpDeclSpec` have already been resolved to the actual
module to get the information from during renaming. Therefore we just
need to fetch the precise interface from disk (and not attempt to rename
it again).
Fixes #25951
(cherry picked from commit 91564dafd60445f03025c3fee4f9802e80bb09c3)
- - - - -
274e3cc3 by Sven Tennie at 2025-08-28T15:00:12+05:30
RV64: Introduce J instruction (non-local jumps) and don't deallocate stack slots for J_TBL (#25738)
J_TBL result in local jumps, there should not deallocate stack slots
(see Note [extra spill slots].)
J is for non-local jumps, these may need to deallocate stack slots.
(cherry picked from commit 0eef99b07f80f81d463652d11bdc2282df3dcf33)
- - - - -
787c0f9f by Zubin Duggal at 2025-08-28T15:00:12+05:30
get-win32-tarballs.py: List tarball files to be downloaded if we cannot find them
Fixes #25929
(cherry picked from commit aba2a4a5913a347f7e11623ac3e6f528cf8d8c39)
- - - - -
652f3c8a by Ben Gamari at 2025-08-28T15:00:12+05:30
llvmGen: Fix linkage of built-in arrays
LLVM now insists that built-in arrays use Appending linkage, not
Internal.
Fixes #25769.
(cherry picked from commit a9d0a22c0777de18446f7f1e31ec0f575d53b290)
- - - - -
85e28e72 by sheaf at 2025-08-28T15:00:12+05:30
Use mkTrAppChecked in ds_ev_typeable
This change avoids violating the invariant of mkTrApp according to which
the argument should not be a fully saturated function type.
This ensures we don't return false negatives for type equality
involving function types.
Fixes #25998
(cherry picked from commit 9c6d2b1bf54310b6d9755aa2ba67fbe38feeac51)
- - - - -
0e31d484 by Ben Gamari at 2025-08-28T15:00:12+05:30
Reapply "Division by constants optimization"
This reverts commit eb2859af981415ed6bf08fcf4d8f19811bf95494.
(cherry picked from commit f0499c94071c11d31d5afc996431cf4b909dbd76)
- - - - -
0c6f0f52 by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker: Don't fail due to RTLD_NOW
In !12264 we started using the NativeObj machinery introduced some time
ago for loading of shared objects. One of the side-effects of this
change is shared objects are now loaded eagerly (i.e. with `RTLD_NOW`).
This is needed by NativeObj to ensure full visibility of the mappings of
the loaded object, which is in turn needed for safe shared object
unloading.
Unfortunately, this change subtly regressed, causing compilation
failures in some programs. Specifically, shared objects which refer to
undefined symbols (e.g. which may be usually provided by either the
executable image or libraries loaded via `dlopen`) will fail to load
with eager binding. This is problematic as GHC loads all package
dependencies while, e.g., evaluating TemplateHaskell splices. This
results in compilation failures in programs depending upon (but not
using at compile-time) packages with undefined symbol references.
To mitigate this NativeObj now first attempts to load an object via
eager binding, reverting to lazy binding (and disabling unloading) on
failure.
See Note [Don't fail due to RTLD_NOW].
Fixes #25943.
(cherry picked from commit 715d2a8550418d342bea767e1a4b0c7695966463)
(cherry picked from commit a9de3b73ebb6f29eeae7d170a0210f5bedeb8d85)
- - - - -
48c54627 by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker: Factor out ProddableBlocks machinery
(cherry picked from commit 2921131cfa185c8e0ec48ddce2c994615493ca0a)
(cherry picked from commit 7d7e096504cd35272df9727b92dcbe7d94927ac8)
- - - - -
a3e42760 by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker: Improve efficiency of proddable blocks structure
Previously the linker's "proddable blocks" check relied on a simple
linked list of spans. This resulted in extremely poor complexity while
linking objects with lots of small sections (e.g. objects built with
split sections).
Rework the mechanism to instead use a simple interval set implemented
via binary search.
Fixes #26009.
(cherry picked from commit e6e69dba996f47e21391f023010f5b138dc1df9c)
(cherry picked from commit b388ca86b5e56636a1862987ec1b1d3deefedc9e)
- - - - -
67f9fbff by Ben Gamari at 2025-08-28T15:00:12+05:30
testsuite: Add simple functional test for ProddableBlockSet
(cherry picked from commit 915902fc09ff4b00cf676c40d31dbbbf7d1cb7d7)
(cherry picked from commit dc4c540ddd39fb99b18630aebd2849ac29a4cd73)
- - - - -
68943109 by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS
The `LOAD_LIBRARY_SEARCH_USER_DIRS` and
`LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and
have been available every since. As we no longer support Windows XP we
can drop this check.
Addresses #26009.
(cherry picked from commit 1f38e2739fbbae3cbe925320fa70965004aaaca5)
(cherry picked from commit 10cfa8946b76a914fb3ecd4df62d32160b64151a)
- - - - -
6156e123 by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker/PEi386: Clean up code style
(cherry picked from commit facf379b0f1c0d1cbc3c1896cce603c89e837481)
(cherry picked from commit 92793b3799525f46373d9696c7e91c0d14860fa8)
- - - - -
f1690509 by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/Hash: Factor out hashBuffer
This is a useful helper which can be used for non-strings as well.
(cherry picked from commit 827961b9a724d8b2dd848222f980efc2de3996e3)
(cherry picked from commit a8c1ecb0d45050491496c0d04cc022a294a075b1)
- - - - -
d2cebb8a by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker/PEi386: Fix incorrect use of break in nested for
Previously the happy path of PEi386 used `break` in a double-`for` loop
resulting in redundant calls to `LoadLibraryEx`.
Fixes #26052.
(cherry picked from commit 6fbb05cf8a999628476d0d7274f30ef45e4d3932)
(cherry picked from commit 36a8bd2b7ceb0622e0aca2bed9cee7162076379c)
- - - - -
e8e5f8ed by Ben Gamari at 2025-08-28T15:00:12+05:30
rts: Correctly mark const arguments
(cherry picked from commit 320d7dd3e8de62f970d23ac1d27c665093d22aaa)
(cherry picked from commit 3a389cacefaffb3293f6b5f2ed5b20f2dbb9b4e3)
- - - - -
391fdddd by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker/PEi386: Don't repeatedly load DLLs
Previously every DLL-imported symbol would result in a call to
`LoadLibraryEx`. This ended up constituting over 40% of the runtime of
`ghc --interactive -e 42` on Windows. Avoid this by maintaining a
hash-set of loaded DLL names, skipping the call if we have already
loaded the requested DLL.
Addresses #26009.
(cherry picked from commit e6b0067bfa49b42bf4599af8d6a3c97878302624)
(cherry picked from commit b24be9b90adcf3fb9ee0c6b7e120b4bf1e77f072)
- - - - -
3ca736d0 by Ben Gamari at 2025-08-28T15:00:12+05:30
rts/linker: Expand comment describing ProddableBlockSet
(cherry picked from commit 9631a12c0b89529c3d1147d0770ec6b9023cdb17)
(cherry picked from commit 6ad664de0a4ab3e1747d318aabb5035ce7c74fcd)
- - - - -
dce8c450 by Cheng Shao at 2025-08-28T15:00:12+05:30
rts: fix rts_clearMemory logic when sanity checks are enabled
This commit fixes an RTS assertion failure when invoking
rts_clearMemory with +RTS -DS. -DS implies -DZ which asserts that free
blocks contain 0xaa as the designated garbage value. Also adds the
sanity way to rts_clearMemory test to prevent future regression.
Closes #26011.
ChatGPT Codex automatically diagnosed the issue and proposed the
initial patch in a single shot, given a GHC checkout and the following
prompt:
---
Someone is reporting the following error when attempting to use `rts_clearMemory` with the RTS option `-DS`:
```
test.wasm: internal error: ASSERTION FAILED: file rts/sm/Storage.c, line 1216
(GHC version 9.12.2.20250327 for wasm32_unknown_wasi)
Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug
```
What's the culprit? How do I look into this issue?
---
I manually reviewed & revised the patch, tested and submitted it.
(cherry picked from commit 86406f48659a5ab61ce1fd2a2d427faba2dcdb09)
- - - - -
7ae88b04 by kwxm at 2025-08-28T15:00:12+05:30
Fix bugs in `integerRecipMod` and `integerPowMod`
This fixes #26017.
* `integerRecipMod x 1` now returns `(# 1 | #)` for all x; previously it
incorrectly returned `(# | () #)`, indicating failure.
* `integerPowMod 0 e m` now returns `(# | () #)` for e<0 and m>1, indicating
failure; previously it incorrectly returned `(# 0 | #)`.
(cherry picked from commit 8ded23300367c6e032b3c5a635fd506b8915374b)
- - - - -
791810f3 by Matthew Pickering at 2025-08-28T15:00:12+05:30
interpreter: Fix INTERP_STATS profiling code
The profiling code had slightly bitrotted since the last time it was
used. This just fixes things so that if you toggle the INTERP_STATS
macro then it just works and prints out the stats.
Fixes #25695
(cherry picked from commit 66c7f65676801367f440a6a644f87d71157d2f3f)
- - - - -
ae2ddb3e by Matthew Pickering at 2025-08-28T15:00:12+05:30
interpreter: Fix overflows and reentrancy in statistics calculation
1. Use unsigned long for counter, as they can easily overflow if you are
running a long benchmark.
2. Make interp_shutdown reentrant by copying the command frequency table
into an array.
Fixes #25756
(cherry picked from commit c4e112fccd10ca745771dd81d2c1eb340aa8dd86)
- - - - -
ad197ae0 by Ben Gamari at 2025-08-28T15:00:13+05:30
rts: Tighten up invariants of PACK
(cherry picked from commit aa58fc5b9745a2201707de81a91960b213ea3258)
- - - - -
63d5fbdf by Ben Gamari at 2025-08-28T15:00:13+05:30
rts: Improve documentation of SLIDE bytecode instruction
(cherry picked from commit 0e084029def86e9e67b89317f44fd71c823e9bca)
- - - - -
8bbd1619 by Ben Gamari at 2025-08-28T15:00:13+05:30
rts/Interpreter: Assert that TEST*_P discriminators are valid
(cherry picked from commit 9bf3663b9970851e7b5701d68147450272823197)
- - - - -
71a17bd7 by Ben Gamari at 2025-08-28T15:00:13+05:30
Revert "rts/Interpreter: Assert that TEST*_P discriminators are valid"
This assertion was based on the misconception that `GET_TAG` was
returning the pointer tag whereas it is actually returning the
constructor tag.
This reverts commit 9bf3663b9970851e7b5701d68147450272823197.
Fixes #25527.
(cherry picked from commit dd95940639fd198f97fb3f44e84494eaca721788)
- - - - -
1546bc7b by Matthew Pickering at 2025-08-28T15:00:13+05:30
interpreter: Fix underflow frame lookups
BCOs can be nested, resulting in nested BCO stack frames where the inner most
stack frame can refer to variables stored on earlier stack frames via the
PUSH_L instruction.
|---------|
| BCO_1 | -<-ā
|---------|
......... |
|---------| | PUSH_L <n>
| BCO_N | ->-ā
|---------|
Here BCO_N is syntactically nested within the code for BCO_1 and will result
in code that references the prior stack frame of BCO_1 for some of it's local
variables. If a stack overflow happens between the creation of the stack frame
for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving
BCO_1 in place, invalidating a simple offset based reference to the outer stack
frames.
Therefore `ReadSpW` first performs a bounds check to ensure that accesses onto
the stack will succeed. If the target address would not be a valid location for
the current stack chunk then `slow_spw` function is called, which dereferences
the underflow frame to adjust the offset before performing the lookup.
ā->--x | CHK_1 |
| CHK_2 | | | |---------|
|---------| | ā-> | BCO_1 |
| UD_FLOW | -- x |---------|
|---------| |
| ...... | |
|---------| | PUSH_L <n>
| BCO_ N | ->-ā
|---------|
Fixes #25750
(cherry picked from commit f4da90f11e3a3a634ec3edb6d70d96fe3515b726)
- - - - -
5fe14f38 by Ben Gamari at 2025-08-28T15:00:13+05:30
base: Note strictness changes made in 4.16.0.0
Addresses #25886.
(cherry picked from commit 7722232c6f8f0b57db03d0439d77896d38191bf9)
- - - - -
8d3be3e0 by HĆ©cate Kleidukos at 2025-08-28T15:00:13+05:30
Expose all of Backtraces' internals for ghc-internal
Closes #26049
(cherry picked from commit 16014bf84afa0d009b6254b103033bceca42233a)
- - - - -
b5dc9d07 by ARATA Mizuki at 2025-08-28T15:00:13+05:30
AArch64 NCG: Fix sub-word arithmetic right shift
As noted in Note [Signed arithmetic on AArch64], we should zero-extend sub-word values.
Fixes #26061
(cherry picked from commit 265d0024abc95be941f8e4769f24af128eedaa10)
- - - - -
9608101d by ARATA Mizuki at 2025-08-28T15:00:13+05:30
x86 NCG: Fix code generation of bswap64 on i386
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
Fix #25601
(cherry picked from commit bfa6b70f27dc2ce7fc890ec71103c40f66497c77)
- - - - -
3f1823e1 by Cheng Shao at 2025-08-28T15:00:13+05:30
testsuite: add T26120 marked as broken
(cherry picked from commit 44b8cee2d5c114b238898ce4ee7b44ecaa0bf491)
- - - - -
6265a7b2 by Cheng Shao at 2025-08-28T15:00:13+05:30
compiler: fix GHC.SysTools.Ar archive member size writing logic
This patch fixes a long-standing bug in `GHC.SysTools.Ar` that emits
the wrong archive member size in each archive header. It should encode
the exact length of the member payload, excluding any padding byte,
otherwise malformed archive that extracts a broken object with an
extra trailing byte could be created.
Apart from the in-tree `T26120` test, I've also created an out-of-tree
testsuite at https://github.com/TerrorJack/ghc-ar-quickcheck that
contains QuickCheck roundtrip tests for `GHC.SysTools.Ar`. With this
fix, simple roundtrip tests and `writeGNUAr`/GNU `ar` roundtrip test
passes. There might be more bugs lurking in here, but this patch is
still a critical bugfix already.
Fixes #26120 #22586.
Co-authored-by: Codex <codex(a)openai.com>
(cherry picked from commit 894a04f3a82dd39ecef71619e2032c4dfead556e)
- - - - -
f4b6c0f6 by Berk ĆzkĆ¼tĆ¼k at 2025-08-28T15:00:13+05:30
Consider `PromotedDataCon` in `tyConStupidTheta`
Haddock checks data declarations for the stupid theta so as not to
pretty-print them as empty contexts. Type data declarations end up as
`PromotedDataCon`s by the time Haddock performs this check, causing a
panic. This commit extends `tyConStupidTheta` so that it returns an
empty list for `PromotedDataCon`s. This decision was guided by the fact
that type data declarations never have data type contexts (see (R1) in
Note [Type data declarations]).
Fixes #25739.
(cherry picked from commit 8d33d048dbe159a045a4c304fa92318365a3dfe2)
- - - - -
b19089ae by Teo Camarasu at 2025-08-28T15:00:13+05:30
rts/nonmovingGC: remove n_free
We remove the nonmovingHeap.n_free variable.
We wanted this to track the length of nonmovingHeap.free.
But this isn't possible to do atomically.
When this isn't accurate we can get a segfault by going past the end of
the list.
Instead, we just count the length of the list when we grab it in
nonmovingPruneFreeSegment.
Resolves #26186
(cherry picked from commit 45efaf71d97355f76fe0db5af2fc5b4b67fddf47)
- - - - -
74dd3f5f by Andreas Klebinger at 2025-08-28T15:00:13+05:30
Disable -fprof-late-overloaded-calls for join points.
Currently GHC considers cost centres as destructive to
join contexts. Or in other words this is not considered valid:
join f x = ...
in
... -> scc<tick> jmp
This makes the functionality of `-fprof-late-overloaded-calls` not feasible
for join points in general. We used to try to work around this by putting the
ticks on the rhs of the join point rather than around the jump. However beyond
the loss of accuracy this was broken for recursive join points as we ended up
with something like:
rec-join f x = scc<tick> ... jmp f x
Which similarly is not valid as the tick once again destroys the tail call.
One might think we could limit ourselves to non-recursive tail calls and do
something clever like:
join f x = scc<tick> ...
in ... jmp f x
And sometimes this works! But sometimes the full rhs would look something like:
join g x = ....
join f x = scc<tick> ... -> jmp g x
Which, would again no longer be valid. I believe in the long run we can make
cost centre ticks non-destructive to join points. Or we could keep track of
where we are/are not allowed to insert a cost centre. But in the short term I will
simply disable the annotation of join calls under this flag.
(cherry picked from commit 7da86e165612721c4e09f772a3fdaffc733e9293)
- - - - -
5fa6f699 by Zubin Duggal at 2025-08-28T15:00:13+05:30
fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory
Fixes #24093
(cherry picked from commit 9fa590a6e27545995cdcf419ed7a6504e6668b18)
- - - - -
545e96e3 by Sebastian Graf at 2025-08-28T15:00:13+05:30
CprAnal: Detect recursive newtypes (#25944)
While `cprTransformDataConWork` handles recursive data con workers, it
did not detect the case when a newtype is responsible for the recursion.
This is now detected in the `Cast` case of `cprAnal`.
The same reproducer made it clear that `isRecDataCon` lacked congruent
handling for `AppTy` and `CastTy`, now fixed.
Furthermore, the new repro case T25944 triggered this bug via an
infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`.
While it should be much less likely to trigger such an infinite loop now
that `isRecDataCon` has been fixed, I made sure to abort the loop after
10 iterations and emitting a warning instead.
Fixes #25944.
(cherry picked from commit 4bc78496406f7469640faaa46e2f311c05760124)
- - - - -
fbe25886 by Ben Gamari at 2025-08-28T15:00:13+05:30
configure: Allow override of CrossCompiling
As noted in #26236, the current inference logic is a bit simplistic. In
particular, there are many cases (e.g. building for a new libc) where
the target and host triples may differ yet we are still able to run the
produced artifacts as native code.
Closes #26236.
(cherry picked from commit 81577fe7c1913c53608bf03e48f84507be904620)
- - - - -
e0bf70b5 by Simon Peyton Jones at 2025-08-28T15:00:13+05:30
Take more care in zonkEqTypes on AppTy/AppTy
This patch fixes #26256.
See Note [zonkEqTypes and the PKTI] in GHC.Tc.Solver.Equality
(cherry picked from commit 18036d5205ac648bb245217519fed2fd931a9982)
- - - - -
54927b2d by Andreas Klebinger at 2025-08-28T15:00:13+05:30
Make unexpected LLVM versions a warning rather than an error.
Typically a newer LLVM version *will* work so erroring out if
a user uses a newer LLVM version is too aggressive.
Fixes #25915
(cherry picked from commit 50842f83f467ff54dd22470559a7af79d2025c03)
- - - - -
54c283e5 by Teo Camarasu at 2025-08-28T15:00:13+05:30
rts: spin if we see a WHITEHOLE in messageBlackHole
When a BLACKHOLE gets cancelled in raiseAsync, we indirect to a THUNK.
GC can then shortcut this, replacing our BLACKHOLE with a fresh THUNK.
This THUNK is not guaranteed to have a valid indirectee field.
If at the same time, a message intended for the previous BLACKHOLE is
processed and concurrently we BLACKHOLE the THUNK, thus temporarily
turning it into a WHITEHOLE, we can get a segfault, since we look at the
undefined indirectee field of the THUNK
The fix is simple: spin if we see a WHITEHOLE, and it will soon be
replaced with a valid BLACKHOLE.
Resolves #26205
(cherry picked from commit 4021181ee0860aca2054883a531f3312361cc701)
- - - - -
e5f36a81 by Teo Camarasu at 2025-08-28T15:00:13+05:30
rts: ensure MessageBlackHole.link is always a valid closure
We turn a MessageBlackHole into an StgInd in wakeBlockingQueue().
Therefore it's important that the link field, which becomes the
indirection field, always points to a valid closure.
It's unclear whether it's currently possible for the previous behaviour
to lead to a crash, but it's good to be consistent about this invariant nonetheless.
Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at>
(cherry picked from commit a8b2fbae6bcf20bc2f3fe58803096d2a9c5fc43d)
- - - - -
ad06bbec by Reed Mullanix at 2025-08-28T15:00:13+05:30
ghc-internal: Fix naturalAndNot for NB/NS case
When the first argument to `naturalAndNot` is larger than a `Word` and the second is `Word`-sized, `naturalAndNot` will truncate the
result:
```
>>> naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)
0
```
In contrast, `naturalAndNot` does not truncate when both arguments are larger than a `Word`, so this appears to be a bug.
Luckily, the fix is pretty easy: we just need to call `bigNatAndNotWord#` instead of truncating.
Fixes #26230
(cherry picked from commit a766286fe759251eceb304c54ba52841c2a51f86)
- - - - -
e0200899 by Ben Gamari at 2025-08-28T15:00:13+05:30
llvmGen: Fix built-in variable predicate
Previously the predicate to identify LLVM builtin global variables was
checking for `$llvm` rather than `@llvm` as it should.
(cherry picked from commit 6e67fa083a50684e1cfae546e07cab4d4250e871)
- - - - -
246 changed files:
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- .gitlab/rel_eng/upload_ghc_libs.py
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/Cmm/Config.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/Reg.hs
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RV64/Instr.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs
- compiler/GHC/CmmToAsm/Wasm/Asm.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/Wasm/Types.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Driver/Config/Cmm.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Llvm/Types.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/String.hs
- compiler/GHC/Plugins.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/SysTools/Ar.hs
- compiler/GHC/SysTools/Process.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Types.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Id/Make.hs
- configure.ac
- docs/users_guide/exts/instances.rst
- docs/users_guide/exts/named_defaults.rst
- docs/users_guide/exts/overloaded_strings.rst
- docs/users_guide/exts/poly_kinds.rst
- + docs/users_guide/exts/type_defaulting.rst
- docs/users_guide/exts/types.rst
- docs/users_guide/ghci.rst
- docs/users_guide/profiling.rst
- docs/users_guide/using-optimisation.rst
- libffi-tarballs
- libraries/base/changelog.md
- libraries/ghc-bignum/changelog.md
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Lib.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Lib/Map.hs ā libraries/ghc-boot-th/GHC/Boot/TH/Lib/Map.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Lift.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs ā libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-boot-th/GHC/Internal/TH/PprLib.hs ā libraries/ghc-boot-th/GHC/Boot/TH/PprLib.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Quote.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Syntax.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/GHCi/TH/Binary.hs
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/PprLib.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- m4/fp_setup_windows_toolchain.m4
- rts/Hash.c
- rts/Hash.h
- rts/Interpreter.c
- rts/Interpreter.h
- rts/Linker.c
- rts/LinkerInternals.h
- rts/Messages.c
- rts/PathUtils.c
- rts/PathUtils.h
- rts/RtsMain.c
- rts/StgMiscClosures.cmm
- rts/Updates.h
- rts/include/rts/storage/InfoTables.h
- rts/linker/Elf.c
- rts/linker/LoadNativeObjPosix.c
- rts/linker/MachO.c
- rts/linker/PEi386.c
- rts/linker/PEi386.h
- + rts/linker/ProddableBlocks.c
- + rts/linker/ProddableBlocks.h
- rts/rts.cabal
- rts/sm/NonMoving.c
- rts/sm/NonMoving.h
- rts/sm/NonMovingAllocate.c
- rts/sm/Sanity.c
- rts/sm/Storage.h
- + testsuite/tests/bytecode/T25975.hs
- + testsuite/tests/bytecode/T25975.stdout
- testsuite/tests/bytecode/all.T
- + testsuite/tests/cmm/opt/T25771.cmm
- + testsuite/tests/cmm/opt/T25771.stderr
- testsuite/tests/cmm/opt/all.T
- + testsuite/tests/cmm/should_run/T25601.hs
- + testsuite/tests/cmm/should_run/T25601.stdout
- + testsuite/tests/cmm/should_run/T25601a.cmm
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/codeGen/should_run/T26061.hs
- + testsuite/tests/codeGen/should_run/T26061.stdout
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/cpranal/sigs/T25944.hs
- + testsuite/tests/cpranal/sigs/T25944.stderr
- testsuite/tests/cpranal/sigs/all.T
- testsuite/tests/deriving/should_compile/T17324.stderr
- testsuite/tests/ffi/should_run/all.T
- + testsuite/tests/ghc-api/T26120.hs
- + testsuite/tests/ghc-api/T26120.stdout
- testsuite/tests/ghc-api/all.T
- testsuite/tests/ghc-api/settings-escape/T11938.hs ā testsuite/tests/ghc-api/settings-escape/T24265.hs
- testsuite/tests/ghc-api/settings-escape/T11938.stderr ā testsuite/tests/ghc-api/settings-escape/T24265.stderr
- + testsuite/tests/ghc-api/settings-escape/T25204.hs
- + testsuite/tests/ghc-api/settings-escape/T25204.stdout
- + testsuite/tests/ghc-api/settings-escape/T25204_C.c
- testsuite/tests/ghc-api/settings-escape/all.T
- + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/ghc version.h
- testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib/.gitkeep ā testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/.gitkeep
- + testsuite/tests/ghci/scripts/GhciPackageRename.hs
- + testsuite/tests/ghci/scripts/GhciPackageRename.script
- + testsuite/tests/ghci/scripts/GhciPackageRename.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- + testsuite/tests/lib/integer/T26017.hs
- + testsuite/tests/lib/integer/T26017.stdout
- testsuite/tests/lib/integer/all.T
- testsuite/tests/lib/integer/integerRecipMod.hs
- testsuite/tests/lib/integer/integerRecipMod.stdout
- + testsuite/tests/llvm/should_run/T25730.hs
- + testsuite/tests/llvm/should_run/T25730.stdout
- + testsuite/tests/llvm/should_run/T25730C.c
- + testsuite/tests/llvm/should_run/T25770.hs
- + testsuite/tests/llvm/should_run/T25770.stdout
- testsuite/tests/llvm/should_run/all.T
- testsuite/tests/module/T11970A.stderr
- testsuite/tests/module/mod176.stderr
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr
- + testsuite/tests/parser/should_run/T25784.hs
- + testsuite/tests/parser/should_run/T25784.stdout
- + testsuite/tests/parser/should_run/T25937.hs
- + testsuite/tests/parser/should_run/T25937.stdout
- testsuite/tests/parser/should_run/all.T
- + testsuite/tests/parser/should_run/parser_unit_tests.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/plugins/static-plugins.stdout
- + testsuite/tests/pmcheck/should_compile/T25749.hs
- testsuite/tests/pmcheck/should_compile/all.T
- testsuite/tests/rename/should_compile/T14881.stderr
- + testsuite/tests/rename/should_compile/T24035.hs
- + testsuite/tests/rename/should_compile/T24035_aux.hs
- + testsuite/tests/rename/should_compile/T24035b.hs
- + testsuite/tests/rename/should_compile/T24035b.stderr
- testsuite/tests/rename/should_compile/all.T
- testsuite/tests/rts/T13082/Makefile
- testsuite/tests/rts/T13082/T13082_fail.stderr ā testsuite/tests/rts/T13082/T13082_fail.stdout
- + testsuite/tests/rts/TestProddableBlockSet.c
- testsuite/tests/rts/all.T
- testsuite/tests/simd/should_run/all.T
- + testsuite/tests/simd/should_run/doublex2_arith.hs
- + testsuite/tests/simd/should_run/doublex2_arith.stdout
- + testsuite/tests/simd/should_run/doublex2_arith_baseline.hs
- + testsuite/tests/simd/should_run/doublex2_arith_baseline.stdout
- + testsuite/tests/simd/should_run/doublex2_fma.hs
- + testsuite/tests/simd/should_run/doublex2_fma.stdout
- + testsuite/tests/simd/should_run/floatx4_arith.hs
- + testsuite/tests/simd/should_run/floatx4_arith.stdout
- + testsuite/tests/simd/should_run/floatx4_arith_baseline.hs
- + testsuite/tests/simd/should_run/floatx4_arith_baseline.stdout
- + testsuite/tests/simd/should_run/floatx4_fma.hs
- + testsuite/tests/simd/should_run/floatx4_fma.stdout
- + testsuite/tests/simplCore/should_compile/T25883.hs
- + testsuite/tests/simplCore/should_compile/T25883.substr-simpl
- + testsuite/tests/simplCore/should_compile/T25883b.hs
- + testsuite/tests/simplCore/should_compile/T25883b.substr-simpl
- + testsuite/tests/simplCore/should_compile/T25883c.hs
- + testsuite/tests/simplCore/should_compile/T25883c.substr-simpl
- + testsuite/tests/simplCore/should_compile/T25883d.hs
- + testsuite/tests/simplCore/should_compile/T25883d.stderr
- + testsuite/tests/simplCore/should_compile/T25883d_import.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplCore/should_fail/T25672.hs
- + testsuite/tests/simplCore/should_fail/T25672.stderr
- testsuite/tests/simplCore/should_fail/all.T
- + testsuite/tests/simplCore/should_run/T23429.hs
- + testsuite/tests/simplCore/should_run/T23429.stdout
- testsuite/tests/simplCore/should_run/all.T
- + testsuite/tests/typecheck/should_compile/T26256a.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T25004.hs
- + testsuite/tests/typecheck/should_fail/T25004.stderr
- testsuite/tests/typecheck/should_fail/all.T
- + testsuite/tests/typecheck/should_run/T25529.hs
- + testsuite/tests/typecheck/should_run/T25529.stdout
- + testsuite/tests/typecheck/should_run/T25998.hs
- + testsuite/tests/typecheck/should_run/T25998.stdout
- testsuite/tests/typecheck/should_run/all.T
- + utils/haddock/html-test/ref/Bug25739.html
- + utils/haddock/html-test/src/Bug25739.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e67ba5ed9c896235e9c50a20b5062fā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e67ba5ed9c896235e9c50a20b5062fā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 7 commits: tests: disable T22859 under LLVM
by Hannes Siebenhandl (ļ¼ fendor) 28 Aug '25
by Hannes Siebenhandl (ļ¼ fendor) 28 Aug '25
28 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
37655c46 by Teo Camarasu at 2025-08-26T15:24:51-04:00
tests: disable T22859 under LLVM
This test was failing under the LLVM backend since the allocations
differ from the NCG.
Resolves #26282
- - - - -
2cbba9d6 by Teo Camarasu at 2025-08-26T15:25:33-04:00
base-exports: update version numbers
As the version of the compiler has been bumped, a lot of the embedded
version numbers will need to be updated if we ever run this test with
`--test-accept` so let's just update them now, and keep future diffs
clean.
- - - - -
f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00
Import new name for 'utimbuf' on windows to fix #26337
Fixes an `-Wincompatible-pointer-types` instance that turns into an error on
recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross.
This long-standing warning has been present at least since 9.4:
```
C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error:
warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types]
|
26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
| ^
HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
^~
C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error:
note: passing argument to parameter '_Utimbuf' here
|
109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
| ^
__CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
```
- - - - -
ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00
Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide.
- - - - -
cb6fdf9e by fendor at 2025-08-28T09:14:51+02:00
Move stack decoding logic from ghc-heap to ghc-internal
The stack decoding logic in `ghc-heap` is more sophisticated than the one
currently employed in `CloneStack`. We want to use the stack decoding
implementation from `ghc-heap` in `base`.
We cannot simply depend on `ghc-heap` in `base` due do bootstrapping
issues.
Thus, we move the code that is necessary to implement stack decoding to
`ghc-internal`. This is the right location, as we don't want to add a
new API to `base`.
Moving the stack decoding logic and re-exposing it in ghc-heap is
insufficient, though, as we have a dependency cycle between.
* ghc-heap depends on stage1:ghc-internal
* stage0:ghc depends on stage0:ghc-heap
To fix this, we remove ghc-heap from the set of `stage0` dependencies.
This is not entirely straight-forward, as a couple of boot dependencies,
such as `ghci` depend on `ghc-heap`.
Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci`
to use `ghc-internal` instead of `ghc-heap`, which already exports the
relevant modules.
However, we cannot 100% remove ghc's dependency on `ghc-heap`, since
when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet
available.
Thus, when we compile with the boot-compiler, we still depend on an
older version of `ghc-heap`, and only use the modules from `ghc-internal`,
if the `ghc-internal` version is recent enough.
-------------------------
Metric Increase:
T24602_perf_size
T25046_perf_size_gzip
T25046_perf_size_unicode
T25046_perf_size_unicode_gzip
size_hello_artifact
size_hello_artifact_gzip
size_hello_unicode
size_hello_unicode_gzip
-------------------------
These metric increases are unfortunate, they are most likely caused by
the larger (literally in terms of lines of code) stack decoder implementation
that are now linked into hello-word binaries.
On linux, it is almost a 10% increase, which is considerable.
- - - - -
6f9119b2 by fendor at 2025-08-28T09:14:51+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
82369d4f by fendor at 2025-08-28T09:14:52+02:00
Remove stg_decodeStackzh
- - - - -
77 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/separate_compilation.rst
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/cbits/HeapPrim.cmm ā libraries/ghc-internal/cbits/HeapPrim.cmm
- libraries/ghc-heap/cbits/Stack.cmm ā libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/cbits/Stack_c.c ā libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc ā libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghc-heap/tests/stack-annotation/Makefile ā libraries/ghc-internal/tests/stack-annotation/Makefile
- libraries/ghc-heap/tests/stack-annotation/TestUtils.hs ā libraries/ghc-internal/tests/stack-annotation/TestUtils.hs
- libraries/ghc-heap/tests/stack-annotation/all.T ā libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/ghci.cabal.in
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- testsuite/.gitignore
- 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
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/rts/all.T
- testsuite/tests/th/Makefile
- + testsuite/tests/th/TH_Depends_Dir.hs
- + testsuite/tests/th/TH_Depends_Dir.stdout
- + testsuite/tests/th/TH_Depends_Dir_External.hs
- testsuite/tests/th/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e80d28e7466cfffea51725a1cb4f3ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e80d28e7466cfffea51725a1cb4f3ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Move stack decoding logic from ghc-heap to ghc-internal
by Marge Bot (ļ¼ marge-bot) 27 Aug '25
by Marge Bot (ļ¼ marge-bot) 27 Aug '25
27 Aug '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
202ca885 by fendor at 2025-08-27T19:24:41-04:00
Move stack decoding logic from ghc-heap to ghc-internal
The stack decoding logic in `ghc-heap` is more sophisticated than the one
currently employed in `CloneStack`. We want to use the stack decoding
implementation from `ghc-heap` in `base`.
We cannot simply depend on `ghc-heap` in `base` due do bootstrapping
issues.
Thus, we move the code that is necessary to implement stack decoding to
`ghc-internal`. This is the right location, as we don't want to add a
new API to `base`.
Moving the stack decoding logic and re-exposing it in ghc-heap is
insufficient, though, as we have a dependency cycle between.
* ghc-heap depends on stage1:ghc-internal
* stage0:ghc depends on stage0:ghc-heap
To fix this, we remove ghc-heap from the set of `stage0` dependencies.
This is not entirely straight-forward, as a couple of boot dependencies,
such as `ghci` depend on `ghc-heap`.
Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci`
to use `ghc-internal` instead of `ghc-heap`, which already exports the
relevant modules.
However, we cannot 100% remove ghc's dependency on `ghc-heap`, since
when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet
available.
Thus, when we compile with the boot-compiler, we still depend on an
older version of `ghc-heap`, and only use the modules from `ghc-internal`,
if the `ghc-internal` version is recent enough.
-------------------------
Metric Increase:
T24602_perf_size
T25046_perf_size_gzip
T25046_perf_size_unicode
T25046_perf_size_unicode_gzip
size_hello_artifact
size_hello_artifact_gzip
size_hello_unicode
size_hello_unicode_gzip
-------------------------
These metric increases are unfortunate, they are most likely caused by
the larger (literally in terms of lines of code) stack decoder implementation
that are now linked into hello-word binaries.
On linux, it is almost a 10% increase, which is considerable.
- - - - -
c0602d43 by fendor at 2025-08-27T19:24:41-04:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
04568b6b by fendor at 2025-08-27T19:24:41-04:00
Remove stg_decodeStackzh
- - - - -
7eecfb55 by sheaf at 2025-08-27T19:24:50-04:00
Fix orientation in HsWrapper composition (<.>)
This commit fixes the order in which WpCast HsWrappers are composed,
fixing a bug introduced in commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1.
Fixes #26350
- - - - -
57 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/ghc.cabal.in
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/cbits/HeapPrim.cmm ā libraries/ghc-internal/cbits/HeapPrim.cmm
- libraries/ghc-heap/cbits/Stack.cmm ā libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/cbits/Stack_c.c ā libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc ā libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-heap/tests/stack-annotation/Makefile ā libraries/ghc-internal/tests/stack-annotation/Makefile
- libraries/ghc-heap/tests/stack-annotation/TestUtils.hs ā libraries/ghc-internal/tests/stack-annotation/TestUtils.hs
- libraries/ghc-heap/tests/stack-annotation/all.T ā libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/ghci.cabal.in
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- 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
- + testsuite/tests/typecheck/should_compile/T26350.hs
- testsuite/tests/typecheck/should_compile/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68ccc1ac22a8d858f9d0037f39be1fā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68ccc1ac22a8d858f9d0037f39be1fā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Import new name for 'utimbuf' on windows to fix #26337
by Marge Bot (ļ¼ marge-bot) 27 Aug '25
by Marge Bot (ļ¼ marge-bot) 27 Aug '25
27 Aug '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00
Import new name for 'utimbuf' on windows to fix #26337
Fixes an `-Wincompatible-pointer-types` instance that turns into an error on
recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross.
This long-standing warning has been present at least since 9.4:
```
C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error:
warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types]
|
26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
| ^
HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
^~
C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error:
note: passing argument to parameter '_Utimbuf' here
|
109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
| ^
__CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
```
- - - - -
ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00
Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide.
- - - - -
bd0022d5 by fendor at 2025-08-27T15:01:57-04:00
Move stack decoding logic from ghc-heap to ghc-internal
The stack decoding logic in `ghc-heap` is more sophisticated than the one
currently employed in `CloneStack`. We want to use the stack decoding
implementation from `ghc-heap` in `base`.
We cannot simply depend on `ghc-heap` in `base` due do bootstrapping
issues.
Thus, we move the code that is necessary to implement stack decoding to
`ghc-internal`. This is the right location, as we don't want to add a
new API to `base`.
Moving the stack decoding logic and re-exposing it in ghc-heap is
insufficient, though, as we have a dependency cycle between.
* ghc-heap depends on stage1:ghc-internal
* stage0:ghc depends on stage0:ghc-heap
To fix this, we remove ghc-heap from the set of `stage0` dependencies.
This is not entirely straight-forward, as a couple of boot dependencies,
such as `ghci` depend on `ghc-heap`.
Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci`
to use `ghc-internal` instead of `ghc-heap`, which already exports the
relevant modules.
However, we cannot 100% remove ghc's dependency on `ghc-heap`, since
when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet
available.
Thus, when we compile with the boot-compiler, we still depend on an
older version of `ghc-heap`, and only use the modules from `ghc-internal`,
if the `ghc-internal` version is recent enough.
-------------------------
Metric Increase:
T24602_perf_size
T25046_perf_size_gzip
T25046_perf_size_unicode
T25046_perf_size_unicode_gzip
size_hello_artifact
size_hello_artifact_gzip
size_hello_unicode
size_hello_unicode_gzip
-------------------------
These metric increases are unfortunate, they are most likely caused by
the larger (literally in terms of lines of code) stack decoder implementation
that are now linked into hello-word binaries.
On linux, it is almost a 10% increase, which is considerable.
- - - - -
67d31794 by fendor at 2025-08-27T15:01:58-04:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
4831a63c by fendor at 2025-08-27T15:01:58-04:00
Remove stg_decodeStackzh
- - - - -
68ccc1ac by sheaf at 2025-08-27T15:02:15-04:00
Fix orientation in HsWrapper composition (<.>)
This commit fixes the order in which WpCast HsWrappers are composed,
fixing a bug introduced in commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1.
Fixes #26350
- - - - -
80 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/separate_compilation.rst
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/cbits/HeapPrim.cmm ā libraries/ghc-internal/cbits/HeapPrim.cmm
- libraries/ghc-heap/cbits/Stack.cmm ā libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/cbits/Stack_c.c ā libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc ā libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc ā libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghc-heap/tests/stack-annotation/Makefile ā libraries/ghc-internal/tests/stack-annotation/Makefile
- libraries/ghc-heap/tests/stack-annotation/TestUtils.hs ā libraries/ghc-internal/tests/stack-annotation/TestUtils.hs
- libraries/ghc-heap/tests/stack-annotation/all.T ā libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs ā libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout ā libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/ghci.cabal.in
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- testsuite/.gitignore
- 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
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/th/Makefile
- + testsuite/tests/th/TH_Depends_Dir.hs
- + testsuite/tests/th/TH_Depends_Dir.stdout
- + testsuite/tests/th/TH_Depends_Dir_External.hs
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_compile/T26350.hs
- testsuite/tests/typecheck/should_compile/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86ce75c68648a51f11ac183990170aā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86ce75c68648a51f11ac183990170aā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/fix-foundation-test-shift-amounts] Inline generator functions
by Sven Tennie (ļ¼ supersven) 27 Aug '25
by Sven Tennie (ļ¼ supersven) 27 Aug '25
27 Aug '25
Sven Tennie pushed to branch wip/supersven/fix-foundation-test-shift-amounts at Glasgow Haskell Compiler / GHC
Commits:
7f520e69 by Sven Tennie at 2025-08-27T19:28:49+02:00
Inline generator functions
- - - - -
1 changed file:
- testsuite/tests/numeric/should_run/foundation.hs
Changes:
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -133,51 +133,34 @@ newtype NonZero a = NonZero { getNonZero :: a }
instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
arbitrary = nonZero
--- | A newtype for shift amounts that are bounded by word size
-newtype BoundedShift a = BoundedShift { getBoundedShift :: Int }
- deriving (Eq,Ord,Show)
+-- | A newtype for shift amounts that are bounded by @word_size - 1@
+newtype BoundedShift a = BoundedShift {getBoundedShift :: Int}
+ deriving (Eq, Ord, Show)
--- | Generate shift amounts bounded by the word size for each type
-boundedShift8 :: Gen (BoundedShift Int8)
-boundedShift8 = do
- x <- arbitrary
- return $ BoundedShift (abs x `mod` 8)
-
-boundedShift16 :: Gen (BoundedShift Int16)
-boundedShift16 = do
- x <- arbitrary
- return $ BoundedShift (abs x `mod` 16)
-
-boundedShift32 :: Gen (BoundedShift Int32)
-boundedShift32 = do
- x <- arbitrary
- return $ BoundedShift (abs x `mod` 32)
-
-boundedShift64 :: Gen (BoundedShift Int64)
-boundedShift64 = do
- x <- arbitrary
- return $ BoundedShift (abs x `mod` 64)
-
-boundedShiftWord :: Gen (BoundedShift Int)
-boundedShiftWord = do
- x <- arbitrary
- return $ BoundedShift (abs x `mod` finiteBitSize (undefined :: Word))
-
--- Arbitrary instances for BoundedShift types to work with lambda patterns
instance Arbitrary (BoundedShift Int8) where
- arbitrary = boundedShift8
+ arbitrary = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 8)
instance Arbitrary (BoundedShift Int16) where
- arbitrary = boundedShift16
+ arbitrary = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 8)
instance Arbitrary (BoundedShift Int32) where
- arbitrary = boundedShift32
+ arbitrary = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 8)
instance Arbitrary (BoundedShift Int64) where
- arbitrary = boundedShift64
+ arbitrary = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 8)
instance Arbitrary (BoundedShift Int) where
- arbitrary = boundedShiftWord
+ arbitrary = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` finiteBitSize (undefined :: Word))
instance Arbitrary Natural where
arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f520e6980c84869f81b324f5c824b8ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f520e6980c84869f81b324f5c824b8ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/fix-foundation-test-shift-amounts] foundation test: Fix shift amount (#26248)
by Sven Tennie (ļ¼ supersven) 27 Aug '25
by Sven Tennie (ļ¼ supersven) 27 Aug '25
27 Aug '25
Sven Tennie pushed to branch wip/supersven/fix-foundation-test-shift-amounts at Glasgow Haskell Compiler / GHC
Commits:
522bf61b by Sven Tennie at 2025-08-27T19:09:05+02:00
foundation test: Fix shift amount (#26248)
Shift primops' results are only defined for shift amounts of 0 to word
size - 1.
This has been partly vibe coded: https://github.com/supersven/ghc/pull/1
- - - - -
3 changed files:
- testsuite/tests/numeric/should_run/foundation.hs
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Syntax.hs
Changes:
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -24,7 +24,7 @@ module Main
( main
) where
-import Data.Bits (Bits((.&.), bit))
+import Data.Bits (Bits((.&.), bit), finiteBitSize)
import Data.Word
import Data.Int
import GHC.Natural
@@ -133,6 +133,52 @@ newtype NonZero a = NonZero { getNonZero :: a }
instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
arbitrary = nonZero
+-- | A newtype for shift amounts that are bounded by word size
+newtype BoundedShift a = BoundedShift { getBoundedShift :: Int }
+ deriving (Eq,Ord,Show)
+
+-- | Generate shift amounts bounded by the word size for each type
+boundedShift8 :: Gen (BoundedShift Int8)
+boundedShift8 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 8)
+
+boundedShift16 :: Gen (BoundedShift Int16)
+boundedShift16 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 16)
+
+boundedShift32 :: Gen (BoundedShift Int32)
+boundedShift32 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 32)
+
+boundedShift64 :: Gen (BoundedShift Int64)
+boundedShift64 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 64)
+
+boundedShiftWord :: Gen (BoundedShift Int)
+boundedShiftWord = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` finiteBitSize (undefined :: Word))
+
+-- Arbitrary instances for BoundedShift types to work with lambda patterns
+instance Arbitrary (BoundedShift Int8) where
+ arbitrary = boundedShift8
+
+instance Arbitrary (BoundedShift Int16) where
+ arbitrary = boundedShift16
+
+instance Arbitrary (BoundedShift Int32) where
+ arbitrary = boundedShift32
+
+instance Arbitrary (BoundedShift Int64) where
+ arbitrary = boundedShift64
+
+instance Arbitrary (BoundedShift Int) where
+ arbitrary = boundedShiftWord
+
instance Arbitrary Natural where
arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
@@ -395,6 +441,10 @@ class TestPrimop f where
testPrimopDivLike :: String -> f -> f -> Test
testPrimopDivLike _ _ _ = error "Div testing not supported for this type."
+ -- | Special test method for shift operations that bounds the shift amount
+ testPrimopShift :: String -> f -> f -> Test
+ testPrimopShift _ _ _ = error "Shift testing not supported for this type."
+
{-
instance TestPrimop (Int# -> Int# -> Int#) where
testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
@@ -460,9 +510,9 @@ testPrimops = Group "primop"
, testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8#
, testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8#
, testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8#
- , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
- , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
- , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
+ , testPrimopShift "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
+ , testPrimopShift "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
+ , testPrimopShift "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
, testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8#
, testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8#
, testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8#
@@ -482,8 +532,8 @@ testPrimops = Group "primop"
, testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8#
, testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8#
, testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8#
- , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
- , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
+ , testPrimopShift "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
+ , testPrimopShift "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
, testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8#
, testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8#
, testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8#
@@ -500,9 +550,9 @@ testPrimops = Group "primop"
, testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16#
, testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16#
, testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16#
- , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
- , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
- , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
+ , testPrimopShift "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
+ , testPrimopShift "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
+ , testPrimopShift "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
, testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16#
, testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16#
, testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16#
@@ -522,8 +572,8 @@ testPrimops = Group "primop"
, testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16#
, testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16#
, testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16#
- , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
- , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
+ , testPrimopShift "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
+ , testPrimopShift "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
, testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16#
, testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16#
, testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16#
@@ -540,9 +590,9 @@ testPrimops = Group "primop"
, testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32#
, testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32#
, testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32#
- , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
- , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
- , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
+ , testPrimopShift "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
+ , testPrimopShift "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
+ , testPrimopShift "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
, testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32#
, testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32#
, testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32#
@@ -562,8 +612,8 @@ testPrimops = Group "primop"
, testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32#
, testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32#
, testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32#
- , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
- , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
+ , testPrimopShift "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
+ , testPrimopShift "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
, testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32#
, testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32#
, testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32#
@@ -579,9 +629,9 @@ testPrimops = Group "primop"
, testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64#
, testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64#
, testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64#
- , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
- , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
- , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
+ , testPrimopShift "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
+ , testPrimopShift "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
+ , testPrimopShift "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
, testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64#
, testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64#
, testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64#
@@ -600,8 +650,8 @@ testPrimops = Group "primop"
, testPrimop "or64#" Primop.or64# Wrapper.or64#
, testPrimop "xor64#" Primop.xor64# Wrapper.xor64#
, testPrimop "not64#" Primop.not64# Wrapper.not64#
- , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
- , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
+ , testPrimopShift "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
+ , testPrimopShift "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
, testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64#
, testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64#
, testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64#
@@ -632,9 +682,9 @@ testPrimops = Group "primop"
, testPrimop "<=#" (Primop.<=#) (Wrapper.<=#)
, testPrimop "chr#" Primop.chr# Wrapper.chr#
, testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word#
- , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
- , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
- , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
+ , testPrimopShift "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
+ , testPrimopShift "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
+ , testPrimopShift "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
, testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord#
, testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC#
, testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC#
@@ -649,8 +699,8 @@ testPrimops = Group "primop"
, testPrimop "or#" Primop.or# Wrapper.or#
, testPrimop "xor#" Primop.xor# Wrapper.xor#
, testPrimop "not#" Primop.not# Wrapper.not#
- , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
- , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
+ , testPrimopShift "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
+ , testPrimopShift "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
, testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int#
, testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord#
, testPrimop "geWord#" Primop.geWord# Wrapper.geWord#
@@ -709,6 +759,7 @@ instance TestPrimop (Char# -> Int#) where
instance TestPrimop (Int# -> Int# -> Int#) where
testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShift shift :: BoundedShift Int) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift))
instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
@@ -741,6 +792,7 @@ instance TestPrimop (Int# -> Word#) where
instance TestPrimop (Int16# -> Int# -> Int16#) where
testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt16#-> x0) (BoundedShift shift :: BoundedShift Int16) -> wInt16# (l x0 (uInt# shift)) === wInt16# (r x0 (uInt# shift))
instance TestPrimop (Int16# -> Int16# -> Int#) where
testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -765,6 +817,7 @@ instance TestPrimop (Int16# -> Word16#) where
instance TestPrimop (Int32# -> Int# -> Int32#) where
testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt32#-> x0) (BoundedShift shift :: BoundedShift Int32) -> wInt32# (l x0 (uInt# shift)) === wInt32# (r x0 (uInt# shift))
instance TestPrimop (Int32# -> Int32# -> Int#) where
testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -789,6 +842,7 @@ instance TestPrimop (Int32# -> Word32#) where
instance TestPrimop (Int64# -> Int# -> Int64#) where
testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt64#-> x0) (BoundedShift shift :: BoundedShift Int64) -> wInt64# (l x0 (uInt# shift)) === wInt64# (r x0 (uInt# shift))
instance TestPrimop (Int64# -> Int64# -> Int#) where
testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -809,6 +863,7 @@ instance TestPrimop (Int64# -> Word64#) where
instance TestPrimop (Int8# -> Int# -> Int8#) where
testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt8#-> x0) (BoundedShift shift :: BoundedShift Int8) -> wInt8# (l x0 (uInt# shift)) === wInt8# (r x0 (uInt# shift))
instance TestPrimop (Int8# -> Int8# -> Int#) where
testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -833,6 +888,7 @@ instance TestPrimop (Int8# -> Word8#) where
instance TestPrimop (Word# -> Int# -> Word#) where
testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord#-> x0) (BoundedShift shift :: BoundedShift Int) -> wWord# (l x0 (uInt# shift)) === wWord# (r x0 (uInt# shift))
instance TestPrimop (Word# -> Word# -> Int#) where
testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -870,6 +926,7 @@ instance TestPrimop (Word# -> Word8#) where
instance TestPrimop (Word16# -> Int# -> Word16#) where
testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord16#-> x0) (BoundedShift shift :: BoundedShift Int16) -> wWord16# (l x0 (uInt# shift)) === wWord16# (r x0 (uInt# shift))
instance TestPrimop (Word16# -> Word16# -> Int#) where
testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -894,6 +951,7 @@ instance TestPrimop (Word16# -> Word16#) where
instance TestPrimop (Word32# -> Int# -> Word32#) where
testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord32#-> x0) (BoundedShift shift :: BoundedShift Int32) -> wWord32# (l x0 (uInt# shift)) === wWord32# (r x0 (uInt# shift))
instance TestPrimop (Word32# -> Word32# -> Int#) where
testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -918,6 +976,7 @@ instance TestPrimop (Word32# -> Word32#) where
instance TestPrimop (Word64# -> Int# -> Word64#) where
testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord64#-> x0) (BoundedShift shift :: BoundedShift Int64) -> wWord64# (l x0 (uInt# shift)) === wWord64# (r x0 (uInt# shift))
instance TestPrimop (Word64# -> Word64# -> Int#) where
testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -938,6 +997,7 @@ instance TestPrimop (Word64# -> Word64#) where
instance TestPrimop (Word8# -> Int# -> Word8#) where
testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord8#-> x0) (BoundedShift shift :: BoundedShift Int8) -> wWord8# (l x0 (uInt# shift)) === wWord8# (r x0 (uInt# shift))
instance TestPrimop (Word8# -> Word8# -> Int#) where
testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -705,12 +705,16 @@ gen_foundation_tests (Info _ entries)
mkInstances inst_ty =
let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r"
+ shift_lambda = "\\ " ++ mkArg (0::Int) (head arg_tys) ++ " (BoundedShift shift :: BoundedShift " ++ shiftBoundType (head arg_tys) ++ ") -> " ++ mk_shift_body "l" ++ " === " ++ mk_shift_body "r"
in unlines $
[ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where"
, " testPrimop s l r = Property s $ " ++ test_lambda ]
++ (if mb_divable_tys
then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda]
else [])
+ ++ (if mb_shiftable_tys
+ then [" testPrimopShift s l r = Property s $ " ++ shift_lambda]
+ else [])
where
arg_tys = args inst_ty
-- eg Int -> Int -> a
@@ -718,7 +722,14 @@ gen_foundation_tests (Info _ entries)
[ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons
_ -> False
+ -- eg SomeType# -> Int# -> SomeType#
+ mb_shiftable_tys = case arg_tys of
+ [ty1,"Int#"] -> let res_type = getResultType inst_ty
+ in ty1 == res_type && ty1 `elem` shiftableTyCons
+ _ -> False
+
mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")")
+ mk_shift_body s = res_ty inst_ty (" (" ++ s ++ " x0 (uInt# shift))")
vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys)
@@ -761,6 +772,8 @@ gen_foundation_tests (Info _ entries)
, (testable (ty po))
= let testPrimOpHow = if is_divLikeOp po
then "testPrimopDivLike"
+ else if is_shiftLikeOp po
+ then "testPrimopShift"
else "testPrimop"
qualOp qualification =
let qName = wrap qualification poName
@@ -784,6 +797,27 @@ gen_foundation_tests (Info _ entries)
testableTyCon _ = False
divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
,"Int8#", "Int16#", "Int32#", "Int64#"]
+ shiftableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
+ ,"Int8#", "Int16#", "Int32#", "Int64#"]
+
+ shiftBoundType :: String -> String
+ shiftBoundType "Int8#" = "Int8"
+ shiftBoundType "Int16#" = "Int16"
+ shiftBoundType "Int32#" = "Int32"
+ shiftBoundType "Int64#" = "Int64"
+ shiftBoundType "Word8#" = "Int8" -- Word8 uses Int8 bound
+ shiftBoundType "Word16#" = "Int16" -- Word16 uses Int16 bound
+ shiftBoundType "Word32#" = "Int32" -- Word32 uses Int32 bound
+ shiftBoundType "Word64#" = "Int64" -- Word64 uses Int64 bound
+ shiftBoundType "Int#" = "Int"
+ shiftBoundType "Word#" = "Int" -- Word uses Int bound
+ shiftBoundType t = error $ "shiftBoundType: unknown type " ++ t
+
+ getResultType :: Ty -> String
+ getResultType (TyF _ t2) = getResultType t2
+ getResultType (TyApp (TyCon c) []) = c
+ getResultType (TyUTup _) = "" -- Unboxed tuples can't be shift operations
+ getResultType t = error $ "getResultType: unexpected type " ++ pprTy t
mb_defined_bits :: Entry -> Maybe Word
mb_defined_bits op@(PrimOpSpec{}) =
=====================================
utils/genprimopcode/Syntax.hs
=====================================
@@ -1,6 +1,6 @@
module Syntax where
-import Data.List (nub)
+import Data.List (nub, isInfixOf)
------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
@@ -66,6 +66,21 @@ is_divLikeOp entry = case entry of
Just (OptionTrue{}) -> True
_ -> False
+is_shiftLikeOp :: Entry -> Bool
+is_shiftLikeOp entry = case entry of
+ PrimOpSpec{} -> has_shift_like
+ PseudoOpSpec{} -> has_shift_like
+ PrimVecOpSpec{} -> has_shift_like
+ PrimTypeSpec{} -> False
+ PrimVecTypeSpec{} -> False
+ Section{} -> False
+ where
+ has_shift_like = case entry of
+ PrimOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n
+ PseudoOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n
+ PrimVecOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n
+ _ -> False
+
-- a binding of property to value
data Option
= OptionFalse String -- name = False
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/522bf61b71aa8595a8de5897237b9b6ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/522bf61b71aa8595a8de5897237b9b6ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/fix-foundation-test-shift-amounts] foundation test: Fix shift amount (#26248)
by Sven Tennie (ļ¼ supersven) 27 Aug '25
by Sven Tennie (ļ¼ supersven) 27 Aug '25
27 Aug '25
Sven Tennie pushed to branch wip/supersven/fix-foundation-test-shift-amounts at Glasgow Haskell Compiler / GHC
Commits:
9ed60877 by Sven Tennie at 2025-08-27T19:06:18+02:00
foundation test: Fix shift amount (#26248)
Shift primops' results are only defined for shift amounts of 0 to word
size - 1.
This has been partly vipe coded: https://github.com/supersven/ghc/pull/1
- - - - -
3 changed files:
- testsuite/tests/numeric/should_run/foundation.hs
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Syntax.hs
Changes:
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -24,7 +24,7 @@ module Main
( main
) where
-import Data.Bits (Bits((.&.), bit))
+import Data.Bits (Bits((.&.), bit), finiteBitSize)
import Data.Word
import Data.Int
import GHC.Natural
@@ -133,6 +133,52 @@ newtype NonZero a = NonZero { getNonZero :: a }
instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
arbitrary = nonZero
+-- | A newtype for shift amounts that are bounded by word size
+newtype BoundedShift a = BoundedShift { getBoundedShift :: Int }
+ deriving (Eq,Ord,Show)
+
+-- | Generate shift amounts bounded by the word size for each type
+boundedShift8 :: Gen (BoundedShift Int8)
+boundedShift8 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 8)
+
+boundedShift16 :: Gen (BoundedShift Int16)
+boundedShift16 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 16)
+
+boundedShift32 :: Gen (BoundedShift Int32)
+boundedShift32 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 32)
+
+boundedShift64 :: Gen (BoundedShift Int64)
+boundedShift64 = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` 64)
+
+boundedShiftWord :: Gen (BoundedShift Int)
+boundedShiftWord = do
+ x <- arbitrary
+ return $ BoundedShift (abs x `mod` finiteBitSize (undefined :: Word))
+
+-- Arbitrary instances for BoundedShift types to work with lambda patterns
+instance Arbitrary (BoundedShift Int8) where
+ arbitrary = boundedShift8
+
+instance Arbitrary (BoundedShift Int16) where
+ arbitrary = boundedShift16
+
+instance Arbitrary (BoundedShift Int32) where
+ arbitrary = boundedShift32
+
+instance Arbitrary (BoundedShift Int64) where
+ arbitrary = boundedShift64
+
+instance Arbitrary (BoundedShift Int) where
+ arbitrary = boundedShiftWord
+
instance Arbitrary Natural where
arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
@@ -395,6 +441,10 @@ class TestPrimop f where
testPrimopDivLike :: String -> f -> f -> Test
testPrimopDivLike _ _ _ = error "Div testing not supported for this type."
+ -- | Special test method for shift operations that bounds the shift amount
+ testPrimopShift :: String -> f -> f -> Test
+ testPrimopShift _ _ _ = error "Shift testing not supported for this type."
+
{-
instance TestPrimop (Int# -> Int# -> Int#) where
testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
@@ -460,9 +510,9 @@ testPrimops = Group "primop"
, testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8#
, testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8#
, testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8#
- , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
- , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
- , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
+ , testPrimopShift "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
+ , testPrimopShift "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
+ , testPrimopShift "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
, testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8#
, testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8#
, testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8#
@@ -482,8 +532,8 @@ testPrimops = Group "primop"
, testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8#
, testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8#
, testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8#
- , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
- , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
+ , testPrimopShift "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
+ , testPrimopShift "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
, testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8#
, testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8#
, testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8#
@@ -500,9 +550,9 @@ testPrimops = Group "primop"
, testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16#
, testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16#
, testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16#
- , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
- , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
- , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
+ , testPrimopShift "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
+ , testPrimopShift "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
+ , testPrimopShift "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
, testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16#
, testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16#
, testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16#
@@ -522,8 +572,8 @@ testPrimops = Group "primop"
, testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16#
, testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16#
, testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16#
- , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
- , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
+ , testPrimopShift "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
+ , testPrimopShift "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
, testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16#
, testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16#
, testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16#
@@ -540,9 +590,9 @@ testPrimops = Group "primop"
, testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32#
, testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32#
, testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32#
- , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
- , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
- , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
+ , testPrimopShift "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
+ , testPrimopShift "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
+ , testPrimopShift "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
, testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32#
, testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32#
, testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32#
@@ -562,8 +612,8 @@ testPrimops = Group "primop"
, testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32#
, testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32#
, testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32#
- , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
- , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
+ , testPrimopShift "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
+ , testPrimopShift "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
, testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32#
, testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32#
, testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32#
@@ -579,9 +629,9 @@ testPrimops = Group "primop"
, testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64#
, testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64#
, testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64#
- , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
- , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
- , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
+ , testPrimopShift "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
+ , testPrimopShift "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
+ , testPrimopShift "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
, testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64#
, testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64#
, testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64#
@@ -600,8 +650,8 @@ testPrimops = Group "primop"
, testPrimop "or64#" Primop.or64# Wrapper.or64#
, testPrimop "xor64#" Primop.xor64# Wrapper.xor64#
, testPrimop "not64#" Primop.not64# Wrapper.not64#
- , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
- , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
+ , testPrimopShift "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
+ , testPrimopShift "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
, testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64#
, testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64#
, testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64#
@@ -632,9 +682,9 @@ testPrimops = Group "primop"
, testPrimop "<=#" (Primop.<=#) (Wrapper.<=#)
, testPrimop "chr#" Primop.chr# Wrapper.chr#
, testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word#
- , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
- , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
- , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
+ , testPrimopShift "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
+ , testPrimopShift "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
+ , testPrimopShift "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
, testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord#
, testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC#
, testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC#
@@ -649,8 +699,8 @@ testPrimops = Group "primop"
, testPrimop "or#" Primop.or# Wrapper.or#
, testPrimop "xor#" Primop.xor# Wrapper.xor#
, testPrimop "not#" Primop.not# Wrapper.not#
- , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
- , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
+ , testPrimopShift "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
+ , testPrimopShift "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
, testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int#
, testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord#
, testPrimop "geWord#" Primop.geWord# Wrapper.geWord#
@@ -709,6 +759,7 @@ instance TestPrimop (Char# -> Int#) where
instance TestPrimop (Int# -> Int# -> Int#) where
testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShift shift :: BoundedShift Int) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift))
instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
@@ -741,6 +792,7 @@ instance TestPrimop (Int# -> Word#) where
instance TestPrimop (Int16# -> Int# -> Int16#) where
testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt16#-> x0) (BoundedShift shift :: BoundedShift Int16) -> wInt16# (l x0 (uInt# shift)) === wInt16# (r x0 (uInt# shift))
instance TestPrimop (Int16# -> Int16# -> Int#) where
testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -765,6 +817,7 @@ instance TestPrimop (Int16# -> Word16#) where
instance TestPrimop (Int32# -> Int# -> Int32#) where
testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt32#-> x0) (BoundedShift shift :: BoundedShift Int32) -> wInt32# (l x0 (uInt# shift)) === wInt32# (r x0 (uInt# shift))
instance TestPrimop (Int32# -> Int32# -> Int#) where
testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -789,6 +842,7 @@ instance TestPrimop (Int32# -> Word32#) where
instance TestPrimop (Int64# -> Int# -> Int64#) where
testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt64#-> x0) (BoundedShift shift :: BoundedShift Int64) -> wInt64# (l x0 (uInt# shift)) === wInt64# (r x0 (uInt# shift))
instance TestPrimop (Int64# -> Int64# -> Int#) where
testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -809,6 +863,7 @@ instance TestPrimop (Int64# -> Word64#) where
instance TestPrimop (Int8# -> Int# -> Int8#) where
testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uInt8#-> x0) (BoundedShift shift :: BoundedShift Int8) -> wInt8# (l x0 (uInt# shift)) === wInt8# (r x0 (uInt# shift))
instance TestPrimop (Int8# -> Int8# -> Int#) where
testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -833,6 +888,7 @@ instance TestPrimop (Int8# -> Word8#) where
instance TestPrimop (Word# -> Int# -> Word#) where
testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord#-> x0) (BoundedShift shift :: BoundedShift Int) -> wWord# (l x0 (uInt# shift)) === wWord# (r x0 (uInt# shift))
instance TestPrimop (Word# -> Word# -> Int#) where
testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -870,6 +926,7 @@ instance TestPrimop (Word# -> Word8#) where
instance TestPrimop (Word16# -> Int# -> Word16#) where
testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord16#-> x0) (BoundedShift shift :: BoundedShift Int16) -> wWord16# (l x0 (uInt# shift)) === wWord16# (r x0 (uInt# shift))
instance TestPrimop (Word16# -> Word16# -> Int#) where
testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -894,6 +951,7 @@ instance TestPrimop (Word16# -> Word16#) where
instance TestPrimop (Word32# -> Int# -> Word32#) where
testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord32#-> x0) (BoundedShift shift :: BoundedShift Int32) -> wWord32# (l x0 (uInt# shift)) === wWord32# (r x0 (uInt# shift))
instance TestPrimop (Word32# -> Word32# -> Int#) where
testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -918,6 +976,7 @@ instance TestPrimop (Word32# -> Word32#) where
instance TestPrimop (Word64# -> Int# -> Word64#) where
testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord64#-> x0) (BoundedShift shift :: BoundedShift Int64) -> wWord64# (l x0 (uInt# shift)) === wWord64# (r x0 (uInt# shift))
instance TestPrimop (Word64# -> Word64# -> Int#) where
testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
@@ -938,6 +997,7 @@ instance TestPrimop (Word64# -> Word64#) where
instance TestPrimop (Word8# -> Int# -> Word8#) where
testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+ testPrimopShift s l r = Property s $ \ (uWord8#-> x0) (BoundedShift shift :: BoundedShift Int8) -> wWord8# (l x0 (uInt# shift)) === wWord8# (r x0 (uInt# shift))
instance TestPrimop (Word8# -> Word8# -> Int#) where
testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -705,12 +705,16 @@ gen_foundation_tests (Info _ entries)
mkInstances inst_ty =
let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r"
+ shift_lambda = "\\ " ++ mkArg (0::Int) (head arg_tys) ++ " (BoundedShift shift :: BoundedShift " ++ shiftBoundType (head arg_tys) ++ ") -> " ++ mk_shift_body "l" ++ " === " ++ mk_shift_body "r"
in unlines $
[ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where"
, " testPrimop s l r = Property s $ " ++ test_lambda ]
++ (if mb_divable_tys
then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda]
else [])
+ ++ (if mb_shiftable_tys
+ then [" testPrimopShift s l r = Property s $ " ++ shift_lambda]
+ else [])
where
arg_tys = args inst_ty
-- eg Int -> Int -> a
@@ -718,7 +722,14 @@ gen_foundation_tests (Info _ entries)
[ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons
_ -> False
+ -- eg SomeType# -> Int# -> SomeType#
+ mb_shiftable_tys = case arg_tys of
+ [ty1,"Int#"] -> let res_type = getResultType inst_ty
+ in ty1 == res_type && ty1 `elem` shiftableTyCons
+ _ -> False
+
mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")")
+ mk_shift_body s = res_ty inst_ty (" (" ++ s ++ " x0 (uInt# shift))")
vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys)
@@ -761,6 +772,8 @@ gen_foundation_tests (Info _ entries)
, (testable (ty po))
= let testPrimOpHow = if is_divLikeOp po
then "testPrimopDivLike"
+ else if is_shiftLikeOp po
+ then "testPrimopShift"
else "testPrimop"
qualOp qualification =
let qName = wrap qualification poName
@@ -784,6 +797,27 @@ gen_foundation_tests (Info _ entries)
testableTyCon _ = False
divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
,"Int8#", "Int16#", "Int32#", "Int64#"]
+ shiftableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
+ ,"Int8#", "Int16#", "Int32#", "Int64#"]
+
+ shiftBoundType :: String -> String
+ shiftBoundType "Int8#" = "Int8"
+ shiftBoundType "Int16#" = "Int16"
+ shiftBoundType "Int32#" = "Int32"
+ shiftBoundType "Int64#" = "Int64"
+ shiftBoundType "Word8#" = "Int8" -- Word8 uses Int8 bound
+ shiftBoundType "Word16#" = "Int16" -- Word16 uses Int16 bound
+ shiftBoundType "Word32#" = "Int32" -- Word32 uses Int32 bound
+ shiftBoundType "Word64#" = "Int64" -- Word64 uses Int64 bound
+ shiftBoundType "Int#" = "Int"
+ shiftBoundType "Word#" = "Int" -- Word uses Int bound
+ shiftBoundType t = error $ "shiftBoundType: unknown type " ++ t
+
+ getResultType :: Ty -> String
+ getResultType (TyF _ t2) = getResultType t2
+ getResultType (TyApp (TyCon c) []) = c
+ getResultType (TyUTup _) = "" -- Unboxed tuples can't be shift operations
+ getResultType t = error $ "getResultType: unexpected type " ++ pprTy t
mb_defined_bits :: Entry -> Maybe Word
mb_defined_bits op@(PrimOpSpec{}) =
=====================================
utils/genprimopcode/Syntax.hs
=====================================
@@ -1,6 +1,6 @@
module Syntax where
-import Data.List (nub)
+import Data.List (nub, isInfixOf)
------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
@@ -66,6 +66,21 @@ is_divLikeOp entry = case entry of
Just (OptionTrue{}) -> True
_ -> False
+is_shiftLikeOp :: Entry -> Bool
+is_shiftLikeOp entry = case entry of
+ PrimOpSpec{} -> has_shift_like
+ PseudoOpSpec{} -> has_shift_like
+ PrimVecOpSpec{} -> has_shift_like
+ PrimTypeSpec{} -> False
+ PrimVecTypeSpec{} -> False
+ Section{} -> False
+ where
+ has_shift_like = case entry of
+ PrimOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n
+ PseudoOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n
+ PrimVecOpSpec { name = n } -> "Shift" `Data.List.isInfixOf` n
+ _ -> False
+
-- a binding of property to value
data Option
= OptionFalse String -- name = False
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ed60877eeae5f76adc06b1b6f9628cā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ed60877eeae5f76adc06b1b6f9628cā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/supersven/fix-foundation-test-shift-amounts
by Sven Tennie (ļ¼ supersven) 27 Aug '25
by Sven Tennie (ļ¼ supersven) 27 Aug '25
27 Aug '25
Sven Tennie pushed new branch wip/supersven/fix-foundation-test-shift-amounts at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/fix-foundation-testā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0