diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-05-06 14:52:53 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-05-12 21:41:43 -0400 |
| commit | bfabf94f63b6644bd32982fd13ea0c8bca9aeae4 (patch) | |
| tree | b185749a9676a57c226dab9681fa3c4ba0415dd3 /compiler/GHC | |
| parent | da56ed41b62ab132db6d62637c11076985410b24 (diff) | |
| download | haskell-bfabf94f63b6644bd32982fd13ea0c8bca9aeae4.tar.gz | |
Replace CPP assertions with Haskell functions
There is no reason to use CPP. __LINE__ and __FILE__ macros are now
better replaced with GHC's CallStack. As a bonus, assert error messages
now contain more information (function name, column).
Here is the mapping table (HasCallStack omitted):
* ASSERT: assert :: Bool -> a -> a
* MASSERT: massert :: Bool -> m ()
* ASSERTM: assertM :: m Bool -> m ()
* ASSERT2: assertPpr :: Bool -> SDoc -> a -> a
* MASSERT2: massertPpr :: Bool -> SDoc -> m ()
* ASSERTM2: assertPprM :: m Bool -> SDoc -> m ()
Diffstat (limited to 'compiler/GHC')
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) |