[Git][ghc/ghc][master] 4 commits: Track in-scope variables in ruleCheckProgram
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat May 4 00:49:26 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
be1e60ee by Simon Peyton Jones at 2024-05-03T20:47:37-04:00
Track in-scope variables in ruleCheckProgram
This small patch fixes #24726, by tracking in-scope variables
properly in -drule-check. Not hard to do!
- - - - -
58408c77 by Simon Peyton Jones at 2024-05-03T20:47:37-04:00
Add a couple more HasCallStack constraints in SimpleOpt
Just for debugging, no effect on normal code
- - - - -
70e245e8 by Simon Peyton Jones at 2024-05-03T20:47:37-04:00
Add comments to Prep.hs
This documentation patch fixes a TODO left over from !12364
- - - - -
e5687186 by Simon Peyton Jones at 2024-05-03T20:47:37-04:00
Use HasDebugCallStack, rather than HasCallStack
- - - - -
21 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/Maybe.hs
- compiler/GHC/Stg/Subst.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Types/Origin.hs-boot
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/TcType.hs-boot
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Word64.hs
- + testsuite/tests/simplCore/should_compile/T24726.hs
- + testsuite/tests/simplCore/should_compile/T24726.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -483,7 +483,7 @@ isOffsetImm off w
-- TODO OPT: we might be able give getRegister
-- a hint, what kind of register we want.
-getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)
+getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)
getFloatReg expr = do
r <- getRegister expr
case r of
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs
=====================================
@@ -8,11 +8,11 @@ import GHC.Platform.Reg
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Misc( HasDebugCallStack )
import GHC.Platform
import Data.Word
-import GHC.Stack
-- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp
-- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON
-- extension in Armv8-A.
@@ -65,7 +65,7 @@ showBits :: Word32 -> String
showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]
-- FR instance implementation (See Linear.FreeRegs)
-allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
+allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs
allocateReg (RealRegSingle r) (FreeRegs g f)
| r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))
| r < 32 && testBit g r = FreeRegs (clearBit g r) f
@@ -127,7 +127,7 @@ getFreeRegs cls (FreeRegs g f)
initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
-releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
+releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs
releaseReg (RealRegSingle r) (FreeRegs g f)
| r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))
| r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -2360,7 +2360,7 @@ addWeakFVs dmd_ty weak_fvs
-- L demand doesn't get both'd with the Bot coming up from the inner
-- call to f. So we just get an L demand for x for g.
-setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]
+setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var]
setBndrsDemandInfo (b:bs) ds
| isTyVar b = b : setBndrsDemandInfo bs ds
setBndrsDemandInfo (b:bs) (d:ds) =
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -47,7 +47,7 @@ import GHC.Driver.Ppr( showSDoc )
import GHC.Core -- All of it
import GHC.Core.Subst
import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
-import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars
+import GHC.Core.FVs ( exprFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames )
import GHC.Core.Utils ( exprType, mkTick, mkTicks
, stripTicksTopT, stripTicksTopE
@@ -1887,41 +1887,59 @@ ruleCheckProgram ropts phase rule_pat rules binds
vcat [ p $$ line | p <- bagToList results ]
]
where
+ line = text (replicate 20 '-')
env = RuleCheckEnv { rc_is_active = isActive phase
, rc_id_unf = idUnfolding -- Not quite right
-- Should use activeUnfolding
, rc_pattern = rule_pat
, rc_rules = rules
, rc_ropts = ropts
- }
- results = unionManyBags (map (ruleCheckBind env) binds)
- line = text (replicate 20 '-')
+ , rc_in_scope = emptyInScopeSet }
+
+ results = go env binds
+
+ go _ [] = emptyBag
+ go env (bind:binds) = let (env', ds) = ruleCheckBind env bind
+ in ds `unionBags` go env' binds
+
+data RuleCheckEnv = RuleCheckEnv
+ { rc_is_active :: Activation -> Bool
+ , rc_id_unf :: IdUnfoldingFun
+ , rc_pattern :: String
+ , rc_rules :: Id -> [CoreRule]
+ , rc_ropts :: RuleOpts
+ , rc_in_scope :: InScopeSet }
+
+extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv
+extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v
+ = env { rc_in_scope = in_scope `extendInScopeSet` v }
-data RuleCheckEnv = RuleCheckEnv {
- rc_is_active :: Activation -> Bool,
- rc_id_unf :: IdUnfoldingFun,
- rc_pattern :: String,
- rc_rules :: Id -> [CoreRule],
- rc_ropts :: RuleOpts
-}
+extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv
+extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs
+ = env { rc_in_scope = in_scope `extendInScopeSetList` vs }
-ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
+ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc)
-- The Bag returned has one SDoc for each call site found
-ruleCheckBind env (NonRec _ r) = ruleCheck env r
-ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
+ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r)
+ruleCheckBind env (Rec prs) = (env', unionManyBags (map (ruleCheck env') rhss))
+ where
+ (bs, rhss) = unzip prs
+ env' = env `extendInScopeListRC` bs
ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
-ruleCheck _ (Var _) = emptyBag
-ruleCheck _ (Lit _) = emptyBag
-ruleCheck _ (Type _) = emptyBag
-ruleCheck _ (Coercion _) = emptyBag
-ruleCheck env (App f a) = ruleCheckApp env (App f a) []
-ruleCheck env (Tick _ e) = ruleCheck env e
-ruleCheck env (Cast e _) = ruleCheck env e
-ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
-ruleCheck env (Lam _ e) = ruleCheck env e
-ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
- unionManyBags [ruleCheck env r | Alt _ _ r <- as]
+ruleCheck _ (Var _) = emptyBag
+ruleCheck _ (Lit _) = emptyBag
+ruleCheck _ (Type _) = emptyBag
+ruleCheck _ (Coercion _) = emptyBag
+ruleCheck env (App f a) = ruleCheckApp env (App f a) []
+ruleCheck env (Tick _ e) = ruleCheck env e
+ruleCheck env (Cast e _) = ruleCheck env e
+ruleCheck env (Let bd e) = let (env', ds) = ruleCheckBind env bd
+ in ds `unionBags` ruleCheck env' e
+ruleCheck env (Lam b e) = ruleCheck (env `extendInScopeRC` b) e
+ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags`
+ unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r
+ | Alt _ bs r <- as]
ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
@@ -1945,8 +1963,9 @@ ruleAppCheck_help env fn args rules
vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
vcat (map check_rule rules)]
where
- n_args = length args
- i_args = args `zip` [1::Int ..]
+ in_scope = rc_in_scope env
+ n_args = length args
+ i_args = args `zip` [1::Int ..]
rough_args = map roughTopName args
check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule
@@ -1976,10 +1995,8 @@ ruleAppCheck_help env fn args rules
mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
not (isJust (match_fn rule_arg arg))]
- lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl
where
- in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)
renv = RV { rv_lcl = mkRnEnv2 in_scope
, rv_tmpls = mkVarSet rule_bndrs
, rv_fltR = mkEmptySubst in_scope
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -228,13 +228,14 @@ enterRecGroupRHSs env bndrs k
(env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}
---------------
-simple_opt_clo :: InScopeSet
+simple_opt_clo :: HasCallStack
+ => InScopeSet
-> SimpleClo
-> OutExpr
simple_opt_clo in_scope (e_env, e)
= simple_opt_expr (soeSetInScope in_scope e_env) e
-simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
+simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr env expr
= go expr
where
@@ -397,7 +398,8 @@ simple_app env (Let bind body) args
simple_app env e as
= finish_app env (simple_opt_expr env e) as
-finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
+finish_app :: HasCallStack
+ => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
-- See Note [Eliminate casts in function position]
finish_app env (Cast (Lam x e) co) as@(_:_)
| not (isTyVar x) && not (isCoVar x)
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1636,7 +1636,7 @@ tyConAppArgs_maybe ty = case splitTyConApp_maybe ty of
Just (_, tys) -> Just tys
Nothing -> Nothing
-tyConAppArgs :: HasCallStack => Type -> [Type]
+tyConAppArgs :: HasDebugCallStack => Type -> [Type]
tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)
-- | Attempts to tease a type apart into a type constructor and the application
@@ -1676,7 +1676,7 @@ splitTyConAppNoView_maybe ty
--
-- Consequently, you may need to zonk your type before
-- using this function.
-tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
+tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
-- Defined here to avoid module loops between Unify and TcType.
tcSplitTyConApp_maybe ty
= case coreFullView ty of
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -2354,45 +2354,49 @@ we are optimizing away 'lazy' (see Note [lazyId magic], and also
'cpeRhsE'.) Then, we could have started with:
let x :: ()
- x = lazy @ () y
+ x = lazy @() y
-which is a perfectly fine, non-trivial thunk, but then CorePrep will
-drop 'lazy', giving us 'x = y' which is trivial and impermissible.
-The solution is CorePrep to have a miniature inlining pass which deals
-with cases like this. We can then drop the let-binding altogether.
+which is a perfectly fine, non-trivial thunk, but then CorePrep will drop
+'lazy', giving us 'x = y' which is trivial and impermissible. The solution is
+CorePrep to have a miniature inlining pass which deals with cases like this.
+We can then drop the let-binding altogether.
-Why does the removal of 'lazy' have to occur in CorePrep?
-The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the
-main reason is that lazy must appear in unfoldings (optimizer
-output) and it must prevent call-by-value for catch# (which
-is implemented by CorePrep.)
+Why does the removal of 'lazy' have to occur in CorePrep? The gory details
+are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that
+lazy must appear in unfoldings (optimizer output) and it must prevent
+call-by-value for catch# (which is implemented by CorePrep.)
-An alternate strategy for solving this problem is to have the
-inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
-We decided not to adopt this solution to keep the definition
-of 'exprIsTrivial' simple.
+An alternate strategy for solving this problem is to have the inliner treat
+'lazy e' as a trivial expression if 'e' is trivial. We decided not to adopt
+this solution to keep the definition of 'exprIsTrivial' simple.
There is ONE caveat however: for top-level bindings we have
to preserve the binding so that we float the (hacky) non-recursive
binding for data constructors; see Note [Data constructor workers].
-Note [CorePrep inlines trivial CoreExpr not Id]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-TODO
-Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
-IdEnv Id? Naively, we might conjecture that trivial updatable thunks
-as per Note [Inlining in CorePrep] always have the form
-'lazy @ SomeType gbl_id'. But this is not true: the following is
-perfectly reasonable Core:
+Note [CorePrepEnv: cpe_subst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field,
+for these reasons:
- let x :: ()
- x = lazy @ (forall a. a) y @ Bool
+1. To support cloning of local Ids so that they are
+ all unique (see Note [Cloning in CorePrep])
+
+2. To support beta-reduction of runRW, see Note [runRW magic] and
+ Note [runRW arg].
+
+3. To let us inline trivial RHSs of non top-level let-bindings,
+ see Note [lazyId magic], Note [Inlining in CorePrep] (#12076)
-When we inline 'x' after eliminating 'lazy', we need to replace
-occurrences of 'x' with 'y @ bool', not just 'y'. Situations like
-this can easily arise with higher-rank types; thus, cpe_env must
-map to CoreExprs, not Ids.
+ Note that, if (y::forall a. a->a), we could get
+ x = lazy @(forall a.a) y @Bool
+ so after eliminating `lazy`, we need to replace occurrences of `x` with
+ `y @Bool`, not just `y`. Situations like this can easily arise with
+ higher-rank types; thus, `cpe_subst` must map to CoreExprs, not Ids, which
+ oc course it does
+4. The TyCoVar part of the substitution is used only for
+ Note [Cloning CoVars and TyVars]
-}
data CorePrepConfig = CorePrepConfig
@@ -2418,23 +2422,9 @@ data CorePrepEnv
-- the case where a function we think should bottom
-- unexpectedly returns.
- , cpe_subst :: Subst
- -- ^ The IdEnv part of the substitution is used for three operations:
- --
- -- 1. To support cloning of local Ids so that they are
- -- all unique (see Note [Cloning in CorePrep])
- --
- -- 2. To support beta-reduction of runRW, see
- -- Note [runRW magic] and Note [runRW arg].
- --
- -- 3. To let us inline trivial RHSs of non top-level let-bindings,
- -- see Note [lazyId magic], Note [Inlining in CorePrep]
- -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
- --
- -- The TyCoVar part of the substitution is used only for
- -- Note [Cloning CoVars and TyVars]
+ , cpe_subst :: Subst -- ^ See Note [CorePrepEnv: cpe_subst]
- , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
+ , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
}
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
=====================================
compiler/GHC/Data/Maybe.hs
=====================================
@@ -33,7 +33,7 @@ import Control.Monad.Trans.Maybe
import Control.Exception (SomeException(..))
import Data.Maybe
import Data.Foldable ( foldlM, for_ )
-import GHC.Utils.Misc (HasCallStack)
+import GHC.Utils.Misc (HasDebugCallStack)
import Data.List.NonEmpty ( NonEmpty )
import Control.Applicative( Alternative( (<|>) ) )
@@ -66,7 +66,7 @@ firstJustsM = foldlM go Nothing where
go Nothing action = action
go result@(Just _) _action = return result
-expectJust :: HasCallStack => String -> Maybe a -> a
+expectJust :: HasDebugCallStack => String -> Maybe a -> a
{-# INLINE expectJust #-}
expectJust _ (Just x) = x
expectJust err Nothing = error ("expectJust " ++ err)
=====================================
compiler/GHC/Stg/Subst.hs
=====================================
@@ -55,7 +55,7 @@ substBndrs = runState . traverse (state . substBndr)
-- | Substitutes an occurrence of an identifier for its counterpart recorded
-- in the 'Subst'.
-lookupIdSubst :: HasCallStack => Id -> Subst -> Id
+lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id
lookupIdSubst id (Subst in_scope env)
| not (isLocalId id) = id
| Just id' <- lookupVarEnv env id = id'
@@ -65,7 +65,7 @@ lookupIdSubst id (Subst in_scope env)
-- | Substitutes an occurrence of an identifier for its counterpart recorded
-- in the 'Subst'. Does not generate a debug warning if the identifier to
-- to substitute wasn't in scope.
-noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id
+noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id
noWarnLookupIdSubst id (Subst in_scope env)
| not (isLocalId id) = id
| Just id' <- lookupVarEnv env id = id'
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -2445,7 +2445,7 @@ postfixModTbl
]
-- | Lookup `Type` in an association list.
-assoc_ty_id :: HasCallStack => String -- The class involved
+assoc_ty_id :: HasDebugCallStack => String -- The class involved
-> [(Type,a)] -- The table
-> Type -- The type
-> a -- The result of the lookup
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -649,7 +649,7 @@ mkDirectThetaSpec origin t_or_k =
, sps_type_or_kind = t_or_k
})
-substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec
+substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec
substPredSpec subst ps =
case ps of
SimplePredSpec { sps_pred = pred
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -3589,7 +3589,7 @@ data SkolemModeDetails
| SMDSkolemTv SkolemInfo
-smVanilla :: HasCallStack => SkolemMode
+smVanilla :: HasDebugCallStack => SkolemMode
smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this
, sm_parent = False
, sm_tvtv = pprPanic "sm_tvtv" callStackDoc -- We always override this
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -77,6 +77,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Stack
import GHC.Utils.Monad
+import GHC.Utils.Misc( HasDebugCallStack )
import GHC.Types.Unique
import GHC.Types.Unique.Supply
@@ -327,10 +328,10 @@ data SkolemInfoAnon
--
-- We're hoping to be able to get rid of this entirely, but for the moment
-- it's still needed.
-unkSkol :: HasCallStack => SkolemInfo
+unkSkol :: HasDebugCallStack => SkolemInfo
unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon
-unkSkolAnon :: HasCallStack => SkolemInfoAnon
+unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon
unkSkolAnon = UnkSkol callStack
-- | Wrap up the origin of a skolem type variable with a new 'Unique',
@@ -895,7 +896,7 @@ pprCtOrigin simple_origin
= ctoHerald <+> pprCtO simple_origin
-- | Short one-liners
-pprCtO :: HasCallStack => CtOrigin -> SDoc
+pprCtO :: HasDebugCallStack => CtOrigin -> SDoc
pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)]
pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]
pprCtO AppOrigin = text "an application"
@@ -960,7 +961,7 @@ pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check"
pprCtO (ImpedanceMatching {}) = text "combining required constraints"
pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]
-pprNonLinearPatternReason :: HasCallStack => NonLinearPatternReason -> SDoc
+pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc
pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")
pprNonLinearPatternReason GeneralisedPatternReason = parens (text "non-variable pattern bindings that have been generalised aren't linear")
pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms aren't linear")
=====================================
compiler/GHC/Tc/Types/Origin.hs-boot
=====================================
@@ -1,7 +1,7 @@
module GHC.Tc.Types.Origin where
import GHC.Prelude.Basic ( Int, Maybe )
-import GHC.Stack ( HasCallStack )
+import GHC.Utils.Misc ( HasDebugCallStack )
import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )
data SkolemInfoAnon
@@ -16,4 +16,4 @@ data FixedRuntimeRepOrigin
mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext
mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext
-unkSkol :: HasCallStack => SkolemInfo
+unkSkol :: HasDebugCallStack => SkolemInfo
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -609,7 +609,7 @@ data TcTyVarDetails
, mtv_ref :: IORef MetaDetails
, mtv_tclvl :: TcLevel } -- See Note [TcLevel invariants]
-vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
+vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails
vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False
instance Outputable TcTyVarDetails where
=====================================
compiler/GHC/Tc/Utils/TcType.hs-boot
=====================================
@@ -1,16 +1,16 @@
module GHC.Tc.Utils.TcType where
import GHC.Utils.Outputable( SDoc )
+import GHC.Utils.Misc( HasDebugCallStack )
import GHC.Prelude ( Bool )
import {-# SOURCE #-} GHC.Types.Var ( TcTyVar )
import {-# SOURCE #-} GHC.Tc.Types.Origin ( FixedRuntimeRepOrigin )
import GHC.Types.Name.Env ( NameEnv )
-import GHC.Stack
data MetaDetails
data TcTyVarDetails
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
+vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails
isMetaTyVar :: TcTyVar -> Bool
isTyConableTyVar :: TcTyVar -> Bool
=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -488,7 +488,7 @@ only _ = panic "Util: only"
-- | Extract the single element of a list and panic with the given message if
-- there are more elements or the list was empty.
-- Like 'expectJust', but for lists.
-expectOnly :: HasCallStack => String -> [a] -> a
+expectOnly :: HasDebugCallStack => String -> [a] -> a
{-# INLINE expectOnly #-}
#if defined(DEBUG)
expectOnly _ [a] = a
@@ -511,7 +511,7 @@ changeLast [_] x = [x]
changeLast (x:xs) x' = x : changeLast xs x'
-- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'.
-expectNonEmpty :: HasCallStack => String -> [a] -> NonEmpty a
+expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a
{-# INLINE expectNonEmpty #-}
expectNonEmpty _ (x:xs) = x:|xs
expectNonEmpty msg [] = expectNonEmptyPanic msg
=====================================
compiler/GHC/Utils/Word64.hs
=====================================
@@ -6,15 +6,15 @@ module GHC.Utils.Word64 (
import GHC.Prelude
import GHC.Utils.Panic.Plain (assert)
+import GHC.Utils.Misc (HasDebugCallStack)
import Data.Word
-import GHC.Stack
-intToWord64 :: HasCallStack => Int -> Word64
+intToWord64 :: HasDebugCallStack => Int -> Word64
intToWord64 x = assert (0 <= x) (fromIntegral x)
-word64ToInt :: HasCallStack => Word64 -> Int
+word64ToInt :: HasDebugCallStack => Word64 -> Int
word64ToInt x = assert (x <= fromIntegral (maxBound :: Int)) (fromIntegral x)
truncateWord64ToWord32 :: Word64 -> Word32
-truncateWord64ToWord32 = fromIntegral
\ No newline at end of file
+truncateWord64ToWord32 = fromIntegral
=====================================
testsuite/tests/simplCore/should_compile/T24726.hs
=====================================
@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -drule-check concatMap #-}
+ -- This rule-check thing crashed #24726
+
+module T24726 where
+
+data Stream a = forall s. Stream (s -> ()) s
+
+concatMapS :: (a -> Stream b) -> Stream a -> Stream b
+concatMapS f (Stream next0 s0) = Stream undefined undefined
+{-# INLINE [1] concatMapS #-}
+
+concatMapS' :: (s -> ()) -> (a -> s) -> Stream a -> Stream b
+concatMapS' = undefined
+
+{-# RULES "concatMap" forall step f. concatMapS (\x -> Stream step (f x)) = concatMapS' step f #-}
+
+replicateStep :: a -> b
+replicateStep _ = undefined
+{-# INLINE replicateStep #-}
+
+replicateS :: Int -> a -> Stream a
+replicateS n x0 = Stream replicateStep undefined
+{-# INLINE replicateS #-}
+
+foo1 :: Stream Int -> Stream Int
+foo1 = concatMapS (replicateS 2)
=====================================
testsuite/tests/simplCore/should_compile/T24726.stderr
=====================================
@@ -0,0 +1,36 @@
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -514,3 +514,4 @@ test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
+test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba480026903aa735e63818a64228ab13639ecdc9...e56871861c8a531feaa1a24e37fb56ba6c8cc690
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba480026903aa735e63818a64228ab13639ecdc9...e56871861c8a531feaa1a24e37fb56ba6c8cc690
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240503/dfdb177a/attachment-0001.html>
More information about the ghc-commits
mailing list