Commit 626db8f8 authored by Ben Gamari's avatar Ben Gamari 🐢

Unify CallStack handling in ghc

Here we introduce compatibility wrappers for HasCallStack constraints.
This is necessary as we must support GHC 7.10.1 which lacks sane call
stack support. We also introduce another constraint synonym,
HasDebugCallStack, which only provides a call stack when DEBUG is set.
parent 91238453
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module RepType
( -- * Code generator views onto Types
......@@ -332,14 +333,14 @@ fitsIn ty1 ty2
********************************************************************** -}
-- | Discovers the primitive representation of a more abstract 'UnaryType'
typePrimRep :: UnaryType -> PrimRep
typePrimRep :: HasDebugCallStack => UnaryType -> PrimRep
typePrimRep ty = kindPrimRep (text "kindRep ty" <+> ppr ty $$ ppr (typeKind ty))
(typeKind ty)
-- | Find the runtime representation of a 'TyCon'. Defined here to
-- avoid module loops. Do not call this on unboxed tuples or sums,
-- because they don't /have/ a runtime representation
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep :: HasDebugCallStack => TyCon -> PrimRep
tyConPrimRep tc
= ASSERT2( not (isUnboxedTupleTyCon tc), ppr tc )
ASSERT2( not (isUnboxedSumTyCon tc), ppr tc )
......@@ -350,7 +351,7 @@ tyConPrimRep tc
-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep'
-- of values of types of this kind.
kindPrimRep :: SDoc -> Kind -> PrimRep
kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> PrimRep
kindPrimRep doc ki
| Just ki' <- coreViewOneStarKind ki
= kindPrimRep doc ki'
......
......@@ -65,9 +65,6 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
import GHC.Stack (CallStack)
#endif
{-
************************************************************************
......@@ -138,21 +135,11 @@ mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
substPredOrigin ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> PredOrigin -> PredOrigin
substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
substPredOrigin subst (PredOrigin pred origin t_or_k)
= PredOrigin (substTy subst pred) origin t_or_k
substThetaOrigin ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> ThetaOrigin -> ThetaOrigin
substThetaOrigin :: HasCallStack => TCvSubst -> ThetaOrigin -> ThetaOrigin
substThetaOrigin subst = map (substPredOrigin subst)
data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
......
......@@ -167,9 +167,6 @@ import UniqFM
import qualified Data.Data as Data hiding ( TyCon )
import Data.List
import Data.IORef ( IORef ) -- for CoercionHole
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
import GHC.Stack (CallStack)
#endif
{-
%************************************************************************
......@@ -1986,12 +1983,7 @@ ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])
-}
-- | Type substitution, see 'zipTvSubst'
substTyWith ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
[TyVar] -> [Type] -> Type -> Type
substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type
-- Works only if the domain of the substitution is a
-- superset of the type being substituted into
substTyWith tvs tys = ASSERT( length tvs == length tys )
......@@ -2018,12 +2010,7 @@ substTyWithInScope in_scope tvs tys ty =
where tenv = zipTyEnv tvs tys
-- | Coercion substitution, see 'zipTvSubst'
substCoWith ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
[TyVar] -> [Type] -> Coercion -> Coercion
substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion
substCoWith tvs tys = ASSERT( length tvs == length tys )
substCo (zipTvSubst tvs tys)
......@@ -2075,11 +2062,7 @@ isValidTCvSubst (TCvSubst in_scope tenv cenv) =
-- | This checks if the substitution satisfies the invariant from
-- Note [The substitution invariant].
checkValidSubst ::
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> [Type] -> [Coercion] -> a -> a
checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a
checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
= ASSERT2( isValidTCvSubst subst,
text "in_scope" <+> ppr in_scope $$
......@@ -2111,12 +2094,7 @@ checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
-- | Substitute within a 'Type'
-- The substitution has to satisfy the invariants described in
-- Note [The substitution invariant].
substTy ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> Type -> Type
substTy :: HasCallStack => TCvSubst -> Type -> Type
substTy subst ty
| isEmptyTCvSubst subst = ty
| otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty
......@@ -2134,12 +2112,7 @@ substTyUnchecked subst ty
-- | Substitute within several 'Type's
-- The substitution has to satisfy the invariants described in
-- Note [The substitution invariant].
substTys ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> [Type] -> [Type]
substTys :: HasCallStack => TCvSubst -> [Type] -> [Type]
substTys subst tys
| isEmptyTCvSubst subst = tys
| otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys
......@@ -2157,12 +2130,7 @@ substTysUnchecked subst tys
-- | Substitute within a 'ThetaType'
-- The substitution has to satisfy the invariants described in
-- Note [The substitution invariant].
substTheta ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> ThetaType -> ThetaType
substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType
substTheta = substTys
-- | Substitute within a 'ThetaType' disabling the sanity checks.
......@@ -2218,12 +2186,7 @@ lookupTyVar (TCvSubst _ tenv _) tv
-- | Substitute within a 'Coercion'
-- The substitution has to satisfy the invariants described in
-- Note [The substitution invariant].
substCo ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> Coercion -> Coercion
substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion
substCo subst co
| isEmptyTCvSubst subst = co
| otherwise = checkValidSubst subst [] [co] $ subst_co subst co
......@@ -2241,12 +2204,7 @@ substCoUnchecked subst co
-- | Substitute within several 'Coercion's
-- The substitution has to satisfy the invariants described in
-- Note [The substitution invariant].
substCos ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> [Coercion] -> [Coercion]
substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion]
substCos subst cos
| isEmptyTCvSubst subst = cos
| otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos
......@@ -2341,12 +2299,7 @@ substCoVars subst cvs = map (substCoVar subst) cvs
lookupCoVar :: TCvSubst -> Var -> Maybe Coercion
lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v
substTyVarBndr ::
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
(?callStack :: CallStack) =>
#endif
TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndr = substTyVarBndrCallback substTy
-- | Like 'substTyVarBndr' but disables sanity checks.
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-
(c) The University of Glasgow 2006
......@@ -26,12 +27,7 @@ import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Exception (catch, SomeException(..))
import Data.Maybe
#if __GLASGOW_HASKELL__ >= 800
import GHC.Stack
#else
import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
#endif
import Util (HasCallStack)
infixr 4 `orElse`
......
......@@ -118,9 +118,6 @@ import Data.List (intersperse)
import GHC.Fingerprint
import GHC.Show ( showMultiLineString )
#if __GLASGOW_HASKELL__ > 710
import GHC.Stack
#endif
{-
************************************************************************
......@@ -1074,9 +1071,13 @@ doOrDoes _ = text "do"
************************************************************************
-}
pprPanic :: String -> SDoc -> a
callStackDoc :: HasCallStack => SDoc
callStackDoc =
hang (text "Call stack:") 4 (vcat $ map text $ lines prettyCurrentCallStack)
pprPanic :: HasCallStack => String -> SDoc -> a
-- ^ Throw an exception saying "bug in GHC"
pprPanic = panicDoc
pprPanic s doc = panicDoc s (doc $$ callStackDoc)
pprSorry :: String -> SDoc -> a
-- ^ Throw an exception saying "this isn't finished yet"
......@@ -1101,13 +1102,8 @@ pprTraceIt desc x = pprTrace desc (ppr x) x
-- | If debug output is on, show some 'SDoc' on the screen along
-- with a call stack when available.
#if __GLASGOW_HASKELL__ > 710
pprSTrace :: (?callStack :: CallStack) => SDoc -> a -> a
pprSTrace = pprTrace (prettyCallStack ?callStack)
#else
pprSTrace :: SDoc -> a -> a
pprSTrace = pprTrace "no callstack info"
#endif
pprSTrace :: HasCallStack => SDoc -> a -> a
pprSTrace doc = pprTrace "" (doc $$ callStackDoc)
warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
-- ^ Just warn about an assertion failure, recording the given file and line number.
......@@ -1122,22 +1118,11 @@ warnPprTrace True file line msg x
-- | Panic with an assertation failure, recording the given file and
-- line number. Should typically be accessed with the ASSERT family of macros
#if __GLASGOW_HASKELL__ > 710
assertPprPanic :: (?callStack :: CallStack) => String -> Int -> SDoc -> a
assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a
assertPprPanic _file _line msg
= pprPanic "ASSERT failed!" doc
where
doc = sep [ text (prettyCallStack ?callStack)
, msg ]
#else
assertPprPanic :: String -> Int -> SDoc -> a
assertPprPanic file line msg
= pprPanic "ASSERT failed!" doc
where
doc = sep [ hsep [ text "file", text file
, text "line", int line ]
, msg ]
#endif
doc = sep [ msg, callStackDoc ]
pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen dflags cont heading pretty_msg
......
-- (c) The University of Glasgow 2006
{-# LANGUAGE CPP, BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__ < 800
-- For CallStack business
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE FlexibleContexts #-}
#endif
-- | Highly random utility functions
--
......@@ -110,6 +118,12 @@ module Util (
-- * Hashing
hashString,
-- * Call stacks
GHC.Stack.CallStack,
HasCallStack,
HasDebugCallStack,
prettyCurrentCallStack,
) where
#include "HsVersions.h"
......@@ -123,6 +137,7 @@ import System.IO.Unsafe ( unsafePerformIO )
import Data.List hiding (group)
import GHC.Exts
import qualified GHC.Stack
import Control.Applicative ( liftA2 )
import Control.Monad ( liftM )
......@@ -1260,3 +1275,32 @@ mulHi :: Int32 -> Int32 -> Int32
mulHi a b = fromIntegral (r `shiftR` 32)
where r :: Int64
r = fromIntegral a * fromIntegral b
-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.
#if __GLASGOW_HASKELL__ >= 800
type HasCallStack = GHC.Stack.HasCallStack
#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
type HasCallStack = (?callStack :: GHC.Stack.CallStack)
-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
#else
type HasCallStack = (() :: Constraint)
#endif
-- | A call stack constraint, but only when 'isDebugOn'.
#if DEBUG
type HasDebugCallStack = HasCallStack
#else
type HasDebugCallStack = (() :: Constraint)
#endif
-- | Pretty-print the current callstack
#if __GLASGOW_HASKELL__ >= 800
prettyCurrentCallStack :: HasCallStack => String
prettyCurrentCallStack = GHC.Stack.prettyCallStack GHC.Stack.callStack
#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
prettyCurrentCallStack :: (?callStack :: GHC.Stack.CallStack) => String
prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack
#else
prettyCurrentCallStack :: HasCallStack => String
prettyCurrentCallStack = "Call stack unavailable"
#endif
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment