nuclear debugging

12 files changed, 37 insertions, 34 deletions

diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
index 6426251d20..70ccd80d6c 100644
--- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
@@ -199,7 +199,7 @@ data PmExprList
 --   ending in a wildcard variable x (of list type). Should be pretty-printed as
 --   (1:2:_).
 -- * @pmExprAsList [] == Just ('NilTerminated' [])@
-pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList
+pmExprAsList :: HasCallStack => Delta -> PmAltCon -> [Id] -> Maybe PmExprList
 pmExprAsList delta = go_con []
   where
     go_var rev_pref x
diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs
index 10f172a430..79d45cb312 100644
--- a/compiler/GHC/HsToCore/PmCheck/Types.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Types.hs
@@ -341,7 +341,7 @@ instance Outputable PmLitValue where
   ppr (PmLitOverString s) = pprHsString s
 
 -- Take care of negated literals
-minuses :: Int -> SDoc -> SDoc
+minuses ::  HasCallStack => Int -> SDoc -> SDoc
 minuses n sdoc = iterate (\sdoc -> parens (char '-' <> sdoc)) sdoc !! n
 
 instance Outputable PmLit where
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index 64bfb89731..439f38f4dd 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -371,7 +371,7 @@ orphNamesOfMCo :: MCoercion -> NameSet
 orphNamesOfMCo MRefl    = emptyNameSet
 orphNamesOfMCo (MCo co) = orphNamesOfCo co
 
-orphNamesOfCo :: Coercion -> NameSet
+orphNamesOfCo :: HasCallStack => Coercion -> NameSet
 orphNamesOfCo (Refl ty)             = orphNamesOfType ty
 orphNamesOfCo (GRefl _ ty mco)      = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco
 orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index da60eff5b6..685822fab8 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -816,7 +816,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
       worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
                           | otherwise  = Suspension ct ty hval n
 
-extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
+extractSubTerms :: HasCallStack => (Type -> ForeignHValue -> TcM Term)
                 -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
 extractSubTerms recurse clos = liftM thdOf3 . go 0 0
   where
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 121f64533d..3353ddd7e4 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -492,7 +492,7 @@ inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
 -- See Note [Substitution on IfaceType]
 inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
 
-substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
+substIfaceType :: HasCallStack => IfaceTySubst -> IfaceType -> IfaceType
 -- See Note [Substitution on IfaceType]
 substIfaceType env ty
   = go ty
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index c6c27f8ffe..09f4b06ead 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -2132,7 +2132,7 @@ tx_con_tte _      alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
 tx_con_tte dflags (DataAlt dc)  -- See Note [caseRules for tagToEnum]
   = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc
 
-tx_con_dtt :: Type -> AltCon -> Maybe AltCon
+tx_con_dtt :: HasCallStack => Type -> AltCon -> Maybe AltCon
 tx_con_dtt _  DEFAULT = Just DEFAULT
 tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
    | tag >= 0
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index ecb70eb560..7c3d8059f4 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -76,7 +76,7 @@ import Control.Monad
 ************************************************************************
 -}
 
-synonymTyConsOfType :: Type -> [TyCon]
+synonymTyConsOfType :: HasCallStack => Type -> [TyCon]
 -- Does not look through type synonyms at all
 -- Return a list of synonym tycons
 -- Keep this synchronized with 'expandTypeSynonyms'
diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs
index 0cd374641c..ed97f71c2d 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/types/Coercion.hs
@@ -714,7 +714,7 @@ mkFunCo r co1 co2
 -- | Apply a 'Coercion' to another 'Coercion'.
 -- The second coercion must be Nominal, unless the first is Phantom.
 -- If the first is Phantom, then the second can be either Phantom or Nominal.
-mkAppCo :: Coercion     -- ^ :: t1 ~r t2
+mkAppCo :: HasCallStack => Coercion     -- ^ :: t1 ~r t2
         -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2
         -> Coercion     -- ^ :: t1 s1 ~r t2 s2
 mkAppCo co arg
