summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Builtin/Types.hs9
-rw-r--r--compiler/GHC/Builtin/Uniques.hs6
-rw-r--r--compiler/GHC/Builtin/Utils.hs1
-rw-r--r--compiler/GHC/ByteCode/Asm.hs4
-rw-r--r--compiler/GHC/ByteCode/Linker.hs6
-rw-r--r--compiler/GHC/Cmm/CLabel.hs9
-rw-r--r--compiler/GHC/Cmm/Graph.hs2
-rw-r--r--compiler/GHC/Cmm/Info.hs3
-rw-r--r--compiler/GHC/Cmm/Ppr.hs2
-rw-r--r--compiler/GHC/CmmToAsm.hs4
-rw-r--r--compiler/GHC/CmmToAsm/BlockLayout.hs13
-rw-r--r--compiler/GHC/CmmToAsm/CFG.hs7
-rw-r--r--compiler/GHC/CmmToAsm/PPC/CodeGen.hs4
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs28
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs17
-rw-r--r--compiler/GHC/Core.hs5
-rw-r--r--compiler/GHC/Core/Class.hs7
-rw-r--r--compiler/GHC/Core/Coercion.hs105
-rw-r--r--compiler/GHC/Core/Coercion/Axiom.hs5
-rw-r--r--compiler/GHC/Core/Coercion/Opt.hs95
-rw-r--r--compiler/GHC/Core/DataCon.hs17
-rw-r--r--compiler/GHC/Core/FVs.hs8
-rw-r--r--compiler/GHC/Core/FamInstEnv.hs13
-rw-r--r--compiler/GHC/Core/InstEnv.hs16
-rw-r--r--compiler/GHC/Core/Lint.hs5
-rw-r--r--compiler/GHC/Core/Make.hs13
-rw-r--r--compiler/GHC/Core/Opt/Arity.hs18
-rw-r--r--compiler/GHC/Core/Opt/CSE.hs4
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs13
-rw-r--r--compiler/GHC/Core/Opt/CprAnal.hs4
-rw-r--r--compiler/GHC/Core/Opt/DmdAnal.hs9
-rw-r--r--compiler/GHC/Core/Opt/FloatIn.hs5
-rw-r--r--compiler/GHC/Core/Opt/FloatOut.hs4
-rw-r--r--compiler/GHC/Core/Opt/OccurAnal.hs9
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs2
-rw-r--r--compiler/GHC/Core/Opt/SetLevels.hs7
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs42
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Env.hs25
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs7
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs5
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs10
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs9
-rw-r--r--compiler/GHC/Core/PatSyn.hs8
-rw-r--r--compiler/GHC/Core/Rules.hs1
-rw-r--r--compiler/GHC/Core/SimpleOpt.hs15
-rw-r--r--compiler/GHC/Core/Subst.hs21
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs2
-rw-r--r--compiler/GHC/Core/TyCo/Subst.hs70
-rw-r--r--compiler/GHC/Core/TyCon.hs7
-rw-r--r--compiler/GHC/Core/Type.hs37
-rw-r--r--compiler/GHC/Core/Unfold/Make.hs4
-rw-r--r--compiler/GHC/Core/Unify.hs5
-rw-r--r--compiler/GHC/Core/Utils.hs22
-rw-r--r--compiler/GHC/CoreToIface.hs10
-rw-r--r--compiler/GHC/CoreToStg.hs31
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs15
-rw-r--r--compiler/GHC/Data/List/SetOps.hs2
-rw-r--r--compiler/GHC/Data/StringBuffer.hs3
-rw-r--r--compiler/GHC/Driver/CmdLine.hs3
-rw-r--r--compiler/GHC/Driver/Env.hs2
-rw-r--r--compiler/GHC/Driver/Main.hs5
-rw-r--r--compiler/GHC/Driver/Make.hs14
-rw-r--r--compiler/GHC/Driver/MakeFile.hs3
-rw-r--r--compiler/GHC/Driver/Pipeline.hs7
-rw-r--r--compiler/GHC/Driver/Ppr.hs19
-rw-r--r--compiler/GHC/Driver/Ppr.hs-boot2
-rw-r--r--compiler/GHC/Driver/Session.hs1
-rw-r--r--compiler/GHC/Hs/Expr.hs3
-rw-r--r--compiler/GHC/HsToCore.hs10
-rw-r--r--compiler/GHC/HsToCore/Binds.hs8
-rw-r--r--compiler/GHC/HsToCore/Expr.hs25
-rw-r--r--compiler/GHC/HsToCore/Foreign/Call.hs8
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs8
-rw-r--r--compiler/GHC/HsToCore/GuardedRHSs.hs5
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs8
-rw-r--r--compiler/GHC/HsToCore/Match.hs15
-rw-r--r--compiler/GHC/HsToCore/Match/Constructor.hs11
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs3
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs4
-rw-r--r--compiler/GHC/HsToCore/Pmc/Ppr.hs6
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver.hs7
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver/Types.hs5
-rw-r--r--compiler/GHC/HsToCore/Quote.hs7
-rw-r--r--compiler/GHC/HsToCore/Usage.hs2
-rw-r--r--compiler/GHC/HsToCore/Utils.hs11
-rw-r--r--compiler/GHC/Iface/Binary.hs7
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs3
-rw-r--r--compiler/GHC/Iface/Load.hs21
-rw-r--r--compiler/GHC/Iface/Make.hs8
-rw-r--r--compiler/GHC/Iface/Recomp.hs9
-rw-r--r--compiler/GHC/Iface/Recomp/Binary.hs3
-rw-r--r--compiler/GHC/Iface/Rename.hs5
-rw-r--r--compiler/GHC/Iface/Syntax.hs4
-rw-r--r--compiler/GHC/IfaceToCore.hs6
-rw-r--r--compiler/GHC/Linker/Loader.hs6
-rw-r--r--compiler/GHC/Parser/PostProcess.hs5
-rw-r--r--compiler/GHC/Rename/Env.hs2
-rw-r--r--compiler/GHC/Rename/Expr.hs7
-rw-r--r--compiler/GHC/Rename/HsType.hs10
-rw-r--r--compiler/GHC/Rename/Module.hs9
-rw-r--r--compiler/GHC/Rename/Names.hs18
-rw-r--r--compiler/GHC/Rename/Pat.hs4
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs9
-rw-r--r--compiler/GHC/Stg/Lift.hs7
-rw-r--r--compiler/GHC/Stg/Lift/Monad.hs4
-rw-r--r--compiler/GHC/Stg/Subst.hs2
-rw-r--r--compiler/GHC/Stg/Syntax.hs5
-rw-r--r--compiler/GHC/Stg/Unarise.hs25
-rw-r--r--compiler/GHC/StgToByteCode.hs15
-rw-r--r--compiler/GHC/StgToCmm.hs6
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs2
-rw-r--r--compiler/GHC/StgToCmm/Closure.hs19
-rw-r--r--compiler/GHC/StgToCmm/DataCon.hs9
-rw-r--r--compiler/GHC/StgToCmm/Env.hs4
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs8
-rw-r--r--compiler/GHC/StgToCmm/Layout.hs4
-rw-r--r--compiler/GHC/StgToCmm/Monad.hs2
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs3
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs11
-rw-r--r--compiler/GHC/Tc/Deriv.hs9
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs9
-rw-r--r--compiler/GHC/Tc/Deriv/Generics.hs7
-rw-r--r--compiler/GHC/Tc/Deriv/Infer.hs19
-rw-r--r--compiler/GHC/Tc/Errors.hs15
-rw-r--r--compiler/GHC/Tc/Gen/App.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs19
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs3
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs9
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs11
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs13
-rw-r--r--compiler/GHC/Tc/Instance/Family.hs5
-rw-r--r--compiler/GHC/Tc/Instance/FunDeps.hs6
-rw-r--r--compiler/GHC/Tc/Module.hs15
-rw-r--r--compiler/GHC/Tc/Solver.hs7
-rw-r--r--compiler/GHC/Tc/Solver/Canonical.hs17
-rw-r--r--compiler/GHC/Tc/Solver/Interact.hs9
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs6
-rw-r--r--compiler/GHC/Tc/Solver/Rewrite.hs9
-rw-r--r--compiler/GHC/Tc/TyCl.hs26
-rw-r--r--compiler/GHC/Tc/TyCl/Build.hs18
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs3
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs3
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs13
-rw-r--r--compiler/GHC/Tc/Types.hs2
-rw-r--r--compiler/GHC/Tc/Types/Evidence.hs8
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs6
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs5
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs1
-rw-r--r--compiler/GHC/Tc/Utils/TcMType.hs36
-rw-r--r--compiler/GHC/Tc/Utils/TcType.hs25
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs21
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs22
-rw-r--r--compiler/GHC/Tc/Validity.hs2
-rw-r--r--compiler/GHC/Types/Avail.hs1
-rw-r--r--compiler/GHC/Types/Id.hs19
-rw-r--r--compiler/GHC/Types/Id/Info.hs7
-rw-r--r--compiler/GHC/Types/Id/Make.hs16
-rw-r--r--compiler/GHC/Types/Literal.hs24
-rw-r--r--compiler/GHC/Types/Name/Cache.hs3
-rw-r--r--compiler/GHC/Types/Name/Ppr.hs2
-rw-r--r--compiler/GHC/Types/Name/Reader.hs2
-rw-r--r--compiler/GHC/Types/Name/Shape.hs7
-rw-r--r--compiler/GHC/Types/RepType.hs5
-rw-r--r--compiler/GHC/Types/Unique.hs5
-rw-r--r--compiler/GHC/Types/Unique/FM.hs5
-rw-r--r--compiler/GHC/Types/Unique/Supply.hs5
-rw-r--r--compiler/GHC/Types/Var.hs15
-rw-r--r--compiler/GHC/Unit/Finder.hs3
-rw-r--r--compiler/GHC/Utils/Constants.hs51
-rw-r--r--compiler/GHC/Utils/Error.hs4
-rw-r--r--compiler/GHC/Utils/Misc.hs51
-rw-r--r--compiler/GHC/Utils/Panic.hs25
-rw-r--r--compiler/GHC/Utils/Panic/Plain.hs30
174 files changed, 1054 insertions, 903 deletions
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 321b20e877..48fb80df68 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -196,6 +196,7 @@ import GHC.Data.BooleanFormula ( mkAnd )
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import qualified Data.ByteString.Char8 as BS
@@ -719,7 +720,7 @@ mkDataConWorkerName data_con wrk_key =
mkWiredInName modu wrk_occ wrk_key
(AnId (dataConWorkId data_con)) UserSyntax
where
- modu = ASSERT( isExternalName dc_name )
+ modu = assert (isExternalName dc_name) $
nameModule dc_name
dc_name = dataConName data_con
dc_occ = nameOccName dc_name
@@ -993,7 +994,7 @@ cTupleTyConKeys = mkUniqSet $ map getUnique cTupleTyConNames
isCTupleTyConName :: Name -> Bool
isCTupleTyConName n
- = ASSERT2( isExternalName n, ppr n )
+ = assertPpr (isExternalName n) (ppr n) $
getUnique n `elementOfUniqSet` cTupleTyConKeys
-- | If the given name is that of a constraint tuple, return its arity.
@@ -2062,11 +2063,11 @@ extractPromotedList tys = go tys
where
go list_ty
| Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty
- = ASSERT( tc `hasKey` consDataConKey )
+ = assert (tc `hasKey` consDataConKey) $
t : go ts
| Just (tc, [_k]) <- splitTyConApp_maybe list_ty
- = ASSERT( tc `hasKey` nilDataConKey )
+ = assert (tc `hasKey` nilDataConKey)
[]
| otherwise
diff --git a/compiler/GHC/Builtin/Uniques.hs b/compiler/GHC/Builtin/Uniques.hs
index 317670bb37..772213cee8 100644
--- a/compiler/GHC/Builtin/Uniques.hs
+++ b/compiler/GHC/Builtin/Uniques.hs
@@ -65,8 +65,8 @@ import GHC.Types.Unique
import GHC.Data.FastString
import GHC.Utils.Outputable
-import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.Maybe
@@ -113,8 +113,8 @@ TypeRep for sum DataCon of arity k and alternative n (zero-based):
mkSumTyConUnique :: Arity -> Unique
mkSumTyConUnique arity =
- ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the
- -- alternative
+ assert (arity < 0x3f) $ -- 0x3f since we only have 6 bits to encode the
+ -- alternative
mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)
mkSumDataConUnique :: ConTagZ -> Arity -> Unique
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
index 948752d55d..7494fc416e 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -76,6 +76,7 @@ import GHC.Types.Unique ( isValidKnownKeyUnique )
import GHC.Utils.Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
import GHC.Hs.Doc
import GHC.Unit.Module.ModIface (IfaceExport)
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index 1f11938517..542a6b3635 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -34,7 +34,7 @@ import GHC.Types.Unique.DSet
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc
+import GHC.Utils.Panic.Plain
import GHC.Core.TyCon
import GHC.Data.FastString
@@ -202,7 +202,7 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
(final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm
-- precomputed size should be equal to final size
- ASSERT(n_insns == sizeSS final_insns) return ()
+ massert (n_insns == sizeSS final_insns)
let asm_insns = ssElts final_insns
insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs
index 50bef7972e..9170da7710 100644
--- a/compiler/GHC/ByteCode/Linker.hs
+++ b/compiler/GHC/ByteCode/Linker.hs
@@ -39,8 +39,8 @@ import GHC.Data.FastString
import GHC.Data.SizedSeq
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable
-import GHC.Utils.Misc
import GHC.Types.Name
import GHC.Types.Name.Env
@@ -150,7 +150,7 @@ resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of
-> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
| otherwise
- -> ASSERT2(isExternalName nm, ppr nm)
+ -> assertPpr (isExternalName nm) (ppr nm) $
do
let sym_to_find = nameToCLabel nm "closure"
m <- lookupSymbol interp sym_to_find
@@ -187,7 +187,7 @@ nameToCLabel :: Name -> String -> FastString
nameToCLabel n suffix = mkFastString label
where
encodeZ = zString . zEncodeFS
- (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
+ (Module pkgKey modName) = assert (isExternalName n) $ nameModule n
packagePart = encodeZ (unitFS pkgKey)
modulePart = encodeZ (moduleNameFS modName)
occPart = encodeZ (occNameFS (nameOccName n))
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index a0c16857cb..97c87cae67 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -146,6 +146,7 @@ import GHC.Builtin.PrimOps
import GHC.Types.CostCentre
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Driver.Session
import GHC.Platform
@@ -666,22 +667,22 @@ mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel
mkSelectorInfoLabel platform upd offset =
- ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
+ assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $
RtsLabel (RtsSelectorInfoTable upd offset)
mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel
mkSelectorEntryLabel platform upd offset =
- ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
+ assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $
RtsLabel (RtsSelectorEntry upd offset)
mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel
mkApInfoTableLabel platform upd arity =
- ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
+ assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $
RtsLabel (RtsApInfoTable upd arity)
mkApEntryLabel :: Platform -> Bool -> Int -> CLabel
mkApEntryLabel platform upd arity =
- ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
+ assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $
RtsLabel (RtsApEntry upd arity)
diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs
index edff1d8f11..ef8ae7f26b 100644
--- a/compiler/GHC/Cmm/Graph.hs
+++ b/compiler/GHC/Cmm/Graph.hs
@@ -38,8 +38,8 @@ import GHC.Types.ForeignCall
import GHC.Data.OrdList
import GHC.Runtime.Heap.Layout (ByteOff)
import GHC.Types.Unique.Supply
-import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
-----------------------------------------------------------------------------
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
index 996821ab3b..66669c4389 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -51,6 +51,7 @@ import GHC.Data.Maybe
import GHC.Driver.Session
import GHC.Utils.Error (withTimingSilent)
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.Unique.Supply
import GHC.Utils.Logger
import GHC.Utils.Monad
@@ -257,7 +258,7 @@ mkInfoTableContents dflags
slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)
srt_lit = case srt_label of
[] -> mkIntCLit platform 0
- (lit:_rest) -> ASSERT( null _rest ) lit
+ (lit:_rest) -> assert (null _rest) lit
mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs
index 479dee7430..0f846bad1b 100644
--- a/compiler/GHC/Cmm/Ppr.hs
+++ b/compiler/GHC/Cmm/Ppr.hs
@@ -56,7 +56,7 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Cmm.Ppr.Decl
import GHC.Cmm.Ppr.Expr
-import GHC.Utils.Misc
+import GHC.Utils.Constants (debugIsOn)
import GHC.Types.Basic
import GHC.Cmm.Dataflow.Block
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index c4a7ebacd4..5ff75e6520 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -136,6 +136,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Exception (evaluate)
+import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import GHC.Types.Unique.Set
@@ -725,8 +726,7 @@ maybeDumpCfg logger dflags (Just cfg) msg proc_name
checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
-> [NatCmmDecl statics instr]
checkLayout procsUnsequenced procsSequenced =
- ASSERT2(setNull diff,
- ppr "Block sequencing dropped blocks:" <> ppr diff)
+ assertPpr (setNull diff) (ppr "Block sequencing dropped blocks:" <> ppr diff)
procsSequenced
where
blocks1 = foldl' (setUnion) setEmpty $
diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs
index d7314eaa5b..5048d59e30 100644
--- a/compiler/GHC/CmmToAsm/BlockLayout.hs
+++ b/compiler/GHC/CmmToAsm/BlockLayout.hs
@@ -31,11 +31,12 @@ import GHC.Cmm.Dataflow.Label
import GHC.Platform
import GHC.Types.Unique.FM
-import GHC.Utils.Misc
import GHC.Data.Graph.Directed
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Misc
import GHC.Data.Maybe
-- DEBUGGING ONLY
@@ -312,7 +313,7 @@ instance Eq BlockChain where
-- in the chain.
instance Ord (BlockChain) where
(BlockChain lbls1) `compare` (BlockChain lbls2)
- = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)
+ = assert (toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) $
strictlyOrdOL lbls1 lbls2
instance Outputable (BlockChain) where
@@ -719,7 +720,7 @@ sequenceChain info weights blocks@((BasicBlock entry _):_) =
directEdges
(neighbourChains, combined)
- = ASSERT(noDups $ mapElems builtChains)
+ = assert (noDups $ mapElems builtChains) $
{-# SCC "groupNeighbourChains" #-}
-- pprTraceIt "NeighbourChains" $
combineNeighbourhood rankedEdges (mapElems builtChains)
@@ -759,7 +760,7 @@ sequenceChain info weights blocks@((BasicBlock entry _):_) =
#endif
blockList
- = ASSERT(noDups [masterChain])
+ = assert (noDups [masterChain])
(concatMap fromOL $ map chainBlocks prepedChains)
--chainPlaced = setFromList $ map blockId blockList :: LabelSet
@@ -773,14 +774,14 @@ sequenceChain info weights blocks@((BasicBlock entry _):_) =
-- We want debug builds to catch this as it's a good indicator for
-- issues with CFG invariants. But we don't want to blow up production
-- builds if something slips through.
- ASSERT(null unplaced)
+ assert (null unplaced) $
--pprTraceIt "placedBlocks" $
-- ++ [] is stil kinda expensive
if null unplaced then blockList else blockList ++ unplaced
getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap
in
--Assert we placed all blocks given as input
- ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
+ assert (all (\bid -> mapMember bid blockMap) placedBlocks) $
dropJumps info $ map getBlock placedBlocks
{-# SCC dropJumps #-}
diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs
index 870897cceb..17631c989d 100644
--- a/compiler/GHC/CmmToAsm/CFG.hs
+++ b/compiler/GHC/CmmToAsm/CFG.hs
@@ -74,6 +74,7 @@ import Data.Bifunctor
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
-- DEBUGGING ONLY
--import GHC.Cmm.DebugBlock
--import GHC.Data.OrdList
@@ -212,7 +213,7 @@ getCfgNodes m =
hasNode :: CFG -> BlockId -> Bool
hasNode m node =
-- Check the invariant that each node must exist in the first map or not at all.
- ASSERT( found || not (any (mapMember node) m))
+ assert (found || not (any (mapMember node) m))
found
where
found = mapMember node m
@@ -645,8 +646,8 @@ getCfg platform weights graph =
(CmmCall { cml_cont = Nothing }) -> []
other ->
panic "Foo" $
- ASSERT2(False, ppr "Unknown successor cause:" <>
- (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other)))
+ assertPpr False (ppr "Unknown successor cause:" <>
+ (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) $
map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other
where
bid = G.entryLabel block
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index 953cb85ba9..7e2daf76f8 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -64,13 +64,13 @@ import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
import GHC.Data.OrdList
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad ( mapAndUnzipM, when )
import Data.Word
import GHC.Types.Basic
import GHC.Data.FastString
-import GHC.Utils.Misc
-- -----------------------------------------------------------------------------
-- Top-level of the instruction selector
@@ -468,7 +468,7 @@ getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])
getRegister' _ platform (CmmLoad mem pk)
| not (isWord64 pk) = do
Amode addr addr_code <- getAmode D mem
- let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
+ let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $
addr_code `snocOL` LD format dst addr
return (Any format code)
| not (target32Bit platform) = do
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index 97dcda5a5b..210bea0af2 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -79,7 +79,9 @@ import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
import GHC.Types.ForeignCall ( CCallConv(..) )
import GHC.Data.OrdList
import GHC.Utils.Outputable
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Driver.Session
import GHC.Utils.Misc
@@ -1268,7 +1270,7 @@ getAmode e = do
-- what mangleIndexTree has just done.
CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]
| is32BitLit is32Bit lit
- -- ASSERT(rep == II32)???
+ -- assert (rep == II32)???
-> do
(x_reg, x_code) <- getSomeReg x
let off = ImmInt (-(fromInteger i))
@@ -1276,7 +1278,7 @@ getAmode e = do
CmmMachOp (MO_Add _rep) [x, CmmLit lit]
| is32BitLit is32Bit lit
- -- ASSERT(rep == II32)???
+ -- assert (rep == II32)???
-> do
(x_reg, x_code) <- getSomeReg x
let off = litToImm lit
@@ -1474,7 +1476,7 @@ addAlignmentCheck align reg =
where
check :: Format -> Reg -> InstrBlock
check fmt reg =
- ASSERT(not $ isFloatFormat fmt)
+ assert (not $ isFloatFormat fmt) $
toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)
, JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel
]
@@ -1941,10 +1943,10 @@ genCondBranch' _ bid id false bool = do
-- Use ASSERT so we don't break releases if
-- LTT/LE creep in somehow.
LTT ->
- ASSERT2(False, ppr "Should have been turned into >")
+ assertPpr False (ppr "Should have been turned into >")
and_ordered
LE ->
- ASSERT2(False, ppr "Should have been turned into >=")
+ assertPpr False (ppr "Should have been turned into >=")
and_ordered
_ -> and_ordered
@@ -2885,7 +2887,7 @@ evalArgs bid actuals
lreg <- newLocalReg $ cmmExprType platform actual
(instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual
-- The above assignment shouldn't change the current block
- MASSERT(isNothing bid1)
+ massert (isNothing bid1)
return (instrs, CmmReg $ CmmLocal lreg)
newLocalReg :: CmmType -> NatM LocalReg
@@ -2961,7 +2963,7 @@ genCCall32' target dest_regs args = do
-- Arguments can be smaller than 32-bit, but we still use @PUSH
-- II32@ - the usual calling conventions expect integers to be
-- 4-byte aligned.
- ASSERT((typeWidth arg_ty) <= W32) return ()
+ massert ((typeWidth arg_ty) <= W32)
(operand, code) <- getOperand arg
delta <- getDeltaNat
setDeltaNat (delta-size)
@@ -2988,7 +2990,7 @@ genCCall32' target dest_regs args = do
push_codes <- mapM push_arg (reverse prom_args)
delta <- getDeltaNat
- MASSERT(delta == delta0 - tot_arg_size)
+ massert (delta == delta0 - tot_arg_size)
-- deal with static vs dynamic call targets
(callinsns,cconv) <-
@@ -2999,8 +3001,8 @@ genCCall32' target dest_regs args = do
where fn_imm = ImmCLbl lbl
ForeignTarget expr conv
-> do { (dyn_r, dyn_c) <- getSomeReg expr
- ; ASSERT( isWord32 (cmmExprType platform expr) )
- return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
+ ; massert (isWord32 (cmmExprType platform expr))
+ ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
PrimTarget _
-> panic $ "genCCall: Can't handle PrimTarget call type here, error "
++ "probably because too many return values."
@@ -3186,7 +3188,7 @@ genCCall64' target dest_regs args = do
-- Arguments can be smaller than 64-bit, but we still use @PUSH
-- II64@ - the usual calling conventions expect integers to be
-- 8-byte aligned.
- ASSERT(width <= W64) return ()
+ massert (width <= W64)
(arg_op, arg_code) <- getOperand arg
delta <- getDeltaNat
setDeltaNat (delta-arg_size)
@@ -3620,9 +3622,9 @@ condFltReg is32Bit cond x y = condFltReg_sse2
GU -> plain_test dst
GEU -> plain_test dst
-- Use ASSERT so we don't break releases if these creep in.
- LTT -> ASSERT2(False, ppr "Should have been turned into >")
+ LTT -> assertPpr False (ppr "Should have been turned into >") $
and_ordered dst
- LE -> ASSERT2(False, ppr "Should have been turned into >=")
+ LE -> assertPpr False (ppr "Should have been turned into >=") $
and_ordered dst
_ -> and_ordered dst)
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 3ad52b6f79..3f81c79e3f 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -13,12 +13,14 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
+import GHC.Platform
+import GHC.Platform.Regs ( activeStgRegs )
+
import GHC.Llvm
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.Regs
import GHC.Cmm.BlockId
-import GHC.Platform.Regs ( activeStgRegs )
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Ppr as PprCmm
@@ -29,14 +31,15 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Collections
import GHC.Data.FastString
-import GHC.Types.ForeignCall
-import GHC.Utils.Outputable
-import GHC.Utils.Panic (assertPanic)
-import qualified GHC.Utils.Panic as Panic
-import GHC.Platform
import GHC.Data.OrdList
+
+import GHC.Types.ForeignCall
import GHC.Types.Unique.Supply
import GHC.Types.Unique
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic.Plain (massert)
+import qualified GHC.Utils.Panic as Panic
import GHC.Utils.Misc
import Control.Monad.Trans.Class
@@ -559,7 +562,7 @@ genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
, MO_AddWordC w
, MO_SubWordC w
]
- MASSERT(valid)
+ massert valid
let width = widthToLlvmInt w
-- This will do most of the work of generating the call to the intrinsic and
-- extracting the values from the struct.
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 7f30fc5f00..498b58031c 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -115,6 +115,7 @@ import GHC.Utils.Binary
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Driver.Ppr
@@ -300,7 +301,7 @@ data AltCon
-- The instance adheres to the order described in [Core case invariants]
instance Ord AltCon where
compare (DataAlt con1) (DataAlt con2) =
- ASSERT( dataConTyCon con1 == dataConTyCon con2 )
+ assert (dataConTyCon con1 == dataConTyCon con2) $
compare (dataConTag con1) (dataConTag con2)
compare (DataAlt _) _ = GT
compare _ (DataAlt _) = LT
@@ -1803,7 +1804,7 @@ mkCoBind cv co = NonRec cv (Coercion co)
varToCoreExpr :: CoreBndr -> Expr b
varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
| isCoVar v = Coercion (mkCoVarCo v)
- | otherwise = ASSERT( isId v ) Var v
+ | otherwise = assert (isId v) $ Var v
varsToCoreExprs :: [CoreBndr] -> [Expr b]
varsToCoreExprs vs = map varToCoreExpr vs
diff --git a/compiler/GHC/Core/Class.hs b/compiler/GHC/Core/Class.hs
index dfb651c279..b6648ceaac 100644
--- a/compiler/GHC/Core/Class.hs
+++ b/compiler/GHC/Core/Class.hs
@@ -34,6 +34,7 @@ import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)
@@ -254,20 +255,20 @@ classAllSelIds :: Class -> [Id]
-- Both superclass-dictionary and method selectors
classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})
= sc_sels ++ classMethods c
-classAllSelIds c = ASSERT( null (classMethods c) ) []
+classAllSelIds c = assert (null (classMethods c) ) []
classSCSelIds :: Class -> [Id]
-- Both superclass-dictionary and method selectors
classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})
= sc_sels
-classSCSelIds c = ASSERT( null (classMethods c) ) []
+classSCSelIds c = assert (null (classMethods c) ) []
classSCSelId :: Class -> Int -> Id
-- Get the n'th superclass selector Id
-- where n is 0-indexed, and counts
-- *all* superclasses including equalities
classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n
- = ASSERT( n >= 0 && lengthExceeds sc_sels n )
+ = assert (n >= 0 && lengthExceeds sc_sels n )
sc_sels !! n
classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index b364091958..e0957c0278 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -162,6 +162,7 @@ import GHC.Types.Unique.Set
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad (foldM, zipWithM)
import Data.Function ( on )
@@ -404,7 +405,7 @@ decomposeFunCo :: HasDebugCallStack
-- Expects co :: (s1 -> t1) ~ (s2 -> t2)
-- Returns (co1 :: s1~s2, co2 :: t1~t2)
-- See Note [Function coercions] for the "3" and "4"
-decomposeFunCo r co = ASSERT2( all_ok, ppr co )
+decomposeFunCo r co = assertPpr all_ok (ppr co)
(mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co)
where
Pair s1t1 s2t2 = coercionKind co
@@ -584,7 +585,7 @@ coVarKindsTypesRole cv
coVarKind :: CoVar -> Type
coVarKind cv
- = ASSERT( isCoVar cv )
+ = assert (isCoVar cv )
varType cv
coVarRole :: CoVar -> Role
@@ -860,8 +861,8 @@ once ~# is made to be homogeneous.
-- See Note [Unused coercion variable in ForAllCo]
mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion
mkForAllCo v kind_co co
- | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True
- , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True
+ | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True
+ , assert (isTyVar v || almostDevoidCoVarOfCo v co) True
, Just (ty, r) <- isReflCo_maybe co
, isGReflCo kind_co
= mkReflCo r (mkTyCoInvForAllTy v ty)
@@ -873,9 +874,9 @@ mkForAllCo v kind_co co
-- The kind of the tycovar should be the left-hand kind of the kind coercion.
mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion
mkForAllCo_NoRefl v kind_co co
- | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True
- , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True
- , ASSERT( not (isReflCo co)) True
+ | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True
+ , assert (isTyVar v || almostDevoidCoVarOfCo v co) True
+ , assert (not (isReflCo co)) True
, isCoVar v
, not (v `elemVarSet` tyCoVarsOfCo co)
= FunCo (coercionRole co) (multToCo Many) kind_co co
@@ -907,7 +908,7 @@ mkHomoForAllCos vs co
-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.
mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion
mkHomoForAllCos_NoRefl vs orig_co
- = ASSERT( not (isReflCo orig_co))
+ = assert (not (isReflCo orig_co))
foldr go orig_co vs
where
go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co
@@ -942,7 +943,7 @@ mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]
mkAxInstCo role ax index tys cos
| arity == n_tys = downgradeRole role ax_role $
mkAxiomInstCo ax_br index (rtys `chkAppend` cos)
- | otherwise = ASSERT( arity < n_tys )
+ | otherwise = assert (arity < n_tys) $
downgradeRole role ax_role $
mkAppCos (mkAxiomInstCo ax_br index
(ax_args `chkAppend` cos))
@@ -962,7 +963,7 @@ mkAxInstCo role ax index tys cos
-- worker function
mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
mkAxiomInstCo ax index args
- = ASSERT( args `lengthIs` coAxiomArity ax index )
+ = assert (args `lengthIs` coAxiomArity ax index) $
AxiomInstCo ax index args
-- to be used only with unbranched axioms
@@ -977,7 +978,7 @@ mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type
-- A companion to mkAxInstCo:
-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))
mkAxInstRHS ax index tys cos
- = ASSERT( tvs `equalLength` tys1 )
+ = assert (tvs `equalLength` tys1) $
mkAppTys rhs' tys2
where
branch = coAxiomNthBranch ax index
@@ -995,7 +996,7 @@ mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0
-- at the types given.
mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type
mkAxInstLHS ax index tys cos
- = ASSERT( tvs `equalLength` tys1 )
+ = assert (tvs `equalLength` tys1) $
mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)
where
branch = coAxiomNthBranch ax index
@@ -1052,7 +1053,7 @@ mkNthCo :: HasDebugCallStack
-> Coercion
-> Coercion
mkNthCo r n co
- = ASSERT2( good_call, bad_call_msg )
+ = assertPpr good_call bad_call_msg $
go r n co
where
Pair ty1 ty2 = coercionKind co
@@ -1061,14 +1062,14 @@ mkNthCo r n co
| Just (ty, _) <- isReflCo_maybe co
, Just (tv, _) <- splitForAllTyCoVar_maybe ty
= -- works for both tyvar and covar
- ASSERT( r == Nominal )
+ assert (r == Nominal) $
mkNomReflCo (varType tv)
go r n co
| Just (ty, r0) <- isReflCo_maybe co
, let tc = tyConAppTyCon ty
- = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )
- ASSERT( nthRole r0 tc n == r )
+ = assertPpr (ok_tc_app ty n) (ppr n $$ ppr ty) $
+ assert (nthRole r0 tc n == r) $
mkReflCo r (tyConAppArgN n ty)
where ok_tc_app :: Type -> Int -> Bool
ok_tc_app ty n
@@ -1080,7 +1081,7 @@ mkNthCo r n co
= False
go r 0 (ForAllCo _ kind_co _)
- = ASSERT( r == Nominal )
+ = assert (r == Nominal)
kind_co
-- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)
-- then (nth 0 co :: k1 ~N k2)
@@ -1090,12 +1091,12 @@ mkNthCo r n co
go _ n (FunCo _ w arg res)
= mkNthCoFunCo n w arg res
- go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n
- , (vcat [ ppr tc
- , ppr arg_cos
- , ppr r0
- , ppr n
- , ppr r ]) )
+ go r n (TyConAppCo r0 tc arg_cos) = assertPpr (r == nthRole r0 tc n)
+ (vcat [ ppr tc
+ , ppr arg_cos
+ , ppr r0
+ , ppr n
+ , ppr r ]) $
arg_cos `getNth` n
go r n co =
@@ -1260,7 +1261,7 @@ mkSubCo (FunCo Nominal w arg res)
= FunCo Representational w
(downgradeRole Representational Nominal arg)
(downgradeRole Representational Nominal res)
-mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )
+mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $
SubCo co
-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]
@@ -1414,13 +1415,13 @@ promoteCoercion co = case co of
_ | ki1 `eqType` ki2
-> mkNomReflCo (typeKind ty1)
-- no later branch should return refl
- -- The ASSERT( False )s throughout
+ -- The assert (False )s throughout
-- are these cases explicitly, but they should never fire.
- Refl _ -> ASSERT( False )
+ Refl _ -> assert False $
mkNomReflCo ki1
- GRefl _ _ MRefl -> ASSERT( False )
+ GRefl _ _ MRefl -> assert False $
mkNomReflCo ki1
GRefl _ _ (MCo co) -> co
@@ -1443,12 +1444,12 @@ promoteCoercion co = case co of
-> promoteCoercion g
ForAllCo _ _ _
- -> ASSERT( False )
+ -> assert False $
mkNomReflCo liftedTypeKind
-- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep
FunCo _ _ _ _
- -> ASSERT( False )
+ -> assert False $
mkNomReflCo liftedTypeKind
CoVarCo {} -> mkKindCo co
@@ -1474,7 +1475,7 @@ promoteCoercion co = case co of
| Just _ <- splitForAllCo_maybe co
, n == 0
- -> ASSERT( False ) mkNomReflCo liftedTypeKind
+ -> assert False $ mkNomReflCo liftedTypeKind
| otherwise
-> mkKindCo co
@@ -1490,15 +1491,15 @@ promoteCoercion co = case co of
InstCo g _
| isForAllTy_ty ty1
- -> ASSERT( isForAllTy_ty ty2 )
+ -> assert (isForAllTy_ty ty2) $
promoteCoercion g
| otherwise
- -> ASSERT( False)
+ -> assert False $
mkNomReflCo liftedTypeKind
-- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep
KindCo _
- -> ASSERT( False )
+ -> assert False $
mkNomReflCo liftedTypeKind
SubCo g
@@ -1565,7 +1566,7 @@ castCoercionKind1 :: Coercion -> Role -> Type -> Type
-> CoercionN -> Coercion
castCoercionKind1 g r t1 t2 h
= case g of
- Refl {} -> ASSERT( r == Nominal ) -- Refl is always Nominal
+ Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal
mkNomReflCo (mkCastTy t2 h)
GRefl _ _ mco -> case mco of
MRefl -> mkReflCo r (mkCastTy t2 h)
@@ -1600,7 +1601,7 @@ mkFamilyTyConAppCo :: TyCon -> [CoercionN] -> CoercionN
mkFamilyTyConAppCo tc cos
| Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
, let tvs = tyConTyVars tc
- fam_cos = ASSERT2( tvs `equalLength` cos, ppr tc <+> ppr cos )
+ fam_cos = assertPpr (tvs `equalLength` cos) (ppr tc <+> ppr cos) $
map (liftCoSubstWith Nominal tvs cos) fam_tys
= mkTyConAppCo Nominal fam_tc fam_cos
| otherwise
@@ -1615,7 +1616,7 @@ mkPiCos r vs co = foldr (mkPiCo r) co vs
-- are quantified over the same variable.
mkPiCo :: Role -> Var -> Coercion -> Coercion
mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co
- | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) )
+ | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $
-- We didn't call mkForAllCo here because if v does not appear
-- in co, the argement coercion will be nominal. But here we
-- want it to be r. It is only called in 'mkPiCos', which is
@@ -1979,7 +1980,7 @@ extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)
-- lift_s1 :: s1 ~r s1'
-- lift_s2 :: s2 ~r s2'
-- kco :: (s1 ~r s2) ~N (s1' ~r s2')
- ASSERT( isCoVar v )
+ assert (isCoVar v) $
let (_, _, s1, s2, r) = coVarKindsTypesRole v
lift_s1 = ty_co_subst lc r s1
lift_s2 = ty_co_subst lc r s2
@@ -2040,7 +2041,7 @@ ty_co_subst !lc role ty
-- fall into it.
then mkForAllCo v' h body_co
else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)
- go r ty@(LitTy {}) = ASSERT( r == Nominal )
+ go r ty@(LitTy {}) = assert (r == Nominal) $
mkNomReflCo ty
go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co)
(substRightCo lc co)
@@ -2135,7 +2136,7 @@ liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
-> LiftingContext -> TyVar
-> (LiftingContext, TyVar, CoercionN, a)
liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var
- = ASSERT( isTyVar old_var )
+ = assert (isTyVar old_var) $
( LC (subst `extendTCvInScope` new_var) new_cenv
, new_var, eta, stuff )
where
@@ -2153,7 +2154,7 @@ liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
-> LiftingContext -> CoVar
-> (LiftingContext, CoVar, CoercionN, a)
liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var
- = ASSERT( isCoVar old_var )
+ = assert (isCoVar old_var) $
( LC (subst `extendTCvInScope` new_var) new_cenv
, new_var, kind_co, stuff )
where
@@ -2348,7 +2349,7 @@ coercionLKind co
, cab_lhs = lhs } <- coAxiomNthBranch ax ind
, let (tys1, cotys1) = splitAtList tvs tys
cos1 = map stripCoercionTy cotys1
- = ASSERT( tys `equalLength` (tvs ++ cvs) )
+ = assert (tys `equalLength` (tvs ++ cvs)) $
-- Invariant of AxiomInstCo: cos should
-- exactly saturate the axiom branch
substTyWith tvs tys1 $
@@ -2364,7 +2365,7 @@ coercionLKind co
go_nth :: Int -> Type -> Type
go_nth d ty
| Just args <- tyConAppArgs_maybe ty
- = ASSERT( args `lengthExceeds` d )
+ = assert (args `lengthExceeds` d) $
args `getNth` d
| d == 0
@@ -2410,7 +2411,7 @@ coercionRKind co
, cab_rhs = rhs } <- coAxiomNthBranch ax ind
, let (tys2, cotys2) = splitAtList tvs tys
cos2 = map stripCoercionTy cotys2
- = ASSERT( tys `equalLength` (tvs ++ cvs) )
+ = assert (tys `equalLength` (tvs ++ cvs)) $
-- Invariant of AxiomInstCo: cos should
-- exactly saturate the axiom branch
substTyWith tvs tys2 $
@@ -2589,9 +2590,9 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
in mkCoherenceRightCo r ty2 co co'
go ty1@(TyVarTy tv1) _tyvarty
- = ASSERT( case _tyvarty of
+ = assert (case _tyvarty of
{ TyVarTy tv2 -> tv1 == tv2
- ; _ -> False } )
+ ; _ -> False }) $
mkNomReflCo ty1
go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 })
@@ -2599,7 +2600,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
= mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2)
go (TyConApp tc1 args1) (TyConApp tc2 args2)
- = ASSERT( tc1 == tc2 )
+ = assert (tc1 == tc2) $
mkTyConAppCo Nominal tc1 (zipWith go args1 args2)
go (AppTy ty1a ty1b) ty2
@@ -2612,7 +2613,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)
| isTyVar tv1
- = ASSERT( isTyVar tv2 )
+ = assert (isTyVar tv2) $
mkForAllCo tv1 kind_co (go ty1 ty2')
where kind_co = go (tyVarKind tv1) (tyVarKind tv2)
in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
@@ -2621,7 +2622,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
ty2
go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)
- = ASSERT( isCoVar cv1 && isCoVar cv2 )
+ = assert (isCoVar cv1 && isCoVar cv2) $
mkForAllCo cv1 kind_co (go ty1 ty2')
where s1 = varType cv1
s2 = varType cv2
@@ -2646,9 +2647,9 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
ty2
go ty1@(LitTy lit1) _lit2
- = ASSERT( case _lit2 of
+ = assert (case _lit2 of
{ LitTy lit2 -> lit1 == lit2
- ; _ -> False } )
+ ; _ -> False }) $
mkNomReflCo ty1
go (CoercionTy co1) (CoercionTy co2)
@@ -3019,8 +3020,8 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
co1_kind = coercionKind co1
unrewritten_tys = map (coercionRKind . snd) args
(arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys
- casted_args = ASSERT2( equalLength args arg_cos
- , ppr args $$ ppr arg_cos )
+ casted_args = assertPpr (equalLength args arg_cos)
+ (ppr args $$ ppr arg_cos)
[ (casted_xi, casted_co)
| ((xi, co), arg_co, role) <- zip3 args arg_cos roles
, let casted_xi = xi `mkCastTy` arg_co
diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs
index 46b238e678..e48ed2bd42 100644
--- a/compiler/GHC/Core/Coercion/Axiom.hs
+++ b/compiler/GHC/Core/Coercion/Axiom.hs
@@ -47,6 +47,7 @@ import GHC.Types.Var
import GHC.Utils.Misc
import GHC.Utils.Binary
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.Pair
import GHC.Types.Basic
import Data.Typeable ( Typeable )
@@ -143,7 +144,7 @@ newtype Branches (br :: BranchFlag)
type role Branches nominal
manyBranches :: [CoAxBranch] -> Branches Branched
-manyBranches brs = ASSERT( snd bnds >= fst bnds )
+manyBranches brs = assert (snd bnds >= fst bnds )
MkBranches (listArray bnds brs)
where
bnds = (0, length brs - 1)
@@ -155,7 +156,7 @@ toBranched :: Branches br -> Branches Branched
toBranched = MkBranches . unMkBranches
toUnbranched :: Branches br -> Branches Unbranched
-toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) )
+toUnbranched (MkBranches arr) = assert (bounds arr == (0,0) )
MkBranches arr
fromBranches :: Branches br -> [CoAxBranch]
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 62b83bd8c1..81def895e0 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -30,8 +30,10 @@ import GHC.Core.Unify
import Control.Monad ( zipWithM )
import GHC.Utils.Outputable
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
{-
%************************************************************************
@@ -130,18 +132,18 @@ optCoercion' env co
(Pair in_ty1 in_ty2, in_role) = coercionKindRole co
(Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
in
- ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&
- substTyUnchecked env in_ty2 `eqType` out_ty2 &&
- in_role == out_role
- , text "optCoercion changed types!"
- $$ hang (text "in_co:") 2 (ppr co)
- $$ hang (text "in_ty1:") 2 (ppr in_ty1)
- $$ hang (text "in_ty2:") 2 (ppr in_ty2)
- $$ hang (text "out_co:") 2 (ppr out_co)
- $$ hang (text "out_ty1:") 2 (ppr out_ty1)
- $$ hang (text "out_ty2:") 2 (ppr out_ty2)
- $$ hang (text "subst:") 2 (ppr env) )
- out_co
+ assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 &&
+ substTyUnchecked env in_ty2 `eqType` out_ty2 &&
+ in_role == out_role)
+ ( text "optCoercion changed types!"
+ $$ hang (text "in_co:") 2 (ppr co)
+ $$ hang (text "in_ty1:") 2 (ppr in_ty1)
+ $$ hang (text "in_ty2:") 2 (ppr in_ty2)
+ $$ hang (text "out_co:") 2 (ppr out_co)
+ $$ hang (text "out_ty1:") 2 (ppr out_ty1)
+ $$ hang (text "out_ty2:") 2 (ppr out_ty2)
+ $$ hang (text "subst:") 2 (ppr env))
+ out_co
| otherwise = opt_co1 lc False co
where
@@ -197,28 +199,31 @@ opt_co4_wrap env sym rep r co
, text "Rep:" <+> ppr rep
, text "Role:" <+> ppr r
, text "Co:" <+> ppr co ]) $
- ASSERT( r == coercionRole co )
+ assert (r == coercionRole co )
let result = opt_co4 env sym rep r co in
pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $
result
-}
opt_co4 env _ rep r (Refl ty)
- = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$
- text "Found role:" <+> ppr Nominal $$
- text "Type:" <+> ppr ty )
+ = assertPpr (r == Nominal)
+ (text "Expected role:" <+> ppr r $$
+ text "Found role:" <+> ppr Nominal $$
+ text "Type:" <+> ppr ty) $
liftCoSubst (chooseRole rep r) env ty
opt_co4 env _ rep r (GRefl _r ty MRefl)
- = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$
- text "Found role:" <+> ppr _r $$
- text "Type:" <+> ppr ty )
+ = assertPpr (r == _r)
+ (text "Expected role:" <+> ppr r $$
+ text "Found role:" <+> ppr _r $$
+ text "Type:" <+> ppr ty) $
liftCoSubst (chooseRole rep r) env ty
opt_co4 env sym rep r (GRefl _r ty (MCo co))
- = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$
- text "Found role:" <+> ppr _r $$
- text "Type:" <+> ppr ty )
+ = assertPpr (r == _r)
+ (text "Expected role:" <+> ppr r $$
+ text "Found role:" <+> ppr _r $$
+ text "Type:" <+> ppr ty) $
if isGReflCo co || isGReflCo co'
then liftCoSubst r' env ty
else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)
@@ -234,7 +239,7 @@ opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co
-- exchange them.
opt_co4 env sym rep r g@(TyConAppCo _r tc cos)
- = ASSERT( r == _r )
+ = assert (r == _r) $
case (rep, r) of
(True, Nominal) ->
mkTyConAppCo Representational tc
@@ -263,7 +268,7 @@ opt_co4 env sym rep r (ForAllCo tv k_co co)
-- Use the "mk" functions to check for nested Refls
opt_co4 env sym rep r (FunCo _r cow co1 co2)
- = ASSERT( r == _r )
+ = assert (r == _r) $
if rep
then mkFunCo Representational cow' co1' co2'
else mkFunCo r cow' co1' co2'
@@ -280,7 +285,7 @@ opt_co4 env sym rep r (CoVarCo cv)
= mkReflCo (chooseRole rep r) ty1
| otherwise
- = ASSERT( isCoVar cv1 )
+ = assert (isCoVar cv1 )
wrapRole rep r $ wrapSym sym $
CoVarCo cv1
@@ -302,7 +307,7 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos)
-- e.g. if g is a top-level axiom
-- g a : f a ~ a
-- then (sym (g ty)) /= g (sym ty) !!
- = ASSERT( r == coAxiomRole con )
+ = assert (r == coAxiomRole con )
wrapRole rep (coAxiomRole con) $
wrapSym sym $
-- some sub-cos might be P: use opt_co2
@@ -313,7 +318,7 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos)
-- Note that the_co does *not* have sym pushed into it
opt_co4 env sym rep r (UnivCo prov _r t1 t2)
- = ASSERT( r == _r )
+ = assert (r == _r )
opt_univ env sym prov (chooseRole rep r) t1 t2
opt_co4 env sym rep r (TransCo co1 co2)
@@ -327,7 +332,7 @@ opt_co4 env sym rep r (TransCo co1 co2)
opt_co4 env _sym rep r (NthCo _r n co)
| Just (ty, _) <- isReflCo_maybe co
- , Just (_tc, args) <- ASSERT( r == _r )
+ , Just (_tc, args) <- assert (r == _r )
splitTyConApp_maybe ty
= liftCoSubst (chooseRole rep r) env (args `getNth` n)
@@ -338,18 +343,18 @@ opt_co4 env _sym rep r (NthCo _r n co)
= liftCoSubst (chooseRole rep r) env (varType tv)
opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))
- = ASSERT( r == r1 )
+ = assert (r == r1 )
opt_co4_wrap env sym rep r (cos `getNth` n)
-- see the definition of GHC.Builtin.Types.Prim.funTyCon
opt_co4 env sym rep r (NthCo r1 n (FunCo _r2 w co1 co2))
- = ASSERT( r == r1 )
+ = assert (r == r1 )
opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2)
opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))
-- works for both tyvar and covar
- = ASSERT( r == _r )
- ASSERT( n == 0 )
+ = assert (r == _r )
+ assert (n == 0 )
opt_co4_wrap env sym rep Nominal eta
opt_co4 env sym rep r (NthCo _r n co)
@@ -370,10 +375,10 @@ opt_co4 env sym rep r (NthCo _r n co)
opt_co4 env sym rep r (LRCo lr co)
| Just pr_co <- splitAppCo_maybe co
- = ASSERT( r == Nominal )
+ = assert (r == Nominal )
opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)
| Just pr_co <- splitAppCo_maybe co'
- = ASSERT( r == Nominal )
+ = assert (r == Nominal) $
if rep
then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)
else pick_lr lr pr_co
@@ -453,7 +458,7 @@ opt_co4 env sym rep r (InstCo co1 arg)
(n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))
opt_co4 env sym _rep r (KindCo co)
- = ASSERT( r == Nominal )
+ = assert (r == Nominal) $
let kco' = promoteCoercion co in
case kco' of
KindCo co' -> promoteCoercion (opt_co1 env sym co')
@@ -462,12 +467,12 @@ opt_co4 env sym _rep r (KindCo co)
-- and substitution/optimization at the same time
opt_co4 env sym _ r (SubCo co)
- = ASSERT( r == Representational )
+ = assert (r == Representational) $
opt_co4_wrap env sym True Nominal co
-- This could perhaps be optimized more.
opt_co4 env sym rep r (AxiomRuleCo co cs)
- = ASSERT( r == coaxrRole co )
+ = assert (r == coaxrRole co) $
wrapRole rep r $
wrapSym sym $
AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)
@@ -638,7 +643,7 @@ opt_trans2 _ co1 co2
opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))
- = ASSERT( r1 == r2 )
+ = assert (r1 == r2) $
fireTransRule "GRefl" in_co1 in_co2 $
mkGReflRightCo r1 t1 (opt_trans is co1 co2)
@@ -647,7 +652,7 @@ opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)
| d1 == d2
, coercionRole co1 == coercionRole co2
, co1 `compatible_co` co2
- = ASSERT( r1 == r2 )
+ = assert (r1 == r2) $
fireTransRule "PushNth" in_co1 in_co2 $
mkNthCo r1 d1 (opt_trans is co1 co2)
@@ -667,7 +672,7 @@ opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
in_co2@(UnivCo p2 r2 _tyl2 tyr2)
| Just prov' <- opt_trans_prov p1 p2
- = ASSERT( r1 == r2 )
+ = assert (r1 == r2) $
fireTransRule "UnivCo" in_co1 in_co2 $
mkUnivCo prov' r1 tyl1 tyr2
where
@@ -682,12 +687,12 @@ opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
-- Push transitivity down through matching top-level constructors.
opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)
| tc1 == tc2
- = ASSERT( r1 == r2 )
+ = assert (r1 == r2) $
fireTransRule "PushTyConApp" in_co1 in_co2 $
mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)
opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b)
- = ASSERT( r1 == r2) -- Just like the TyConAppCo/TyConAppCo case
+ = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case
fireTransRule "PushFun" in_co1 in_co2 $
mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b)
@@ -858,7 +863,7 @@ opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs
= opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)
| otherwise
- = ASSERT( co1bs `equalLength` co2bs )
+ = assert (co1bs `equalLength` co2bs) $
fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $
let rt1a = coercionRKind co1a
@@ -1191,7 +1196,7 @@ etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
-- g :: T s1 .. sn ~ T t1 .. tn
-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]
etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)
- = ASSERT( tc == tc2 ) Just cos2
+ = assert (tc == tc2) $ Just cos2
etaTyConAppCo_maybe tc co
| not (mustBeSaturated tc)
@@ -1204,7 +1209,7 @@ etaTyConAppCo_maybe tc co
, tys2 `lengthIs` n -- This can fail in an erroneous program
-- E.g. T a ~# T a b
-- #14607
- = ASSERT( tc == tc1 )
+ = assert (tc == tc1) $
Just (decomposeCo n co (tyConRolesX r tc1))
-- NB: n might be <> tyConArity tc
-- e.g. data family T a :: * -> *
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 63510e5f24..4714b3be01 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -92,6 +92,7 @@ import GHC.Builtin.Uniques( mkAlphaTyVarUnique )
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BSB
@@ -1432,9 +1433,9 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality
-> [Scaled Type]
dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,
dcExTyCoVars = ex_tvs}) inst_tys
- = ASSERT2( univ_tvs `equalLength` inst_tys
- , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
- ASSERT2( null ex_tvs, ppr dc )
+ = assertPpr (univ_tvs `equalLength` inst_tys)
+ (text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) $
+ assertPpr (null ex_tvs) (ppr dc) $
map (mapScaledType (substTyWith univ_tvs inst_tys)) (dataConRepArgTys dc)
-- | Returns just the instantiated /value/ argument types of a 'DataCon',
@@ -1450,8 +1451,8 @@ dataConInstOrigArgTys
dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dcExTyCoVars = ex_tvs}) inst_tys
- = ASSERT2( tyvars `equalLength` inst_tys
- , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
+ = assertPpr (tyvars `equalLength` inst_tys)
+ (text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys) $
substScaledTys subst arg_tys
where
tyvars = univ_tvs ++ ex_tvs
@@ -1475,7 +1476,7 @@ dataConRepArgTys (MkData { dcRep = rep
, dcOtherTheta = theta
, dcOrigArgTys = orig_arg_tys })
= case rep of
- NoDataConRep -> ASSERT( null eq_spec ) (map unrestricted theta) ++ orig_arg_tys
+ NoDataConRep -> assert (null eq_spec) $ (map unrestricted theta) ++ orig_arg_tys
DCR { dcr_arg_tys = arg_tys } -> arg_tys
-- | The string @package:module.name@ identifying a constructor, which is attached
@@ -1493,7 +1494,7 @@ dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
occNameFS $ nameOccName name
]
where name = dataConName dc
- mod = ASSERT( isExternalName name ) nameModule name
+ mod = assert (isExternalName name) $ nameModule name
isTupleDataCon :: DataCon -> Bool
isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
@@ -1522,7 +1523,7 @@ specialPromotedDc = isKindTyCon . dataConTyCon
classDataCon :: Class -> DataCon
classDataCon clas = case tyConDataCons (classTyCon clas) of
- (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
+ (dict_constr:no_more) -> assert (null no_more) dict_constr
[] -> panic "classDataCon"
dataConCannotMatch :: [Type] -> DataCon -> Bool
diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs
index 1fbf119172..d21407d42b 100644
--- a/compiler/GHC/Core/FVs.hs
+++ b/compiler/GHC/Core/FVs.hs
@@ -80,7 +80,7 @@ import GHC.Data.Maybe( orElse )
import GHC.Utils.FV as FV
import GHC.Utils.Misc
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
{-
************************************************************************
@@ -628,14 +628,14 @@ varTypeTyCoFVs :: Var -> FV
varTypeTyCoFVs var = tyCoFVsOfType (varType var)
idFreeVars :: Id -> VarSet
-idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id
+idFreeVars id = assert (isId id) $ fvVarSet $ idFVs id
dIdFreeVars :: Id -> DVarSet
dIdFreeVars id = fvDVarSet $ idFVs id
idFVs :: Id -> FV
-- Type variables, rule variables, and inline variables
-idFVs id = ASSERT( isId id)
+idFVs id = assert (isId id) $
varTypeTyCoFVs id `unionFV`
bndrRuleAndUnfoldingFVs id
@@ -654,7 +654,7 @@ idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
idRuleVars id = fvVarSet $ idRuleFVs id
idRuleFVs :: Id -> FV
-idRuleFVs id = ASSERT( isId id)
+idRuleFVs id = assert (isId id) $
FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))
idUnfoldingVars :: Id -> VarSet
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index 187ccf4994..4b41f40dee 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -62,6 +62,7 @@ import Data.Array( Array, assocs )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
{-
************************************************************************
@@ -808,9 +809,9 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })
-- In example above, fam tys' = F [b]
my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _
- = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs,
- (ppr fam <+> ppr tys) $$
- (ppr tpl_tvs <+> ppr tpl_tys) )
+ = assertPpr (tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs)
+ ((ppr fam <+> ppr tys) $$
+ (ppr tpl_tvs <+> ppr tpl_tys)) $
-- Unification will break badly if the variables overlap
-- They shouldn't because we allocate separate uniques for them
if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch
@@ -1003,7 +1004,7 @@ lookup_fam_inst_env' match_fun ie fam match_tys
| Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1
= (FamInstMatch { fim_instance = item
, fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2
- , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )
+ , fim_cos = assert (all (isJust . lookupCoVar subst) tpl_cvs) $
substCoVars subst tpl_cvs
})
: find rest
@@ -1186,7 +1187,7 @@ findBranch branches target_tys
| apartnessCheck flattened_target branch
-> -- matching worked & we're apart from all incompatible branches.
-- success
- ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )
+ assert (all (isJust . lookupCoVar subst) tpl_cvs) $
Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)
-- failure. keep looking
@@ -1509,7 +1510,7 @@ normalise_args fun_ki roles args
normalise_tyvar :: TyVar -> NormM (Coercion, Type)
normalise_tyvar tv
- = ASSERT( isTyVar tv )
+ = assert (isTyVar tv) $
do { lc <- getLC
; r <- getRole
; return $ case liftCoSubstTyVar lc r tv of
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 840465425f..55f96a1b18 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -54,6 +54,7 @@ import Data.Maybe ( isJust )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
{-
************************************************************************
@@ -266,7 +267,7 @@ mkLocalInstance dfun oflag tvs cls tys
where
cls_name = className cls
dfun_name = idName dfun
- this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
+ this_mod = assert (isExternalName dfun_name) $ nameModule dfun_name
is_local name = nameIsLocalOrFrom this_mod name
-- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv
@@ -274,9 +275,9 @@ mkLocalInstance dfun oflag tvs cls tys
arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
-- See Note [When exactly is an instance decl an orphan?]
- orph | is_local cls_name = NotOrphan (nameOccName cls_name)
- | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns
- | otherwise = IsOrphan
+ orph | is_local cls_name = NotOrphan (nameOccName cls_name)
+ | all notOrphan mb_ns = assert (not (null mb_ns)) $ head mb_ns
+ | otherwise = IsOrphan
notOrphan NotOrphan{} = True
notOrphan _ = False
@@ -859,10 +860,9 @@ lookupInstEnv' ie vis_mods cls tys
= find ms us rest
| otherwise
- = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,
- (ppr cls <+> ppr tys) $$
- (ppr tpl_tvs <+> ppr tpl_tys)
- )
+ = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set)
+ ((ppr cls <+> ppr tys) $$
+ (ppr tpl_tvs <+> ppr tpl_tys)) $
-- Unification will break badly if the variables overlap
-- They shouldn't because we allocate separate uniques for them
-- See Note [Template tyvars are fresh]
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 7eaec265a8..aa26fdabc4 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -76,6 +76,7 @@ import GHC.Data.List.SetOps
import GHC.Builtin.Names
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Core.InstEnv ( instanceDFunId )
import GHC.Core.Coercion.Opt ( checkAxInstCo )
@@ -1539,7 +1540,7 @@ lintIdBndr :: TopLevelFlag -> BindingSite
-- new type to the in-scope set of the second argument
-- ToDo: lint its rules
lintIdBndr top_lvl bind_site id thing_inside
- = ASSERT2( isId id, ppr id )
+ = assertPpr (isId id) (ppr id) $
do { flags <- getLintFlags
; checkL (not (lf_check_global_ids flags) || isLocalId id)
(text "Non-local Id binder" <+> ppr id)
@@ -2778,7 +2779,7 @@ addWarnL msg = LintM $ \ env (warns,errs) ->
addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc
addMsg is_error env msgs msg
- = ASSERT2( notNull loc_msgs, msg )
+ = assertPpr (notNull loc_msgs) msg $
msgs `snocBag` mk_msg msg
where
loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index cd92848a30..46ea720ec2 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -84,6 +84,7 @@ import GHC.Builtin.Types.Prim
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
@@ -167,7 +168,7 @@ mkCoreAppTyped _ (fun, fun_ty) (Type ty)
mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
= (App fun (Coercion co), funResultTy fun_ty)
mkCoreAppTyped d (fun, fun_ty) arg
- = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
+ = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d)
(mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty)
where
(mult, arg_ty, res_ty) = splitFunTy fun_ty
@@ -393,7 +394,7 @@ mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs))
-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup tys exps
- = ASSERT( tys `equalLength` exps)
+ = assert (tys `equalLength` exps) $
mkCoreConApps (tupleDataCon Unboxed (length tys))
(map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
@@ -407,8 +408,8 @@ mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
-- Alternative number ("alt") starts from 1.
mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUbxSum arity alt tys exp
- = ASSERT( length tys == arity )
- ASSERT( alt <= arity )
+ = assert (length tys == arity) $
+ assert (alt <= arity) $
mkCoreConApps (sumDataCon alt arity)
(map (Type . getRuntimeRep) tys
++ map Type tys
@@ -516,7 +517,7 @@ mkSmallTupleSelector, mkSmallTupleSelector1
-> CoreExpr -- Scrutinee
-> CoreExpr
mkSmallTupleSelector [var] should_be_the_same_var _ scrut
- = ASSERT(var == should_be_the_same_var)
+ = assert (var == should_be_the_same_var) $
scrut -- Special case for 1-tuples
mkSmallTupleSelector vars the_var scrut_var scrut
= mkSmallTupleSelector1 vars the_var scrut_var scrut
@@ -524,7 +525,7 @@ mkSmallTupleSelector vars the_var scrut_var scrut
-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkSmallTupleSelector1 vars the_var scrut_var scrut
- = ASSERT( notNull vars )
+ = assert (notNull vars) $
Case scrut scrut_var (idType the_var)
[Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)]
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 36a2535c09..73f8135a46 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -61,8 +61,10 @@ import GHC.Types.Basic
import GHC.Types.Tickish
import GHC.Builtin.Uniques
import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Utils.Misc
@@ -1622,7 +1624,7 @@ pushCoTyArg co ty
= Just (ty, MRefl)
| isForAllTy_ty tyL
- = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )
+ = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $
Just (ty `mkCastTy` co1, MCo co2)
| otherwise
@@ -1671,7 +1673,7 @@ pushCoValArg co
-- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
-- then co1 :: tyL1 ~ tyR1
-- co2 :: tyL2 ~ tyR2
- = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
+ = assertPpr (isFunTy tyR) (ppr co $$ ppr arg) $
Just (coToMCo (mkSymCo co1), coToMCo co2)
-- Critically, coToMCo to checks for ReflCo; the whole coercion may not
-- be reflexive, but either of its components might be
@@ -1691,7 +1693,7 @@ pushCoercionIntoLambda
-- ===>
-- (\x'. e |> co')
pushCoercionIntoLambda in_scope x e co
- | ASSERT(not (isTyVar x) && not (isCoVar x)) True
+ | assert (not (isTyVar x) && not (isCoVar x)) True
, Pair s1s2 t1t2 <- coercionKind co
, Just (_, _s1,_s2) <- splitFunTy_maybe s1s2
, Just (w1, t1,_t2) <- splitFunTy_maybe t1t2
@@ -1764,8 +1766,8 @@ pushCoDataCon dc dc_args co
ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc
, ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]
in
- ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
- ASSERT2( equalLength val_args arg_tys, dump_doc )
+ assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $
+ assertPpr (equalLength val_args arg_tys) dump_doc $
Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
| otherwise
@@ -1806,14 +1808,14 @@ collectBindersPushingCo e
go_lam bs b e co
| isTyVar b
, let Pair tyL tyR = coercionKind co
- , ASSERT( isForAllTy_ty tyL )
+ , assert (isForAllTy_ty tyL) $
isForAllTy_ty tyR
, isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo]
= go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))
| isCoVar b
, let Pair tyL tyR = coercionKind co
- , ASSERT( isForAllTy_co tyL )
+ , assert (isForAllTy_co tyL) $
isForAllTy_co tyR
, isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo]
, let cov = mkCoVarCo b
@@ -1821,7 +1823,7 @@ collectBindersPushingCo e
| isId b
, let Pair tyL tyR = coercionKind co
- , ASSERT( isFunTy tyL) isFunTy tyR
+ , assert (isFunTy tyL) $ isFunTy tyR
, (co_mult, co_arg, co_res) <- decomposeFunCo Representational co
, isReflCo co_mult -- See Note [collectBindersPushingCo]
, isReflCo co_arg -- See Note [collectBindersPushingCo]
diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs
index 4e5f511109..9855c41731 100644
--- a/compiler/GHC/Core/Opt/CSE.hs
+++ b/compiler/GHC/Core/Opt/CSE.hs
@@ -32,7 +32,7 @@ import GHC.Utils.Outputable
import GHC.Types.Basic
import GHC.Types.Tickish
import GHC.Core.Map.Expr
-import GHC.Utils.Misc ( filterOut, equalLength, debugIsOn )
+import GHC.Utils.Misc ( filterOut, equalLength )
import GHC.Utils.Panic
import Data.List ( mapAccumL )
@@ -693,7 +693,7 @@ combineAlts env alts
, Alt _ bndrs1 rhs1 <- alt1
, let filtered_alts = filterOut (identical_alt rhs1) rest_alts
, not (equalLength rest_alts filtered_alts)
- = ASSERT2( null bndrs1, ppr alts )
+ = assertPpr (null bndrs1) (ppr alts) $
Alt DEFAULT [] rhs1 : filtered_alts
| otherwise
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 33ceebe70a..1402a021f7 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -70,6 +70,7 @@ import GHC.Types.Basic
import GHC.Platform
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Applicative ( Alternative(..) )
@@ -1536,7 +1537,7 @@ tagToEnumRule = do
let tag = fromInteger i
correct_tag dc = (dataConTagZ dc) == tag
(dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
- ASSERT(null rest) return ()
+ massert (null rest)
return $ mkTyApps (Var (dataConWorkId dc)) tc_args
-- See Note [tagToEnum#]
@@ -1564,7 +1565,7 @@ dataToTagRule = a `mplus` b
[_, val_arg] <- getArgs
in_scope <- getInScopeEnv
(_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
- ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
+ massert (not (isNewTyCon (dataConTyCon dc)))
return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))
{- Note [dataToTag# magic]
@@ -2137,7 +2138,7 @@ match_append_lit foldVariant _ id_unf _
in eqExpr freeVars c1 c2
, (c1Ticks, c1') <- stripTicksTop tickishFloatable c1
, c2Ticks <- stripTicksTopT tickishFloatable c2
- = ASSERT( ty1 `eqType` ty2 )
+ = assert (ty1 `eqType` ty2) $
Just $ mkTicks strTicks
$ Var unpk `App` Type ty1
`App` Lit (LitString (s1 `BS.append` s2))
@@ -2337,7 +2338,7 @@ match_inline _ = Nothing
addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules op num_ops = do
- ASSERT(op == numAdd num_ops) return ()
+ massert (op == numAdd num_ops)
env <- getEnv
guard (roNumConstantFolding env)
[arg1,arg2] <- getArgs
@@ -2349,7 +2350,7 @@ addFoldingRules op num_ops = do
subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules op num_ops = do
- ASSERT(op == numSub num_ops) return ()
+ massert (op == numSub num_ops)
env <- getEnv
guard (roNumConstantFolding env)
[arg1,arg2] <- getArgs
@@ -2358,7 +2359,7 @@ subFoldingRules op num_ops = do
mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules op num_ops = do
- ASSERT(op == numMul num_ops) return ()
+ massert (op == numMul num_ops)
env <- getEnv
guard (roNumConstantFolding env)
[arg1,arg2] <- getArgs
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index 10630c1516..6c76671c4b 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -31,7 +31,7 @@ import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe )
import GHC.Utils.Misc
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) )
import GHC.Data.Graph.UnVar -- for UnVarSet
import GHC.Data.Maybe ( isJust )
@@ -221,7 +221,7 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs)
| DataAlt dc <- con
, let ids = filter isId bndrs
, CprType arity cpr <- scrut_ty
- , ASSERT( arity == 0 ) True
+ , assert (arity == 0 ) True
= case unpackConFieldsCpr dc cpr of
AllFieldsSame field_cpr
| let sig = mkCprSig 0 field_cpr
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 0de022a78b..ac049c0212 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -40,6 +40,7 @@ import GHC.Core.FamInstEnv
import GHC.Core.Opt.Arity ( typeArity )
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.Maybe ( isJust )
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
@@ -344,7 +345,7 @@ dmdAnalStar :: AnalEnv
-> (PlusDmdArg, CoreExpr)
dmdAnalStar env (n :* cd) e
| WithDmdType dmd_ty e' <- dmdAnal env cd e
- = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
+ = assertPpr (not (isUnliftedType (exprType e)) || exprOkForSpeculation e) (ppr e)
-- The argument 'e' should satisfy the let/app invariant
-- See Note [Analysing with absent demand] in GHC.Types.Demand
(toPlusDmdArg $ multDmdType n dmd_ty, e')
@@ -443,7 +444,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
| otherwise
-- __DEFAULT and literal alts. Simply add demands and discard the
-- evaluation cardinality, as we evaluate the scrutinee exactly once.
- = ASSERT( null bndrs ) (bndrs, case_bndr_sd)
+ = assert (null bndrs) (bndrs, case_bndr_sd)
fam_envs = ae_fam_envs env
alt_ty3
-- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
@@ -1271,7 +1272,7 @@ setBndrsDemandInfo (b:bs) (d:ds)
let !new_info = setIdDemandInfo b d
!vars = setBndrsDemandInfo bs ds
in new_info : vars
-setBndrsDemandInfo [] ds = ASSERT( null ds ) []
+setBndrsDemandInfo [] ds = assert (null ds) []
setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs)
annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var
@@ -1296,7 +1297,7 @@ annotateLamIdBndr :: AnalEnv
annotateLamIdBndr env arg_of_dfun dmd_ty id
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
- = ASSERT( isId id )
+ = assert (isId id) $
-- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
WithDmdType final_ty new_id
where
diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs
index 0f2eb85f73..78e993a26a 100644
--- a/compiler/GHC/Core/Opt/FloatIn.hs
+++ b/compiler/GHC/Core/Opt/FloatIn.hs
@@ -42,6 +42,7 @@ import GHC.Unit.Module.ModGuts
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
{-
Top-level interface function, @floatInwards@. Note that we do not
@@ -151,7 +152,7 @@ fiExpr :: Platform
fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit)
-- See Note [Dead bindings]
-fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty
+fiExpr _ to_drop (_, AnnType ty) = assert (null to_drop) $ Type ty
fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v)
fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
fiExpr platform to_drop (_, AnnCast expr (co_ann, co))
@@ -701,7 +702,7 @@ sepBindsByDropPoint platform is_case drop_pts floaters
= [] : [[] | _ <- drop_pts]
| otherwise
- = ASSERT( drop_pts `lengthAtLeast` 2 )
+ = assert (drop_pts `lengthAtLeast` 2) $
go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
where
n_alts = length drop_pts
diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs
index ed6c3759c1..c66ae34fa9 100644
--- a/compiler/GHC/Core/Opt/FloatOut.hs
+++ b/compiler/GHC/Core/Opt/FloatOut.hs
@@ -629,8 +629,8 @@ instance Outputable FloatBinds where
flattenTopFloats :: FloatBinds -> Bag CoreBind
flattenTopFloats (FB tops ceils defs)
- = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )
- ASSERT2( isEmptyBag ceils, ppr ceils )
+ = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $
+ assertPpr (isEmptyBag ceils) (ppr ceils)
tops
addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index 7efcba8cd8..c7b13f17c0 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -54,6 +54,7 @@ import GHC.Utils.Misc
import GHC.Data.Maybe( isJust )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.List (mapAccumL, mapAccumR)
{-
@@ -3020,7 +3021,7 @@ tagNonRecBinder lvl usage binder
occ = lookupDetails usage binder
will_be_join = decideJoinPointHood lvl usage [binder]
occ' | will_be_join = -- must already be marked AlwaysTailCalled
- ASSERT(isAlwaysTailCalled occ) occ
+ assert (isAlwaysTailCalled occ) occ
| otherwise = markNonTail occ
binder' = setBinderOcc occ' binder
usage' = usage `delDetails` binder
@@ -3060,7 +3061,7 @@ tagRecBinders lvl body_uds triples
, AlwaysTailCalled arity <- tailCallInfo occ
= Just arity
| otherwise
- = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if
+ = assert (not will_be_joins) -- Should be AlwaysTailCalled if
Nothing -- we are making join points!
-- 3. Compute final usage details from adjusted RHS details
@@ -3205,7 +3206,7 @@ markNonTail occ = occ { occ_tail = NoTailCallInfo }
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
-addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
+addOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $
ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`
tailCallInfo a2 }
-- Both branches are at least One
@@ -3227,7 +3228,7 @@ orOccInfo (OneOcc { occ_in_lam = in_lam1
, occ_int_cxt = int_cxt1 `mappend` int_cxt2
, occ_tail = tail1 `andTailCallInfo` tail2 }
-orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
+orOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $
ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`
tailCallInfo a2 }
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index f81f45eba2..c97f266052 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -52,9 +52,9 @@ import GHC.Core.FamInstEnv
import qualified GHC.Utils.Error as Err
import GHC.Utils.Error ( withTiming )
import GHC.Utils.Logger as Logger
-import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
import GHC.Unit.External
import GHC.Unit.Module.Env
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index e18c7d3e82..ed7f95b0b7 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -120,6 +120,7 @@ import GHC.Types.Unique.Supply
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Types.Unique.DFM
import GHC.Utils.FV
@@ -1052,7 +1053,7 @@ notWorthFloating e abs_vars
= go e (count isId abs_vars)
where
go (Var {}) n = n >= 0
- go (Lit lit) n = ASSERT( n==0 )
+ go (Lit lit) n = assert (n==0) $
litIsTrivial lit -- Note [Floating literals]
go (Tick t e) n = not (tickishIsCode t) && go e n
go (Cast e _) n = go e n
@@ -1708,7 +1709,7 @@ newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
newPolyBndrs dest_lvl
env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
abs_vars bndrs
- = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer.
+ = assert (all (not . isCoVar) bndrs) $ -- What would we add to the CoSubst in this case. No easy answer.
do { uniqs <- getUniquesM
; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
bndr_prs = bndrs `zip` new_bndrs
@@ -1807,7 +1808,7 @@ cloneLetVars is_rec
add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
add_id id_env (v, v1)
| isTyVar v = delVarEnv id_env v
- | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
+ | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)
{-
Note [Zapping the demand info]
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 3d1a8ce3aa..da15163ba6 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -65,8 +65,9 @@ import GHC.Data.Maybe ( orElse )
import Control.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
-import GHC.Utils.Misc
import GHC.Unit.Module ( moduleName, pprModuleName )
import GHC.Core.Multiplicity
import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
@@ -293,7 +294,7 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs
| Just cont <- mb_cont
= {-#SCC "simplRecOrTopPair-join" #-}
- ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )
+ assert (isNotTopLevel top_lvl && isJoinId new_bndr )
trace_bind "join" $
simplJoinBind env cont old_bndr new_bndr rhs env
@@ -328,8 +329,8 @@ simplLazyBind :: SimplEnv
-- Precondition: rhs obeys the let/app invariant
-- NOT used for JoinIds
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
- = ASSERT( isId bndr )
- ASSERT2( not (isJoinId bndr), ppr bndr )
+ = assert (isId bndr )
+ assertPpr (not (isJoinId bndr)) (ppr bndr) $
-- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]
(tvs, body) = case collectTyAndValBinders rhs of
@@ -415,7 +416,7 @@ simplNonRecX :: SimplEnv
-- Precondition: rhs satisfies the let/app invariant
simplNonRecX env bndr new_rhs
- | ASSERT2( not (isJoinId bndr), ppr bndr )
+ | assertPpr (not (isJoinId bndr)) (ppr bndr) $
isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
= return (emptyFloats env, env) -- Here c is dead, and we avoid
-- creating the binding c = (a,b)
@@ -444,7 +445,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv
-- See Note [Core let/app invariant] in GHC.Core
completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
- = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )
+ = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $
do { (prepd_floats, new_bndr, new_rhs)
<- prepareBinding env top_lvl old_bndr new_bndr new_rhs
; let floats = emptyFloats env `addLetFloats` prepd_floats
@@ -805,7 +806,7 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
_ -> return (mkFloatBind env (NonRec new_bndr new_rhs))
| otherwise
- = ASSERT( isId new_bndr )
+ = assert (isId new_bndr) $
do { let old_info = idInfo old_bndr
old_unf = unfoldingInfo old_info
occ_info = occInfo old_info
@@ -1096,7 +1097,7 @@ simplExprF1 env (Let (Rec pairs) body) cont
simplExprF1 env (Let (NonRec bndr rhs) body) cont
| Type ty <- rhs -- First deal with type lets (let a = Type ty in e)
= {-#SCC "simplExprF1-NonRecLet-Type" #-}
- ASSERT( isTyVar bndr )
+ assert (isTyVar bndr) $
do { ty' <- simplType env ty
; simplExprF (extendTvSubst env bndr ty') body cont }
@@ -1605,7 +1606,7 @@ simplNonRecE :: SimplEnv
-- the call to simplLam in simplExprF (Lam ...)
simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
- | ASSERT( isId bndr && not (isJoinId bndr) ) True
+ | assert (isId bndr && not (isJoinId bndr) ) True
, Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se
= do { tick (PreInlineUnconditionally bndr)
; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
@@ -1639,7 +1640,7 @@ simplRecE :: SimplEnv
-- * non-top-level recursive lets in expressions
simplRecE env pairs body cont
= do { let bndrs = map fst pairs
- ; MASSERT(all (not . isJoinId) bndrs)
+ ; massert (all (not . isJoinId) bndrs)
; env1 <- simplRecBndrs env bndrs
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
@@ -1745,7 +1746,7 @@ simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplNonRecJoinPoint env bndr rhs body cont
- | ASSERT( isJoinId bndr ) True
+ | assert (isJoinId bndr ) True
, Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env
= do { tick (PreInlineUnconditionally bndr)
; simplExprF env' body cont }
@@ -2203,7 +2204,7 @@ tryRules env rules fn args call_cont
-- Takes K -> e into tagK# -> e
-- where tagK# is the tag of constructor K
enum_to_tag (DataAlt con, [], rhs)
- = ASSERT( isEnumerationTyCon (dataConTyCon con) )
+ = assert (isEnumerationTyCon (dataConTyCon con) )
(LitAlt tag, [], rhs)
where
tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))
@@ -2679,7 +2680,7 @@ rebuildCase env scrut case_bndr alts cont
}
where
simple_rhs env wfloats scrut' bs rhs =
- ASSERT( null bs )
+ assert (null bs) $
do { (floats1, env') <- simplNonRecX env case_bndr scrut'
-- scrut is a constructor application,
-- hence satisfies let/app invariant
@@ -2978,7 +2979,7 @@ simplAlt :: SimplEnv
-> SimplM OutAlt
simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)
- = ASSERT( null bndrs )
+ = assert (null bndrs) $
do { let env' = addBinderUnfolding env case_bndr'
(mkOtherCon imposs_deflt_cons)
-- Record the constructors that the case-binder *can't* be.
@@ -2986,7 +2987,7 @@ simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)
; return (Alt DEFAULT [] rhs') }
simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)
- = ASSERT( null bndrs )
+ = assert (null bndrs) $
do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)
; rhs' <- simplExprC env' rhs cont'
; return (Alt (LitAlt lit) [] rhs') }
@@ -3212,15 +3213,15 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
bind_args env' [] _ = return (emptyFloats env', env')
bind_args env' (b:bs') (Type ty : args)
- = ASSERT( isTyVar b )
+ = assert (isTyVar b )
bind_args (extendTvSubst env' b ty) bs' args
bind_args env' (b:bs') (Coercion co : args)
- = ASSERT( isCoVar b )
+ = assert (isCoVar b )
bind_args (extendCvSubst env' b co) bs' args
bind_args env' (b:bs') (arg : args)
- = ASSERT( isId b )
+ = assert (isId b) $
do { let b' = zap_occ b
-- Note that the binder might be "dead", because it doesn't
-- occur in the RHS; and simplNonRecX may therefore discard
@@ -4056,8 +4057,7 @@ simplRules env mb_new_id rules mb_cont
; let rhs_ty = substTy env' (exprType rhs)
rhs_cont = case mb_cont of -- See Note [Rules and unfolding for join points]
Nothing -> mkBoringStop rhs_ty
- Just cont -> ASSERT2( join_ok, bad_join_msg )
- cont
+ Just cont -> assertPpr join_ok bad_join_msg cont
lhs_env = updMode updModeForRules env'
rhs_env = updMode (updModeForStableUnfoldings act) env'
-- See Note [Simplifying the RHS of a RULE]
@@ -4089,4 +4089,4 @@ unfolding. We used to use the much more conservative updModeForRules
for the RHS as well as the LHS, but that seems more conservative
than necesary. Allowing some inlining might, for example, eliminate
a binding.
--} \ No newline at end of file
+-}
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index d1b33b0290..43d28cffe2 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -70,6 +70,7 @@ import GHC.Types.Basic
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Types.Unique.FM ( pprUniqFM )
@@ -336,17 +337,17 @@ bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }
---------------------
extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
- = ASSERT2( isId var && not (isCoVar var), ppr var )
+ = assertPpr (isId var && not (isCoVar var)) (ppr var) $
env { seIdSubst = extendVarEnv subst var res }
extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res
- = ASSERT2( isTyVar var, ppr var $$ ppr res )
+ = assertPpr (isTyVar var) (ppr var $$ ppr res) $
env {seTvSubst = extendVarEnv tsubst var res}
extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co
- = ASSERT( isCoVar var )
+ = assert (isCoVar var) $
env {seCvSubst = extendVarEnv csubst var co}
---------------------
@@ -516,7 +517,7 @@ emptyJoinFloats = nilOL
unitLetFloat :: OutBind -> LetFloats
-- This key function constructs a singleton float with the right form
-unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
+unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $
LetFloats (unitOL bind) (flag bind)
where
flag (Rec {}) = FltLifted
@@ -526,12 +527,12 @@ unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
-- String literals can be floated freely.
-- See Note [Core top-level string literals] in GHC.Core.
| exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF)
- | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
+ | otherwise = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr)
FltCareful
-- Unlifted binders can only be let-bound if exprOkForSpeculation holds
unitJoinFloat :: OutBind -> JoinFloats
-unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))
+unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $
unitOL bind
mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
@@ -618,7 +619,7 @@ mkRecFloats :: SimplFloats -> SimplFloats
mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
, sfJoinFloats = jbs
, sfInScope = in_scope })
- = ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
+ = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $
SimplFloats { sfLetFloats = floats'
, sfJoinFloats = jfloats'
, sfInScope = in_scope }
@@ -654,7 +655,7 @@ wrapJoinFloats join_floats body
getTopFloatBinds :: SimplFloats -> [CoreBind]
getTopFloatBinds (SimplFloats { sfLetFloats = lbs
, sfJoinFloats = jbs})
- = ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings
+ = assert (isNilOL jbs) $ -- Can't be any top-level join bindings
letFloatBinds lbs
{-# INLINE mapLetFloats #-}
@@ -786,7 +787,7 @@ simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
-- Recursive let binders
simplRecBndrs env@(SimplEnv {}) ids
-- See Note [Bangs in the Simplifier]
- = ASSERT(all (not . isJoinId) ids)
+ = assert (all (not . isJoinId) ids) $
do { let (!env1, ids1) = mapAccumL substIdBndr env ids
; seqIds ids1 `seq` return env1 }
@@ -832,7 +833,7 @@ subst_id_bndr :: SimplEnv
-> (SimplEnv, OutBndr)
subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
old_id adjust_type
- = ASSERT2( not (isCoVar old_id), ppr old_id )
+ = assertPpr (not (isCoVar old_id)) (ppr old_id)
(env { seInScope = new_in_scope,
seIdSubst = new_subst }, new_id)
-- It's important that both seInScope and seIdSubst are updated with
@@ -933,7 +934,7 @@ simplRecJoinBndrs :: SimplEnv -> [InBndr]
-- context being pushed inward may change types
-- See Note [Return type for join points]
simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty
- = ASSERT(all isJoinId ids)
+ = assert (all isJoinId ids) $
do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids
; seqIds ids1 `seq` return env1 }
@@ -960,7 +961,7 @@ adjustJoinPointType :: Mult
-- INVARIANT: If any of the first n binders are foralls, those tyvars
-- cannot appear in the original result type. See isValidJoinPointType.
adjustJoinPointType mult new_res_ty join_id
- = ASSERT( isJoinId join_id )
+ = assert (isJoinId join_id) $
setIdType join_id new_join_ty
where
orig_ar = idJoinArity join_id
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index e66c88ac7a..75f5acaace 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -73,6 +73,7 @@ import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Logger
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Core.Opt.ConstantFold
import GHC.Data.FastString ( fsLit )
@@ -1928,8 +1929,8 @@ new binding is abstracted. Note that
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
-> OutExpr -> SimplM ([OutBind], OutExpr)
abstractFloats uf_opts top_lvl main_tvs floats body
- = ASSERT( notNull body_floats )
- ASSERT( isNilOL (sfJoinFloats floats) )
+ = assert (notNull body_floats) $
+ assert (isNilOL (sfJoinFloats floats)) $
do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
; return (float_binds, GHC.Core.Subst.substExpr subst body) }
where
@@ -2252,7 +2253,7 @@ mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)
, inner_scrut_var == outer_bndr
= do { tick (CaseMerge outer_bndr)
- ; let wrap_alt (Alt con args rhs) = ASSERT( outer_bndr `notElem` args )
+ ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)
(Alt con args (wrap_rhs rhs))
-- Simplifier's no-shadowing invariant should ensure
-- that outer_bndr is not shadowed by the inner patterns
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 7509a4cda3..c5745f8b2f 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -57,7 +57,8 @@ import GHC.Utils.Misc
import GHC.Data.Pair
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import GHC.Types.Unique.FM
import GHC.Utils.Monad
@@ -1342,7 +1343,7 @@ harmful. I'm not sure.
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
scApp env (Var fn, args) -- Function is a variable
- = ASSERT( not (null args) )
+ = assert (not (null args)) $
do { args_w_usgs <- mapM (scExpr env) args
; let (arg_usgs, args') = unzip args_w_usgs
arg_usg = combineUsages arg_usgs
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 65f07703b2..d27fdef24b 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -32,6 +32,7 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Types.Unique
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Core.FamInstEnv
import GHC.Utils.Monad
@@ -519,8 +520,9 @@ tryWW dflags fam_envs is_rec fn_id rhs
cpr_ty = getCprSig (cprSigInfo fn_info)
-- Arity of the CPR sig should match idArity when it's not a join point.
-- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal
- cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info
- , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info))
+ cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info)
+ (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty)
+ <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $
ct_cpr cpr_ty
new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)
@@ -886,11 +888,11 @@ get around by localising the Id for the auxiliary bindings in 'splitThunk'.
-- Note [Thunk splitting for top-level binders].
splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
splitThunk dflags fam_envs is_rec x rhs
- = ASSERT(not (isJoinId x))
+ = assert (not (isJoinId x)) $
do { let x' = localiseId x -- See comment above
; (useful,_, wrap_fn, work_fn)
<- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x']
; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ]
- ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive
+ ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive
return res
else return [(x, rhs)] }
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 5bd7bdf263..ce8d901ee2 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -51,6 +51,7 @@ import GHC.Types.Name ( getOccFS )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Data.FastString
@@ -1372,8 +1373,8 @@ mkWWcpr _opts vars [] =
return (False, toOL vars, nop_fn, nop_fn)
mkWWcpr opts vars cprs = do
-- No existentials in 'vars'. 'wantToUnboxResult' should have checked that.
- MASSERT2( not (any isTyVar vars), ppr vars $$ ppr cprs )
- MASSERT2( equalLength vars cprs, ppr vars $$ ppr cprs )
+ massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs)
+ massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs)
(usefuls, varss, wrap_build_ress, work_unpack_ress) <-
unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs
return ( or usefuls
@@ -1384,7 +1385,7 @@ mkWWcpr opts vars cprs = do
mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResult
-- ^ See if we want to unbox the result and hand off to 'unbox_one_result'.
mkWWcpr_one opts res_bndr cpr
- | ASSERT( not (isTyVar res_bndr) ) True
+ | assert (not (isTyVar res_bndr) ) True
, Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr
= unbox_one_result opts res_bndr arg_cprs dcpc
| otherwise
@@ -1404,7 +1405,7 @@ unbox_one_result opts res_bndr arg_cprs
pat_bndrs_uniqs <- getUniquesM
let (_exs, arg_ids) =
dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args
- MASSERT( null _exs ) -- Should have been caught by wantToUnboxResult
+ massert (null _exs) -- Should have been caught by wantToUnboxResult
let -- con_app = (C a b |> sym co)
con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co
diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs
index 3fa12a626a..03daede521 100644
--- a/compiler/GHC/Core/PatSyn.hs
+++ b/compiler/GHC/Core/PatSyn.hs
@@ -473,8 +473,8 @@ patSynInstArgTys :: PatSyn -> [Type] -> [Type]
patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
, psExTyVars = ex_tvs, psArgs = arg_tys })
inst_tys
- = ASSERT2( tyvars `equalLength` inst_tys
- , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
+ = assertPpr (tyvars `equalLength` inst_tys)
+ (text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys) $
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = binderVars (univ_tvs ++ ex_tvs)
@@ -488,8 +488,8 @@ patSynInstResTy :: PatSyn -> [Type] -> Type
patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
, psResultTy = res_ty })
inst_tys
- = ASSERT2( univ_tvs `equalLength` inst_tys
- , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
+ = assertPpr (univ_tvs `equalLength` inst_tys)
+ (text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys) $
substTyWith (binderVars univ_tvs) inst_tys res_ty
-- | Print the type of a pattern synonym. The foralls are printed explicitly
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 41cab2d201..c61cdb8ee4 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -66,6 +66,7 @@ import GHC.Driver.Ppr
import GHC.Driver.Flags
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.Bag
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 53c239426a..abf4a6c3a7 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -52,6 +52,7 @@ import GHC.Types.Basic
import GHC.Unit.Module ( Module )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe ( orElse )
import GHC.Data.FastString
@@ -419,15 +420,15 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
top_level
| Type ty <- in_rhs -- let a::* = TYPE ty in <body>
, let out_ty = substTy (soe_subst rhs_env) ty
- = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr in_rhs )
+ = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $
(env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
| Coercion co <- in_rhs
, let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co
- = ASSERT( isCoVar in_bndr )
+ = assert (isCoVar in_bndr)
(env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
- | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
+ | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)
-- The previous two guards got rid of tyvars and coercions
-- See Note [Core type and coercion invariant] in GHC.Core
pre_inline_unconditionally
@@ -477,11 +478,11 @@ simple_out_bind :: TopLevelFlag
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)
| Type out_ty <- out_rhs
- = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr out_ty $$ ppr out_rhs )
+ = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr out_ty $$ ppr out_rhs)
(env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
| Coercion out_co <- out_rhs
- = ASSERT( isCoVar in_bndr )
+ = assert (isCoVar in_bndr)
(env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
| otherwise
@@ -495,7 +496,7 @@ simple_out_bind_pair :: SimpleOptEnv
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
occ_info active stable_unf top_level
- | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
+ | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)
-- Type and coercion bindings are caught earlier
-- See Note [Core type and coercion invariant]
post_inline_unconditionally
@@ -1342,7 +1343,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
-- Only do value lambdas.
-- this implies that x is not in scope in gamma (makes this code simpler)
, not (isTyVar x) && not (isCoVar x)
- , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
+ , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True
, Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
, let res = Just (x',e',ts)
= --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index f60b60b02b..0f1305c52a 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -67,6 +67,7 @@ import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.List (mapAccumL)
@@ -191,13 +192,13 @@ zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv empt
extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
extendIdSubst (Subst in_scope ids tvs cvs) v r
- = ASSERT2( isNonCoVarId v, ppr v $$ ppr r )
+ = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $
Subst in_scope (extendVarEnv ids v r) tvs cvs
-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
extendIdSubstList (Subst in_scope ids tvs cvs) prs
- = ASSERT( all (isNonCoVarId . fst) prs )
+ = assert (all (isNonCoVarId . fst) prs) $
Subst in_scope (extendVarEnvList ids prs) tvs cvs
-- | Add a substitution for a 'TyVar' to the 'Subst'
@@ -207,7 +208,7 @@ extendIdSubstList (Subst in_scope ids tvs cvs) prs
-- after extending the substitution like this.
extendTvSubst :: Subst -> TyVar -> Type -> Subst
extendTvSubst (Subst in_scope ids tvs cvs) tv ty
- = ASSERT( isTyVar tv )
+ = assert (isTyVar tv) $
Subst in_scope ids (extendVarEnv tvs tv ty) cvs
-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
@@ -223,7 +224,7 @@ extendTvSubstList subst vrs
-- after extending the substitution like this
extendCvSubst :: Subst -> CoVar -> Coercion -> Subst
extendCvSubst (Subst in_scope ids tvs cvs) v r
- = ASSERT( isCoVar v )
+ = assert (isCoVar v) $
Subst in_scope ids tvs (extendVarEnv cvs v r)
-- | Add a substitution appropriate to the thing being substituted
@@ -232,15 +233,15 @@ extendCvSubst (Subst in_scope ids tvs cvs) v r
extendSubst :: Subst -> Var -> CoreArg -> Subst
extendSubst subst var arg
= case arg of
- Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty
- Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
- _ -> ASSERT( isId var ) extendIdSubst subst var arg
+ Type ty -> assert (isTyVar var) $ extendTvSubst subst var ty
+ Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co
+ _ -> assert (isId var) $ extendIdSubst subst var arg
extendSubstWithVar :: Subst -> Var -> Var -> Subst
extendSubstWithVar subst v1 v2
- | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
- | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
- | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2)
+ | isTyVar v1 = assert (isTyVar v2) $ extendTvSubst subst v1 (mkTyVarTy v2)
+ | isCoVar v1 = assert (isCoVar v2) $ extendCvSubst subst v1 (mkCoVarCo v2)
+ | otherwise = assert (isId v2) $ extendIdSubst subst v1 (Var v2)
-- | Add a substitution as appropriate to each of the terms being
-- substituted (whether expressions, types, or coercions). See also
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index eec0d91f0c..19f1590c34 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -938,7 +938,7 @@ which in turn is imported by Type
-}
mkTyVarTy :: TyVar -> Type
-mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) )
+mkTyVarTy v = assertPpr (isTyVar v) (ppr v <+> dcolon <+> ppr (tyVarKind v)) $
TyVarTy v
mkTyVarTys :: [TyVar] -> [Type]
diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs
index e9c9b85a23..a741c6672a 100644
--- a/compiler/GHC/Core/TyCo/Subst.hs
+++ b/compiler/GHC/Core/TyCo/Subst.hs
@@ -76,6 +76,7 @@ import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Data.Pair
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Types.Unique.Supply
import GHC.Types.Unique
@@ -83,6 +84,7 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.List (mapAccumL)
@@ -344,7 +346,7 @@ extendTvSubst (TCvSubst in_scope tenv cenv) tv ty
extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst
extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty
- = ASSERT( isTyVar v )
+ = assert (isTyVar v )
extendTvSubstAndInScope subst v ty
extendTvSubstBinderAndInScope subst (Anon {}) _
= subst
@@ -388,7 +390,7 @@ extendTCvSubstList subst tvs tys
unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst
-- Works when the ranges are disjoint
unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)
- = ASSERT( tenv1 `disjointVarEnv` tenv2
+ = assert (tenv1 `disjointVarEnv` tenv2
&& cenv1 `disjointVarEnv` cenv2 )
TCvSubst (in_scope1 `unionInScope` in_scope2)
(tenv1 `plusVarEnv` tenv2)
@@ -430,7 +432,7 @@ zipTCvSubst tcvs tys
mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs [] = emptyTCvSubst
mkTvSubstPrs prs =
- ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )
+ assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $
mkTvSubst in_scope tenv
where tenv = mkVarEnv prs
in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs
@@ -444,7 +446,7 @@ zipTyEnv tyvars tys
, not (all isTyVar tyvars && (tyvars `equalLength` tys))
= pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys)
| otherwise
- = ASSERT( all (not . isCoercionTy) tys )
+ = assert (all (not . isCoercionTy) tys )
zipToUFM tyvars tys
-- There used to be a special case for when
-- ty == TyVarTy tv
@@ -556,7 +558,7 @@ 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 = {-#SCC "substTyWith" #-}
- ASSERT( tvs `equalLength` tys )
+ assert (tvs `equalLength` tys )
substTy (zipTvSubst tvs tys)
-- | Type substitution, see 'zipTvSubst'. Disables sanity checks.
@@ -566,7 +568,7 @@ substTyWith tvs tys = {-#SCC "substTyWith" #-}
-- substTy and remove this function. Please don't use in new code.
substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type
substTyWithUnchecked tvs tys
- = ASSERT( tvs `equalLength` tys )
+ = assert (tvs `equalLength` tys )
substTyUnchecked (zipTvSubst tvs tys)
-- | Substitute tyvars within a type using a known 'InScopeSet'.
@@ -575,13 +577,13 @@ substTyWithUnchecked tvs tys
-- and of 'ty' minus the domain of the subst.
substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type
substTyWithInScope in_scope tvs tys ty =
- ASSERT( tvs `equalLength` tys )
+ assert (tvs `equalLength` tys )
substTy (mkTvSubst in_scope tenv) ty
where tenv = zipTyEnv tvs tys
-- | Coercion substitution, see 'zipTvSubst'
substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion
-substCoWith tvs tys = ASSERT( tvs `equalLength` tys )
+substCoWith tvs tys = assert (tvs `equalLength` tys )
substCo (zipTvSubst tvs tys)
-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.
@@ -591,7 +593,7 @@ substCoWith tvs tys = ASSERT( tvs `equalLength` tys )
-- substCo and remove this function. Please don't use in new code.
substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion
substCoWithUnchecked tvs tys
- = ASSERT( tvs `equalLength` tys )
+ = assert (tvs `equalLength` tys )
substCoUnchecked (zipTvSubst tvs tys)
@@ -602,12 +604,12 @@ substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)
-- | Type substitution, see 'zipTvSubst'
substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
-substTysWith tvs tys = ASSERT( tvs `equalLength` tys )
+substTysWith tvs tys = assert (tvs `equalLength` tys )
substTys (zipTvSubst tvs tys)
-- | Type substitution, see 'zipTvSubst'
substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]
-substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos )
+substTysWithCoVars cvs cos = assert (cvs `equalLength` cos )
substTys (zipCvSubst cvs cos)
-- | Substitute within a 'Type' after adding the free variables of the type
@@ -634,21 +636,21 @@ isValidTCvSubst (TCvSubst in_scope tenv cenv) =
-- Note [The substitution invariant].
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 $$
- text "tenv" <+> ppr tenv $$
- text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$
- text "cenv" <+> ppr cenv $$
- text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$
- text "tys" <+> ppr tys $$
- text "cos" <+> ppr cos )
- ASSERT2( tysCosFVsInScope,
- text "in_scope" <+> ppr in_scope $$
- text "tenv" <+> ppr tenv $$
- text "cenv" <+> ppr cenv $$
- text "tys" <+> ppr tys $$
- text "cos" <+> ppr cos $$
- text "needInScope" <+> ppr needInScope )
+ = assertPpr (isValidTCvSubst subst)
+ (text "in_scope" <+> ppr in_scope $$
+ text "tenv" <+> ppr tenv $$
+ text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$
+ text "cenv" <+> ppr cenv $$
+ text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$
+ text "tys" <+> ppr tys $$
+ text "cos" <+> ppr cos) $
+ assertPpr tysCosFVsInScope
+ (text "in_scope" <+> ppr in_scope $$
+ text "tenv" <+> ppr tenv $$
+ text "cenv" <+> ppr cenv $$
+ text "tys" <+> ppr tys $$
+ text "cos" <+> ppr cos $$
+ text "needInScope" <+> ppr needInScope)
a
where
substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv
@@ -764,7 +766,7 @@ subst_ty subst ty
substTyVar :: TCvSubst -> TyVar -> Type
substTyVar (TCvSubst _ tenv _) tv
- = ASSERT( isTyVar tv )
+ = assert (isTyVar tv) $
case lookupVarEnv tenv tv of
Just ty -> ty
Nothing -> TyVarTy tv
@@ -783,7 +785,7 @@ substTyCoVar subst tv
lookupTyVar :: TCvSubst -> TyVar -> Maybe Type
-- See Note [Extending the TCvSubst]
lookupTyVar (TCvSubst _ tenv _) tv
- = ASSERT( isTyVar tv )
+ = assert (isTyVar tv )
lookupVarEnv tenv tv
-- | Substitute within a 'Coercion'
@@ -887,7 +889,7 @@ substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder?
-> TCvSubst -> TyVar -> KindCoercion
-> (TCvSubst, TyVar, KindCoercion)
substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co
- = ASSERT( isTyVar old_var )
+ = assert (isTyVar old_var )
( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv
, new_var, new_kind_co )
where
@@ -916,7 +918,7 @@ substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder?
-> (TCvSubst, CoVar, KindCoercion)
substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv)
old_var old_kind_co
- = ASSERT( isCoVar old_var )
+ = assert (isCoVar old_var )
( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv
, new_var, new_kind_co )
where
@@ -983,8 +985,8 @@ substTyVarBndrUsing
:: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind
-> TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
- = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )
- ASSERT( isTyVar old_var )
+ = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $
+ assert (isTyVar old_var )
(TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var)
where
new_env | no_change = delVarEnv tenv old_var
@@ -1018,7 +1020,7 @@ substCoVarBndrUsing
:: (TCvSubst -> Type -> Type)
-> TCvSubst -> CoVar -> (TCvSubst, CoVar)
substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
- = ASSERT( isCoVar old_var )
+ = assert (isCoVar old_var)
(TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)
where
new_co = mkCoVarCo new_var
@@ -1040,7 +1042,7 @@ substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar)
cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq
- = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars
+ = assertPpr (isTyVar tv) (ppr tv) -- I think it's only called on TyVars
(TCvSubst (extendInScopeSet in_scope tv')
(extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv')
where
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index d972752e9a..a97efdf099 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -166,6 +166,7 @@ import GHC.Builtin.Names
import GHC.Data.Maybe
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString.Env
import GHC.Types.FieldLabel
import GHC.Settings.Constants
@@ -455,7 +456,7 @@ instance Outputable TyConBndrVis where
ppr (AnonTCB af) = text "AnonTCB" <> ppr af
mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder
-mkAnonTyConBinder af tv = ASSERT( isTyVar tv)
+mkAnonTyConBinder af tv = assert (isTyVar tv) $
Bndr tv (AnonTCB af)
mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]
@@ -463,7 +464,7 @@ mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs
mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder
-- The odd argument order supports currying
-mkNamedTyConBinder vis tv = ASSERT( isTyVar tv )
+mkNamedTyConBinder vis tv = assert (isTyVar tv) $
Bndr tv (NamedTCB vis)
mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder]
@@ -1752,7 +1753,7 @@ mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn
algTcStupidTheta = stupid,
algTcRhs = rhs,
algTcFields = fieldsOfAlgTcRhs rhs,
- algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,
+ algTcParent = assertPpr (okParent name parent) (ppr name $$ ppr parent) parent,
algTcGadtSyntax = gadt_syn
}
in tc
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 1f2872e056..9e5f05cde6 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -282,6 +282,7 @@ import GHC.Utils.Misc
import GHC.Utils.FV
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.List.SetOps
@@ -417,7 +418,7 @@ coreView ty@(TyConApp tc tys)
-- At the Core level, Constraint = Type
-- See Note [coreView vs tcView]
| isConstraintKindCon tc
- = ASSERT2( null tys, ppr ty )
+ = assertPpr (null tys) (ppr ty) $
Just liftedTypeKind
coreView _ = Nothing
@@ -720,7 +721,7 @@ isUnliftedRuntimeRep _ = False
isNullaryTyConKeyApp :: Unique -> Type -> Bool
isNullaryTyConKeyApp key ty
| Just args <- isTyConKeyApp_maybe key ty
- = ASSERT( null args ) True
+ = assert (null args ) True
| otherwise
= False
{-# INLINE isNullaryTyConKeyApp #-}
@@ -1099,7 +1100,7 @@ splitAppTys ty = split ty ty []
in
(TyConApp tc tc_args1, tc_args2 ++ args)
split _ (FunTy _ w ty1 ty2) args
- = ASSERT( null args )
+ = assert (null args )
(TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2])
where
rep1 = getRuntimeRep ty1
@@ -1119,7 +1120,7 @@ repSplitAppTys ty = split ty []
in
(TyConApp tc tc_args1, tc_args2 ++ args)
split (FunTy _ w ty1 ty2) args
- = ASSERT( null args )
+ = assert (null args )
(TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2])
where
rep1 = getRuntimeRep ty1
@@ -1363,8 +1364,8 @@ applyTysX :: [TyVar] -> Type -> [Type] -> Type
-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
-- Assumes that (/\tvs. body_ty) is closed
applyTysX tvs body_ty arg_tys
- = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff )
- ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )
+ = assertPpr (arg_tys `lengthAtLeast` n_tvs) pp_stuff $
+ assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $
mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty)
(drop n_tvs arg_tys)
where
@@ -1511,7 +1512,7 @@ newTyConInstRhs :: TyCon -> [Type] -> Type
-- arguments, using an eta-reduced version of the @newtype@ if possible.
-- This requires tys to have at least @newTyConInstArity tycon@ elements.
newTyConInstRhs tycon tys
- = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs )
+ = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $
applyTysX tvs rhs tys
where
(tvs, rhs) = newTyConEtadRhs tycon
@@ -1750,7 +1751,7 @@ mkTyCoInvForAllTy tv ty
-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar
mkInfForAllTy :: TyVar -> Type -> Type
-mkInfForAllTy tv ty = ASSERT( isTyVar tv )
+mkInfForAllTy tv ty = assert (isTyVar tv )
ForAllTy (Bndr tv Inferred) ty
-- | Like 'mkForAllTys', but assumes all variables are dependent and
@@ -1765,7 +1766,7 @@ mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs
-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified',
-- a common case
mkSpecForAllTy :: TyVar -> Type -> Type
-mkSpecForAllTy tv ty = ASSERT( isTyVar tv )
+mkSpecForAllTy tv ty = assert (isTyVar tv )
-- covar is always Inferred, so input should be tyvar
ForAllTy (Bndr tv Specified) ty
@@ -1776,7 +1777,7 @@ mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs
-- | Like mkForAllTys, but assumes all variables are dependent and visible
mkVisForAllTys :: [TyVar] -> Type -> Type
-mkVisForAllTys tvs = ASSERT( all isTyVar tvs )
+mkVisForAllTys tvs = assert (all isTyVar tvs )
-- covar is always Inferred, so all inputs should be tyvar
mkForAllTys [ Bndr tv Required | tv <- tvs ]
@@ -1790,7 +1791,7 @@ mkVisForAllTys tvs = ASSERT( all isTyVar tvs )
mkTyConBindersPreferAnon :: [TyVar] -- ^ binders
-> TyCoVarSet -- ^ free variables of result
-> [TyConBinder]
-mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars)
+mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars)
fst (go vars)
where
go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars
@@ -2155,7 +2156,7 @@ tyCoBinderType (Anon _ ty) = scaledThing ty
tyBinderType :: TyBinder -> Type
tyBinderType (Named (Bndr tv _))
- = ASSERT( isTyVar tv )
+ = assert (isTyVar tv )
tyVarKind tv
tyBinderType (Anon _ ty) = scaledThing ty
@@ -2185,7 +2186,7 @@ mkFamilyTyConApp :: TyCon -> [Type] -> Type
mkFamilyTyConApp tc tys
| Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
, let tvs = tyConTyVars tc
- fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys )
+ fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $
zipTvSubst tvs tys
= mkTyConApp fam_tc (substTys fam_subst fam_tys)
| otherwise
@@ -2328,7 +2329,7 @@ isUnboxedSumType ty
isAlgType :: Type -> Bool
isAlgType ty
= case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+ Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )
isAlgTyCon tc
_other -> False
@@ -2347,7 +2348,7 @@ isStrictType = isUnliftedType
isPrimitiveType :: Type -> Bool
-- ^ Returns true of types that are opaque to Haskell.
isPrimitiveType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+ Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )
isPrimTyCon tc
_ -> False
@@ -2669,7 +2670,7 @@ nonDetCmpTypesX _ _ [] = GT
-- See Note [nonDetCmpType nondeterminism]
nonDetCmpTc :: TyCon -> TyCon -> Ordering
nonDetCmpTc tc1 tc2
- = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) )
+ = assert (not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2)) $
u1 `nonDetCmpUnique` u2
where
u1 = tyConUnique tc1
@@ -2858,7 +2859,7 @@ tcIsConstraintKind :: Kind -> Bool
tcIsConstraintKind ty
| Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here
, isConstraintKindCon tc
- = ASSERT2( null args, ppr ty ) True
+ = assertPpr (null args) (ppr ty) True
| otherwise
= False
@@ -3282,7 +3283,7 @@ during type inference.
-- E.g. True of TYPE k, TYPE (F Int)
-- False of TYPE 'LiftedRep
isKindLevPoly :: Kind -> Bool
-isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k )
+isKindLevPoly k = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $
-- the isLiftedTypeKind check is necessary b/c of Constraint
go k
where
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
index 29ec60087c..513b246324 100644
--- a/compiler/GHC/Core/Unfold/Make.hs
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -149,8 +149,8 @@ specUnfolding :: SimpleOpts
--
specUnfolding opts spec_bndrs spec_app rule_lhs_args
df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
- = ASSERT2( rule_lhs_args `equalLength` old_bndrs
- , ppr df $$ ppr rule_lhs_args )
+ = assertPpr (rule_lhs_args `equalLength` old_bndrs)
+ (ppr df $$ ppr rule_lhs_args) $
-- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise
mkDFunUnfolding spec_bndrs con (map spec_arg args)
-- For DFunUnfoldings we transform
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index 3b67a0a6f8..bbdae319db 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -51,6 +51,7 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Exts( oneShot )
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import Data.Data ( Data )
@@ -308,7 +309,7 @@ roughMatchTcs tys = map rough tys
rough ty
| Just (ty', _) <- splitCastTy_maybe ty = rough ty'
| Just (tc,_) <- splitTyConApp_maybe ty
- , not (isTypeFamilyTyCon tc) = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc )
+ , not (isTypeFamilyTyCon tc) = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) $
KnownTc (tyConName tc)
-- See Note [Rough matching in class and family instances]
| otherwise = OtherTc
@@ -2021,7 +2022,7 @@ coreFlattenTyFamApp tv_subst env fam_tc fam_args
where
arity = tyConArity fam_tc
tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv
- (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )
+ (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $
splitAt arity fam_args
-- Apply the substitution before looking up an application in the
-- environment. See Note [Flattening type-family applications when matching instances],
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 01b35f4b1f..f63fc87e2a 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -96,8 +96,10 @@ import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.Multiplicity
import GHC.Types.Unique
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps( minusList )
@@ -180,7 +182,7 @@ mkFunctionType :: Mult -> Type -> Type -> Type
-- See GHC.Types.Var Note [AnonArgFlag]
mkFunctionType mult arg_ty res_ty
| isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag]
- = ASSERT(eqType mult Many)
+ = assert (eqType mult Many) $
mkInvisFunTy mult arg_ty res_ty
| otherwise
@@ -305,9 +307,9 @@ applyTypeToArgs e op_ty args
-- identity coercions and coalescing nested coercions
mkCast :: CoreExpr -> CoercionR -> CoreExpr
mkCast e co
- | ASSERT2( coercionRole co == Representational
- , text "coercion" <+> ppr co <+> text "passed to mkCast"
- <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )
+ | assertPpr (coercionRole co == Representational)
+ (text "coercion" <+> ppr co <+> text "passed to mkCast"
+ <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co)) $
isReflCo co
= e
@@ -614,8 +616,8 @@ This makes it easy to find, though it makes matching marginally harder.
-- | Extract the default case alternative
findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))
-findDefault (Alt DEFAULT args rhs : alts) = ASSERT( null args ) (alts, Just rhs)
-findDefault alts = (alts, Nothing)
+findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)
+findDefault alts = (alts, Nothing)
addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault alts Nothing = alts
@@ -640,7 +642,7 @@ findAlt con alts
= case con `cmpAltCon` con1 of
LT -> deflt -- Missed it already; the alts are in increasing order
EQ -> Just alt
- GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
+ GT -> assert (not (con1 == DEFAULT)) $ go alts deflt
{- Note [Unreachable code]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -695,8 +697,8 @@ trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
-- We want to drop the leading type argument of the scrutinee
-- leaving the arguments to match against the pattern
-trimConArgs DEFAULT args = ASSERT( null args ) []
-trimConArgs (LitAlt _) args = ASSERT( null args ) []
+trimConArgs DEFAULT args = assert (null args) []
+trimConArgs (LitAlt _) args = assert (null args) []
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities)
@@ -2027,7 +2029,7 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for
-- where the double-primed variables are created with the FastStrings and
-- Uniques given as fss and us
dataConInstPat fss uniqs mult con inst_tys
- = ASSERT( univ_tvs `equalLength` inst_tys )
+ = assert (univ_tvs `equalLength` inst_tys) $
(ex_bndrs, arg_ids)
where
univ_tvs = dataConUnivTyVars con
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index b9980a0edf..60ebf9e9be 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -631,15 +631,15 @@ toIfaceLFInfo nm lfi = case lfi of
LFReEntrant top_lvl arity no_fvs _arg_descr ->
-- Exported LFReEntrant closures are top level, and top-level closures
-- don't have free variables
- ASSERT2(isTopLevel top_lvl, ppr nm)
- ASSERT2(no_fvs, ppr nm)
+ assertPpr (isTopLevel top_lvl) (ppr nm) $
+ assertPpr no_fvs (ppr nm) $
IfLFReEntrant arity
LFThunk top_lvl no_fvs updatable sfi mb_fun ->
-- Exported LFThunk closures are top level (which don't have free
-- variables) and non-standard (see cgTopRhsClosure)
- ASSERT2(isTopLevel top_lvl, ppr nm)
- ASSERT2(no_fvs, ppr nm)
- ASSERT2(sfi == NonStandardThunk, ppr nm)
+ assertPpr (isTopLevel top_lvl) (ppr nm) $
+ assertPpr no_fvs (ppr nm) $
+ assertPpr (sfi == NonStandardThunk) (ppr nm) $
IfLFThunk updatable mb_fun
LFCon dc ->
IfLFCon (dataConName dc)
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index af8c8ae25b..fe2fb027c4 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -44,8 +44,8 @@ import GHC.Types.Literal
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Data.FastString
-import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Driver.Session
import GHC.Platform.Ways
import GHC.Driver.Ppr
@@ -311,7 +311,7 @@ coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
(env', ccs', bind)
coreTopBindToStg dflags this_mod env ccs (Rec pairs)
- = ASSERT( not (null pairs) )
+ = assert (not (null pairs)) $
let
binders = map fst pairs
@@ -344,7 +344,7 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
stg_arity =
stgRhsArity stg_rhs
- ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
+ ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,
ccs') }
where
-- It's vital that the arity on a top-level Id matches
@@ -455,7 +455,7 @@ coreToStgExpr (Case scrut bndr _ alts)
= -- This case is a bit smelly.
-- See Note [Nullary unboxed tuple] in GHC.Core.Type
-- where a nullary tuple is mapped to (State# World#)
- ASSERT( null binders )
+ assert (null binders) $
do { rhs2 <- coreToStgExpr rhs
; return (DEFAULT, [], rhs2) }
| otherwise
@@ -481,8 +481,7 @@ mkStgAltType bndr alts
Just tc
| isAbstractTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
- | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
- PolyAlt
+ | otherwise -> assertPpr (_is_poly_alt_tycon tc) (ppr tc) PolyAlt
Nothing -> PolyAlt
[non_gcd] -> PrimAlt non_gcd
not_unary -> MultiValAlt (length not_unary)
@@ -505,7 +504,7 @@ mkStgAltType bndr alts
| ((Alt (DataAlt con) _ _) : _) <- data_alts =
AlgAlt (dataConTyCon con)
| otherwise =
- ASSERT(null data_alts)
+ assert (null data_alts)
PolyAlt
where
(data_alts, _deflt) = findDefault alts
@@ -544,17 +543,17 @@ coreToStgApp f args ticks = do
-- Some primitive operator that might be implemented as a library call.
-- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
-- we require that primop applications be saturated.
- PrimOpId op -> ASSERT( saturated )
+ PrimOpId op -> assert saturated $
StgOpApp (StgPrimOp op) args' res_ty
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
PrimCallConv _))
- -> ASSERT( saturated )
+ -> assert saturated $
StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
-- A regular foreign call.
- FCallId call -> ASSERT( saturated )
+ FCallId call -> assert saturated $
StgOpApp (StgFCallOp call (idType f)) args' res_ty
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
@@ -585,7 +584,7 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token
; return (StgVarArg coercionTokenId : args', ts) }
coreToStgArgs (Tick t e : args)
- = ASSERT( not (tickishIsCode t) )
+ = assert (not (tickishIsCode t)) $
do { (args', ts) <- coreToStgArgs (e : args)
; let !t' = coreToStgTick (exprType e) t
; return (args', t':ts) }
@@ -724,8 +723,8 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
, -- Dynamic StgConApps are updatable
not (isDllConApp dflags this_mod con args)
= -- CorePrep does this right, but just to make sure
- ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
- , ppr bndr $$ ppr con $$ ppr args)
+ assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
+ (ppr bndr $$ ppr con $$ ppr args)
( StgRhsCon dontCareCCS con mn ticks args, ccs )
-- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
@@ -929,7 +928,7 @@ lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
Just xx -> xx
- Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
+ Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC this_mod =
@@ -961,8 +960,8 @@ myCollectArgs expr
where
go (Var v) as ts = (v, as, ts)
go (App f a) as ts = go f (a:as) ts
- go (Tick t e) as ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as
- , ppr e $$ ppr as $$ ppr ts )
+ go (Tick t e) as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as)
+ (ppr e $$ ppr as $$ ppr ts) $
-- See Note [Ticks in applications]
go e as (t:ts) -- ticks can appear in type apps
go (Cast e _) as ts = go e as ts
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 215c672446..30d08f130f 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -59,6 +59,7 @@ import GHC.Data.FastString
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable
import GHC.Utils.Monad ( mapAccumLM )
import GHC.Utils.Logger
@@ -290,7 +291,7 @@ corePrepTopBinds initialCorePrepEnv binds
go _ [] = return emptyFloats
go env (bind : binds) = do (env', floats, maybe_new_bind)
<- cpeBind TopLevel env bind
- MASSERT(isNothing maybe_new_bind)
+ massert (isNothing maybe_new_bind)
-- Only join points get returned this way by
-- cpeBind, and no join point may float to top
floatss <- go env' binds
@@ -613,7 +614,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
; return (env2, floats1, Nothing) }
| otherwise -- A join point; see Note [Join points and floating]
- = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point
+ = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point
do { (_, bndr1) <- cpCloneBndr env bndr
; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
; return (extendCorePrepEnv env bndr bndr2,
@@ -658,7 +659,7 @@ cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
-- Used for all bindings
-- The binder is already cloned, hence an OutId
cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
- = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair
+ = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair
do { (floats1, rhs1) <- cpeRhsE env rhs
-- See if we are allowed to float this stuff out of the RHS
@@ -736,7 +737,7 @@ cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-- Used for all join bindings
-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
cpeJoinPair env bndr rhs
- = ASSERT(isJoinId bndr)
+ = assert (isJoinId bndr) $
do { let Just join_arity = isJoinId_maybe bndr
(bndrs, body) = collectNBinders join_arity rhs
@@ -1110,7 +1111,7 @@ cpeApp top_env expr
-> [Demand]
-> UniqSM (CpeApp, Floats)
rebuild_app _ [] app floats ss
- = ASSERT(null ss) -- make sure we used all the strictness info
+ = assert (null ss) -- make sure we used all the strictness info
return (app, floats)
rebuild_app env (a : as) fun' floats ss = case a of
@@ -1620,7 +1621,7 @@ mkFloat dmd is_unlifted bndr rhs
-- Otherwise we get case (\x -> e) of ...!
| is_unlifted = FloatCase rhs bndr DEFAULT [] True
- -- we used to ASSERT2(ok_for_spec, ppr rhs) here, but it is now disabled
+ -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled
-- because exprOkForSpeculation isn't stable under ANF-ing. See for
-- example #19489 where the following unlifted expression:
--
@@ -2101,7 +2102,7 @@ wrapTicks (Floats flag floats0) expr =
-- those early, as relying on mkTick to spot it after the fact
-- can yield O(n^3) complexity [#11095]
go (floats, ticks) (FloatTick t)
- = ASSERT(tickishPlace t == PlaceNonLam)
+ = assert (tickishPlace t == PlaceNonLam)
(floats, if any (flip tickishContains t) ticks
then ticks else t:ticks)
go (floats, ticks) f
diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs
index 66bd8cf3ba..6c06e6017c 100644
--- a/compiler/GHC/Data/List/SetOps.hs
+++ b/compiler/GHC/Data/List/SetOps.hs
@@ -38,7 +38,7 @@ import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Set as S
getNth :: Outputable a => [a] -> Int -> a
-getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
+getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $
xs !! n
{-
diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs
index 0de4b007ba..0932397ae5 100644
--- a/compiler/GHC/Data/StringBuffer.hs
+++ b/compiler/GHC/Data/StringBuffer.hs
@@ -56,7 +56,6 @@ import GHC.Data.FastString
import GHC.Utils.Encoding
import GHC.Utils.IO.Unsafe
import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
import GHC.Utils.Exception ( bracket_ )
import Data.Maybe
@@ -150,7 +149,7 @@ skipBOM h size offset =
if size > 0 && offset == 0
then do
-- Validate assumption that handle is in binary mode.
- ASSERTM( hGetEncoding h >>= return . isNothing )
+ assertM (hGetEncoding h >>= return . isNothing)
-- Temporarily select utf8 encoding with error ignoring,
-- to make `hLookAhead` and `hGetChar` return full Unicode characters.
bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do
diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs
index 568e83e795..1283723e05 100644
--- a/compiler/GHC/Driver/CmdLine.hs
+++ b/compiler/GHC/Driver/CmdLine.hs
@@ -30,6 +30,7 @@ import GHC.Prelude
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.Bag
import GHC.Types.SrcLoc
import GHC.Utils.Json
@@ -224,7 +225,7 @@ processOneArg opt_kind rest arg args
= let dash_arg = '-' : arg
rest_no_eq = dropEq rest
in case opt_kind of
- NoArg a -> ASSERT(null rest) Right (a, args)
+ NoArg a -> assert (null rest) Right (a, args)
HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
| otherwise -> case args of
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 79d9e47088..3d59e72468 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -263,7 +263,7 @@ lookupType hsc_env name = do
let pte = eps_PTE eps
hpt = hsc_HPT hsc_env
- mod = ASSERT2( isExternalName name, ppr name )
+ mod = assertPpr (isExternalName name) (ppr name) $
if isHoleName name
then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))
else nameModule name
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 3f4844b57c..4768c17f9f 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -207,6 +207,7 @@ import GHC.Types.HpcInfo
import GHC.Utils.Fingerprint ( Fingerprint )
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
@@ -333,7 +334,7 @@ ioMsgMaybe ioA = do
logDiagnostics warns
case mb_r of
Nothing -> throwErrors errs
- Just r -> ASSERT( isEmptyMessages errs ) return r
+ Just r -> assert (isEmptyMessages errs ) return r
-- | like ioMsgMaybe, except that we ignore error messages and return
-- 'Nothing' instead.
@@ -540,7 +541,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
src_filename = ms_hspp_file mod_summary
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
keep_rn' = gopt Opt_WriteHie dflags || keep_rn
- MASSERT( isHomeModule home_unit outer_mod )
+ massert (isHomeModule home_unit outer_mod)
tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 654ba697a1..4181e13ab5 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -82,6 +82,7 @@ import GHC.Utils.Exception ( tryIO, AsyncException(..), evaluate )
import GHC.Utils.Monad ( allM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
@@ -425,7 +426,7 @@ load' how_much mHscMessage mod_graph = do
-- files without corresponding hs files.
-- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
-- not (ms_mod_name s `elem` all_home_mods)]
- -- ASSERT( null bad_boot_mods ) return ()
+ -- assert (null bad_boot_mods ) return ()
-- check that the module given in HowMuch actually exists, otherwise
-- topSortModuleGraph will bomb later.
@@ -519,8 +520,9 @@ load' how_much mHscMessage mod_graph = do
-- is stable).
partial_mg
| LoadDependenciesOf _mod <- how_much
- = ASSERT( case last partial_mg0 of
- AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )
+ = assert (case last partial_mg0 of
+ AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod
+ _ -> False) $
List.init partial_mg0
| otherwise
= partial_mg0
@@ -658,7 +660,7 @@ load' how_much mHscMessage mod_graph = do
|| allHpt (isJust.hm_linkable)
(filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
hpt5)
- ASSERT( just_linkables ) do
+ assert just_linkables $ do
-- Link everything together
hsc_env <- getSession
@@ -1765,7 +1767,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
| not (backendProducesObject bcknd), is_stable_bco,
(bcknd /= NoBackend) `implies` not is_fake_linkable ->
- ASSERT(isJust old_hmi) -- must be in the old_hpt
+ assert (isJust old_hmi) $ -- must be in the old_hpt
let Just hmi = old_hmi in do
debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
return hmi
@@ -2893,7 +2895,7 @@ cyclicModuleErr :: [ModuleGraphNode] -> SDoc
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr mss
- = ASSERT( not (null mss) )
+ = assert (not (null mss)) $
case findCycle graph of
Nothing -> text "Unexpected non-cycle" <+> ppr mss
Just path0 -> vcat
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index f49dca22ad..bffeb65850 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -28,6 +28,7 @@ import qualified GHC.SysTools as SysTools
import GHC.Data.Graph.Directed ( SCC(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import Data.List (partition)
@@ -418,7 +419,7 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
pp_group (AcyclicSCC ms) = pp_ms ms
pp_group (CyclicSCC mss)
- = ASSERT( not (null boot_only) )
+ = assert (not (null boot_only)) $
-- The boot-only list must be non-empty, else there would
-- be an infinite chain of non-boot imports, and we've
-- already checked for that in processModDeps
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 5496fe31a2..b116c30693 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -73,6 +73,7 @@ import GHC.Linker.Types
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Exception as Exception
@@ -136,7 +137,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $
MC.handle handler $
fmap Right $ do
- MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
+ massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn)
(dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)
Nothing
-- We keep the processed file for the whole session to save on
@@ -145,7 +146,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
Nothing{-no ModLocation-}
[]{-no foreign objects-}
-- We stop before Hsc phase so we shouldn't generate an interface
- MASSERT(isNothing mb_iface)
+ massert (isNothing mb_iface)
return (dflags, fp)
where
srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
@@ -228,7 +229,7 @@ compileOne' m_tc_result mHscMessage
case (status, bcknd) of
(HscUpToDate iface hmi_details, _) ->
-- TODO recomp014 triggers this assert. What's going on?!
- -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )
+ -- assert (isJust mb_old_linkable || isNoLink (ghcLink dflags) )
return $! HomeModInfo iface hmi_details mb_old_linkable
(HscNotGeneratingCode iface hmi_details, NoBackend) ->
let mb_linkable = if isHsBootOrSig src_flavour
diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs
index b6dee0f8e3..b663e8bbff 100644
--- a/compiler/GHC/Driver/Ppr.hs
+++ b/compiler/GHC/Driver/Ppr.hs
@@ -28,6 +28,7 @@ import {-# SOURCE #-} GHC.Driver.Session
import {-# SOURCE #-} GHC.Unit.State
import GHC.Utils.Exception
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -123,16 +124,12 @@ pprTraceException heading doc =
pprSTrace :: HasCallStack => SDoc -> a -> a
pprSTrace doc = pprTrace "" (doc $$ callStackDoc)
-warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a
--- ^ Just warn about an assertion failure, recording the given file and line number.
--- Should typically be accessed with the WARN macros
-warnPprTrace _ _ _ _ x | not debugIsOn = x
-warnPprTrace _ _file _line _msg x
- | unsafeHasNoDebugOutput = x
-warnPprTrace False _file _line _msg x = x
-warnPprTrace True file line msg x
- = pprDebugAndThen defaultSDocContext trace heading
+-- | Just warn about an assertion failure, recording the given file and line number.
+warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
+warnPprTrace _ _ x | not debugIsOn = x
+warnPprTrace _ _msg x | unsafeHasNoDebugOutput = x
+warnPprTrace False _msg x = x
+warnPprTrace True msg x
+ = pprDebugAndThen defaultSDocContext trace (text "WARNING:")
(msg $$ callStackDoc )
x
- where
- heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
diff --git a/compiler/GHC/Driver/Ppr.hs-boot b/compiler/GHC/Driver/Ppr.hs-boot
index a1f864bda8..58f812d6d8 100644
--- a/compiler/GHC/Driver/Ppr.hs-boot
+++ b/compiler/GHC/Driver/Ppr.hs-boot
@@ -6,4 +6,4 @@ import {-# SOURCE #-} GHC.Driver.Session
import {-# SOURCE #-} GHC.Utils.Outputable
showSDoc :: DynFlags -> SDoc -> String
-warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a
+warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 2673840100..25c55819c5 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -240,6 +240,7 @@ import GHC.Settings.Constants
import GHC.Utils.Panic
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Utils.Misc
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.GlobalVars
import GHC.Data.Maybe
import GHC.Utils.Monad
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 3cff120713..305b27f327 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -58,6 +58,7 @@ import GHC.Unit.Module (ModuleName)
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Core.Type
import GHC.Builtin.Types (mkTupleStr)
@@ -1280,7 +1281,7 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
= case ctxt of
FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
| SrcStrict <- strictness
- -> ASSERT(null pats) -- A strict variable binding
+ -> assert (null pats) -- A strict variable binding
(char '!'<>pprPrefixOcc fun, pats)
| Prefix <- fixity
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index a5f638ab12..2db6b6b18f 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -65,7 +65,7 @@ import GHC.Data.OrdList
import GHC.Utils.Error
import GHC.Utils.Outputable
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Logger
@@ -211,7 +211,7 @@ deSugar hsc_env
-- never desugared and compiled (there's no code!)
-- Consequently, this should hold for any ModGuts that make
-- past desugaring. See Note [Identity versus semantic module].
- ; MASSERT( id_mod == mod )
+ ; massert (id_mod == mod)
; foreign_files <- readIORef th_foreign_files_var
@@ -298,7 +298,7 @@ deSugarExpr hsc_env tc_expr = do
initDsTc $
dsLExpr tc_expr
- MASSERT( isEmptyMessages tc_msgs ) -- the type-checker isn't doing anything here
+ massert (isEmptyMessages tc_msgs) -- the type-checker isn't doing anything here
-- mb_result is Nothing only when a failure happens in the type-checker,
-- but mb_core_expr is Nothing when a failure happens in the desugarer
@@ -698,8 +698,8 @@ patchMagicDefn orig_pair@(orig_id, orig_rhs)
= do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs
-- Patching should not change the Name or the type of the Id
- ; MASSERT( getUnique magic_id == getUnique orig_id )
- ; MASSERT( varType magic_id `eqType` varType orig_id )
+ ; massert (getUnique magic_id == getUnique orig_id)
+ ; massert (varType magic_id `eqType` varType orig_id)
; return magic_pair }
| otherwise
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 7af84d1d06..760fbe166c 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -62,6 +62,8 @@ import GHC.Types.Var.Env
import GHC.Types.Var( EvVar )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Unit.Module
import GHC.Types.SrcLoc
import GHC.Data.Maybe
@@ -98,7 +100,7 @@ dsTopLHsBinds binds
= do { (force_vars, prs) <- dsLHsBinds binds
; when debugIsOn $
do { xstrict <- xoptM LangExt.Strict
- ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
+ ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }
-- with -XStrict, even top-level vars are listed as force vars.
; return (toOL prs) }
@@ -1139,7 +1141,7 @@ dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc)
; if ok
then return (\e -> (Lam x (w2 (app e arg))))
else return id } -- this return is irrelevant
-dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational)
+dsHsWrapper (WpCast co) = assert (coercionRole co == Representational) $
return $ \e -> mkCastDs e co
dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm
; return (\e -> App e core_tm) }
@@ -1150,7 +1152,7 @@ dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $
--------------------------------------
dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [] = return []
-dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null
+dsTcEvBinds_s (b:rest) = assert (null rest) $ -- Zonker ensures null
dsTcEvBinds b
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 176aa1bc02..64e799d0e9 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -70,6 +70,7 @@ import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Core.PatSyn
import Control.Monad
import Data.Void( absurd )
@@ -161,19 +162,19 @@ ds_val_bind (NonRecursive, hsbinds) body
ds_val_bind (is_rec, binds) _body
| anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds
- = ASSERT( isRec is_rec )
+ = assert (isRec is_rec )
errDsCoreExpr $
hang (text "Recursive bindings for unlifted types aren't allowed:")
2 (vcat (map ppr (bagToList binds)))
-- Ordinary case for bindings; none should be unlifted
ds_val_bind (is_rec, binds) body
- = do { MASSERT( isRec is_rec || isSingletonBag binds )
+ = do { massert (isRec is_rec || isSingletonBag binds)
-- we should never produce a non-recursive list of multiple binds
; (force_vars,prs) <- dsLHsBinds binds
; let body' = foldr seqVar body force_vars
- ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
+ ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $
case prs of
[] -> return body
_ -> return (Let (Rec prs) body') }
@@ -209,8 +210,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun
-- so must be simply unboxed
= do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
Nothing matches
- ; MASSERT( null args ) -- Functions aren't lifted
- ; MASSERT( isIdHsWrapper co_fn )
+ ; massert (null args) -- Functions aren't lifted
+ ; massert (isIdHsWrapper co_fn)
; let rhs' = mkOptTickBox tick rhs
; return (bindNonRec fun rhs' body) }
@@ -245,9 +246,9 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
-- function in GHC.Tc.Utils.Zonk:
-- putSrcSpanDs loc $ do
-- { core_expr <- dsExpr e
--- ; MASSERT2( exprType core_expr `eqType` hsExprType e
--- , ppr e <+> dcolon <+> ppr (hsExprType e) $$
--- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
+-- ; massertPpr (exprType core_expr `eqType` hsExprType e)
+-- (ppr e <+> dcolon <+> ppr (hsExprType e) $$
+-- ppr core_expr <+> dcolon <+> ppr (exprType core_expr))
-- ; return core_expr }
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (L loc e) =
@@ -484,7 +485,7 @@ dsExpr (RecordCon { rcon_con = L _ con_like
mk_arg (arg_ty, fl)
= case findField (rec_flds rbinds) (flSelector fl) of
- (rhs:rhss) -> ASSERT( null rhss )
+ (rhs:rhss) -> assert (null rhss )
dsLExprNoLP rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
@@ -603,7 +604,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields
| null fields
= dsLExpr record_expr
| otherwise
- = ASSERT2( notNull cons_to_upd, ppr expr )
+ = assertPpr (notNull cons_to_upd) (ppr expr) $
do { record_expr' <- dsLExpr record_expr
; field_binds' <- mapM ds_field fields
@@ -771,7 +772,7 @@ dsExpr (HsTick _ tickish e) = do
dsExpr (HsBinTick _ ixT ixF e) = do
e2 <- dsLExpr e
- do { ASSERT(exprType e2 `eqType` boolTy)
+ do { assert (exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
@@ -938,7 +939,7 @@ dsDo ctx stmts
goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts)
go _ (LastStmt _ body _ _) stmts
- = ASSERT( null stmts ) dsLExpr body
+ = assert (null stmts ) dsLExpr body
-- The 'return' op isn't used for 'do' expressions
go _ (BodyStmt _ rhs then_expr _) stmts
diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs
index 5cf906e376..f946a8be25 100644
--- a/compiler/GHC/HsToCore/Foreign/Call.hs
+++ b/compiler/GHC/HsToCore/Foreign/Call.hs
@@ -46,8 +46,8 @@ import GHC.Types.Literal
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Utils.Outputable
-import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.Maybe
@@ -120,7 +120,7 @@ mkFCall :: DynFlags -> Unique -> ForeignCall
-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
-- a b s x c
mkFCall dflags uniq the_fcall val_args res_ty
- = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level
+ = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level
mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where
arg_tys = map exprType val_args
@@ -163,7 +163,7 @@ unboxArg arg
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
- = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
+ = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $
-- Typechecker ensures this
do case_bndr <- newSysLocalDs Many arg_ty
prim_arg <- newSysLocalDs Many data_con_arg_ty1
@@ -289,7 +289,7 @@ mk_alt return_result (Nothing, wrap_result)
mk_alt return_result (Just prim_res_ty, wrap_result)
= -- The ccall returns a non-() value
- ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
+ assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $
-- True because resultWrapper ensures it is so
do { result_id <- newSysLocalDs Many prim_res_ty
; state_id <- newSysLocalDs Many realWorldStatePrimTy
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 933e8241e2..ff1fb52eba 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -57,8 +57,8 @@ import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Platform
import GHC.Data.OrdList
-import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Driver.Hooks
import GHC.Utils.Encoding
@@ -174,7 +174,7 @@ dsCImport id co (CLabel cid) cconv _ _ = do
IsFunction
_ -> IsData
(resTy, foRhs) <- resultWrapper ty
- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
+ assert (fromJust resTy `eqType` addrPrimTy) $ -- typechecker ensures this
let
rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
rhs' = Cast rhs co
@@ -819,8 +819,8 @@ getPrimTyOf ty
| otherwise =
case splitDataProductType_maybe rep_ty of
Just (_, _, data_con, [Scaled _ prim_ty]) ->
- ASSERT(dataConSourceArity data_con == 1)
- ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
+ assert (dataConSourceArity data_con == 1) $
+ assertPpr (isUnliftedType prim_ty) (ppr prim_ty)
prim_ty
_other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)
where
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 4ad474ceb7..6469b7b969 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -30,6 +30,7 @@ import GHC.Utils.Misc
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Core.Multiplicity
import Control.Monad ( zipWithM )
import Data.List.NonEmpty ( NonEmpty, toList )
@@ -63,8 +64,8 @@ dsGRHSs :: HsMatchContext GhcRn
-- one for each GRHS.
-> DsM (MatchResult CoreExpr)
dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
- = ASSERT( notNull grhss )
- do { match_results <- ASSERT( length grhss == length rhss_nablas )
+ = assert (notNull grhss) $
+ do { match_results <- assert (length grhss == length rhss_nablas) $
zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss
; nablas <- getPmNablas
-- We need to remember the Nablas from the particular match context we
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index e2691de6c0..d96825937b 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -35,9 +35,9 @@ import GHC.Builtin.Names
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Tc.Utils.TcType
import GHC.Data.List.SetOps( getNth )
-import GHC.Utils.Misc
{-
List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -222,7 +222,7 @@ deListComp [] _ = panic "deListComp"
deListComp (LastStmt _ body _ _ : quals) list
= -- Figure 7.4, SLPJ, p 135, rule C above
- ASSERT( null quals )
+ assert (null quals) $
do { core_body <- dsLExpr body
; return (mkConsExpr (exprType core_body) core_body list) }
@@ -329,7 +329,7 @@ dfListComp :: Id -> Id -- 'c' and 'n'
dfListComp _ _ [] = panic "dfListComp"
dfListComp c_id n_id (LastStmt _ body _ _ : quals)
- = ASSERT( null quals )
+ = assert (null quals) $
do { core_body <- dsLExprNoLP body
; return (mkApps (Var c_id) [core_body, Var n_id]) }
@@ -485,7 +485,7 @@ dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDsA loc (dsMcStmt stmt lstmts)
dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsMcStmt (LastStmt _ body _ ret_op) stmts
- = ASSERT( null stmts )
+ = assert (null stmts) $
do { body' <- dsLExpr body
; dsSyntaxExpr ret_op [body'] }
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index a5960529c5..e80c751cb4 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -61,6 +61,7 @@ import GHC.Utils.Misc
import GHC.Types.Name
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Types.Unique
import GHC.Types.Unique.DFM
@@ -184,15 +185,15 @@ match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
-> DsM (MatchResult CoreExpr) -- ^ Desugared result!
match [] ty eqns
- = ASSERT2( not (null eqns), ppr ty )
+ = assertPpr (not (null eqns)) (ppr ty) $
return (foldr1 combineMatchResults match_results)
where
- match_results = [ ASSERT( null (eqn_pats eqn) )
+ match_results = [ assert (null (eqn_pats eqn)) $
eqn_rhs eqn
| eqn <- eqns ]
match (v:vs) ty eqns -- Eqns *can* be empty
- = ASSERT2( all (isInternalName . idName) vars, ppr vars )
+ = assertPpr (all (isInternalName . idName) vars) (ppr vars) $
do { dflags <- getDynFlags
; let platform = targetPlatform dflags
-- Tidy the first pattern, generating
@@ -574,12 +575,12 @@ push_bang_into_newtype_arg :: SrcSpanAnnA
-- See Note [Bang patterns and newtypes]
-- We are transforming !(N p) into (N !p)
push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))
- = ASSERT( null args)
+ = assert (null args) $
PrefixCon ts [L l (BangPat noExtField arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
| HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
- = ASSERT( null flds)
+ = assert (null flds) $
RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
= L l (BangPat noExtField arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
@@ -873,7 +874,7 @@ matchSinglePatVar :: Id -- See Note [Match Ids]
-> HsMatchContext GhcRn -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar var mb_scrut ctx pat ty match_result
- = ASSERT2( isInternalName (idName var), ppr var )
+ = assertPpr (isInternalName (idName var)) (ppr var) $
do { dflags <- getDynFlags
; locn <- getSrcSpanDs
-- Pattern match check warnings
@@ -1171,7 +1172,7 @@ patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
(HsFractional f, is_neg)
| is_neg -> PgN $! negateFractionalLit f
| otherwise -> PgN f
- (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
+ (HsIsString _ s, _) -> assert (isNothing mb_neg) $
PgOverS s
patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
case oval of
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index 39817044cc..b4acb7fa47 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -36,6 +36,7 @@ import GHC.Types.FieldLabel ( flSelector )
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad(liftM)
import Data.List (groupBy)
import Data.List.NonEmpty (NonEmpty(..))
@@ -133,10 +134,10 @@ matchOneConLike :: [Id]
-> NonEmpty EquationInfo
-> DsM (CaseAlt ConLike)
matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor
- = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
+ = do { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $
-- ex_tvs can only be tyvars as data types in source
-- Haskell cannot mention covar yet (Aug 2018).
- ASSERT( tvs1 `equalLength` ex_tvs )
+ assert (tvs1 `equalLength` ex_tvs) $
arg_tys ++ mkTyVarTys tvs1
val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
@@ -147,7 +148,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
- = ASSERT( notNull arg_eqn_prs )
+ = assert (notNull arg_eqn_prs) $
do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
; match_result <- match (group_arg_vars ++ vars) ty eqns'
@@ -216,8 +217,8 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
| RecCon flds <- arg_pats
, let rpats = rec_flds flds
, not (null rpats) -- Treated specially; cf conArgPats
- = ASSERT2( fields1 `equalLength` arg_vars,
- ppr con1 $$ ppr fields1 $$ ppr arg_vars )
+ = assertPpr (fields1 `equalLength` arg_vars)
+ (ppr con1 $$ ppr fields1 $$ ppr arg_vars) $
map lookup_fld rpats
| otherwise
= arg_vars
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index a3cc8f44af..1a1ce99ead 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -56,6 +56,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
@@ -204,7 +205,7 @@ dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = b
!denom = mkIntegerExpr (denominator val)
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
- (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+ (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 01b712a102..7d7ea92071 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -33,7 +33,6 @@ import GHC.Builtin.Names (rationalTyConName)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc
import GHC.Core.DataCon
import GHC.Types.Var (EvVar)
import GHC.Core.Coercion
@@ -405,7 +404,8 @@ desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
let go_export :: ABExport GhcTc -> Maybe PmGrd
go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}
| isIdHsWrapper wrap
- = ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y))
+ = assertPpr (idType x `eqType` idType y)
+ (ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y)) $
Just $ PmLet x (Var y)
| otherwise
= Nothing
diff --git a/compiler/GHC/HsToCore/Pmc/Ppr.hs b/compiler/GHC/HsToCore/Pmc/Ppr.hs
index 3de6a14970..7a15a18528 100644
--- a/compiler/GHC/HsToCore/Pmc/Ppr.hs
+++ b/compiler/GHC/HsToCore/Pmc/Ppr.hs
@@ -21,8 +21,8 @@ import GHC.Core.DataCon
import GHC.Builtin.Types
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad.Trans.RWS.CPS
-import GHC.Utils.Misc
import GHC.Data.Maybe
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
@@ -203,8 +203,8 @@ pmExprAsList nabla = go_con []
go_con rev_pref (PmAltConLike (RealDataCon c)) es
| c == nilDataCon
- = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))
+ = assert (null es) $ Just (NilTerminated (reverse rev_pref))
| c == consDataCon
- = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)
+ = assert (length es == 2) $ go_var (es !! 0 : rev_pref) (es !! 1)
go_con _ _ _
= Nothing
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
index 726652924d..bc663a3184 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -47,6 +47,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Monad (allM)
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.Bag
import GHC.Types.CompleteMatch
import GHC.Types.Unique.Set
@@ -397,7 +398,7 @@ pmIsClosedType ty
= case splitTyConApp_maybe ty of
Just (tc, ty_args)
| is_algebraic_like tc && not (isFamilyTyCon tc)
- -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+ -> assertPpr (ty_args `lengthIs` tyConArity tc) (ppr ty) True
_other -> False
where
-- This returns True for TyCons which /act like/ algebraic types.
@@ -796,7 +797,7 @@ addNotConCt nabla x nalt = do
-- See Note [Completeness checking with required Thetas]
| hasRequiredTheta nalt = neg
| otherwise = extendPmAltConSet neg nalt
- MASSERT( isPmAltConMatchStrict nalt )
+ massert (isPmAltConMatchStrict nalt)
let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot }
-- 3. Make sure there's at least one other possible constructor
mb_rcm' <- lift (markMatched nalt rcm)
@@ -853,7 +854,7 @@ addConCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x alt tvs args =
MaybeBot -> pure (nabla_with MaybeBot)
IsBot -> addBotCt (nabla_with MaybeBot) y
IsNotBot -> addNotBotCt (nabla_with MaybeBot) y
- _ -> ASSERT( isPmAltConMatchStrict alt )
+ _ -> assert (isPmAltConMatchStrict alt )
pure (nabla_with IsNotBot) -- strict match ==> not ⊥
equateTys :: [Type] -> [Type] -> [PhiCt]
diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
index 7516a56995..2961cb7433 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
@@ -36,7 +36,6 @@ module GHC.HsToCore.Pmc.Solver.Types (
import GHC.Prelude
-import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Types.Id
@@ -47,7 +46,7 @@ import GHC.Types.Name
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Utils.Outputable
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.List.SetOps (unionLists)
import GHC.Data.Maybe
import GHC.Core.Type
@@ -431,7 +430,7 @@ instance Eq PmAltCon where
-- | Type of a 'PmAltCon'
pmAltConType :: PmAltCon -> [Type] -> Type
-pmAltConType (PmAltLit lit) _arg_tys = ASSERT( null _arg_tys ) pmLitType lit
+pmAltConType (PmAltLit lit) _arg_tys = assert (null _arg_tys ) $ pmLitType lit
pmAltConType (PmAltConLike con) arg_tys = conLikeResTy con arg_tys
-- | Is a match on this constructor forcing the match variable?
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index e13f0ceb50..26341017ba 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -65,6 +65,7 @@ import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad
@@ -128,7 +129,7 @@ mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
(mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))
- MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)
+ massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)
let m_ty = Type m_var
-- Construct the contents of MetaWrappers
@@ -1796,7 +1797,7 @@ repSts (stmt@RecStmt{} : ss)
-- Bring all of binders in the recursive group into scope for the
-- whole group.
; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt))
- ; MASSERT(sort ss1 == sort ss1_other)
+ ; massert (sort ss1 == sort ss1_other)
; z <- repRecSt (nonEmptyCoreList rss)
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
@@ -2172,7 +2173,7 @@ globalVar name
; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))
; rep2_nwDsM mkNameLName [occ,uni] }
where
- mod = ASSERT( isExternalName name) nameModule name
+ mod = assert (isExternalName name) nameModule name
name_mod = moduleNameString (moduleName mod)
name_pkg = unitString (moduleUnit mod)
name_occ = nameOccName name
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index a0fadacb89..4b1e6e4346 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -289,7 +289,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
| isWiredInName name = mv_map -- ignore wired-in names
| otherwise
= case nameModule_maybe name of
- Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map
+ Nothing -> assertPpr (isSystemName name) (ppr name) mv_map
-- See Note [Internal used_names]
Just mod ->
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 002cf8d4b2..32e4e0990d 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -78,6 +78,7 @@ import GHC.Builtin.Names
import GHC.Types.Name( isInternalName )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Utils.Misc
@@ -144,7 +145,7 @@ selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var))
-- multiplicity stored within the variable
-- itself. It's easier to pull it from the
-- variable, so we ignore the multiplicity.
-selectMatchVar _w (AsPat _ var _) = ASSERT( isManyDataConTy _w ) (return (unLoc var))
+selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var))
selectMatchVar w other_pat = newSysLocalDsNoLP w (hsPatType other_pat)
{- Note [Localise pattern binders]
@@ -198,7 +199,7 @@ worthy of a type synonym and a few handy functions.
-}
firstPat :: EquationInfo -> Pat GhcTc
-firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
+firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)
shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
-- Drop the first pattern in each equation
@@ -283,7 +284,7 @@ mkCoPrimCaseMatchResult var ty match_alts
sorted_alts = sortWith fst match_alts -- Right order for a Case
mk_alt fail (lit, mr)
- = ASSERT( not (litIsLifted lit) )
+ = assert (not (litIsLifted lit)) $
do body <- runMatchResult fail mr
return (Alt (LitAlt lit) [] body)
@@ -299,7 +300,7 @@ mkCoAlgCaseMatchResult
-> MatchResult CoreExpr
mkCoAlgCaseMatchResult var ty match_alts
| isNewtype -- Newtype case; use a let
- = ASSERT( null match_alts_tail && null (tail arg_ids1) )
+ = assert (null match_alts_tail && null (tail arg_ids1)) $
mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
| otherwise
@@ -313,7 +314,7 @@ mkCoAlgCaseMatchResult var ty match_alts
alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail
= match_alts
-- Stuff for newtype
- arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
+ arg_id1 = assert (notNull arg_ids1) $ head arg_ids1
var_ty = idType var
(tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
-- (not that splitTyConApp does, these days)
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index 293058f0ca..c796ed1713 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -51,7 +51,6 @@ import GHC.Types.SrcLoc
import GHC.Platform
import GHC.Data.FastString
import GHC.Settings.Constants
-import GHC.Utils.Misc
import Data.Array
import Data.Array.IO
@@ -300,7 +299,7 @@ getSymbolTable bh name_cache = do
serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName bh name _ = do
- let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+ let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
@@ -329,7 +328,7 @@ putName _dict BinSymbolTable{
bh name
| isKnownKeyName name
, let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
- = -- ASSERT(u < 2^(22 :: Int))
+ = -- assert (u < 2^(22 :: Int))
put_ bh (0x80000000
.|. (fromIntegral (ord c) `shiftL` 22)
.|. (fromIntegral u :: Word32))
@@ -340,7 +339,7 @@ putName _dict BinSymbolTable{
Just (off,_) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt symtab_next
- -- MASSERT(off < 2^(30 :: Int))
+ -- massert (off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 692e4a2213..d2e172dbba 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -57,6 +57,7 @@ import GHC.Types.Var.Env
import GHC.Builtin.Uniques
import GHC.Iface.Make ( mkIfaceExports )
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.FastString
@@ -907,7 +908,7 @@ instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
detSpan = case detScope of
LocalScope a -> Just a
_ -> Nothing
- toBind (PrefixCon ts args) = ASSERT(null ts) PrefixCon ts $ map (C Use) args
+ toBind (PrefixCon ts args) = assert (null ts) $ PrefixCon ts $ map (C Use) args
toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
toBind (RecCon r) = RecCon $ map (PSC detSpan) r
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 99fcfcd4dd..2d474d0da3 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -64,7 +64,8 @@ import GHC.Utils.Binary ( BinData(..) )
import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import GHC.Settings.Constants
@@ -165,13 +166,13 @@ importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
importDecl name
- = ASSERT( not (isWiredInName name) )
+ = assert (not (isWiredInName name)) $
do { dflags <- getDynFlags
; logger <- getLogger
; liftIO $ trace_if logger dflags nd_doc
-- Load the interface, which should populate the PTE
- ; mb_iface <- ASSERT2( isExternalName name, ppr name )
+ ; mb_iface <- assertPpr (isExternalName name) (ppr name) $
loadInterface nd_doc (nameModule name) ImportBySystem
; case mb_iface of {
Failed err_msg -> return (Failed err_msg) ;
@@ -245,7 +246,7 @@ checkWiredInTyCon tc
; dflags <- getDynFlags
; logger <- getLogger
; liftIO $ trace_if logger dflags (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)
- ; ASSERT( isExternalName tc_name )
+ ; assert (isExternalName tc_name )
when (mod /= nameModule tc_name)
(initIfaceTcRn (loadWiredInHomeIface tc_name))
-- Don't look for (non-existent) Float.hi when
@@ -268,7 +269,7 @@ ifCheckWiredInThing thing
-- the HPT, so without the test we'll demand-load it into the PIT!
-- C.f. the same test in checkWiredInTyCon above
; let name = getName thing
- ; ASSERT2( isExternalName name, ppr name )
+ ; assertPpr (isExternalName name) (ppr name) $
when (needWiredInHomeIface thing && mod /= nameModule name)
(loadWiredInHomeIface name) }
@@ -348,8 +349,8 @@ loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
loadInterfaceForName doc name
= do { when debugIsOn $ -- Check pre-condition
do { this_mod <- getModule
- ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }
- ; ASSERT2( isExternalName name, ppr name )
+ ; massertPpr (not (nameIsLocalOrFrom this_mod name)) (ppr name <+> parens doc) }
+ ; assertPpr (isExternalName name) (ppr name) $
initIfaceTcRn $ loadSysInterface doc (nameModule name) }
-- | Only loads the interface for external non-local names.
@@ -368,7 +369,7 @@ loadInterfaceForModule doc m
-- Should not be called with this module
when debugIsOn $ do
this_mod <- getModule
- MASSERT2( this_mod /= m, ppr m <+> parens doc )
+ massertPpr (this_mod /= m) (ppr m <+> parens doc)
initIfaceTcRn $ loadSysInterface doc m
{-
@@ -388,7 +389,7 @@ loadInterfaceForModule doc m
-- See Note [Loading instances for wired-in things]
loadWiredInHomeIface :: Name -> IfM lcl ()
loadWiredInHomeIface name
- = ASSERT( isWiredInName name )
+ = assert (isWiredInName name) $
do _ <- loadSysInterface doc (nameModule name); return ()
where
doc = text "Need home interface for wired-in thing" <+> ppr name
@@ -692,7 +693,7 @@ computeInterface
-> Module
-> IO (MaybeErr SDoc (ModIface, FilePath))
computeInterface hsc_env doc_str hi_boot_file mod0 = do
- MASSERT( not (isHoleModule mod0) )
+ massert (not (isHoleModule mod0))
let name_cache = hsc_NC hsc_env
let fc = hsc_FC hsc_env
let home_unit = hsc_home_unit hsc_env
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 323f69f0d3..01c547023c 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -76,7 +76,7 @@ import GHC.Types.HpcInfo
import GHC.Types.CompleteMatch
import GHC.Utils.Outputable
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc hiding ( eqListBy )
import GHC.Utils.Logger
@@ -646,7 +646,7 @@ classToIfaceDecl env clas
(env2, if_decl) = tyConToIfaceDecl env1 tc
toIfaceClassOp (sel_id, def_meth)
- = ASSERT( sel_tyvars == binderVars tc_binders )
+ = assert (sel_tyvars == binderVars tc_binders) $
IfaceClassOp (getName sel_id)
(tidyToIfaceType env1 op_ty)
(fmap toDmSpec def_meth)
@@ -689,7 +689,7 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
, is_cls_nm = cls_name, is_cls = cls
, is_tcs = rough_tcs
, is_orphan = orph })
- = ASSERT( cls_name == className cls )
+ = assert (cls_name == className cls) $
IfaceClsInst { ifDFun = idName dfun_id
, ifOFlag = oflag
, ifInstCls = cls_name
@@ -707,7 +707,7 @@ famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
, ifFamInstOrph = orph }
where
fam_decl = tyConName $ coAxiomTyCon axiom
- mod = ASSERT( isExternalName (coAxiomName axiom) )
+ mod = assert (isExternalName (coAxiomName axiom)) $
nameModule (coAxiomName axiom)
is_local name = nameIsLocalOrFrom mod name
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 409cb712f2..3d84c17565 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -36,6 +36,7 @@ import GHC.Data.FastString
import GHC.Utils.Error
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc as Utils hiding ( eqListBy )
import GHC.Utils.Binary
@@ -359,7 +360,7 @@ checkHsig :: Logger -> HomeUnit -> DynFlags -> ModSummary -> ModIface -> IO Reco
checkHsig logger home_unit dflags mod_summary iface = do
let outer_mod = ms_mod mod_summary
inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)
- MASSERT( isHomeModule home_unit outer_mod )
+ massert (isHomeModule home_unit outer_mod)
case inner_mod == mi_semantic_module iface of
True -> up_to_date logger dflags (text "implementing module unchanged")
False -> return (RecompBecause "implementing module changed")
@@ -882,7 +883,7 @@ addFingerprints hsc_env iface0
, let out = localOccs $ freeNamesDeclABI abi
]
- name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
+ name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)
localOccs =
map (getUnique . getParent . getOccName)
-- NB: names always use semantic module, so
@@ -925,7 +926,7 @@ addFingerprints hsc_env iface0
| isWiredInName name = putNameLiterally bh name
-- wired-in names don't have fingerprints
| otherwise
- = ASSERT2( isExternalName name, ppr name )
+ = assertPpr (isExternalName name) (ppr name) $
let hash | nameModule name /= semantic_mod = global_hash_fn name
-- Get it from the REAL interface!!
-- This will trigger when we compile an hsig file
@@ -1497,7 +1498,7 @@ mkHashFun hsc_env eps name
occ = nameOccName name
orig_mod = nameModule name
lookup mod = do
- MASSERT2( isExternalName name, ppr name )
+ massertPpr (isExternalName name) (ppr name)
iface <- case lookupIfaceByModule hpt pit mod of
Just iface -> return iface
Nothing ->
diff --git a/compiler/GHC/Iface/Recomp/Binary.hs b/compiler/GHC/Iface/Recomp/Binary.hs
index 083ad431af..fd14c86673 100644
--- a/compiler/GHC/Iface/Recomp/Binary.hs
+++ b/compiler/GHC/Iface/Recomp/Binary.hs
@@ -16,7 +16,6 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
@@ -43,6 +42,6 @@ computeFingerprint put_nonbinding_name a = do
-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: BinHandle -> Name -> IO ()
-putNameLiterally bh name = ASSERT( isExternalName name ) do
+putNameLiterally bh name = assert (isExternalName name) $ do
put_ bh $! nameModule name
put_ bh $! nameOccName name
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index 500e12a1db..2df946529a 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -251,7 +251,8 @@ rnAvailInfo (AvailTC n ns) = do
ns' <- mapM rnGreName ns
case ns' of
[] -> panic "rnAvailInfoEmpty AvailInfo"
- (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do
+ (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest)
+ (ppr rep $$ hcat (map ppr rest)) $ do
n' <- setNameModule (Just (childModule rep)) n
return (AvailTC n' ns')
where
@@ -376,7 +377,7 @@ rnIfaceNeverExported name = do
iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
let m = renameHoleModule unit_state hmap $ nameModule name
-- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.
- MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
+ massertPpr (iface_semantic_mod == m) (ppr iface_semantic_mod <+> ppr m)
setNameModule (Just m) name
-- Note [rnIfaceNeverExported]
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index fe1fa6a58f..1f2cd97937 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -76,7 +76,7 @@ import GHC.Utils.Binary
import GHC.Utils.Binary.Typeable ()
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn,
+import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
seqList, zipWithEqual )
import Control.Monad
@@ -657,7 +657,7 @@ pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs
, ifaxbLHS = pat_tys
, ifaxbRHS = rhs
, ifaxbIncomps = incomps })
- = ASSERT2( null _cvs, pp_tc $$ ppr _cvs )
+ = assertPpr (null _cvs) (pp_tc $$ ppr _cvs) $
hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
$+$
nest 4 maybe_incomps
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index a17679c89a..9c96fd8ece 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -74,6 +74,8 @@ import GHC.Unit.Home.ModInfo
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import GHC.Data.Bag
@@ -1557,12 +1559,12 @@ tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type])
-> IfaceAlt
-> IfL CoreAlt
tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs)
- = ASSERT( null names ) do
+ = assert (null names) $ do
rhs' <- tcIfaceExpr rhs
return (Alt DEFAULT [] rhs')
tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs)
- = ASSERT( null names ) do
+ = assert (null names) $ do
lit' <- tcIfaceLit lit
rhs' <- tcIfaceExpr rhs
return (Alt (LitAlt lit') [] rhs')
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index ee4c9a718b..6a5a87ca97 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -67,6 +67,8 @@ import GHC.Types.Unique.DSet
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (isWindowsHost, isDarwinHost)
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
@@ -180,7 +182,7 @@ loadName interp hsc_env name = do
case lookupNameEnv (closure_env pls) name of
Just (_,aa) -> return (pls,aa)
- Nothing -> ASSERT2(isExternalName name, ppr name)
+ Nothing -> assertPpr (isExternalName name) (ppr name) $
do let sym_to_find = nameToCLabel name "closure"
m <- lookupClosure interp (unpackFS sym_to_find)
r <- case m of
@@ -757,7 +759,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
return lnk
adjust_ul new_osuf (DotO file) = do
- MASSERT(osuf `isSuffixOf` file)
+ massert (osuf `isSuffixOf` file)
let file_base = fromJust (stripExtension osuf file)
new_file = file_base <.> new_osuf
ok <- doesFileExist new_file
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 8f9ba78b13..742e659605 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -144,6 +144,7 @@ import Data.Foldable
import GHC.Driver.Flags ( WarningFlag(..) )
import qualified Data.Semigroup as Semi
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
@@ -478,8 +479,8 @@ cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup binding
= do { (mbs, sigs, fam_ds, tfam_insts
, dfam_insts, _) <- cvBindsAndSigs binding
- ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
- return $ ValBinds NoAnnSortKey mbs sigs }
+ ; massert (null fam_ds && null tfam_insts && null dfam_insts)
+ ; return $ ValBinds NoAnnSortKey mbs sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index d204e6ed0e..2425a253a5 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1530,7 +1530,7 @@ warnIfDeprecated gre@(GRE { gre_imp = iss })
where
occ = greOccName gre
name = greMangledName gre
- name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+ name_mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
mk_msg imp_spec txt
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 0ddd207148..3d27e77ea5 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -61,6 +61,7 @@ import GHC.Utils.Misc
import GHC.Data.List.SetOps ( removeDups )
import GHC.Utils.Error
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc
import GHC.Data.FastString
@@ -1670,7 +1671,7 @@ segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))
segsToStmts _ [] fvs_later = ([], fvs_later)
segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
- = ASSERT( not (null ss) )
+ = assert (not (null ss))
(new_stmt : later_stmts, later_uses `plusFV` uses)
where
(later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
@@ -1903,8 +1904,8 @@ mkStmtTreeHeuristic stmts =
-- using dynamic programming. /O(n^3)/
mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal stmts =
- ASSERT(not (null stmts)) -- the empty case is handled by the caller;
- -- we don't support empty StmtTrees.
+ assert (not (null stmts)) $ -- the empty case is handled by the caller;
+ -- we don't support empty StmtTrees.
fst (arr ! (0,n))
where
n = length stmts - 1
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index e7a5f9fa5a..c827b92a45 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -68,6 +68,7 @@ import GHC.Types.Fixity ( compareFixity, negateFixity
import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
@@ -1386,9 +1387,8 @@ mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
---------------------------
-- Default case
mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
- = ASSERT2( right_op_ok fix (unLoc e2),
- ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
- )
+ = assertPpr (right_op_ok fix (unLoc e2))
+ (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $
return (OpApp fix e1 op e2)
----------------------------
@@ -1429,7 +1429,7 @@ right_op_ok _ _
-- And "deriving" code should respect this (use HsPar if not)
mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)
mkNegAppRn neg_arg neg_name
- = ASSERT( not_op_app (unLoc neg_arg) )
+ = assert (not_op_app (unLoc neg_arg)) $
return (NegApp noExtField neg_arg neg_name)
not_op_app :: HsExpr id -> Bool
@@ -1500,7 +1500,7 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2
}
mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
- = ASSERT( not_op_pat (unLoc p2) )
+ = assert (not_op_pat (unLoc p2)) $
return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 80384e56d8..1a5fcedf8f 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -58,7 +58,7 @@ import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) )
import GHC.Data.FastString
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
-import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith )
+import GHC.Utils.Misc ( lengthExceeds, partitionWith )
import GHC.Utils.Panic
import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )
@@ -1527,8 +1527,11 @@ rnTyClDecls tycl_ds
all_groups = first_group ++ groups
- ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map
- $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
+ ; massertPpr (null final_inst_ds)
+ (ppr instds_w_fvs
+ $$ ppr inst_ds_map
+ $$ ppr (flattenSCCs tycl_sccs)
+ $$ ppr final_inst_ds)
; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
; return (all_groups, all_fvs) }
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 2abc65e001..40853a16e2 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -451,11 +451,11 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by =
-- 'imp_finsts' if it defines an orphan or instance family; thus the
-- orph_iface/has_iface tests.
- orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+ orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` dep_orphs deps)) (ppr imp_sem_mod <+> ppr (dep_orphs deps)) $
imp_sem_mod : dep_orphs deps
| otherwise = dep_orphs deps
- finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+ finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` dep_finsts deps)) (ppr imp_sem_mod <+> ppr (dep_orphs deps)) $
imp_sem_mod : dep_finsts deps
| otherwise = dep_finsts deps
@@ -488,8 +488,8 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by =
-- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
- ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))
- , ppr ipkg <+> ppr (dep_pkgs deps) )
+ assertPpr (not (ipkg `elem` (map fst $ dep_pkgs deps)))
+ (ppr ipkg <+> ppr (dep_pkgs deps))
([], (ipkg, False) : dep_pkgs deps, False)
in ImportAvails {
@@ -1127,16 +1127,16 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-> (GreName, AvailInfo, Maybe Name)
combine (NormalGreName name1, a1@(AvailTC p1 _), mb1)
(NormalGreName name2, a2@(AvailTC p2 _), mb2)
- = ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2
- , ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 )
+ = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2)
+ (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $
if p1 == name1 then (NormalGreName name1, a1, Just p2)
else (NormalGreName name1, a2, Just p1)
-- 'combine' may also be called for pattern synonyms which appear both
-- unassociated and associated (see Note [Importing PatternSynonyms]).
combine (c1, a1, mb1) (c2, a2, mb2)
- = ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2
- && (isAvailTC a1 || isAvailTC a2)
- , ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 )
+ = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2
+ && (isAvailTC a1 || isAvailTC a2))
+ (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $
if isAvailTC a1 then (c1, a1, Nothing)
else (c1, a2, Nothing)
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 1c847dfb97..5934f36f54 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -71,7 +71,7 @@ import GHC.Types.SourceText
import GHC.Utils.Misc
import GHC.Data.List.SetOps( removeDups )
import GHC.Utils.Outputable
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Types.Literal ( inCharRange )
import GHC.Builtin.Types ( nilDataCon )
@@ -691,7 +691,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-- isn't in scope the constructor lookup will add
-- an error but still return an unbound name. We
-- don't want that to screw up the dot-dot fill-in stuff.
- = ASSERT( flds `lengthIs` n )
+ = assert (flds `lengthIs` n) $
do { dd_flag <- xoptM LangExt.RecordWildCards
; checkErr dd_flag (needFlagDotDot ctxt)
; (rdr_env, lcl_env) <- getRdrEnvs
diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
index 0aa8eb53f8..fae6bcb59c 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ b/compiler/GHC/Runtime/Heap/Inspect.hs
@@ -60,6 +60,7 @@ import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Outputable as Ppr
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Char
import GHC.Exts.Heap
import GHC.Runtime.Heap.Layout ( roundUpTo )
@@ -277,7 +278,7 @@ ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- tcSplitTyConApp_maybe ty
- , ASSERT(isNewTyCon tc) True
+ , assert (isNewTyCon tc) True
, Just new_dc <- tyConSingleDataCon_maybe tc = do
real_term <- y max_prec t
return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
@@ -789,7 +790,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- MutVar# :: contents_ty -> MutVar# s contents_ty
traceTR (text "Following a MutVar")
contents_tv <- newVar liftedTypeKind
- MASSERT(isUnliftedType my_ty)
+ massert (isUnliftedType my_ty)
(mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany
contents_ty (mkTyConApp tycon [world,contents_ty])
addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty
@@ -909,7 +910,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
[index size_b aligned_idx word_size endian]
| otherwise =
let (q, r) = size_b `quotRem` word_size
- in ASSERT( r == 0 )
+ in assert (r == 0 )
[ array!!i
| o <- [0.. q - 1]
, let i = (aligned_idx `quot` word_size) + o
@@ -1080,7 +1081,7 @@ getDataConArgTys dc con_app_ty
= do { let rep_con_app_ty = unwrapType con_app_ty
; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
$$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
- ; ASSERT( all isTyVar ex_tvs ) return ()
+ ; assert (all isTyVar ex_tvs ) return ()
-- ex_tvs can only be tyvars as data types in source
-- Haskell cannot mention covar yet (Aug 2018)
; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
index 4e7b66f23d..32e94234b4 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ b/compiler/GHC/Stg/Lift.hs
@@ -28,7 +28,6 @@ import GHC.Stg.Lift.Monad
import GHC.Stg.Syntax
import GHC.Utils.Outputable
import GHC.Types.Unique.Supply
-import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Types.Var.Set
import Control.Monad ( when )
@@ -200,7 +199,9 @@ liftRhs
-> LlStgRhs
-> LiftM OutStgRhs
liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)
- = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)
+ = assertPpr (isNothing mb_former_fvs)
+ (text "Should never lift a constructor"
+ $$ pprStgRhs panicStgPprOpts rhs) $
StgRhsCon ccs con mn ts <$> traverse liftArgs args
liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =
-- This RHS wasn't lifted.
@@ -215,7 +216,7 @@ liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) =
liftArgs :: InStgArg -> LiftM OutStgArg
liftArgs a@(StgLitArg _) = pure a
liftArgs (StgVarArg occ) = do
- ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )
+ assertPprM (not <$> isLifted occ) (text "StgArgs should never be lifted" $$ ppr occ)
StgVarArg <$> substOcc occ
liftExpr :: LlStgExpr -> LiftM OutStgExpr
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
index e43bda363d..c34c74d505 100644
--- a/compiler/GHC/Stg/Lift/Monad.hs
+++ b/compiler/GHC/Stg/Lift/Monad.hs
@@ -36,8 +36,8 @@ import GHC.Stg.Subst
import GHC.Stg.Syntax
import GHC.Core.Utils
import GHC.Types.Unique.Supply
-import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.Multiplicity
@@ -183,7 +183,7 @@ collectFloats = go (0 :: Int) []
map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding
rm_cccs = map_rhss removeRhsCCCS
- merge_binds binds = ASSERT( any is_rec binds )
+ merge_binds binds = assert (any is_rec binds) $
StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)
is_rec StgRec{} = True
is_rec _ = False
diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs
index dce2859262..798a1f38bd 100644
--- a/compiler/GHC/Stg/Subst.hs
+++ b/compiler/GHC/Stg/Subst.hs
@@ -80,5 +80,5 @@ extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) e
-- holds after extending the substitution like this.
extendSubst :: Id -> Id -> Subst -> Subst
extendSubst id new_id (Subst in_scope env)
- = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )
+ = assertPpr (new_id `elemInScopeSet` in_scope) (ppr id <+> ppr new_id $$ ppr in_scope) $
Subst in_scope (extendVarEnv env id new_id)
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index cd25a36c0d..50fdea3dce 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -90,8 +90,7 @@ import GHC.Builtin.PrimOps ( PrimOp, PrimCall )
import GHC.Core.TyCon ( PrimRep(..), TyCon )
import GHC.Core.Type ( Type )
import GHC.Types.RepType ( typePrimRep1 )
-import GHC.Utils.Misc
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
{-
************************************************************************
@@ -503,7 +502,7 @@ type instance XLetNoEscape 'CodeGen = NoExtFieldSilent
stgRhsArity :: StgRhs -> Int
stgRhsArity (StgRhsClosure _ _ _ bndrs _)
- = ASSERT( all isId bndrs ) length bndrs
+ = assert (all isId bndrs) $ length bndrs
-- The arity never includes type parameters, but they should have gone by now
stgRhsArity (StgRhsCon _ _ _ _ _) = 0
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index 7790bc382d..4a4fef1402 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -257,6 +257,7 @@ import GHC.Types.Id.Make (voidPrimId, voidArgId)
import GHC.Utils.Monad (mapAccumLM)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.RepType
import GHC.Stg.Syntax
import GHC.Core.Type
@@ -307,10 +308,10 @@ instance Outputable UnariseVal where
-- | Extend the environment, checking the UnariseEnv invariant.
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho rho x (MultiVal args)
- = ASSERT(all (isNvUnaryType . stgArgType) args)
+ = assert (all (isNvUnaryType . stgArgType) args)
extendVarEnv rho x (MultiVal args)
extendRho rho x (UnaryVal val)
- = ASSERT(isNvUnaryType (stgArgType val))
+ = assert (isNvUnaryType (stgArgType val))
extendVarEnv rho x (UnaryVal val)
--------------------------------------------------------------------------------
@@ -336,7 +337,7 @@ unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
return (StgRhsClosure ext ccs update_flag args1 expr')
unariseRhs rho (StgRhsCon ccs con mu ts args)
- = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
+ = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
return (StgRhsCon ccs con mu ts (unariseConArgs rho args))
--------------------------------------------------------------------------------
@@ -420,7 +421,7 @@ unariseMulti_maybe rho dc args ty_args
= Just (unariseConArgs rho args)
| isUnboxedSumDataCon dc
- , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
+ , let args1 = assert (isSingleton args) (unariseConArgs rho args)
= Just (mkUbxSum dc ty_args args1)
| otherwise
@@ -454,7 +455,7 @@ elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
| isUnboxedTupleBndr bndr
= mapTupleIdBinders bndrs args rho1
| otherwise
- = ASSERT(isUnboxedSumBndr bndr)
+ = assert (isUnboxedSumBndr bndr) $
if null bndrs then rho1
else mapSumIdBinders bndrs args rho1
@@ -489,7 +490,7 @@ unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
| isUnboxedTupleBndr bndr
= do (rho', ys1) <- unariseConArgBinders rho ys
- MASSERT(ys1 `lengthIs` n)
+ massert (ys1 `lengthIs` n)
let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
e' <- unariseExpr rho'' e
return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
@@ -559,7 +560,7 @@ mapTupleIdBinders
-> UnariseEnv
-> UnariseEnv
mapTupleIdBinders ids args0 rho0
- = ASSERT(not (any (isVoidTy . stgArgType) args0))
+ = assert (not (any (isVoidTy . stgArgType) args0)) $
let
ids_unarised :: [(Id, [PrimRep])]
ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
@@ -570,12 +571,12 @@ mapTupleIdBinders ids args0 rho0
let
x_arity = length x_reps
(x_args, args') =
- ASSERT(args `lengthAtLeast` x_arity)
+ assert (args `lengthAtLeast` x_arity)
splitAt x_arity args
rho'
| x_arity == 1
- = ASSERT(x_args `lengthIs` 1)
+ = assert (x_args `lengthIs` 1)
extendRho rho x (UnaryVal (head x_args))
| otherwise
= extendRho rho x (MultiVal x_args)
@@ -593,7 +594,7 @@ mapSumIdBinders
-> UnariseEnv
mapSumIdBinders [id] args rho0
- = ASSERT(not (any (isVoidTy . stgArgType) args))
+ = assert (not (any (isVoidTy . stgArgType) args)) $
let
arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
id_slots = map primRepSlot $ typePrimRep (idType id)
@@ -601,7 +602,7 @@ mapSumIdBinders [id] args rho0
in
if isMultiValBndr id
then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
- else ASSERT(layout1 `lengthIs` 1)
+ else assert (layout1 `lengthIs` 1)
extendRho rho0 id (UnaryVal (args !! head layout1))
mapSumIdBinders ids sum_args _
@@ -787,7 +788,7 @@ unariseConArg _ arg@(StgLitArg lit)
| Just as <- unariseRubbish_maybe lit
= as
| otherwise
- = ASSERT(not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals
+ = assert (not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals
[arg]
unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index b6e71df36a..d27d2ce746 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -60,6 +60,7 @@ import GHC.Builtin.Uniques
import GHC.Builtin.Utils ( primOpId )
import GHC.Data.FastString
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Exception (evaluate)
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
import GHC.StgToCmm.Layout
@@ -633,7 +634,7 @@ returnUnboxedTuple d s p es = do
(tuple_info, tuple_components) = layoutTuple profile d arg_ty es
go _ pushes [] = return (reverse pushes)
go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
- MASSERT(off == dd + szb)
+ massert (off == dd + szb)
go (dd + szb) (push:pushes) cs
pushes <- go d [] tuple_components
ret <- returnUnboxedReps d
@@ -760,7 +761,7 @@ isNNLJoinPoint x = isJoinId x &&
-- See Note [Not-necessarily-lifted join points]
protectNNLJoinPointId :: Id -> Id
protectNNLJoinPointId x
- = ASSERT( isNNLJoinPoint x )
+ = assert (isNNLJoinPoint x )
updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x
{-
@@ -949,10 +950,10 @@ doTailCall init_d s p fn args = do
do_pushes init_d args (map (atomRep platform) args)
where
do_pushes !d [] reps = do
- ASSERT( null reps ) return ()
+ assert (null reps ) return ()
(push_fn, sz) <- pushAtom d p (StgVarArg fn)
platform <- profilePlatform <$> getProfile
- ASSERT( sz == wordSize platform ) return ()
+ assert (sz == wordSize platform ) return ()
let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)
return (push_fn `appOL` (slide `appOL` unitOL ENTER))
do_pushes !d args reps = do
@@ -1134,7 +1135,7 @@ doCase d s p scrut bndr alts
| (NonVoid arg, offset) <- args_offsets ]
p_alts
in do
- MASSERT(isAlgCase)
+ massert isAlgCase
rhs_code <- schemeE stack_bot s p' rhs
return (my_discr alt,
unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)
@@ -1772,7 +1773,7 @@ implement_tagToId
-> BcM BCInstrList
-- See Note [Implementing tagToEnum#]
implement_tagToId d s p arg names
- = ASSERT( notNull names )
+ = assert (notNull names) $
do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
labels <- getLabelsBc (genericLength names)
label_fail <- getLabelBc
@@ -1865,7 +1866,7 @@ pushAtom d p (StgVarArg var)
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
let sz = idSizeCon platform var
- MASSERT( sz == wordSize platform )
+ massert (sz == wordSize platform)
return (unitOL (PUSH_G (getName var)), sz)
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index e66929056c..04d76eeb9b 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -59,7 +59,7 @@ import GHC.Unit.Module
import GHC.Utils.Error
import GHC.Utils.Outputable
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Utils.TmpFs
@@ -224,7 +224,7 @@ cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)
-- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
- = ASSERT(isEmptyDVarSet fvs) -- There should be no free variables
+ = assert (isEmptyDVarSet fvs) -- There should be no free variables
cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body
@@ -262,7 +262,7 @@ cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
-- Generate the entry code, info tables, and (for niladic constructor)
-- the static closure, for a constructor.
cgDataCon mn data_con
- = do { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )
+ = do { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))
; profile <- getProfile
; platform <- getPlatform
; let
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index f1346d2846..13b07c2dd2 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -285,7 +285,7 @@ mkRhsClosure profile bndr _cc
, let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset
- fixedHdrSizeW profile
, offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough
- = -- NOT TRUE: ASSERT(is_single_constructor)
+ = -- NOT TRUE: assert (is_single_constructor)
-- The simplifier may have statically determined that the single alternative
-- is the only possible case and eliminated the others, even if there are
-- other constructors in the datatype. It's still ok to make a selector
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index d73f09e59d..f3619413a8 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -96,6 +96,7 @@ import GHC.Types.RepType
import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import Data.Coerce (coerce)
@@ -158,7 +159,7 @@ nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]
-- non-void; e.g. constructor field binders in case expressions.
-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
assertNonVoidIds :: [Id] -> [NonVoid Id]
-assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))
+assertNonVoidIds ids = assert (not (any (isVoidTy . idType) ids)) $
coerce ids
nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
@@ -168,7 +169,7 @@ nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg)
-- non-void; e.g. constructor arguments.
-- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
+assertNonVoidStgArgs args = assert (not (any (isVoidTy . stgArgType) args)) $
coerce args
@@ -233,7 +234,7 @@ mkLFReEntrant top fvs args arg_descr
-------------
mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
mkLFThunk thunk_ty top fvs upd_flag
- = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
+ = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $
LFThunk top (null fvs)
(isUpdatable upd_flag)
NonStandardThunk
@@ -529,15 +530,15 @@ getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc
| n_args == 0 -- No args at all
&& not (profileIsProfiling (co_profile opts))
-- See Note [Evaluating functions with profiling] in rts/Apply.cmm
- = ASSERT( arity /= 0 ) ReturnIt
+ = assert (arity /= 0) ReturnIt
| n_args < arity = SlowCall -- Not enough args
| otherwise = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity
getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
- = ASSERT( n_args == 0 ) ReturnIt
+ = assert (n_args == 0) ReturnIt
getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
- = ASSERT( n_args == 0 ) ReturnIt
+ = assert (n_args == 0) ReturnIt
-- n_args=0 because it'd be ill-typed to apply a saturated
-- constructor application to anything
@@ -561,7 +562,7 @@ getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun)
| SelectorThunk{} <- std_form_info
= EnterIt
- -- We used to have ASSERT( n_args == 0 ), but actually it is
+ -- We used to have assert (n_args == 0 ), but actually it is
-- possible for the optimiser to generate
-- let bot :: Int = error Int "urk"
-- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
@@ -569,7 +570,7 @@ getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun)
-- So the right thing to do is just to enter the thing
| otherwise -- Jump direct to code for single-entry thunks
- = ASSERT( n_args == 0 )
+ = assert (n_args == 0) $
DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info
updatable) 0
@@ -577,7 +578,7 @@ getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
= SlowCall -- might be a function
getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
- = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
+ = assertPpr (n_args == 0) (ppr name <+> ppr n_args)
EnterIt -- Not a function
getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index fbf7a01399..49cbc2b78d 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -49,6 +49,7 @@ import GHC.Types.RepType (countConRepArgs)
import GHC.Types.Literal
import GHC.Builtin.Utils
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad (mapMaybeM)
@@ -93,8 +94,8 @@ cgTopRhsCon dflags id con mn args
; this_mod <- getModuleName
; when (platformOS platform == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
- MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
- ; ASSERT( args `lengthIs` countConRepArgs con ) return ()
+ massert (not (isDllConApp dflags this_mod con (map fromNonVoid args)))
+ ; assert (args `lengthIs` countConRepArgs con ) return ()
-- LAY IT OUT
; let
@@ -382,7 +383,7 @@ bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
-- binders args, assuming that we have just returned from a 'case' which
-- found a con
bindConArgs (DataAlt con) base args
- = ASSERT(not (isUnboxedTupleDataCon con))
+ = assert (not (isUnboxedTupleDataCon con)) $
do profile <- getProfile
platform <- getPlatform
let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
@@ -402,4 +403,4 @@ bindConArgs (DataAlt con) base args
mapMaybeM bind_arg args_w_offsets
bindConArgs _other_con _base args
- = ASSERT( null args ) return []
+ = assert (null args ) return []
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index 5f4ef641c4..db97e6176f 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -42,9 +42,9 @@ import GHC.Builtin.Types.Prim
import GHC.Types.Unique.FM
import GHC.Types.Var.Env
-import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Driver.Session
@@ -137,7 +137,7 @@ getCgIdInfo id
| isUnliftedType (idType id)
-- An unlifted external Id must refer to a top-level
-- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".
- = ASSERT( idType id `eqType` addrPrimTy )
+ = assert (idType id `eqType` addrPrimTy) $
mkBytesLabel name
| otherwise
= pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index dbc2a9ea06..beadc9af8d 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -53,6 +53,7 @@ import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad ( unless, void )
import Control.Arrow ( first )
@@ -555,7 +556,7 @@ chooseReturnBndrs bndr (PrimAlt _) _alts
= assertNonVoidIds [bndr]
chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]
- = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)
+ = assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $
assertNonVoidIds ids -- 'bndr' is not assigned!
chooseReturnBndrs bndr (AlgAlt _) _alts
@@ -872,7 +873,8 @@ cgConApp con mn stg_args
; emitReturn arg_exprs }
| otherwise -- Boxed constructors; allocate and return
- = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )
+ = assertPpr (stg_args `lengthIs` countConRepArgs con)
+ (ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args) $
do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False
currentCCS con (assertNonVoidStgArgs stg_args)
-- con args are always non-void,
@@ -904,7 +906,7 @@ cgIdApp fun_id args = do
| otherwise -> emitReturn [fun]
-- ToDo: does ReturnIt guarantee tagged?
- EnterIt -> ASSERT( null args ) -- Discarding arguments
+ EnterIt -> assert (null args) $ -- Discarding arguments
emitEnter fun
SlowCall -> do -- A slow function call via the RTS apply routines
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index d10d7f6345..c6c24b7862 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -65,6 +65,8 @@ import GHC.Utils.Misc
import Data.List (mapAccumL, partition)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import Control.Monad
@@ -438,7 +440,7 @@ mkVirtHeapOffsetsWithPadding
-- than the unboxed things
mkVirtHeapOffsetsWithPadding profile header things =
- ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
+ assert (not (any (isVoidRep . fst . fromNonVoid) things))
( tot_wds
, bytesToWordsRoundUp platform bytes_of_ptrs
, concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs
index c2c3b93125..0eb9dc756d 100644
--- a/compiler/GHC/StgToCmm/Monad.hs
+++ b/compiler/GHC/StgToCmm/Monad.hs
@@ -86,7 +86,7 @@ import GHC.Types.Unique.Supply
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc
+import GHC.Utils.Constants (debugIsOn)
import GHC.Exts (oneShot)
import Control.Monad
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index c29da653ba..c6c227f4e6 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -48,6 +48,7 @@ import GHC.Runtime.Heap.Layout
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.Maybe
import Control.Monad (liftM, when, unless)
@@ -1522,7 +1523,7 @@ emitPrimOp dflags primop = case primop of
-- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
-- That won't work.
let tycon = tyConAppTyCon res_ty
- MASSERT(isEnumerationTyCon tycon)
+ massert (isEnumerationTyCon tycon)
platform <- getPlatform
pure [tagToClosure platform tycon amode]
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index 35af67cc54..adbd04b49e 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -76,6 +76,7 @@ import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.RepType
import GHC.Types.CostCentre
import GHC.Types.IPE
@@ -287,12 +288,12 @@ newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- the Sequel. If the Sequel is a join point, using the
-- regs it wants will save later assignments.
newUnboxedTupleRegs res_ty
- = ASSERT( isUnboxedTupleType res_ty )
+ = assert (isUnboxedTupleType res_ty) $
do { platform <- getPlatform
; sequel <- getSequel
; regs <- choose_regs platform sequel
- ; ASSERT( regs `equalLength` reps )
- return (regs, map primRepForeignHint reps) }
+ ; massert (regs `equalLength` reps)
+ ; return (regs, map primRepForeignHint reps) }
where
reps = typePrimRep res_ty
choose_regs _ (AssignTo regs _) = return regs
@@ -323,7 +324,7 @@ emitMultiAssign [] [] = return ()
emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
emitMultiAssign regs rhss = do
platform <- getPlatform
- ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss )
+ assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $
unscramble platform ([1..] `zip` (regs `zip` rhss))
unscramble :: Platform -> [Vrtx] -> FCode ()
@@ -411,7 +412,7 @@ mk_discrete_switch :: Bool -- ^ Use signed comparisons
-- SINGLETON TAG RANGE: no case analysis to do
mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
| lo_tag == hi_tag
- = ASSERT( tag == lo_tag )
+ = assert (tag == lo_tag) $
mkBranch lbl
-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index a899349702..fa1a0afb45 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -61,6 +61,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Data.Bag
import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
@@ -1556,7 +1557,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys
cant_derive_err = ppUnless eta_ok eta_msg
eta_msg = text "cannot eta-reduce the representation type enough"
- MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
+ massert (cls_tys `lengthIs` (classArity cls - 1))
if newtype_strat
then
-- Since the user explicitly asked for GeneralizedNewtypeDeriving,
@@ -1962,7 +1963,7 @@ doDerivInstErrorChecks1 mechanism =
at_last_cls_tv_in_kind kind
= last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
at_tcs = classATs cls
- last_cls_tv = ASSERT( notNull cls_tyvars )
+ last_cls_tv = assert (notNull cls_tyvars )
last cls_tyvars
cant_derive_err
@@ -2056,8 +2057,8 @@ genDerivStuff mechanism loc clas inst_tys tyvars
tyfam_insts <-
-- canDeriveAnyClass should ensure that this code can't be reached
-- unless -XDeriveAnyClass is enabled.
- ASSERT2( isValid (canDeriveAnyClass dflags)
- , ppr "genDerivStuff: bad derived class" <+> ppr clas )
+ assertPpr (isValid (canDeriveAnyClass dflags))
+ (ppr "genDerivStuff: bad derived class" <+> ppr clas) $
mapM (tcATDefault loc mini_subst emptyNameSet)
(classATItems clas)
return ( emptyBag, [] -- No method bindings are needed...
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 5f2f69bee2..69af151327 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -77,6 +77,7 @@ import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Lexeme
import GHC.Data.FastString
import GHC.Data.Pair
@@ -730,7 +731,7 @@ gen_Bounded_binds loc tycon _
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
| otherwise
- = ASSERT(isSingleton data_cons)
+ = assert (isSingleton data_cons)
(listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
where
data_cons = tyConDataCons tycon
@@ -1137,7 +1138,7 @@ gen_Read_binds get_fixity loc tycon _
data_con_str con = occNameString (getOccName con)
- read_arg a ty = ASSERT( not (isUnliftedType ty) )
+ read_arg a ty = assert (not (isUnliftedType ty)) $
noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
-- When reading field labels we might encounter
@@ -1210,7 +1211,7 @@ gen_Show_binds get_fixity loc tycon tycon_args
pats_etc data_con
| nullary_con = -- skip the showParen junk...
- ASSERT(null bs_needed)
+ assert (null bs_needed)
([nlWildPat, con_pat], mk_showString_app op_con_str)
| otherwise =
([a_Pat, con_pat],
@@ -1945,7 +1946,7 @@ gen_Newtype_binds :: SrcSpan
gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
= do let ats = classATs cls
(binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
- atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
+ atf_insts <- assert (all (not . isDataFamilyTyCon) ats) $
mapM mk_atf_inst ats
return ( listToBag binds
, sigs
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 5eff74aaa1..9e2dbf07df 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -54,6 +54,7 @@ import GHC.Types.Var.Env
import GHC.Types.Var.Set (elemVarSet)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Utils.Misc
@@ -388,7 +389,7 @@ mkBindsRep dflags gk tycon = (binds, sigs)
(from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
where gk_ = case gk of
Gen0 -> Gen0_
- Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
+ Gen1 -> assert (tyvars `lengthAtLeast` 1) $
Gen1_ (last tyvars)
where tyvars = tyConTyVars tycon
@@ -439,7 +440,7 @@ tc_mkRepFamInsts gk tycon inst_tys =
; let -- `tyvars` = [a,b]
(tyvars, gk_) = case gk of
Gen0 -> (all_tyvars, Gen0_)
- Gen1 -> ASSERT(not $ null all_tyvars)
+ Gen1 -> assert (not $ null all_tyvars)
(init all_tyvars, Gen1_ $ last all_tyvars)
where all_tyvars = tyConTyVars tycon
@@ -618,7 +619,7 @@ tc_mkRepTy gk_ tycon k =
-- The Bool is True if this constructor has labelled fields
prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])
- [ ASSERT(null fl || lengthExceeds fl j)
+ [ assert (null fl || lengthExceeds fl j) $
arg t sb' ib' (if null fl
then Nothing
else Just (fl !! j))
diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs
index 5ce54339c6..5caf62e6c0 100644
--- a/compiler/GHC/Tc/Deriv/Infer.hs
+++ b/compiler/GHC/Tc/Deriv/Infer.hs
@@ -26,6 +26,7 @@ import GHC.Utils.Error
import GHC.Tc.Utils.Instantiate
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.Pair
import GHC.Builtin.Names
import GHC.Tc.Deriv.Utils
@@ -113,12 +114,12 @@ inferConstraints mechanism
-- Constraints arising from superclasses
-- See Note [Superclasses of derived instance]
cls_tvs = classTyVars main_cls
- sc_constraints = ASSERT2( equalLength cls_tvs inst_tys
- , ppr main_cls <+> ppr inst_tys )
+ sc_constraints = assertPpr (equalLength cls_tvs inst_tys)
+ (ppr main_cls <+> ppr inst_tys)
[ mkThetaOrigin (mkDerivOrigin wildcard)
TypeLevel [] [] [] $
substTheta cls_subst (classSCTheta main_cls) ]
- cls_subst = ASSERT( equalLength cls_tvs inst_tys )
+ cls_subst = assert (equalLength cls_tvs inst_tys) $
zipTvSubst cls_tvs inst_tys
; (inferred_constraints, tvs', inst_tys') <- infer_constraints
@@ -269,7 +270,7 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys
substTheta tc_subst (tyConStupidTheta rep_tc) ]
tc_subst = -- See the comment with all_rep_tc_args for an
-- explanation of this assertion
- ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
+ assert (equalLength rep_tc_tvs all_rep_tc_args) $
zipTvSubst rep_tc_tvs all_rep_tc_args
-- Extra Data constraints
@@ -308,9 +309,9 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys
-- Generic1 needs Functor
-- See Note [Getting base classes]
| is_generic1
- -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )
+ -> assert (rep_tc_tvs `lengthExceeds` 0) $
-- Generic1 has a single kind variable
- ASSERT( cls_tys `lengthIs` 1 )
+ assert (cls_tys `lengthIs` 1) $
do { functorClass <- lift $ tcLookupClass functorClassName
; pure $ con_arg_constraints
$ get_gen1_constraints functorClass }
@@ -319,9 +320,9 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys
| otherwise
-> -- See the comment with all_rep_tc_args for an explanation of
-- this assertion
- ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
- , ppr main_cls <+> ppr rep_tc
- $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
+ assertPpr (equalLength rep_tc_tvs all_rep_tc_args)
+ ( ppr main_cls <+> ppr rep_tc
+ $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args) $
do { let (arg_constraints, tvs', inst_tys')
= con_arg_constraints get_std_constrained_tys
; lift $ traceTc "inferConstraintsStock" $ vcat
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 9de37b0313..40810ee619 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -59,6 +59,7 @@ import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Outputable as O
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Driver.Session
import GHC.Driver.Ppr
@@ -555,7 +556,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
-- says to suppress
; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
; (_, leftovers) <- tryReporters ctxt2 report2 cts1
- ; MASSERT2( null leftovers, ppr leftovers )
+ ; massertPpr (null leftovers) (ppr leftovers)
-- All the Derived ones have been filtered out of simples
-- by the constraint solver. This is ok; we don't want
@@ -1629,8 +1630,8 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2
-- See Note [Error messages for untouchables]
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
- = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
- , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables]
+ = assertPpr (not (isTouchableMetaTyVar lvl tv1))
+ (ppr tv1 $$ ppr lvl) $ -- See Note [Error messages for untouchables]
let msg = misMatchMsg ctxt ct ty1 ty2
tclvl_extra = important $
nest 2 $
@@ -1800,7 +1801,7 @@ extraTyVarEqInfo ctxt tv1 ty2
extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
extraTyVarInfo ctxt tv
- = ASSERT2( isTyVar tv, ppr tv )
+ = assertPpr (isTyVar tv) (ppr tv) $
case tcTyVarDetails tv of
SkolemTv {} -> pprSkols ctxt [tv]
RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"
@@ -2344,7 +2345,7 @@ Warn of loopy local equalities that were dropped.
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report
mkDictErr ctxt cts
- = ASSERT( not (null cts) )
+ = assert (not (null cts)) $
do { inst_envs <- tcGetInstEnvs
; let min_cts = elim_superclasses cts
lookups = map (lookup_cls_inst inst_envs) min_cts
@@ -2518,7 +2519,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
-- Normal overlap error
overlap_msg
- = ASSERT( not (null matches) )
+ = assert (not (null matches)) $
vcat [ addArising orig (text "Overlapping instances for"
<+> pprType (mkClassPred clas tys))
@@ -2571,7 +2572,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
-- Overlap error because of Safe Haskell (first
-- match should be the most specific match)
safe_haskell_msg
- = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )
+ = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $
vcat [ addArising orig (text "Unsafe overlapping instances for"
<+> pprType (mkClassPred clas tys))
, sep [text "The matching instance is:",
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 4f4f53f1cf..1c5876df52 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -991,7 +991,7 @@ qlUnify delta ty1 ty2
----------------
go_kappa bvs kappa ty2
- = ASSERT2( isMetaTyVar kappa, ppr kappa )
+ = assertPpr (isMetaTyVar kappa) (ppr kappa) $
do { info <- readMetaTyVar kappa
; case info of
Indirect ty1 -> go bvs ty1 ty2
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 0ff73863cc..edcd4fc4d5 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -77,6 +77,7 @@ import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
@@ -642,7 +643,7 @@ following.
-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
-- and panic otherwise.
tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty
- = ASSERT( notNull rbnds )
+ = assert (notNull rbnds) $
do { -- STEP -2: typecheck the record_expr, the record to be updated
(record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr
-- Record update drops some of the content of the record (namely the
@@ -679,7 +680,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_
-- See note [Mixed Record Selectors]
; let (data_sels, pat_syn_sels) =
partition isDataConRecordSelector sel_ids
- ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
+ ; massert (all isPatSynRecordSelector pat_syn_sels)
; checkTc ( null data_sels || null pat_syn_sels )
( mixedSelectors data_sels pat_syn_sels )
@@ -713,7 +714,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_
; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
-- Take apart a representative constructor
- ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
+ ; let con1 = assert (not (null relevant_cons) ) head relevant_cons
(con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)
= conLikeFullSig con1
con1_arg_tys = map scaledThing scaled_con1_arg_tys
@@ -940,7 +941,7 @@ arithSeqEltType (Just fl) res_ty
----------------
tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
tcTupArgs args tys
- = do MASSERT( equalLength args tys )
+ = do massert (equalLength args tys)
checkTupSize (length args)
mapM go (args `zip` tys)
where
@@ -1036,11 +1037,11 @@ tcSynArgE orig sigma_ty syn_ty thing_inside
-- another nested arrow is too much for now,
-- but I bet we'll never need this
- ; MASSERT2( case arg_shape of
+ ; massertPpr (case arg_shape of
SynFun {} -> False;
- _ -> True
- , text "Too many nested arrows in SyntaxOpType" $$
- pprCtOrigin orig )
+ _ -> True)
+ (text "Too many nested arrows in SyntaxOpType" $$
+ pprCtOrigin orig)
; let arg_mult = scaledMult arg_ty
; tcSynArgA orig arg_tc_ty [] arg_shape $
@@ -1501,7 +1502,7 @@ badFieldsUpd rbinds data_cons
-- are redundant and can be dropped.
map (fst . head) $ groupBy ((==) `on` snd) growingSets
- aMember = ASSERT( not (null members) ) fst (head members)
+ aMember = assert (not (null members) ) fst (head members)
(members, nonMembers) = partition (or . snd) membership
-- For each field, which constructors contain the field?
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index feef214055..9767681607 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -72,6 +72,7 @@ import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad
import Data.Function
@@ -1206,7 +1207,7 @@ addFunResCtxt fun args fun_res_ty env_ty thing_inside
Just env_ty -> zonkTcType env_ty
Nothing ->
do { dumping <- doptM Opt_D_dump_tc_trace
- ; MASSERT( dumping )
+ ; massert dumping
; newFlexiTyVarTy liftedTypeKind }
; let -- See Note [Splitting nested sigma types in mismatched
-- function types]
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 26bb301361..18af6a8ea4 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -119,6 +119,7 @@ import GHC.Utils.Misc
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Builtin.Names hiding ( wildCardName )
import GHC.Driver.Session
@@ -1273,7 +1274,7 @@ tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
--------- Constraint types
tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind
- = do { MASSERT( isTypeLevel (mode_tyki mode) )
+ = do { massert (isTypeLevel (mode_tyki mode))
; ty' <- tc_lhs_type mode ty liftedTypeKind
; let n' = mkStrLitTy $ hsIPNameFS n
; ipClass <- tcLookupClass ipClassName
@@ -1755,8 +1756,8 @@ mkAppTyM subst fun (Named (Bndr tv _)) arg
mk_app_ty :: TcType -> TcType -> TcType
-- This function just adds an ASSERT for mkAppTyM's precondition
mk_app_ty fun arg
- = ASSERT2( isPiTy fun_kind
- , ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )
+ = assertPpr (isPiTy fun_kind)
+ (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $
mkAppTy fun arg
where
fun_kind = tcTypeKind fun
@@ -2662,7 +2663,7 @@ kcCheckDeclHeader_sig kisig name flav
invis_to_tcb :: TyCoBinder -> TcM TyConBinder
invis_to_tcb tb = do
(tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)
- MASSERT(null stv)
+ massert (null stv)
return tcb
-- Check that the inline kind annotation on a binder is valid
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 671955feb7..f21b5d9593 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -65,6 +65,7 @@ import GHC.Types.Var.Set
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import qualified GHC.LanguageExtensions as LangExt
import Control.Arrow ( second )
import Control.Monad
@@ -221,7 +222,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl
| otherwise -- No signature
= do { (co, bndr_ty) <- case scaledThing exp_pat_ty of
Check pat_ty -> promoteTcType bind_lvl pat_ty
- Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )
+ Infer infer_res -> assert (bind_lvl == ir_lvl infer_res) $
-- If we were under a constructor that bumped the
-- level, we'd be in checking mode (see tcConArg)
-- hence this assertion
@@ -339,7 +340,7 @@ tc_lpat pat_ty penv (L span pat) thing_inside
tc_lpats :: [Scaled ExpSigmaType]
-> Checker [LPat GhcRn] [LPat GhcTc]
tc_lpats tys penv pats
- = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )
+ = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $
tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)
penv
(zipEqual "tc_lpats" pats tys)
@@ -536,8 +537,8 @@ Fortunately that's what matchExpectedFunTySigma returns anyway.
| otherwise = unmangled_result
; pat_ty <- readExpType (scaledThing pat_ty)
- ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced
- return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
+ ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
+ ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
}
SumPat _ pat alt arity -> do
@@ -1271,7 +1272,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of
-- The normal case, when the field comes from the right constructor
(pat_ty : extras) -> do
traceTc "find_field" (ppr pat_ty <+> ppr extras)
- ASSERT( null extras ) (return pat_ty)
+ assert (null extras) (return pat_ty)
field_tys :: [(FieldLabel, Scaled TcType)]
field_tys = zip (conLikeFieldLabels con_like) arg_tys
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 8a6c4399e7..8748fd3786 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -120,6 +120,7 @@ import GHC.Unit.Module.Deps
import GHC.Utils.Misc
import GHC.Utils.Panic as Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Lexeme
import GHC.Utils.Outputable
import GHC.Utils.Logger
@@ -238,7 +239,7 @@ tcUntypedBracket rn_expr brack ps res_ty
-- we want to reflect that in the overall type of the bracket.
; ps' <- case quoteWrapperTyVarTy <$> brack_info of
Just m_var -> mapM (tcPendingSplice m_var) ps
- Nothing -> ASSERT(null ps) return []
+ Nothing -> assert (null ps) $ return []
; traceTc "tc_bracket done untyped" (ppr expected_type)
@@ -2013,7 +2014,7 @@ reifyDataCon isGadtDataCon tys dc
-- constructors can be declared infix.
-- See Note [Infix GADT constructors] in GHC.Tc.TyCl.
| dataConIsInfix dc && not isGadtDataCon ->
- ASSERT( r_arg_tys `lengthIs` 2 ) do
+ assert (r_arg_tys `lengthIs` 2) $ do
{ let [r_a1, r_a2] = r_arg_tys
[s1, s2] = dcdBangs
; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
@@ -2024,7 +2025,7 @@ reifyDataCon isGadtDataCon tys dc
return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
- | otherwise = ASSERT( all isTyVar ex_tvs )
+ | otherwise = assert (all isTyVar ex_tvs)
-- no covars for haskell syntax
(map mk_specified ex_tvs, theta)
ret_con | null ex_tvs' && null theta' = return main_con
@@ -2032,7 +2033,7 @@ reifyDataCon isGadtDataCon tys dc
{ cxt <- reifyCxt theta'
; ex_tvs'' <- reifyTyVarBndrs ex_tvs'
; return (TH.ForallC ex_tvs'' cxt main_con) }
- ; ASSERT( r_arg_tys `equalLength` dcdBangs )
+ ; assert (r_arg_tys `equalLength` dcdBangs)
ret_con }
where
mk_specified tv = Bndr tv SpecifiedSpec
@@ -2493,7 +2494,7 @@ reifyName thing
-- have free variables, we may need to generate NameL's for them.
where
name = getName thing
- mod = ASSERT( isExternalName name ) nameModule name
+ mod = assert (isExternalName name) $ nameModule name
pkg_str = unitString (moduleUnit mod)
mod_str = moduleNameString (moduleName mod)
occ_str = occNameString occ
@@ -2511,7 +2512,7 @@ reifyFieldLabel fl
| otherwise = TH.mkNameG_v pkg_str mod_str occ_str
where
name = flSelector fl
- mod = ASSERT( isExternalName name ) nameModule name
+ mod = assert (isExternalName name) $ nameModule name
pkg_str = unitString (moduleUnit mod)
mod_str = moduleNameString (moduleName mod)
occ_str = unpackFS (flLabel fl)
diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs
index 65e91608b9..ffd2f84f80 100644
--- a/compiler/GHC/Tc/Instance/Family.hs
+++ b/compiler/GHC/Tc/Instance/Family.hs
@@ -49,6 +49,7 @@ import GHC.Types.Var.Set
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.FV
import GHC.Data.Bag( Bag, unionBags, unitBag )
@@ -511,7 +512,7 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
, let rep_tc = dataFamInstRepTyCon rep_fam
co = mkUnbranchedAxInstCo Representational ax rep_args
(mkCoVarCos cvs)
- = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv
+ = assert (null rep_cos) $ -- See Note [Constrained family instances] in GHC.Core.FamInstEnv
Just (rep_tc, rep_args, co)
| otherwise
@@ -752,7 +753,7 @@ reportInjectivityErrors
-> [Bool] -- ^ Injectivity annotation
-> TcM ()
reportInjectivityErrors dflags fi_ax axiom inj
- = ASSERT2( any id inj, text "No injective type variables" )
+ = assertPpr (any id inj) (text "No injective type variables") $
do let lhs = coAxBranchLHS axiom
rhs = coAxBranchRHS axiom
fam_tc = coAxiomTyCon fi_ax
diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs
index 81cf7524e1..c3bf31fed3 100644
--- a/compiler/GHC/Tc/Instance/FunDeps.hs
+++ b/compiler/GHC/Tc/Instance/FunDeps.hs
@@ -266,9 +266,9 @@ improveClsFD clas_tvs fd
= [] -- Filter out ones that can't possibly match,
| otherwise
- = ASSERT2( equalLength tys_inst tys_actual &&
- equalLength tys_inst clas_tvs
- , ppr tys_inst <+> ppr tys_actual )
+ = assertPpr (equalLength tys_inst tys_actual &&
+ equalLength tys_inst clas_tvs)
+ (ppr tys_inst <+> ppr tys_actual) $
case tcMatchTyKis ltys1 ltys2 of
Nothing -> []
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index fc330061e8..72b588a921 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -131,6 +131,7 @@ import GHC.Runtime.Context
import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Logger
@@ -977,7 +978,7 @@ checkBootDeclM is_boot boot_thing real_thing
checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl _ (AnId id1) (AnId id2)
- = ASSERT(id1 == id2)
+ = assert (id1 == id2) $
check (idType id1 `eqType` idType id2)
(text "The two types are different")
@@ -1117,7 +1118,7 @@ checkBootTyCon is_boot tc1 tc2
| Just syn_rhs1 <- synTyConRhs_maybe tc1
, Just syn_rhs2 <- synTyConRhs_maybe tc2
, Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
- = ASSERT(tc1 == tc2)
+ = assert (tc1 == tc2) $
checkRoles roles1 roles2 `andThenCheck`
check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say
-- This allows abstract 'data T a' to be implemented using 'type T = ...'
@@ -1147,7 +1148,7 @@ checkBootTyCon is_boot tc1 tc2
| Just fam_flav1 <- famTyConFlav_maybe tc1
, Just fam_flav2 <- famTyConFlav_maybe tc2
- = ASSERT(tc1 == tc2)
+ = assert (tc1 == tc2) $
let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
-- This case only happens for hsig merging:
@@ -1173,7 +1174,7 @@ checkBootTyCon is_boot tc1 tc2
| isAlgTyCon tc1 && isAlgTyCon tc2
, Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
- = ASSERT(tc1 == tc2)
+ = assert (tc1 == tc2) $
checkRoles roles1 roles2 `andThenCheck`
check (eqListBy (eqTypeX env)
(tyConStupidTheta tc1) (tyConStupidTheta tc2))
@@ -1282,7 +1283,7 @@ checkBootTyCon is_boot tc1 tc2
`andThenCheck`
-- Don't report roles errors unless the type synonym is nullary
checkUnless (not (null tvs)) $
- ASSERT( null roles2 )
+ assert (null roles2) $
-- If we have something like:
--
-- signature H where
@@ -1825,7 +1826,7 @@ checkMain explicit_mod_hdr export_ies
generateMainBinding tcg_env main_name
| otherwise
- -> ASSERT( null exported_mains )
+ -> assert (null exported_mains) $
-- A fully-checked export list can't contain more
-- than one function with the same OccName
do { complain_no_main dflags main_mod main_occ
@@ -2651,7 +2652,7 @@ tcRnType hsc_env flexi normalise rdr_type
-- Since all the wanteds are equalities, the returned bindings will be empty
; empty_binds <- simplifyTop wanted
- ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )
+ ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)
-- Do kind generalisation; see Note [Kind-generalise in tcRnType]
; kvs <- kindGeneralizeAll kind
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 76ce179b9d..373483b5d7 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -120,7 +120,7 @@ simplifyTopImplic implics
= do { empty_binds <- simplifyTop (mkImplicWC implics)
-- Since all the inputs are implications the returned bindings will be empty
- ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )
+ ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)
; return () }
@@ -1932,7 +1932,8 @@ solveImplication imp@(Implic { ic_tclvl = tclvl
-- remaining commented out for now.
{-
check_tc_level = do { cur_lvl <- TcS.getTcLevel
- ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }
+ ; massertPpr (tclvl == pushTcLevel cur_lvl)
+ (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) }
-}
----------------------
@@ -1946,7 +1947,7 @@ setImplicationStatus implic@(Implic { ic_status = status
, ic_info = info
, ic_wanted = wc
, ic_given = givens })
- | ASSERT2( not (isSolvedStatus status ), ppr info )
+ | assertPpr (not (isSolvedStatus status)) (ppr info) $
-- Precondition: we only set the status if it is not already solved
not (isSolvedWC pruned_wc)
= do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index e4020bdfc5..9e47c6ce8d 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -39,6 +39,7 @@ import GHC.Types.Var.Env( mkInScopeSet )
import GHC.Types.Var.Set( delVarSetList, anyVarSet )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Builtin.Types ( anyTypeOfKind )
import GHC.Driver.Session( DynFlags )
import GHC.Types.Name.Set
@@ -208,7 +209,7 @@ canClass :: CtEvidence
canClass ev cls tys pend_sc fds
= -- all classes do *nominal* matching
- ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
+ assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $
do { (xis, cos) <- rewriteArgsNom ev cls_tc tys
; let co = mkTcTyConAppCo Nominal cls_tc cos
xi = mkClassPred cls xis
@@ -503,8 +504,8 @@ makeSuperClasses cts = concatMapM go cts
go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
= mkStrictSuperClasses ev [] [] cls tys
go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
- = ASSERT2( isClassPred pred, ppr pred ) -- The cts should all have
- -- class pred heads
+ = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
+ -- class pred heads
mkStrictSuperClasses ev tvs theta cls tys
where
(tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
@@ -596,7 +597,7 @@ mk_strict_superclasses rec_clss ev tvs theta cls tys
| otherwise -- Wanted/Derived case, just add Derived superclasses
-- that can lead to improvement.
- = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )
+ = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $
concatMapM do_one_derived (immSuperClasses cls tys)
where
loc = ctEvLoc ev
@@ -1214,7 +1215,7 @@ can_eq_nc_forall ev eq_rel s1 s2
-- Done: unify phi1 ~ phi2
go [] subst bndrs2
- = ASSERT( null bndrs2 )
+ = assert (null bndrs2 )
unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)
go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) []
@@ -1851,7 +1852,7 @@ canDecomposableTyConAppOK :: CtEvidence -> EqRel
-> TcS (StopOrContinue Ct)
-- Precondition: tys1 and tys2 are the same length, hence "OK"
canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
- = ASSERT( tys1 `equalLength` tys2 )
+ = assert (tys1 `equalLength` tys2) $
do { traceTcS "canDecomposableTyConAppOK"
(ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)
; case ev of
@@ -2508,7 +2509,7 @@ instance Outputable CanEqOK where
-- TyEq:H: Checked here.
canEqOK :: DynFlags -> EqRel -> CanEqLHS -> Xi -> CanEqOK
canEqOK dflags eq_rel lhs rhs
- = ASSERT( good_rhs )
+ = assert good_rhs $
case checkTypeEq dflags YesTypeFamilies lhs rhs of
CTE_OK -> CanEqOK
CTE_Bad -> CanEqNotOK OtherCIS
@@ -3037,7 +3038,7 @@ rewriteEvidence ev@(CtWanted { ctev_dest = dest
-- The "_SI" variant ensures that we make a new Wanted
-- with the same shadow-info as the existing one
-- with the same shadow-info as the existing one (#16735)
- ; MASSERT( tcCoercionRole co == ctEvRole ev )
+ ; massert (tcCoercionRole co == ctEvRole ev)
; setWantedEvTerm dest
(mkEvCast (getEvExpr mb_new_ev)
(tcDowngradeRole Representational (ctEvRole ev) co))
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index ec6e1f9853..9ccdc5bc60 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -33,6 +33,7 @@ import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )
import GHC.Tc.Types.Evidence
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
@@ -1065,7 +1066,7 @@ shortCutSolver dflags ev_w ev_i
-- Enabled by the -fsolve-constant-dicts flag
= do { ev_binds_var <- getTcEvBindsVar
- ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )
+ ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $
getTcEvBindsMap ev_binds_var
; solved_dicts <- getSolvedDicts
@@ -1290,7 +1291,7 @@ improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType
-- See Note [FunDep and implicit parameter reactions]
-- Precondition: isImprovable work_ev
improveLocalFunEqs work_ev inerts fam_tc args rhs
- = ASSERT( isImprovable work_ev )
+ = assert (isImprovable work_ev) $
unless (null improvement_eqns) $
do { traceTcS "interactFunEq improvements: " $
vcat [ text "Eqns:" <+> ppr improvement_eqns
@@ -2471,8 +2472,8 @@ matchLocalInst pred loc
= (match:matches, unif)
| otherwise
- = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)
- , ppr qci $$ ppr pred )
+ = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))
+ (ppr qci $$ ppr pred)
-- ASSERT: unification relies on the
-- quantified variables being fresh
(matches, unif || this_unif)
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index c12ffca1eb..cf116996d5 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -2353,7 +2353,7 @@ getPendingGivenScs = do { lvl <- getTcLevel
get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)
get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
- = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )
+ = assertPpr (all isGivenCt sc_pending) (ppr sc_pending)
-- When getPendingScDics is called,
-- there are never any Wanteds in the inert set
(sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })
@@ -2470,7 +2470,7 @@ isOuterTyVar :: TcLevel -> TyCoVar -> Bool
-- True of a type variable that comes from a
-- shallower level than the ambient level (tclvl)
isOuterTyVar tclvl tv
- | isTyVar tv = ASSERT2( not (isTouchableMetaTyVar tclvl tv), ppr tv <+> ppr tclvl )
+ | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $
tclvl `strictlyDeeperThan` tcTyVarLevel tv
-- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from
-- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't
@@ -3481,7 +3481,7 @@ unifyTyVar :: TcTyVar -> TcType -> TcS ()
--
-- We should never unify the same variable twice!
unifyTyVar tv ty
- = ASSERT2( isMetaTyVar tv, ppr tv )
+ = assertPpr (isMetaTyVar tv) (ppr tv) $
TcS $ \ env ->
do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)
; TcM.writeMetaTyVar tv ty
diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs
index 6fd4b85da1..2c95f78f6d 100644
--- a/compiler/GHC/Tc/Solver/Rewrite.hs
+++ b/compiler/GHC/Tc/Solver/Rewrite.hs
@@ -28,6 +28,7 @@ import GHC.Types.Var.Env
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Tc.Solver.Monad as TcS
import GHC.Utils.Misc
@@ -257,7 +258,7 @@ rewriteArgsNom ev tc tys
= do { traceTcS "rewrite_args {" (vcat (map ppr tys))
; (tys', cos, kind_co)
<- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys)
- ; MASSERT( isReflMCo kind_co )
+ ; massert (isReflMCo kind_co)
; traceTcS "rewrite }" (vcat (map ppr tys'))
; return (tys', cos) }
@@ -769,8 +770,8 @@ rewrite_fam_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)
-- rewrite_exact_fam_app lifts out the application to top level
-- Postcondition: Coercion :: Xi ~ F tys
rewrite_fam_app tc tys -- Can be over-saturated
- = ASSERT2( tys `lengthAtLeast` tyConArity tc
- , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
+ = assertPpr (tys `lengthAtLeast` tyConArity tc)
+ (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $
-- Type functions are saturated
-- The type function might be *over* saturated
@@ -968,7 +969,7 @@ rewrite_tyvar2 tv fr@(_, eq_rel)
ppr rhs_ty $$ ppr ctev)
; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
rewrite_co = case (ct_eq_rel, eq_rel) of
- (ReprEq, _rel) -> ASSERT( _rel == ReprEq )
+ (ReprEq, _rel) -> assert (_rel == ReprEq )
-- if this ASSERT fails, then
-- eqCanRewriteFR answered incorrectly
rewrite_co1
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index c645bac3b9..800e240f4e 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -91,6 +91,8 @@ import GHC.Unit
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import Control.Monad
@@ -1534,7 +1536,7 @@ getFamFlav mb_parent_tycon info =
case info of
DataFamily -> DataFamilyFlavour mb_parent_tycon
OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
- ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]
+ ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon]
ClosedTypeFamilyFlavour
{- Note [Closed type family mb_parent_tycon]
@@ -2377,7 +2379,7 @@ tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })
tcTyClDecl1 _parent roles_info
(SynDecl { tcdLName = L _ tc_name
, tcdRhs = rhs })
- = ASSERT( isNothing _parent )
+ = assert (isNothing _parent )
fmap noDerivInfos $
tcTySynRhs roles_info tc_name rhs
@@ -2385,7 +2387,7 @@ tcTyClDecl1 _parent roles_info
tcTyClDecl1 _parent roles_info
decl@(DataDecl { tcdLName = L _ tc_name
, tcdDataDefn = defn })
- = ASSERT( isNothing _parent )
+ = assert (isNothing _parent) $
tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn
tcTyClDecl1 _parent roles_info
@@ -2396,7 +2398,7 @@ tcTyClDecl1 _parent roles_info
, tcdSigs = sigs
, tcdATs = ats
, tcdATDefs = at_defs })
- = ASSERT( isNothing _parent )
+ = assert (isNothing _parent) $
do { clas <- tcClassDecl1 roles_info class_name hs_ctxt
meths fundeps sigs ats at_defs
; return (noDerivInfos (classTyCon clas)) }
@@ -2550,7 +2552,7 @@ tcDefaultAssocDecl fam_tc
vis_pats = numVisibleArgs hs_pats
-- Kind of family check
- ; ASSERT( fam_tc_name == tc_name )
+ ; assert (fam_tc_name == tc_name) $
checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Arity check
@@ -2957,7 +2959,7 @@ tcDataDefn err_ctxt roles_info tc_name
mk_tc_rhs _ tycon data_cons
= case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( not (null data_cons) )
+ NewType -> assert (not (null data_cons)) $
mkNewTyConRhs tc_name tycon (head data_cons)
@@ -4303,7 +4305,7 @@ checkPartialRecordField all_cons fld
has_field con = fld `elem` (dataConFieldLabels con)
is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field
- con1 = ASSERT( not (null cons_with_field) ) head cons_with_field
+ con1 = assert (not (null cons_with_field)) $ head cons_with_field
(univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1
eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
inst_tys = substTyVars eq_subst univ_tvs
@@ -4432,12 +4434,12 @@ checkValidDataCon dflags existential_ok tc con
user_tvbs_invariant
= Set.fromList (filterEqSpec eq_spec univs ++ exs)
== Set.fromList user_tvs
- ; MASSERT2( user_tvbs_invariant
- , vcat ([ ppr con
+ ; massertPpr user_tvbs_invariant
+ $ vcat ([ ppr con
, ppr univs
, ppr exs
, ppr eq_spec
- , ppr user_tvs ])) }
+ , ppr user_tvs ]) }
; traceTc "Done validity of data con" $
vcat [ ppr con
@@ -5044,8 +5046,8 @@ addVDQNote :: TcTyCon -> TcM a -> TcM a
-- See Note [Inferring visible dependent quantification]
-- Only types without a signature (CUSK or SAK) here
addVDQNote tycon thing_inside
- | ASSERT2( isTcTyCon tycon, ppr tycon )
- ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )
+ | assertPpr (isTcTyCon tycon) (ppr tycon) $
+ assertPpr (not (tcTyConIsPoly tycon)) (ppr tycon $$ ppr tc_kind)
has_vdq
= addLandmarkErrCtxt vdq_warning thing_inside
| otherwise
diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs
index 1dba4093f1..4e877471bb 100644
--- a/compiler/GHC/Tc/TyCl/Build.hs
+++ b/compiler/GHC/Tc/TyCl/Build.hs
@@ -224,19 +224,19 @@ buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder
pat_ty field_labels
= -- The assertion checks that the matcher is
-- compatible with the pattern synonym
- ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
- , ex_tvs `equalLength` ex_tvs1
- , pat_ty `eqType` substTy subst (scaledThing pat_ty1)
- , prov_theta `eqTypes` substTys subst prov_theta1
- , req_theta `eqTypes` substTys subst req_theta1
- , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))
- ])
- , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
+ assertPpr (and [ univ_tvs `equalLength` univ_tvs1
+ , ex_tvs `equalLength` ex_tvs1
+ , pat_ty `eqType` substTy subst (scaledThing pat_ty1)
+ , prov_theta `eqTypes` substTys subst prov_theta1
+ , req_theta `eqTypes` substTys subst req_theta1
+ , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))
+ ])
+ (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
, ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
, ppr pat_ty <+> twiddle <+> ppr pat_ty1
, ppr prov_theta <+> twiddle <+> ppr prov_theta1
, ppr req_theta <+> twiddle <+> ppr req_theta1
- , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
+ , ppr arg_tys <+> twiddle <+> ppr arg_tys1]) $
mkPatSyn src_name declared_infix
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys pat_ty
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 1c1f6608cd..ea09c89ddb 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -61,6 +61,7 @@ import GHC.Types.Var.Env
import GHC.Types.SourceFile (HscSource(..))
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Data.Maybe
@@ -369,7 +370,7 @@ instantiateMethod :: Class -> TcId -> [TcType] -> TcType
-- Return the "local method type":
-- forall c. Ix x => (ty2,c) -> ty1
instantiateMethod clas sel_id inst_tys
- = ASSERT( ok_first_pred ) local_meth_ty
+ = assert ok_first_pred local_meth_ty
where
rho_ty = piResultTys (idType sel_id) inst_tys
(first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index c5be699e13..8a80baaa90 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -80,6 +80,7 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
@@ -748,7 +749,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
; axiom_name <- newFamInstAxiomName lfam_name [pats]
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( not (null data_cons) )
+ NewType -> assert (not (null data_cons)) $
mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 2ba02e3584..660b0da6da 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -408,7 +408,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
-- See Note [Checking against a pattern signature]
; req_dicts <- newEvVars skol_req_theta
; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
- ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
+ assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $
pushLevelAndCaptureConstraints $
tcExtendNameTyVarEnv univ_tv_prs $
tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index efaf909ef8..02c681926f 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -55,6 +55,7 @@ import GHC.Core.Coercion ( ltRole )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.FV as FV
@@ -715,21 +716,21 @@ runRoleM env thing = (env', update)
setRoleInferenceTc :: Name -> RoleM a -> RoleM a
setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->
- ASSERT( isNothing m_name )
- ASSERT( isEmptyVarEnv vps )
- ASSERT( nvps == 0 )
+ assert (isNothing m_name) $
+ assert (isEmptyVarEnv vps) $
+ assert (nvps == 0) $
unRM thing (Just name) vps nvps state
addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a
addRoleInferenceVar tv thing
= RM $ \m_name vps nvps state ->
- ASSERT( isJust m_name )
+ assert (isJust m_name) $
unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state
setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
setRoleInferenceVars tvs thing
= RM $ \m_name _vps _nvps state ->
- ASSERT( isJust m_name )
+ assert (isJust m_name) $
unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")
state
@@ -888,7 +889,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- Find a representative constructor, con1
cons_w_field = conLikesWithFields all_cons [lbl]
- con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+ con1 = assert (not (null cons_w_field)) $ head cons_w_field
-- Selector type; Note [Polymorphic selectors]
field_ty = conLikeFieldType con1 lbl
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 8e9e1db1b7..3156a581e8 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -1436,7 +1436,7 @@ plusImportAvails
where
plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })
r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})
- | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))
+ | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot))) $
boot1 == IsBoot = r2
| otherwise = r1
-- If either side can "see" a non-hi-boot interface, use that
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index c75760853b..a6dfc4e5f8 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -341,13 +341,13 @@ mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d
mkWpCastR :: TcCoercionR -> HsWrapper
mkWpCastR co
| isTcReflCo co = WpHole
- | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co)
+ | otherwise = assertPpr (tcCoercionRole co == Representational) (ppr co) $
WpCast co
mkWpCastN :: TcCoercionN -> HsWrapper
mkWpCastN co
| isTcReflCo co = WpHole
- | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co)
+ | otherwise = assertPpr (tcCoercionRole co == Nominal) (ppr co) $
WpCast (mkTcSubCo co)
-- The mkTcSubCo converts Nominal to Representational
@@ -866,8 +866,8 @@ Important Details:
mkEvCast :: EvExpr -> TcCoercion -> EvTerm
mkEvCast ev lco
- | ASSERT2( tcCoercionRole lco == Representational
- , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))
+ | assertPpr (tcCoercionRole lco == Representational)
+ (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $
isTcReflCo lco = EvExpr ev
| otherwise = evCast ev lco
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index a27c4de082..592b3a64ac 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -76,10 +76,10 @@ import GHC.Tc.Utils.Env
import GHC.Tc.Errors
import GHC.Tc.Utils.Unify
-import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Data.Maybe
@@ -1060,8 +1060,8 @@ instantiateSignature = do
-- TODO: setup the local RdrEnv so the error messages look a little better.
-- But this information isn't stored anywhere. Should we RETYPECHECK
-- the local one just to get the information? Hmm...
- MASSERT( isHomeModule home_unit outer_mod )
- MASSERT( isHomeUnitInstantiating home_unit)
+ massert (isHomeModule home_unit outer_mod )
+ massert (isHomeUnitInstantiating home_unit)
let uid = Indefinite (homeUnitInstanceOf home_unit)
inner_mod `checkImplements`
Module
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 601cd0a8ea..7edaab0e42 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -85,6 +85,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable
import GHC.Unit.State
@@ -124,7 +125,7 @@ newMethodFromName origin name ty_args
; let ty = piResultTys (idType id) ty_args
(theta, _caller_knows_this) = tcSplitPhiTy ty
- ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
+ ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $
instCall origin ty_args theta
; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }
@@ -397,7 +398,7 @@ tcInstInvisibleTyBinder subst (Anon af ty)
| Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty))
-- Equality is the *only* constraint currently handled in types.
-- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep
- = ASSERT( af == InvisArg )
+ = assert (af == InvisArg) $
do { co <- unifyKind Nothing k1 k2
; arg' <- mk co
; return (subst, arg') }
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 3243be77de..aea13efbc0 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -188,6 +188,7 @@ import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Logger
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 8070b4d513..00b16f8380 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -127,6 +127,8 @@ import GHC.Types.Name.Env
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.Pair
@@ -374,10 +376,10 @@ checkCoercionHole cv co
= do { cv_ty <- zonkTcType (varType cv)
-- co is already zonked, but cv might not be
; return $
- ASSERT2( ok cv_ty
- , (text "Bad coercion hole" <+>
- ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
- , ppr cv_ty ]) )
+ assertPpr (ok cv_ty)
+ (text "Bad coercion hole" <+>
+ ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
+ , ppr cv_ty ])
co }
| otherwise
= return co
@@ -906,7 +908,7 @@ newTauTvDetailsAtLevel tclvl
cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
cloneMetaTyVar tv
- = ASSERT( isTcTyVar tv )
+ = assert (isTcTyVar tv) $
do { ref <- newMutVar Flexi
; name' <- cloneMetaTyVarName (tyVarName tv)
; let details' = case tcTyVarDetails tv of
@@ -918,7 +920,7 @@ cloneMetaTyVar tv
-- Works for both type and kind variables
readMetaTyVar :: TyVar -> TcM MetaDetails
-readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
+readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $
readMutVar (metaTyVarRef tyvar)
isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)
@@ -955,15 +957,13 @@ writeMetaTyVar tyvar ty
-- Everything from here on only happens if DEBUG is on
| not (isTcTyVar tyvar)
- = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar )
- return ()
+ = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar)
| MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar
= writeMetaTyVarRef tyvar ref ty
| otherwise
- = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar )
- return ()
+ = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)
--------------------
writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
@@ -1000,13 +1000,13 @@ writeMetaTyVarRef tyvar ref ty
; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
-- Check for double updates
- ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )
+ ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details)
-- Check for level OK
- ; MASSERT2( level_check_ok, level_check_msg )
+ ; massertPpr level_check_ok level_check_msg
-- Check Kinds ok
- ; MASSERT2( kind_check_ok, kind_msg )
+ ; massertPpr kind_check_ok kind_msg
-- Do the write
; writeMutVar ref (Indirect ty) }
@@ -1714,7 +1714,7 @@ quantifyTyVars dvs
-- We should never quantify over coercion variables; check this
; let co_vars = filter isCoVar final_qtvs
- ; MASSERT2( null co_vars, ppr co_vars )
+ ; massertPpr (null co_vars) (ppr co_vars)
; return final_qtvs }
where
@@ -1757,7 +1757,7 @@ zonkAndSkolemise tyvar
; skolemiseQuantifiedTyVar zonked_tyvar }
| otherwise
- = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )
+ = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $
zonkTyCoVarKind tyvar
skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
@@ -1869,7 +1869,7 @@ skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar
-- We create a skolem TcTyVar, not a regular TyVar
-- See Note [Zonking to Skolem]
skolemiseUnboundMetaTyVar tv
- = ASSERT2( isMetaTyVar tv, ppr tv )
+ = assertPpr (isMetaTyVar tv) (ppr tv) $
do { when debugIsOn (check_empty tv)
; here <- getSrcSpanM -- Get the location from "here"
-- ie where we are generalising
@@ -2199,7 +2199,7 @@ promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool
-- Also returns either the original tyvar (no promotion) or the new one
-- See Note [Promoting unification variables]
promoteMetaTyVarTo tclvl tv
- | ASSERT2( isMetaTyVar tv, ppr tv )
+ | assertPpr (isMetaTyVar tv) (ppr tv) $
tcTyVarLevel tv `strictlyDeeperThan` tclvl
= do { cloned_tv <- cloneMetaTyVar tv
; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
@@ -2240,7 +2240,7 @@ zonkTyCoVar :: TyCoVar -> TcM TcType
-- Works on TyVars and TcTyVars
zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv
| isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv
- | otherwise = ASSERT2( isCoVar tv, ppr tv )
+ | otherwise = assertPpr (isCoVar tv) (ppr tv) $
mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv
-- Hackily, when typechecking type and class decls
-- we have TyVars in scope added (only) in
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 886d120661..bebc370d39 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -229,6 +229,7 @@ import GHC.Data.Maybe
import GHC.Data.List.SetOps ( getNth, findDupsEq )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Utils.Error( Validity(..), isValid )
import qualified GHC.LanguageExtensions as LangExt
@@ -698,7 +699,7 @@ instance Outputable TcLevel where
promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar
promoteSkolem tclvl skol
| tclvl < tcTyVarLevel skol
- = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
+ = assert (isTcTyVar skol && isSkolemTyVar skol )
setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol))
| otherwise
@@ -707,7 +708,7 @@ promoteSkolem tclvl skol
-- | Change the TcLevel in a skolem, extending a substitution
promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
promoteSkolemX tclvl subst skol
- = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
+ = assert (isTcTyVar skol && isSkolemTyVar skol )
(new_subst, new_skol)
where
new_skol
@@ -1005,8 +1006,8 @@ isTouchableMetaTyVar ctxt_tclvl tv
| isTyVar tv -- See Note [Coercion variables in free variable lists]
, MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv
, isTouchableInfo info
- = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
- ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
+ = assertPpr (checkTcLevelInvariant ctxt_tclvl tv_tclvl)
+ (ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl) $
tv_tclvl `sameDepthAs` ctxt_tclvl
| otherwise = False
@@ -1028,7 +1029,7 @@ isTyConableTyVar tv
| otherwise = True
isSkolemTyVar tv
- = ASSERT2( tcIsTcTyVar tv, ppr tv )
+ = assertPpr (tcIsTcTyVar tv) (ppr tv) $
case tcTyVarDetails tv of
MetaTv {} -> False
_other -> True
@@ -1220,13 +1221,13 @@ variables. It's up to you to make sure this doesn't matter.
-- Always succeeds, even if it returns an empty list.
tcSplitPiTys :: Type -> ([TyBinder], Type)
tcSplitPiTys ty
- = ASSERT( all isTyBinder (fst sty) ) sty
+ = assert (all isTyBinder (fst sty) ) sty
where sty = splitPiTys ty
-- | Splits a type into a TyBinder and a body, if possible. Panics otherwise
tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type)
tcSplitPiTy_maybe ty
- = ASSERT( isMaybeTyBinder sty ) sty
+ = assert (isMaybeTyBinder sty ) sty
where
sty = splitPiTy_maybe ty
isMaybeTyBinder (Just (t,_)) = isTyBinder t
@@ -1234,14 +1235,14 @@ tcSplitPiTy_maybe ty
tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type)
tcSplitForAllTyVarBinder_maybe ty | Just ty' <- tcView ty = tcSplitForAllTyVarBinder_maybe ty'
-tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)
+tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = assert (isTyVarBinder tv ) Just (tv, ty)
tcSplitForAllTyVarBinder_maybe _ = Nothing
-- | Like 'tcSplitPiTys', but splits off only named binders,
-- returning just the tyvars.
tcSplitForAllTyVars :: Type -> ([TyVar], Type)
tcSplitForAllTyVars ty
- = ASSERT( all isTyVar (fst sty) ) sty
+ = assert (all isTyVar (fst sty) ) sty
where sty = splitForAllTyCoVars ty
-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible'
@@ -1265,18 +1266,18 @@ tcSplitSomeForAllTyVars argf_pred ty
-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type
-- variable binders. All split tyvars are annotated with '()'.
tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)
-tcSplitForAllReqTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty
+tcSplitForAllReqTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty
where sty = splitForAllReqTVBinders ty
-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type
-- variable binders. All split tyvars are annotated with their 'Specificity'.
tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)
-tcSplitForAllInvisTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty
+tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty
where sty = splitForAllInvisTVBinders ty
-- | Like 'tcSplitForAllTyVars', but splits off only named binders.
tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)
-tcSplitForAllTyVarBinders ty = ASSERT( all isTyVarBinder (fst sty)) sty
+tcSplitForAllTyVarBinders ty = assert (all isTyVarBinder (fst sty)) sty
where sty = splitForAllTyCoVarBinders ty
-- | Is this a ForAllTy with a named binder?
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index eee4e1844c..76d0418eef 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -73,6 +73,7 @@ import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Exts ( inline )
import Control.Monad
@@ -107,7 +108,7 @@ matchActualFunTySigma
-- and NB: res_ty is an (uninstantiated) SigmaType
matchActualFunTySigma herald mb_thing err_info fun_ty
- = ASSERT2( isRhoTy fun_ty, ppr fun_ty )
+ = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
go fun_ty
where
-- Does not allocate unnecessary meta variables: if the input already is
@@ -122,7 +123,7 @@ matchActualFunTySigma herald mb_thing err_info fun_ty
go ty | Just ty' <- tcView ty = go ty'
go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })
- = ASSERT( af == VisArg )
+ = assert (af == VisArg) $
return (idHsWrapper, Scaled w arg_ty, res_ty)
go ty@(TyVarTy tv)
@@ -323,7 +324,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside
| Just ty' <- tcView ty = go acc_arg_tys n ty'
go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty })
- = ASSERT( af == VisArg )
+ = assert (af == VisArg) $
do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)
(n-1) res_ty
; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc
@@ -419,7 +420,7 @@ matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 ->
-- Postcondition: (T k1 k2 k3 a b c) is well-kinded
matchExpectedTyConApp tc orig_ty
- = ASSERT(not $ isFunTyCon tc) go orig_ty
+ = assert (not $ isFunTyCon tc) $ go orig_ty
where
go ty
| Just ty' <- tcView ty
@@ -542,7 +543,7 @@ tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc
-- rho-type, so nothing to instantiate; just go straight to unify.
-- It means we don't need to pass in a CtOrigin
tcWrapResultMono rn_expr expr act_ty res_ty
- = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr )
+ = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $
do { co <- unifyExpectedType rn_expr act_ty res_ty
; return (mkHsWrapCo co expr) }
@@ -1014,7 +1015,7 @@ buildImplicationFor tclvl skol_info skol_tvs given wanted
= return (emptyBag, emptyTcEvBinds)
| otherwise
- = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )
+ = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $
-- Why allow TyVarTvs? Because implicitly declared kind variables in
-- non-CUSK type declarations are TyVarTvs, and we need to bring them
-- into scope as a skolem in an implication. This is OK, though,
@@ -1225,7 +1226,7 @@ uType t_or_k origin orig_ty1 orig_ty2
go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-- See Note [Mismatched type lists and application decomposition]
| tc1 == tc2, equalLength tys1 tys2
- = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
+ = assertPpr (isGenerativeTyCon tc1 Nominal) (ppr tc1) $
do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2
; return $ mkTyConAppCo Nominal tc1 cos }
where
@@ -1244,12 +1245,12 @@ uType t_or_k origin orig_ty1 orig_ty2
go (AppTy s1 t1) (TyConApp tc2 ts2)
| Just (ts2', t2') <- snocView ts2
- = ASSERT( not (mustBeSaturated tc2) )
+ = assert (not (mustBeSaturated tc2)) $
go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
go (TyConApp tc1 ts1) (AppTy s2 t2)
| Just (ts1', t1') <- snocView ts1
- = ASSERT( not (mustBeSaturated tc1) )
+ = assert (not (mustBeSaturated tc1)) $
go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
go (CoercionTy co1) (CoercionTy co2)
@@ -1523,7 +1524,7 @@ lhsPriority :: TcTyVar -> Int
-- => more likely to be eliminated
-- See Note [TyVar/TyVar orientation]
lhsPriority tv
- = ASSERT2( isTyVar tv, ppr tv)
+ = assertPpr (isTyVar tv) (ppr tv) $
case tcTyVarDetails tv of
RuntimeUnk -> 0
SkolemTv {} -> 0
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index bca87fb293..e2fe09991f 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -73,6 +73,8 @@ import GHC.Core.DataCon
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants (debugIsOn)
import GHC.Core.Multiplicity
import GHC.Core
@@ -506,7 +508,7 @@ zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
-- as the old one. This important when zonking the
-- TyVarBndrs of a TyCon, whose Names may scope.
zonkTyBndrX env tv
- = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
+ = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $
do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
-- Internal names tidy up better, for iface files.
; let tv' = mkTyVar (tyVarName tv) ki
@@ -628,7 +630,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_exports = exports
, abs_binds = val_binds
, abs_sig = has_sig })
- = ASSERT( all isImmutableTyVar tyvars )
+ = assert (all isImmutableTyVar tyvars) $
do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
@@ -792,7 +794,7 @@ zonkLExprs env exprs = mapM (zonkLExpr env) exprs
zonkLExpr env expr = wrapLocMA (zonkExpr env) expr
zonkExpr env (HsVar x (L l id))
- = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
+ = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $
return (HsVar x (L l (zonkIdOcc env id)))
zonkExpr env (HsUnboundVar her occ)
@@ -1125,7 +1127,7 @@ zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
new_ty <- zonkTcTypeToTypeX env ty
new_ids <- mapSndM (zonkExpr env) ids
- MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )
+ massert (isLiftedTypeKind (tcTypeKind new_stack_tys))
-- desugarer assumes that this is not levity polymorphic...
-- but indeed it should always be lifted due to the typing
-- rules for arrows
@@ -1148,7 +1150,7 @@ zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
; return (env, WpEvApp arg') }
-zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
+zonkCoFn env (WpTyLam tv) = assert (isImmutableTyVar tv) $
do { (env', tv') <- zonkTyBndrX env tv
; return (env', WpTyLam tv') }
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty
@@ -1479,7 +1481,7 @@ zonk_pat env p@(ConPat { pat_con = L _ con
, cpt_arg_tys = tys
})
})
- = ASSERT( all isImmutableTyVar tyvars )
+ = assert (all isImmutableTyVar tyvars) $
do { new_tys <- mapM (zonkTcTypeToTypeX env) tys
-- an unboxed tuple pattern (but only an unboxed tuple pattern)
@@ -1626,7 +1628,7 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
zonk_it env v
| isId v = do { v' <- zonkIdBndr env v
; return (extendIdZonkEnvRec env [v'], v') }
- | otherwise = ASSERT( isImmutableTyVar v)
+ | otherwise = assert (isImmutableTyVar v)
zonkTyBndrX env v
-- DV: used to be return (env,v) but that is plain
-- wrong because we may need to go inside the kind
@@ -1960,9 +1962,9 @@ zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
; when debugIsOn $
whenNoErrs $
- MASSERT2( False
- , text "Type-correct unfilled coercion hole"
- <+> ppr hole )
+ massertPpr False
+ (text "Type-correct unfilled coercion hole"
+ <+> ppr hole)
; cv' <- zonkCoVar cv
; return $ mkCoVarCo cv' } }
-- This will be an out-of-scope variable, but keeping
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index a85158c122..0605926d94 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -808,7 +808,7 @@ check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand })
check_args_only expand = mapM_ (check_arg expand) tys
check_expansion_only expand
- = ASSERT2( isTypeSynonymTyCon tc, ppr tc )
+ = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $
case tcView ty of
Just ty' -> let err_ctxt = text "In the expansion of type synonym"
<+> quotes (ppr tc)
diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs
index e3e821deca..7c033a9863 100644
--- a/compiler/GHC/Types/Avail.hs
+++ b/compiler/GHC/Types/Avail.hs
@@ -51,6 +51,7 @@ import GHC.Data.List.SetOps
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
+import GHC.Utils.Constants (debugIsOn)
import Data.Data ( Data )
import Data.Either ( partitionEithers )
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 48ec97f6f8..172f9f4d18 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -162,6 +162,7 @@ import GHC.Core.Multiplicity
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.GlobalVars
import GHC.Driver.Ppr
@@ -239,7 +240,7 @@ localiseId :: Id -> Id
-- Make an Id with the same unique and type as the
-- incoming Id, but with an *Internal* Name and *LocalId* flavour
localiseId id
- | ASSERT( isId id ) isLocalId id && isInternalName name
+ | assert (isId id) $ isLocalId id && isInternalName name
= id
| otherwise
= Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id)
@@ -298,19 +299,19 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId
-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal"
mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id
-mkLocalId name w ty = ASSERT( not (isCoVarType ty) )
+mkLocalId name w ty = assert (not (isCoVarType ty)) $
mkLocalIdWithInfo name w ty vanillaIdInfo
-- | Make a local CoVar
mkLocalCoVar :: Name -> Type -> CoVar
mkLocalCoVar name ty
- = ASSERT( isCoVarType ty )
+ = assert (isCoVarType ty) $
Var.mkLocalVar CoVarId name Many ty vanillaIdInfo
-- | Like 'mkLocalId', but checks the type to see if it should make a covar
mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id
mkLocalIdOrCoVar name w ty
- -- We should ASSERT(eqType w Many) in the isCoVarType case.
+ -- We should assert (eqType w Many) in the isCoVarType case.
-- However, currently this assertion does not hold.
-- In tests with -fdefer-type-errors, such as T14584a,
-- we create a linear 'case' where the scrutinee is a coercion
@@ -320,7 +321,7 @@ mkLocalIdOrCoVar name w ty
-- proper ids only; no covars!
mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id
-mkLocalIdWithInfo name w ty info = ASSERT( not (isCoVarType ty) )
+mkLocalIdWithInfo name w ty info = assert (not (isCoVarType ty)) $
Var.mkLocalVar VanillaId name w ty info
-- Note [Free type variables]
@@ -339,7 +340,7 @@ mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaId
-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")
-- that are created by the compiler out of thin air
mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id
-mkSysLocal fs uniq w ty = ASSERT( not (isCoVarType ty) )
+mkSysLocal fs uniq w ty = assert (not (isCoVarType ty)) $
mkLocalId (mkSystemVarName uniq fs) w ty
-- | Like 'mkSysLocal', but checks to see if we have a covar type
@@ -356,7 +357,7 @@ mkSysLocalOrCoVarM fs w ty
-- | Create a user local 'Id'. These are local 'Id's (see "GHC.Types.Var#globalvslocal") with a name and location that the user might recognize
mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id
-mkUserLocal occ uniq w ty loc = ASSERT( not (isCoVarType ty) )
+mkUserLocal occ uniq w ty loc = assert (not (isCoVarType ty)) $
mkLocalId (mkInternalName uniq occ loc) w ty
-- | Like 'mkUserLocal', but checks if we have a coercion type
@@ -545,7 +546,7 @@ isJoinId id
isJoinId_maybe :: Var -> Maybe JoinArity
isJoinId_maybe id
- | isId id = ASSERT2( isId id, ppr id )
+ | isId id = assertPpr (isId id) (ppr id) $
case Var.idDetails id of
JoinId arity -> Just arity
_ -> Nothing
@@ -706,7 +707,7 @@ zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id
-- type, we still want @isStrictId id@ to be @True@.
isStrictId :: Id -> Bool
isStrictId id
- | ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
+ | assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $
isJoinId id = False
| otherwise = isStrictType (idType id) ||
isStrUsedDmd (idDemandInfo id)
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 399937265c..f02409d03c 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -111,6 +111,7 @@ import GHC.Types.Cpr
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.Word
@@ -334,13 +335,13 @@ bitfieldSetLevityInfo info (BitField bits) =
bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetCallArityInfo info bf@(BitField bits) =
- ASSERT(info < 2^(30 :: Int) - 1)
+ assert (info < 2^(30 :: Int) - 1) $
bitfieldSetArityInfo (bitfieldGetArityInfo bf) $
BitField ((fromIntegral info `shiftL` 3) .|. (bits .&. 0b111))
bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetArityInfo info (BitField bits) =
- ASSERT(info < 2^(30 :: Int) - 1)
+ assert (info < 2^(30 :: Int) - 1) $
BitField ((fromIntegral info `shiftL` 33) .|. (bits .&. ((1 `shiftL` 33) - 1)))
-- Getters
@@ -741,7 +742,7 @@ instance Outputable LevityInfo where
-- polymorphic
setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
setNeverLevPoly info ty
- = ASSERT2( not (resultIsLevPoly ty), ppr ty )
+ = assertPpr (not (resultIsLevPoly ty)) (ppr ty) $
info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }
setLevityInfoWithType :: IdInfo -> Type -> IdInfo
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 06f4982e7d..d87db65f0f 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -81,6 +81,7 @@ import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Types.Var (VarBndr(Bndr))
@@ -601,9 +602,8 @@ mkDataConWorkId wkr_name data_con
`setLevityInfoWithType` wkr_ty
id_arg1 = mkScaledTemplateLocal 1 (head arg_tys)
res_ty_args = mkTyCoVarTys univ_tvs
- newtype_unf = ASSERT2( isVanillaDataCon data_con &&
- isSingleton arg_tys
- , ppr data_con )
+ newtype_unf = assertPpr (isVanillaDataCon data_con && isSingleton arg_tys)
+ (ppr data_con) $
-- Note [Newtype datacons]
mkCompulsoryUnfolding defaultSimpleOpts $
mkLams univ_tvs $ Lam id_arg1 $
@@ -821,7 +821,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
; (rep_ids, binds) <- go subst2 boxers term_vars
; return (ex_vars ++ rep_ids, binds) } )
- go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
+ go _ [] src_vars = assertPpr (null src_vars) (ppr data_con) $ return ([], [])
go subst (UnitBox : boxers) (src_var : src_vars)
= do { (rep_ids2, binds) <- go subst boxers src_vars
; return (src_var : rep_ids2, binds) }
@@ -1110,7 +1110,7 @@ dataConArgUnpack (Scaled arg_mult arg_ty)
-- A recursive newtype might mean that
-- 'arg_ty' is a newtype
, let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args
- = ASSERT( null (dataConExTyCoVars con) )
+ = assert (null (dataConExTyCoVars con))
-- Note [Unpacking GADTs and existentials]
( rep_tys `zip` dataConRepStrictness con
,( \ arg_id ->
@@ -1273,7 +1273,7 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- it, otherwise the wrap/unwrap are both no-ops
wrapNewTypeBody tycon args result_expr
- = ASSERT( isNewTyCon tycon )
+ = assert (isNewTyCon tycon) $
mkCast result_expr (mkSymCo co)
where
co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []
@@ -1285,7 +1285,7 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
- = ASSERT( isNewTyCon tycon )
+ = assert (isNewTyCon tycon) $
mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])
-- If the type constructor is a representation type of a data instance, wrap
@@ -1347,7 +1347,7 @@ mkPrimOpId prim_op
mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId dflags uniq fcall ty
- = ASSERT( noFreeVarsOfType ty )
+ = assert (noFreeVarsOfType ty) $
-- A CCallOpId should have no free type variables;
-- when doing substitutions won't substitute over it
mkGlobalId (FCallId fcall) name ty info
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index d2446b9fe5..4552f45bf8 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -374,12 +374,12 @@ litNumCheckRange platform nt i = case nt of
-- | Create a numeric 'Literal' of the given type
mkLitNumber :: Platform -> LitNumType -> Integer -> Literal
mkLitNumber platform nt i =
- ASSERT2(litNumCheckRange platform nt i, integer i)
+ assertPpr (litNumCheckRange platform nt i) (integer i)
(LitNumber nt i)
-- | Creates a 'Literal' of type @Int#@
mkLitInt :: Platform -> Integer -> Literal
-mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x )
+mkLitInt platform x = assertPpr (platformInIntRange platform x) (integer x)
(mkLitIntUnchecked x)
-- | Creates a 'Literal' of type @Int#@.
@@ -403,7 +403,7 @@ mkLitIntWrapC platform i = (n, i /= i')
-- | Creates a 'Literal' of type @Word#@
mkLitWord :: Platform -> Integer -> Literal
-mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x )
+mkLitWord platform x = assertPpr (platformInWordRange platform x) (integer x)
(mkLitWordUnchecked x)
-- | Creates a 'Literal' of type @Word#@.
@@ -427,7 +427,7 @@ mkLitWordWrapC platform i = (n, i /= i')
-- | Creates a 'Literal' of type @Int8#@
mkLitInt8 :: Integer -> Literal
-mkLitInt8 x = ASSERT2( inBoundedRange @Int8 x, integer x ) (mkLitInt8Unchecked x)
+mkLitInt8 x = assertPpr (inBoundedRange @Int8 x) (integer x) (mkLitInt8Unchecked x)
-- | Creates a 'Literal' of type @Int8#@.
-- If the argument is out of the range, it is wrapped.
@@ -440,7 +440,7 @@ mkLitInt8Unchecked i = LitNumber LitNumInt8 i
-- | Creates a 'Literal' of type @Word8#@
mkLitWord8 :: Integer -> Literal
-mkLitWord8 x = ASSERT2( inBoundedRange @Word8 x, integer x ) (mkLitWord8Unchecked x)
+mkLitWord8 x = assertPpr (inBoundedRange @Word8 x) (integer x) (mkLitWord8Unchecked x)
-- | Creates a 'Literal' of type @Word8#@.
-- If the argument is out of the range, it is wrapped.
@@ -453,7 +453,7 @@ mkLitWord8Unchecked i = LitNumber LitNumWord8 i
-- | Creates a 'Literal' of type @Int16#@
mkLitInt16 :: Integer -> Literal
-mkLitInt16 x = ASSERT2( inBoundedRange @Int16 x, integer x ) (mkLitInt16Unchecked x)
+mkLitInt16 x = assertPpr (inBoundedRange @Int16 x) (integer x) (mkLitInt16Unchecked x)
-- | Creates a 'Literal' of type @Int16#@.
-- If the argument is out of the range, it is wrapped.
@@ -466,7 +466,7 @@ mkLitInt16Unchecked i = LitNumber LitNumInt16 i
-- | Creates a 'Literal' of type @Word16#@
mkLitWord16 :: Integer -> Literal
-mkLitWord16 x = ASSERT2( inBoundedRange @Word16 x, integer x ) (mkLitWord16Unchecked x)
+mkLitWord16 x = assertPpr (inBoundedRange @Word16 x) (integer x) (mkLitWord16Unchecked x)
-- | Creates a 'Literal' of type @Word16#@.
-- If the argument is out of the range, it is wrapped.
@@ -479,7 +479,7 @@ mkLitWord16Unchecked i = LitNumber LitNumWord16 i
-- | Creates a 'Literal' of type @Int32#@
mkLitInt32 :: Integer -> Literal
-mkLitInt32 x = ASSERT2( inBoundedRange @Int32 x, integer x ) (mkLitInt32Unchecked x)
+mkLitInt32 x = assertPpr (inBoundedRange @Int32 x) (integer x) (mkLitInt32Unchecked x)
-- | Creates a 'Literal' of type @Int32#@.
-- If the argument is out of the range, it is wrapped.
@@ -492,7 +492,7 @@ mkLitInt32Unchecked i = LitNumber LitNumInt32 i
-- | Creates a 'Literal' of type @Word32#@
mkLitWord32 :: Integer -> Literal
-mkLitWord32 x = ASSERT2( inBoundedRange @Word32 x, integer x ) (mkLitWord32Unchecked x)
+mkLitWord32 x = assertPpr (inBoundedRange @Word32 x) (integer x) (mkLitWord32Unchecked x)
-- | Creates a 'Literal' of type @Word32#@.
-- If the argument is out of the range, it is wrapped.
@@ -505,7 +505,7 @@ mkLitWord32Unchecked i = LitNumber LitNumWord32 i
-- | Creates a 'Literal' of type @Int64#@
mkLitInt64 :: Integer -> Literal
-mkLitInt64 x = ASSERT2( inBoundedRange @Int64 x, integer x ) (mkLitInt64Unchecked x)
+mkLitInt64 x = assertPpr (inBoundedRange @Int64 x) (integer x) (mkLitInt64Unchecked x)
-- | Creates a 'Literal' of type @Int64#@.
-- If the argument is out of the range, it is wrapped.
@@ -518,7 +518,7 @@ mkLitInt64Unchecked i = LitNumber LitNumInt64 i
-- | Creates a 'Literal' of type @Word64#@
mkLitWord64 :: Integer -> Literal
-mkLitWord64 x = ASSERT2( inBoundedRange @Word64 x, integer x ) (mkLitWord64Unchecked x)
+mkLitWord64 x = assertPpr (inBoundedRange @Word64 x) (integer x) (mkLitWord64Unchecked x)
-- | Creates a 'Literal' of type @Word64#@.
-- If the argument is out of the range, it is wrapped.
@@ -551,7 +551,7 @@ mkLitInteger :: Integer -> Literal
mkLitInteger x = LitNumber LitNumInteger x
mkLitNatural :: Integer -> Literal
-mkLitNatural x = ASSERT2( inNaturalRange x, integer x )
+mkLitNatural x = assertPpr (inNaturalRange x) (integer x)
(LitNumber LitNumNatural x)
-- | Create a rubbish literal of the given representation.
diff --git a/compiler/GHC/Types/Name/Cache.hs b/compiler/GHC/Types/Name/Cache.hs
index 4a8ffb50d7..d1ba2b54d4 100644
--- a/compiler/GHC/Types/Name/Cache.hs
+++ b/compiler/GHC/Types/Name/Cache.hs
@@ -25,7 +25,6 @@ import GHC.Types.Unique.Supply
import GHC.Builtin.Types
import GHC.Builtin.Names
-import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -119,7 +118,7 @@ lookupOrigNameCache nc mod occ
extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache' nc name
- = ASSERT2( isExternalName name, ppr name )
+ = assertPpr (isExternalName name) (ppr name) $
extendOrigNameCache nc (nameModule name) (nameOccName name) name
extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs
index 14fb5670e1..ac19547738 100644
--- a/compiler/GHC/Types/Name/Ppr.hs
+++ b/compiler/GHC/Types/Name/Ppr.hs
@@ -112,7 +112,7 @@ mkPrintUnqualified unit_env env
-- Eg f = True; g = 0; f = False
where
is_name :: Name -> Bool
- is_name name = ASSERT2( isExternalName name, ppr name )
+ is_name name = assertPpr (isExternalName name) (ppr name) $
nameModule name == mod && nameOccName name == occ
forceUnqualNames :: [Name]
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index 7ec1356939..bdf2eae770 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -1368,7 +1368,7 @@ ppr_defn_site imp_spec name
2 (pprLoc loc)
where
loc = nameSrcSpan name
- defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+ defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name
same_module = importSpecModule imp_spec == moduleName defining_mod
pp_mod | same_module = empty
| otherwise = text "in" <+> quotes (ppr defining_mod)
diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs
index 456c1d6d24..c65124d51c 100644
--- a/compiler/GHC/Types/Name/Shape.hs
+++ b/compiler/GHC/Types/Name/Shape.hs
@@ -29,8 +29,7 @@ import GHC.Tc.Utils.Monad
import GHC.Iface.Env
import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Control.Monad
@@ -268,11 +267,11 @@ uName flexi subst n1 n2
uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
-> Either SDoc ShNameSubst
uHoleName flexi subst h n =
- ASSERT( isHoleName h )
+ assert (isHoleName h) $
case lookupNameEnv subst h of
Just n' -> uName flexi subst n' n
-- Do a quick check if the other name is substituted.
Nothing | Just n' <- lookupNameEnv subst n ->
- ASSERT( isHoleName n ) uName flexi subst h n'
+ assert (isHoleName n) $ uName flexi subst h n'
| otherwise ->
Right (extendNameEnv subst h n)
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index 4d325e0f5c..de7b36583b 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -39,6 +39,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind, runtimeRepTy )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.List (sort)
import qualified Data.IntSet as IS
@@ -532,7 +533,7 @@ kindPrimRep doc ki
| Just ki' <- coreView ki
= kindPrimRep doc ki'
kindPrimRep doc (TyConApp typ [runtime_rep])
- = ASSERT( typ `hasKey` tYPETyConKey )
+ = assert (typ `hasKey` tYPETyConKey) $
runtimeRepPrimRep doc runtime_rep
kindPrimRep doc ki
= pprPanic "kindPrimRep" (ppr ki $$ doc)
@@ -543,7 +544,7 @@ kindPrimRep doc ki
runtimeRepMonoPrimRep_maybe :: HasDebugCallStack => Type -> Maybe [PrimRep]
runtimeRepMonoPrimRep_maybe rr_ty
| Just (rr_dc, args) <- splitTyConApp_maybe rr_ty
- , ASSERT2( runtimeRepTy `eqType` typeKind rr_ty, ppr rr_ty ) True
+ , assertPpr (runtimeRepTy `eqType` typeKind rr_ty) (ppr rr_ty) True
, RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
= Just (fun args)
| otherwise
diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs
index 0735539910..b74119caa3 100644
--- a/compiler/GHC/Types/Unique.hs
+++ b/compiler/GHC/Types/Unique.hs
@@ -52,8 +52,7 @@ import GHC.Prelude
import GHC.Data.FastString
import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
-- just for implementing a fast [0,61) -> Char function
import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))
@@ -311,7 +310,7 @@ Code stolen from Lennart.
iToBase62 :: Int -> String
iToBase62 n_
- = ASSERT(n_ >= 0) go n_ ""
+ = assert (n_ >= 0) $ go n_ ""
where
go n cs | n < 62
= let !c = chooseChar62 n in c : cs
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
index 6c2eec6a6d..27371d0647 100644
--- a/compiler/GHC/Types/Unique/FM.hs
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -83,8 +83,7 @@ import GHC.Prelude
import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
import GHC.Utils.Outputable
-import GHC.Utils.Panic (assertPanic)
-import GHC.Utils.Misc (debugIsOn)
+import GHC.Utils.Panic.Plain
import qualified Data.IntMap as M
import qualified Data.IntMap.Strict as MS
import qualified Data.IntSet as S
@@ -127,7 +126,7 @@ unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
-- Note that listToUFM (zip ks vs) performs similarly, but
-- the explicit recursion avoids relying too much on fusion.
zipToUFM :: Uniquable key => [key] -> [elt] -> UniqFM key elt
-zipToUFM ks vs = ASSERT( length ks == length vs ) innerZip emptyUFM ks vs
+zipToUFM ks vs = assert (length ks == length vs ) innerZip emptyUFM ks vs
where
innerZip ufm (k:kList) (v:vList) = innerZip (addToUFM ufm k v) kList vList
innerZip ufm _ _ = ufm
diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs
index f3e2b4b353..c477177f09 100644
--- a/compiler/GHC/Types/Unique/Supply.hs
+++ b/compiler/GHC/Types/Unique/Supply.hs
@@ -43,9 +43,6 @@ import Data.Char
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )
-#if defined(DEBUG)
-import GHC.Utils.Misc
-#endif
#endif
import Foreign.Storable
@@ -241,7 +238,7 @@ genSym = do
#if defined(DEBUG)
-- Uh oh! We will overflow next time a unique is requested.
-- (Note that if the increment isn't 1 we may miss this check)
- MASSERT(u /= mask)
+ massert (u /= mask)
#endif
return u
#endif
diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs
index 4bb0b27ac8..f00ad29256 100644
--- a/compiler/GHC/Types/Var.hs
+++ b/compiler/GHC/Types/Var.hs
@@ -112,6 +112,7 @@ import GHC.Utils.Misc
import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import Data.Data
@@ -409,13 +410,10 @@ setVarType id ty = id { varType = ty }
-- abuse, ASSERTs that there is no multiplicity to update.
updateVarType :: (Type -> Type) -> Var -> Var
updateVarType upd var
- | debugIsOn
= case var of
- Id { id_details = details } -> ASSERT( isCoVarDetails details )
+ Id { id_details = details } -> assert (isCoVarDetails details) $
result
_ -> result
- | otherwise
- = result
where
result = var { varType = upd (varType var) }
@@ -424,13 +422,10 @@ updateVarType upd var
-- abuse, ASSERTs that there is no multiplicity to update.
updateVarTypeM :: Monad m => (Type -> m Type) -> Var -> m Var
updateVarTypeM upd var
- | debugIsOn
= case var of
- Id { id_details = details } -> ASSERT( isCoVarDetails details )
+ Id { id_details = details } -> assert (isCoVarDetails details) $
result
_ -> result
- | otherwise
- = result
where
result = do { ty' <- upd (varType var)
; return (var { varType = ty' }) }
@@ -683,7 +678,7 @@ mkTyCoVarBinder vis var = Bndr var vis
-- 'var' should be a type variable
mkTyVarBinder :: vis -> TyVar -> VarBndr TyVar vis
mkTyVarBinder vis var
- = ASSERT( isTyVar var )
+ = assert (isTyVar var) $
Bndr var vis
-- | Make many named binders
@@ -848,7 +843,7 @@ setIdExported tv = pprPanic "setIdExported" (ppr t
setIdNotExported :: Id -> Id
-- ^ We can only do this to LocalIds
-setIdNotExported id = ASSERT( isLocalId id )
+setIdNotExported id = assert (isLocalId id) $
id { idScope = LocalId NotExported }
-----------------------
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
index cc2ccbe874..903fd27891 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ b/compiler/GHC/Unit/Finder.hs
@@ -362,7 +362,8 @@ findPackageModule fc unit_state dflags mod = do
-- for the appropriate config.
findPackageModule_ :: FinderCache -> DynFlags -> InstalledModule -> UnitInfo -> IO InstalledFindResult
findPackageModule_ fc dflags mod pkg_conf = do
- MASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )
+ massertPpr (moduleUnit mod == unitId pkg_conf)
+ (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))
modLocationCache fc mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
diff --git a/compiler/GHC/Utils/Constants.hs b/compiler/GHC/Utils/Constants.hs
new file mode 100644
index 0000000000..518c5f31be
--- /dev/null
+++ b/compiler/GHC/Utils/Constants.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Utils.Constants
+ ( debugIsOn
+ , ghciSupported
+ , isWindowsHost
+ , isDarwinHost
+ )
+where
+
+import GHC.Prelude
+
+{-
+
+These booleans are global constants, set by CPP flags. They allow us to
+recompile a single module (this one) to change whether or not debug output
+appears. They sometimes let us avoid even running CPP elsewhere.
+
+It's important that the flags are literal constants (True/False). Then,
+with -0, tests of the flags in other modules will simplify to the correct
+branch of the conditional, thereby dropping debug code altogether when
+the flags are off.
+-}
+
+ghciSupported :: Bool
+#if defined(HAVE_INTERNAL_INTERPRETER)
+ghciSupported = True
+#else
+ghciSupported = False
+#endif
+
+debugIsOn :: Bool
+#if defined(DEBUG)
+debugIsOn = True
+#else
+debugIsOn = False
+#endif
+
+isWindowsHost :: Bool
+#if defined(mingw32_HOST_OS)
+isWindowsHost = True
+#else
+isWindowsHost = False
+#endif
+
+isDarwinHost :: Bool
+#if defined(darwin_HOST_OS)
+isDarwinHost = True
+#else
+isDarwinHost = False
+#endif
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 2380c95032..2692b30acb 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -72,8 +72,8 @@ import GHC.Data.Bag
import GHC.Utils.Exception
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
-import GHC.Utils.Misc ( debugIsOn )
import GHC.Types.Error
import GHC.Types.SrcLoc as SrcLoc
@@ -152,7 +152,7 @@ mkErrorMsgEnvelope :: Diagnostic e
-> e
-> MsgEnvelope e
mkErrorMsgEnvelope locn unqual msg =
- ASSERT( diagnosticReason msg == ErrorWithoutFlag ) mk_msg_envelope SevError locn unqual msg
+ assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg
-- | Variant that doesn't care about qualified/unqualified names.
mkPlainMsgEnvelope :: Diagnostic e
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index 67d3f11c67..5629b339b9 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -13,10 +13,6 @@
-- | Highly random utility functions
--
module GHC.Utils.Misc (
- -- * Flags dependent on the compiler build
- ghciSupported, debugIsOn,
- isWindowsHost, isDarwinHost,
-
-- * Miscellaneous higher-order functions
applyWhen, nTimes,
@@ -137,6 +133,7 @@ import GHC.Prelude
import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants
import Data.Data
import qualified Data.List as List
@@ -170,50 +167,6 @@ import {-# SOURCE #-} GHC.Driver.Ppr ( warnPprTrace )
infixr 9 `thenCmp`
-{-
-************************************************************************
-* *
-\subsection{Is DEBUG on, are we on Windows, etc?}
-* *
-************************************************************************
-
-These booleans are global constants, set by CPP flags. They allow us to
-recompile a single module (this one) to change whether or not debug output
-appears. They sometimes let us avoid even running CPP elsewhere.
-
-It's important that the flags are literal constants (True/False). Then,
-with -0, tests of the flags in other modules will simplify to the correct
-branch of the conditional, thereby dropping debug code altogether when
-the flags are off.
--}
-
-ghciSupported :: Bool
-#if defined(HAVE_INTERNAL_INTERPRETER)
-ghciSupported = True
-#else
-ghciSupported = False
-#endif
-
-debugIsOn :: Bool
-#if defined(DEBUG)
-debugIsOn = True
-#else
-debugIsOn = False
-#endif
-
-isWindowsHost :: Bool
-#if defined(mingw32_HOST_OS)
-isWindowsHost = True
-#else
-isWindowsHost = False
-#endif
-
-isDarwinHost :: Bool
-#if defined(darwin_HOST_OS)
-isDarwinHost = True
-#else
-isDarwinHost = False
-#endif
{-
************************************************************************
@@ -679,7 +632,7 @@ isSortedBy cmp = sorted
-}
minWith :: Ord b => (a -> b) -> [a] -> a
-minWith get_key xs = ASSERT( not (null xs) )
+minWith get_key xs = assert (not (null xs) )
head (sortWith get_key xs)
nubSort :: Ord a => [a] -> [a]
diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs
index eba104e5b8..d55cb7b186 100644
--- a/compiler/GHC/Utils/Panic.hs
+++ b/compiler/GHC/Utils/Panic.hs
@@ -24,6 +24,9 @@ module GHC.Utils.Panic
, pprPanic
, assertPanic
, assertPprPanic
+ , assertPpr
+ , assertPprM
+ , massertPpr
, sorry
, trace
, panicDoc
@@ -48,6 +51,7 @@ import GHC.Stack
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
+import GHC.Utils.Constants
import GHC.Utils.Exception as Exception
@@ -295,6 +299,21 @@ callStackDoc =
-- | Panic with an assertion failure, recording the given file and
-- line number. Should typically be accessed with the ASSERT family of macros
-assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a
-assertPprPanic _file _line msg
- = pprPanic "ASSERT failed!" msg
+assertPprPanic :: HasCallStack => SDoc -> a
+assertPprPanic msg = withFrozenCallStack (pprPanic "ASSERT failed!" msg)
+
+
+assertPpr :: HasCallStack => Bool -> SDoc -> a -> a
+{-# INLINE assertPpr #-}
+assertPpr cond msg a =
+ if debugIsOn && not cond
+ then withFrozenCallStack (assertPprPanic msg)
+ else a
+
+massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m ()
+{-# INLINE massertPpr #-}
+massertPpr cond msg = withFrozenCallStack (assertPpr cond msg (pure ()))
+
+assertPprM :: (HasCallStack, Monad m) => m Bool -> SDoc -> m ()
+{-# INLINE assertPprM #-}
+assertPprM mcond msg = withFrozenCallStack (mcond >>= \cond -> massertPpr cond msg)
diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs
index 8e54f81cde..048fdf23b1 100644
--- a/compiler/GHC/Utils/Panic/Plain.hs
+++ b/compiler/GHC/Utils/Panic/Plain.hs
@@ -21,6 +21,7 @@ module GHC.Utils.Panic.Plain
, panic, sorry, pgmError
, cmdLineError, cmdLineErrorIO
, assertPanic
+ , assert, assertM, massert
, progName
) where
@@ -28,6 +29,7 @@ module GHC.Utils.Panic.Plain
#include "HsVersions.h"
import GHC.Settings.Config
+import GHC.Utils.Constants
import GHC.Utils.Exception as Exception
import GHC.Stack
import GHC.Prelude
@@ -97,13 +99,13 @@ showPlainGhcException =
sorryMsg :: ShowS -> ShowS
sorryMsg s =
showString "sorry! (unimplemented feature or known bug)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
+ . showString (" GHC version " ++ cProjectVersion ++ ":\n\t")
. s . showString "\n"
panicMsg :: ShowS -> ShowS
panicMsg s =
showString "panic! (the 'impossible' happened)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
+ . showString (" GHC version " ++ cProjectVersion ++ ":\n\t")
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
@@ -136,3 +138,27 @@ assertPanic :: String -> Int -> a
assertPanic file line =
Exception.throw (Exception.AssertionFailed
("ASSERT failed! file " ++ file ++ ", line " ++ show line))
+
+
+assertPanic' :: HasCallStack => a
+assertPanic' =
+ let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack)
+ in
+ Exception.throw (Exception.AssertionFailed
+ ("ASSERT failed!\n"
+ ++ withFrozenCallStack doc))
+
+assert :: HasCallStack => Bool -> a -> a
+{-# INLINE assert #-}
+assert cond a =
+ if debugIsOn && not cond
+ then withFrozenCallStack assertPanic'
+ else a
+
+massert :: (HasCallStack, Applicative m) => Bool -> m ()
+{-# INLINE massert #-}
+massert cond = withFrozenCallStack (assert cond (pure ()))
+
+assertM :: (HasCallStack, Monad m) => m Bool -> m ()
+{-# INLINE assertM #-}
+assertM mcond = withFrozenCallStack (mcond >>= massert)