diff options
| -rw-r--r-- | compiler/simplStg/RepType.hs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs | 17 | ||||
| -rw-r--r-- | compiler/types/TyCoRep.hs | 65 | ||||
| -rw-r--r-- | compiler/utils/Maybes.hs | 8 | ||||
| -rw-r--r-- | compiler/utils/Outputable.hs | 35 | ||||
| -rw-r--r-- | compiler/utils/Util.hs | 46 |
6 files changed, 72 insertions, 106 deletions
diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs index ca8438eec1..6309aecb3a 100644 --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -1,4 +1,5 @@ {-# 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' diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 728460045b..0b5f07301a 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -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) diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index cd221a2ebf..8302af9019 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -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. diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs index b400fa6b32..89dd5b4fae 100644 --- a/compiler/utils/Maybes.hs +++ b/compiler/utils/Maybes.hs @@ -1,6 +1,7 @@ {-# 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` diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index ee0147d308..472af2201e 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -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 diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 0b16fba72d..687ced2f47 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -1,6 +1,14 @@ -- (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 |