@@ -981,7 +981,7 @@ mkSymCo co                        = SymCo co
 
 -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
 --   (co1 ; co2)
-mkTransCo :: Coercion -> Coercion -> Coercion
+mkTransCo :: HasCallStack => Coercion -> Coercion -> Coercion
 mkTransCo co1 co2 | isReflCo co1 = co2
                   | isReflCo co2 = co1
 mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))
@@ -997,18 +997,18 @@ mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))
 mkTransCo co1 co2                 = TransCo co1 co2
 
 
-isErasedCoercion_maybe :: Coercion -> Maybe (Role,Type,Type)
+isErasedCoercion_maybe :: HasCallStack => Coercion -> Maybe (Role,Type,Type)
 isErasedCoercion_maybe (UnivCo ErasedProv r lt rt) = Just (r,lt,rt)
 isErasedCoercion_maybe _ = Nothing
 
-isErasedCoercion :: Coercion -> Bool
+isErasedCoercion ::HasCallStack => Coercion -> Bool
 isErasedCoercion c = case isErasedCoercion_maybe c of
                       Just _ -> True ; Nothing -> False
 
 -- shamelessly copied from Ben Gamari's version of this code
 -- | Make a Erased coercion if building of coercions is disabled, otherwise
 -- return the given un-erased coercion.
-mkErasedCoercion :: HasDebugCallStack
+mkErasedCoercion :: HasCallStack
                  => DynFlags
                  -> Coercion  -- ^ the un-Erased coercion
                  -> Pair Type -- ^ the kind of the coercion
@@ -1046,17 +1046,18 @@ mkErasedCoercion dflags co (Pair ty1 ty2) role fvs
         ]
 
 -- | Replace a coercion with a erased coercion unless coercions are needed.
-eraseCoercion :: DynFlags -> Coercion -> Coercion
+eraseCoercion :: HasCallStack => DynFlags -> Coercion -> Coercion
 eraseCoercion _ co@(UnivCo ErasedProv _ _ _ ) = co  -- already zapped
 eraseCoercion _ co@(Refl _) = co  -- Refl is smaller than zapped coercions
 eraseCoercion _ co@(GRefl _r _ty MRefl ) = co
+eraseCoercion _ c | Just (t,r)<-  isReflexiveCo_maybe c = mkReflCo r t
 eraseCoercion dflags co =
     mkErasedCoercion dflags co (Pair t1 t2) role fvs
   where
     (Pair t1 t2, role) = coercionKindRole co
     fvs = filterDVarSet (not . isCoercionHole) $ tyCoVarsOfCoDSet co
 
-alwaysMkErasedCoercion :: HasDebugCallStack
+alwaysMkErasedCoercion :: HasCallStack
                  => Coercion  -- ^ the un-Erased coercion
                  -> Pair Type -- ^ the kind of the coercion
                  -> Role      -- ^ the role of the coercion
@@ -1092,10 +1093,11 @@ alwaysMkErasedCoercion co (Pair ty1 ty2) role _fvs
         ]
 
 
-forcedEraseCoercion ::  HasDebugCallStack => Coercion -> Coercion
+forcedEraseCoercion ::  HasCallStack  => Coercion -> Coercion
 forcedEraseCoercion co@(UnivCo ErasedProv _ _ _ ) = co  -- already erased/zapped
 forcedEraseCoercion co@(Refl _) = co  -- Refl is smaller than erased coercions
 forcedEraseCoercion co@(GRefl _r _ty MRefl ) = co
+forcedEraseCoercion co | Just (t,r)<-  isReflexiveCo_maybe co = mkReflCo r t
 forcedEraseCoercion co =
     alwaysMkErasedCoercion  co (Pair t1 t2) role fvs
   where
@@ -1108,7 +1110,7 @@ mkTransMCo MRefl     co2       = co2
 mkTransMCo co1       MRefl     = co1
 mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)
 
-mkNthCo :: HasDebugCallStack
+mkNthCo :: HasCallStack
         => Role  -- The role of the coercion you're creating
         -> Int   -- Zero-indexed
         -> Coercion
