[Git][ghc/ghc][wip/T24726] Use HasDebugCallStack, rather than HasCallStack
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Apr 30 21:23:24 UTC 2024
Simon Peyton Jones pushed to branch wip/T24726 at Glasgow Haskell Compiler / GHC
Commits:
023ffbb9 by Simon Peyton Jones at 2024-04-30T22:23:00+01:00
Use HasDebugCallStack, rather than HasCallStack
- - - - -
16 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Type.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
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/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
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1612,7 +1612,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
@@ -1652,7 +1652,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/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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/023ffbb9bb303c7b90219a96b13512b3736c39a1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/023ffbb9bb303c7b90219a96b13512b3736c39a1
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/20240430/f8c7fd73/attachment-0001.html>
More information about the ghc-commits
mailing list