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/StgToCmm | |
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/StgToCmm')
-rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/DataCon.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Env.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Layout.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Monad.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Utils.hs | 11 |
9 files changed, 35 insertions, 27 deletions
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 |