@@ -1327,7 +1329,7 @@ mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole c
              SubCo co
 
 -- | Changes a role, but only a downgrade. See Note [Role twiddling functions]
-downgradeRole_maybe :: Role   -- ^ desired role
+downgradeRole_maybe :: HasCallStack => Role   -- ^ desired role
                     -> Role   -- ^ current role
                     -> Coercion -> Maybe Coercion
 -- In (downgradeRole_maybe dr cr co) it's a precondition that
@@ -1380,7 +1382,7 @@ mkProofIrrelCo r kco        g1 g2 = mkUnivCo (ProofIrrelProv kco) r
 
 -- | Converts a coercion to be nominal, if possible.
 -- See Note [Role twiddling functions]
-setNominalRole_maybe :: Role -- of input coercion
+setNominalRole_maybe ::HasCallStack => Role -- of input coercion
                      -> Coercion -> Maybe Coercion
 setNominalRole_maybe r co
   | r == Nominal = Just co
@@ -1416,6 +1418,7 @@ setNominalRole_maybe r co
                      PhantomProv _    -> False  -- should always be phantom
                      ProofIrrelProv _ -> True   -- it's always safe
                      PluginProv _     -> False  -- who knows? This choice is conservative.
+                     ErasedProv -> False -- conservatively say no
       = Just $ UnivCo prov Nominal co1 co2
     setNominalRole_maybe_helper _ = Nothing
 
@@ -1468,7 +1471,7 @@ ltRole Nominal          _       = True
 
 -- | like mkKindCo, but aggressively & recursively optimizes to avoid using
 -- a KindCo constructor. The output role is nominal.
-promoteCoercion :: Coercion -> CoercionN
+promoteCoercion :: HasCallStack => Coercion -> CoercionN
 
 -- First cases handles anything that should yield refl.
 promoteCoercion co = case co of
@@ -2281,7 +2284,7 @@ seqProv UnsafeCoerceProv    = ()
 seqProv (PhantomProv co)    = seqCo co
 seqProv (ProofIrrelProv co) = seqCo co
 seqProv (PluginProv _)      = ()
-seqPov  ErasedProv          = ()
+seqProv  ErasedProv          = ()
 
 seqCos :: [Coercion] -> ()
 seqCos []       = ()
diff --git a/compiler/types/Coercion.hs-boot b/compiler/types/Coercion.hs-boot
index eb5e81b819..6df4d14ffe 100644
--- a/compiler/types/Coercion.hs-boot
+++ b/compiler/types/Coercion.hs-boot
@@ -15,7 +15,7 @@ import Util
 
 mkReflCo :: Role -> Type -> Coercion
 mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
-mkAppCo :: Coercion -> Coercion -> Coercion
+mkAppCo :: HasCallStack => Coercion -> Coercion -> Coercion
 mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion
 mkFunCo :: Role -> Coercion -> Coercion -> Coercion
 mkCoVarCo :: CoVar -> Coercion
@@ -24,14 +24,14 @@ mkPhantomCo :: Coercion -> Type -> Type -> Coercion
 mkUnsafeCo :: Role -> Type -> Type -> Coercion
 mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion
 mkSymCo :: Coercion -> Coercion
-mkTransCo :: Coercion -> Coercion -> Coercion
-mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion
+mkTransCo :: HasCallStack => Coercion -> Coercion -> Coercion
+mkNthCo :: HasCallStack => Role -> Int -> Coercion -> Coercion
 mkLRCo :: LeftOrRight -> Coercion -> Coercion
 mkInstCo :: Coercion -> Coercion -> Coercion
 mkGReflCo :: Role -> Type -> MCoercionN -> Coercion
 mkNomReflCo :: Type -> Coercion
-mkKindCo :: Coercion -> Coercion
-mkSubCo :: Coercion -> Coercion
+mkKindCo :: HasCallStack => Coercion -> Coercion
+mkSubCo :: HasCallStack => Coercion -> Coercion
 mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion
 mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
 
