diff options
| -rw-r--r-- | ghc/compiler/prelude/PrelNames.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnExpr.lhs | 43 |
2 files changed, 19 insertions, 30 deletions
diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index aa711d2c03..fd5e769f8a 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -282,7 +282,7 @@ knownKeyNames -- Others unsafeCoerceName, otherwiseIdName, plusIntegerName, timesIntegerName, - eqStringName, assertName, runSTRepName, + eqStringName, assertName, assertErrorName, runSTRepName, printName, splitName, fstName, sndName, errorName, @@ -611,7 +611,7 @@ augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey orName = varQual pREL_BASE_Name FSLIT("||") orIdKey -assertName = varQual pREL_BASE_Name FSLIT("assert") assertIdKey +assertName = varQual pREL_BASE_Name FSLIT("assert") assertIdKey lazyIdName = wVarQual pREL_BASE_Name FSLIT("lazy") lazyIdKey -- PrelTup @@ -791,6 +791,7 @@ newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStabl -- Error module errorName = wVarQual pREL_ERR_Name FSLIT("error") errorIdKey +assertErrorName = wVarQual pREL_ERR_Name FSLIT("assertError") assertErrorIdKey recSelErrorName = wVarQual pREL_ERR_Name FSLIT("recSelError") recSelErrorIdKey runtimeErrorName = wVarQual pREL_ERR_Name FSLIT("runtimeError") runtimeErrorIdKey irrefutPatErrorName = wVarQual pREL_ERR_Name FSLIT("irrefutPatError") irrefutPatErrorIdKey @@ -1091,6 +1092,7 @@ andIdKey = mkPreludeMiscIdUnique 57 orIdKey = mkPreludeMiscIdUnique 58 thenIOIdKey = mkPreludeMiscIdUnique 59 lazyIdKey = mkPreludeMiscIdUnique 60 +assertErrorIdKey = mkPreludeMiscIdUnique 61 -- Parallel array functions nullPIdKey = mkPreludeMiscIdUnique 80 diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index a4d6a35cec..bed32e3b1e 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -37,7 +37,7 @@ import PrelNames ( hasKey, assertIdKey, ioDataConName, plusIntegerName, timesIntegerName, replicatePName, mapPName, filterPName, crossPName, zipPName, lengthPName, indexPName, toPName, - enumFromToPName, enumFromThenToPName, assertName, + enumFromToPName, enumFromThenToPName, assertErrorName, fromIntegerName, fromRationalName, minusName, negateName, qTyConName, monadNames ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, @@ -292,11 +292,13 @@ rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars) rnExpr (HsVar v) = lookupOccRn v `thenM` \ name -> - if name `hasKey` assertIdKey then - -- We expand it to (GHCerr.assert__ location) - mkAssertExpr + if name `hasKey` assertIdKey && not opt_IgnoreAsserts then + -- We expand it to (GHC.Err.assertError location_string) + mkAssertErrorExpr else - -- The normal case + -- The normal case. Even if the Id was 'assert', if we are + -- ignoring assertions we leave it as GHC.Base.assert; + -- this function just ignores its first arg. returnM (HsVar name, unitFV name) rnExpr (HsIPVar v) @@ -930,30 +932,15 @@ rnOverLit (HsFractional i _) %************************************************************************ \begin{code} -mkAssertExpr :: RnM (RenamedHsExpr, FreeVars) -mkAssertExpr +mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars) +-- Return an expression for (assertError "Foo.hs:27") +mkAssertErrorExpr = getSrcLocM `thenM` \ sloc -> - - -- if we're ignoring asserts, return (\ _ e -> e) - -- if not, return (assertError "src-loc") - - if opt_IgnoreAsserts then - newUnique `thenM` \ uniq -> - let - vname = mkSystemName uniq FSLIT("v") - expr = HsLam ignorePredMatch - loc = nameSrcLoc vname - ignorePredMatch = mkSimpleMatch [WildPat placeHolderType, VarPat vname] - (HsVar vname) placeHolderType loc - in - returnM (expr, emptyFVs) - else - let - expr = - HsApp (HsVar assertName) - (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))))) - in - returnM (expr, unitFV assertName) + let + expr = HsApp (HsVar assertErrorName) (HsLit msg) + msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))) + in + returnM (expr, unitFV assertErrorName) \end{code} %************************************************************************ |