From e56871861c8a531feaa1a24e37fb56ba6c8cc690 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Tue, 30 Apr 2024 17:46:04 +0100
Subject: [PATCH] Use HasDebugCallStack, rather than HasCallStack
---
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs | 2 +-
compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs | 6 +++---
compiler/GHC/Core/Opt/DmdAnal.hs | 2 +-
compiler/GHC/Core/SimpleOpt.hs | 2 +-
compiler/GHC/Core/Type.hs | 4 ++--
compiler/GHC/Data/Maybe.hs | 4 ++--
compiler/GHC/Stg/Subst.hs | 4 ++--
compiler/GHC/Tc/Deriv/Generate.hs | 2 +-
compiler/GHC/Tc/Deriv/Utils.hs | 2 +-
compiler/GHC/Tc/Gen/HsType.hs | 2 +-
compiler/GHC/Tc/Types/Origin.hs | 9 +++++----
compiler/GHC/Tc/Types/Origin.hs-boot | 4 ++--
compiler/GHC/Tc/Utils/TcType.hs | 2 +-
compiler/GHC/Tc/Utils/TcType.hs-boot | 4 ++--
compiler/GHC/Utils/Misc.hs | 4 ++--
compiler/GHC/Utils/Word64.hs | 8 ++++----
16 files changed, 31 insertions(+), 30 deletions(-)
diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
index 4bcd395eab62..f2810b38b9fb 100644
--- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
+++ b/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
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs
index 59b958ce1ff3..cc7f2c993e0e 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs
+++ b/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)
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 614bd69bb633..35ce07fba695 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/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) =
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index cad74a6ba9c9..4223a73d5b90 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -235,7 +235,7 @@ simple_opt_clo :: HasCallStack
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
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 7c21e2ee9666..8f8d9d554e5a 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/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
diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs
index 1e8424c0a46f..4004c1e32032 100644
--- a/compiler/GHC/Data/Maybe.hs
+++ b/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)
diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs
index e98f445b2ffb..009225cf04c0 100644
--- a/compiler/GHC/Stg/Subst.hs
+++ b/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'
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 1d10414ad38e..1840866aa151 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index e2f179b4ff09..67e7d59bc1d5 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 9e1fcc401719..69684d63f1cb 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index aea97da224eb..fdbe5e3a54a7 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/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")
diff --git a/compiler/GHC/Tc/Types/Origin.hs-boot b/compiler/GHC/Tc/Types/Origin.hs-boot
index ff7ab933f100..faf7bb7a9387 100644
--- a/compiler/GHC/Tc/Types/Origin.hs-boot
+++ b/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
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 9c2ce8904d01..f805929255d9 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot
index b011f93f7570..cdb7c3ddfd06 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs-boot
+++ b/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
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index 1410bdebdfda..718f81a6ce1a 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/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
diff --git a/compiler/GHC/Utils/Word64.hs b/compiler/GHC/Utils/Word64.hs
index f8b0ab0c2664..871e2e7cf100 100644
--- a/compiler/GHC/Utils/Word64.hs
+++ b/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
--
GitLab