diff --git a/compiler/types/TyCoFVs.hs b/compiler/types/TyCoFVs.hs
index dfd90bb5de..6941cbf8c2 100644
--- a/compiler/types/TyCoFVs.hs
+++ b/compiler/types/TyCoFVs.hs
@@ -323,7 +323,7 @@ which type variables are mentioned in a type.  It only matters
 occasionally -- see the calls to exactTyCoVarsOfType.
 -}
 
-exactTyCoVarsOfType :: Type -> TyCoVarSet
+exactTyCoVarsOfType :: HasCallStack => Type -> TyCoVarSet
 -- Find the free type variables (of any kind)
 -- but *expand* type synonyms.  See Note [Silly type synonym] above.
 exactTyCoVarsOfType ty
@@ -385,7 +385,7 @@ exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys
 --
 -- Eta-expanded because that makes it run faster (apparently)
 -- See Note [FV eta expansion] in FV for explanation.
-tyCoFVsOfType :: Type -> FV
+tyCoFVsOfType :: HasCallStack => Type -> FV
 -- See Note [Free variables of types]
 tyCoFVsOfType (TyVarTy v)        f bound_vars (acc_list, acc_set)
   | not (f v) = (acc_list, acc_set)
@@ -437,7 +437,7 @@ tyCoVarsOfCosSet cos = tyCoVarsOfCos $ nonDetEltsUFM cos
   -- It's OK to use nonDetEltsUFM here because we immediately forget the
   -- ordering by returning a set
 
-tyCoFVsOfCo :: Coercion -> FV
+tyCoFVsOfCo :: HasCallStack => Coercion -> FV
 -- Extracts type and coercion variables from a coercion
 -- See Note [Free variables of types]
 tyCoFVsOfCo (Refl ty) fv_cand in_scope acc
@@ -473,7 +473,7 @@ tyCoFVsOfCoVar :: CoVar -> FV
 tyCoFVsOfCoVar v fv_cand in_scope acc
   = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc
 
-tyCoFVsOfProv :: UnivCoProvenance -> FV
+tyCoFVsOfProv :: HasCallStack => UnivCoProvenance -> FV
 tyCoFVsOfProv UnsafeCoerceProv    fv_cand in_scope acc = emptyFV fv_cand in_scope acc
 tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
@@ -525,7 +525,7 @@ coVarsOfCos cos = getCoVarSet (tyCoFVsOfCos cos)
 -- | Given a covar and a coercion, returns True if covar is almost devoid in
 -- the coercion. That is, covar can only appear in Refl and GRefl.
 -- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion
-almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool
+almostDevoidCoVarOfCo :: HasCallStack => CoVar -> Coercion -> Bool
 almostDevoidCoVarOfCo cv co =
   almost_devoid_co_var_of_co co cv
 
diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs
index a8b717df00..7d6116f300 100644
--- a/compiler/utils/ListSetOps.hs
+++ b/compiler/utils/ListSetOps.hs
@@ -33,7 +33,7 @@ import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Set as S
 
-getNth :: Outputable a => [a] -> Int -> a
+getNth :: HasCallStack => Outputable a => [a] -> Int -> a
 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
              xs !! n
 
diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs
index 65fa4f54a5..b7fe05da8b 100644
--- a/libraries/base/GHC/List.hs
+++ b/libraries/base/GHC/List.hs
@@ -917,10 +917,10 @@ concat = foldr (++) []
 -- | List index (subscript) operator, starting from 0.
 -- It is an instance of the more general 'Data.List.genericIndex',
 -- which takes an index of any integral type.
-(!!)                    :: [a] -> Int -> a
+(!!)                    :: HasCallStack => [a] -> Int -> a
 #if defined(USE_REPORT_PRELUDE)
-xs     !! n | n < 0 =  errorWithoutStackTrace "Prelude.!!: negative index"
-[]     !! _         =  errorWithoutStackTrace "Prelude.!!: index too large"
+xs     !! n | n < 0 =  error "Prelude.!!: negative index"
+[]     !! _         =  error "Prelude.!!: index too large"
 (x:_)  !! 0         =  x
 (_:xs) !! n         =  xs !! (n-1)
 #else