Allow CallStacks to be frozen

This introduces "freezing," an operation which prevents further
locations from being appended to a CallStack.  Library authors may want
to prevent CallStacks from exposing implementation details, as a matter
of hygiene. For example, in

```
head [] = error "head: empty list"

ghci> head []
*** Exception: head: empty list
CallStack (from implicit params):
  error, called at ...
```

including the call-site of `error` in `head` is not strictly necessary
as the error message already specifies clearly where the error came
from.

So we add a function `freezeCallStack` that wraps an existing CallStack,
preventing further call-sites from being pushed onto it. In other words,

```
pushCallStack callSite (freezeCallStack callStack) = freezeCallStack callStack
```

Now we can define `head` to not produce a CallStack at all

```
head [] =
  let ?callStack = freezeCallStack emptyCallStack
  in error "head: empty list"

ghci> head []
*** Exception: head: empty list
CallStack (from implicit params):
  error, called at ...
```

---

1. We add the `freezeCallStack` and `emptyCallStack` and update the
   definition of `CallStack` to support this functionality.

2. We add `errorWithoutStackTrace`, a variant of `error` that does not
   produce a stack trace, using this feature. I think this is a sensible
   wrapper function to provide in case users want it.

3. We replace uses of `error` in base with `errorWithoutStackTrace`. The
   rationale is that base does not export any functions that use CallStacks
   (except for `error` and `undefined`) so there's no way for the stack
   traces (from Implicit CallStacks) to include user-defined functions.
   They'll only contain the call to `error` itself. As base already has a
   good habit of providing useful error messages that name the triggering
   function, the stack trace really just adds noise to the error. (I don't
   have a strong opinion on whether we should include this third commit,
   but the change was very mechanical so I thought I'd include it anyway in
   case there's interest)

4. Updates tests in `array` and `stm` submodules

Test Plan: ./validate, new test is T11049

Reviewers: simonpj, nomeata, goldfire, austin, hvr, bgamari

Reviewed By: simonpj

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1628

GHC Trac Issues: #11049

36 files changed, 211 insertions, 120 deletions

diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs
index 6b3a923dbc..c736f56c66 100644
--- a/libraries/base/GHC/Arr.hs
+++ b/libraries/base/GHC/Arr.hs
@@ -173,13 +173,13 @@ can do better, so we override the default method for index.
 {-# NOINLINE indexError #-}
 indexError :: Show a => (a,a) -> a -> String -> b
 indexError rng i tp
-  = error (showString "Ix{" . showString tp . showString "}.index: Index " .
+  = errorWithoutStackTrace (showString "Ix{" . showString tp . showString "}.index: Index " .
            showParen True (showsPrec 0 i) .
            showString " out of range " $
            showParen True (showsPrec 0 rng) "")
 
 hopelessIndexError :: Int -- Try to use 'indexError' instead!
-hopelessIndexError = error "Error in array index"
+hopelessIndexError = errorWithoutStackTrace "Error in array index"
 
 ----------------------------------------------------------------------
 instance  Ix Char  where
@@ -399,7 +399,7 @@ instance Eq (STArray s i e) where
 
 {-# NOINLINE arrEleBottom #-}
 arrEleBottom :: a
-arrEleBottom = error "(Array.!): undefined array element"
+arrEleBottom = errorWithoutStackTrace "(Array.!): undefined array element"
 
 -- | Construct an array with the specified bounds and containing values
 -- for given indices within these bounds.
@@ -504,7 +504,7 @@ safeRangeSize (l,u) = let r = rangeSize (l, u)
 
 -- Don't inline this error message everywhere!!
 negRange :: Int   -- Uninformative, but Ix does not provide Show
-negRange = error "Negative range size"
+negRange = errorWithoutStackTrace "Negative range size"
 
 {-# INLINE[1] safeIndex #-}
 -- See Note [Double bounds-checking of index values]
@@ -531,7 +531,7 @@ lessSafeIndex (l,u) _ i = index (l,u) i
 
 -- Don't inline this long error message everywhere!!
 badSafeIndex :: Int -> Int -> Int
-badSafeIndex i' n = error ("Error in array index; " ++ show i' ++
+badSafeIndex i' n = errorWithoutStackTrace ("Error in array index; " ++ show i' ++
                         " not in range [0.." ++ show n ++ ")")
 
 {-# INLINE unsafeAt #-}
@@ -604,7 +604,7 @@ foldl1Elems f = \ arr@(Array _ _ n _) ->
     go i | i == 0    = unsafeAt arr 0
          | otherwise = f (go (i-1)) (unsafeAt arr i)
   in
-    if n == 0 then error "foldl1: empty Array" else go (n-1)
+    if n == 0 then errorWithoutStackTrace "foldl1: empty Array" else go (n-1)
 
 -- | A right fold over the elements with no starting value
 {-# INLINABLE foldr1Elems #-}
@@ -614,7 +614,7 @@ foldr1Elems f = \ arr@(Array _ _ n _) ->
     go i | i == n-1  = unsafeAt arr i
          | otherwise = f (unsafeAt arr i) (go (i + 1))
   in
-    if n == 0 then error "foldr1: empty Array" else go 0
+    if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0
 
 -- | The list of associations of an array in index order.
 {-# INLINE assocs #-}
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index 89ec703163..92a1ac39f7 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -187,8 +187,8 @@ not True = False
 (&&) True True = True
 otherwise = True
 
-build = error "urk"
-foldr = error "urk"
+build = errorWithoutStackTrace "urk"
+foldr = errorWithoutStackTrace "urk"
 #endif
 
 -- | The 'Maybe' type encapsulates an optional value.  A value of type
@@ -498,7 +498,7 @@ class Applicative m => Monad m where
     -- details). The definition here will be removed in a future
     -- release.
     fail        :: String -> m a
-    fail s      = error s
+    fail s      = errorWithoutStackTrace s
 
 {- Note [Recursive bindings for Applicative/Monad]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/base/GHC/Char.hs b/libraries/base/GHC/Char.hs
index 4928f21e96..c2f4ec4fe5 100644
--- a/libraries/base/GHC/Char.hs
+++ b/libraries/base/GHC/Char.hs
@@ -11,5 +11,5 @@ chr :: Int -> Char
 chr i@(I# i#)
  | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = C# (chr# i#)
  | otherwise
-    = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
+    = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
 
diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs
index b2c96b9fdb..1e9ffd58f0 100644
--- a/libraries/base/GHC/Conc/IO.hs
+++ b/libraries/base/GHC/Conc/IO.hs
@@ -198,6 +198,6 @@ registerDelay usecs
 #else
   | threaded = Event.registerDelay usecs
 #endif
-  | otherwise = error "registerDelay: requires -threaded"
+  | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded"
 
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
diff --git a/libraries/base/GHC/Conc/Signal.hs b/libraries/base/GHC/Conc/Signal.hs
index 4afccf2496..e5cb5e3e43 100644
--- a/libraries/base/GHC/Conc/Signal.hs
+++ b/libraries/base/GHC/Conc/Signal.hs
@@ -55,7 +55,7 @@ setHandler sig handler = do
   let int = fromIntegral sig
   withMVar signal_handlers $ \arr ->
     if not (inRange (boundsIOArray arr) int)
-      then error "GHC.Conc.setHandler: signal out of range"
+      then errorWithoutStackTrace "GHC.Conc.setHandler: signal out of range"
       else do old <- unsafeReadIOArray arr int
               unsafeWriteIOArray arr int handler
               return old
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index 5e277332d0..e1d894a8c1 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -766,7 +766,7 @@ alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
 -- False or raising an exception are both treated as invariant failures.
 always :: STM Bool -> STM ()
 always i = alwaysSucceeds ( do v <- i
-                               if (v) then return () else ( error "Transactional invariant violation" ) )
+                               if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) )
 
 -- |Shared memory locations that support atomic memory transactions.
 data TVar a = TVar (TVar# RealWorld a)
diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs
index 8913a65907..4cbb8cadc2 100644
--- a/libraries/base/GHC/Conc/Windows.hs
+++ b/libraries/base/GHC/Conc/Windows.hs
@@ -123,7 +123,7 @@ threadDelay time
 registerDelay :: Int -> IO (TVar Bool)
 registerDelay usecs
   | threaded = waitForDelayEventSTM usecs
-  | otherwise = error "registerDelay: requires -threaded"
+  | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded"
 
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 
@@ -299,7 +299,7 @@ toWin32ConsoleEvent ev =
        _ -> Nothing
 
 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
-win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
+win32ConsoleHandler = unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler"))
 
 wakeupIOManager :: IO ()
 wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
diff --git a/libraries/base/GHC/ConsoleHandler.hs b/libraries/base/GHC/ConsoleHandler.hs
index 609eb2005c..6d1e36f4ab 100644
--- a/libraries/base/GHC/ConsoleHandler.hs
+++ b/libraries/base/GHC/ConsoleHandler.hs
@@ -96,7 +96,7 @@ installHandler handler
           STG_SIG_DFL -> return Default
           STG_SIG_IGN -> return Ignore
           STG_SIG_HAN -> return (Catch old_h)
-          _           -> error "installHandler: Bad threaded rc value"
+          _           -> errorWithoutStackTrace "installHandler: Bad threaded rc value"
       return (new_h, prev_handler)
 
   | otherwise =
@@ -118,7 +118,7 @@ installHandler handler
          -- stable pointer is no longer in use, free it.
         freeStablePtr osptr
         return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
-     _           -> error "installHandler: Bad non-threaded rc value"
+     _           -> errorWithoutStackTrace "installHandler: Bad non-threaded rc value"
   where
    fromConsoleEvent ev =
      case ev of
@@ -135,7 +135,7 @@ installHandler handler
         Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
         Nothing -> return () -- silently ignore..
 
-   no_handler = error "win32ConsoleHandler"
+   no_handler = errorWithoutStackTrace "win32ConsoleHandler"
 
 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
 
diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs
index dcda47b9fb..729b801dcf 100644
--- a/libraries/base/GHC/Enum.hs
+++ b/libraries/base/GHC/Enum.hs
@@ -123,7 +123,7 @@ boundedEnumFromThen n1 n2
 {-# NOINLINE toEnumError #-}
 toEnumError :: (Show a) => String -> Int -> (a,a) -> b
 toEnumError inst_ty i bnds =
-    error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++
+    errorWithoutStackTrace $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++
             show i ++
             ") is outside of bounds " ++
             show bnds
@@ -131,7 +131,7 @@ toEnumError inst_ty i bnds =
 {-# NOINLINE fromEnumError #-}
 fromEnumError :: (Show a) => String -> a -> b
 fromEnumError inst_ty x =
-    error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++
+    errorWithoutStackTrace $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++
             show x ++
             ") is outside of Int's bounds " ++
             show (minBound::Int, maxBound::Int)
@@ -139,12 +139,12 @@ fromEnumError inst_ty x =
 {-# NOINLINE succError #-}
 succError :: String -> a
 succError inst_ty =
-    error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"
+    errorWithoutStackTrace $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"
 
 {-# NOINLINE predError #-}
 predError :: String -> a
 predError inst_ty =
-    error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"
+    errorWithoutStackTrace $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"
 
 ------------------------------------------------------------------------
 -- Tuples
@@ -155,11 +155,11 @@ instance Bounded () where
     maxBound = ()
 
 instance Enum () where
-    succ _      = error "Prelude.Enum.().succ: bad argument"
-    pred _      = error "Prelude.Enum.().pred: bad argument"
+    succ _      = errorWithoutStackTrace "Prelude.Enum.().succ: bad argument"
+    pred _      = errorWithoutStackTrace "Prelude.Enum.().pred: bad argument"
 
     toEnum x | x == 0    = ()
-             | otherwise = error "Prelude.Enum.().toEnum: bad argument"
+             | otherwise = errorWithoutStackTrace "Prelude.Enum.().toEnum: bad argument"
 
     fromEnum () = 0
     enumFrom ()         = [()]
@@ -266,14 +266,14 @@ instance Bounded Bool where
 
 instance Enum Bool where
   succ False = True
-  succ True  = error "Prelude.Enum.Bool.succ: bad argument"
+  succ True  = errorWithoutStackTrace "Prelude.Enum.Bool.succ: bad argument"
 
   pred True  = False
-  pred False  = error "Prelude.Enum.Bool.pred: bad argument"
+  pred False  = errorWithoutStackTrace "Prelude.Enum.Bool.pred: bad argument"
 
   toEnum n | n == 0    = False
            | n == 1    = True
-           | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument"
+           | otherwise = errorWithoutStackTrace "Prelude.Enum.Bool.toEnum: bad argument"
 
   fromEnum False = 0
   fromEnum True  = 1
@@ -293,16 +293,16 @@ instance Bounded Ordering where
 instance Enum Ordering where
   succ LT = EQ
   succ EQ = GT
-  succ GT = error "Prelude.Enum.Ordering.succ: bad argument"
+  succ GT = errorWithoutStackTrace "Prelude.Enum.Ordering.succ: bad argument"
 
   pred GT = EQ
   pred EQ = LT
-  pred LT = error "Prelude.Enum.Ordering.pred: bad argument"
+  pred LT = errorWithoutStackTrace "Prelude.Enum.Ordering.pred: bad argument"
 
   toEnum n | n == 0 = LT
            | n == 1 = EQ
            | n == 2 = GT
-  toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument"
+  toEnum _ = errorWithoutStackTrace "Prelude.Enum.Ordering.toEnum: bad argument"
 
   fromEnum LT = 0
   fromEnum EQ = 1
@@ -323,10 +323,10 @@ instance  Bounded Char  where
 instance  Enum Char  where
     succ (C# c#)
        | isTrue# (ord# c# /=# 0x10FFFF#) = C# (chr# (ord# c# +# 1#))
-       | otherwise             = error ("Prelude.Enum.Char.succ: bad argument")
+       | otherwise             = errorWithoutStackTrace ("Prelude.Enum.Char.succ: bad argument")
     pred (C# c#)
        | isTrue# (ord# c# /=# 0#) = C# (chr# (ord# c# -# 1#))
-       | otherwise                = error ("Prelude.Enum.Char.pred: bad argument")
+       | otherwise                = errorWithoutStackTrace ("Prelude.Enum.Char.pred: bad argument")
 
     toEnum   = chr
     fromEnum = ord
@@ -449,10 +449,10 @@ instance  Bounded Int where
 
 instance  Enum Int  where
     succ x
-       | x == maxBound  = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound"
+       | x == maxBound  = errorWithoutStackTrace "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound"
        | otherwise      = x + 1
     pred x
-       | x == minBound  = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound"
+       | x == minBound  = errorWithoutStackTrace "Prelude.Enum.pred{Int}: tried to take `pred' of minBound"
        | otherwise      = x - 1
 
     toEnum   x = x
diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs
index 6c40cba570..af6d119ff1 100644
--- a/libraries/base/GHC/Err.hs
+++ b/libraries/base/GHC/Err.hs
@@ -21,7 +21,7 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.Err( absentErr, error, undefined ) where
+module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where
 import GHC.CString ()
 import GHC.Types (Char)
 import GHC.Stack.Types
@@ -35,6 +35,33 @@ import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException )
 error :: (?callStack :: CallStack) => [Char] -> a
 error s = raise# (errorCallWithCallStackException s ?callStack)
 
+-- | A variant of 'error' that does not produce a stack trace.
+--
+-- @since 4.9.0.0
+errorWithoutStackTrace :: [Char] -> a
+errorWithoutStackTrace s
+  = let ?callStack = freezeCallStack ?callStack
+    in error s
+{-# NOINLINE errorWithoutStackTrace #-}
+
+-- Note [Errors in base]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- As of base-4.9.0.0, `error` produces a stack trace alongside the
+-- error message using the Implicit CallStack machinery. This provides
+-- a partial stack trace, containing the call-site of each function
+-- with a (?callStack :: CallStack) implicit parameter constraint.
+--
+-- In base, however, the only functions that have such constraints are
+-- error and undefined, so the stack traces from partial functions in
+-- base will never contain a call-site in user code. Instead we'll
+-- usually just get the actual call to error. Base functions already
+-- have a good habit of providing detailed error messages, including the
+-- name of the offending partial function, so the partial stack-trace
+-- does not provide any extra information, just noise. Thus, we export
+-- the callstack-aware error, but within base we use the
+-- errorWithoutStackTrace variant for more hygienic erorr messages.
+
+
 -- | A special case of 'error'.
 -- It is expected that compilers will recognize this and insert error
 -- messages which are more appropriate to the context in which 'undefined'
@@ -45,4 +72,4 @@ undefined =  error "Prelude.undefined"
 -- | Used for compiler-generated error message;
 -- encoding saves bytes of string junk.
 absentErr :: a
-absentErr = error "Oops! The program has entered an `absent' argument!\n"
+absentErr = errorWithoutStackTrace "Oops! The program has entered an `absent' argument!\n"
diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs
index 61cc773007..903f7c0c23 100644
--- a/libraries/base/GHC/Event/Array.hs
+++ b/libraries/base/GHC/Event/Array.hs
@@ -45,7 +45,7 @@ import GHC.Show (show)
 -- This fugly hack is brought by GHC's apparent reluctance to deal
 -- with MagicHash and UnboxedTuples when inferring types. Eek!
 #define CHECK_BOUNDS(_func_,_len_,_k_) \
-if (_k_) < 0 || (_k_) >= (_len_) then error ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else
+if (_k_) < 0 || (_k_) >= (_len_) then errorWithoutStackTrace ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else
 #else
 #define CHECK_BOUNDS(_func_,_len_,_k_)
 #endif
@@ -247,7 +247,7 @@ copy' d dstart s sstart maxCount = copyHack d s undefined
   copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b)
   copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do
     when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 ||
-          sstart > slen) $ error "copy: bad offsets or lengths"
+          sstart > slen) $ errorWithoutStackTrace "copy: bad offsets or lengths"
     let size = sizeOf dummy
         count = min maxCount (slen - sstart)
     if count == 0
@@ -267,7 +267,7 @@ removeAt a i = removeHack a undefined
   removeHack :: Storable b => Array b -> b -> IO ()
   removeHack (Array ary) dummy = do
     AC fp oldLen cap <- readIORef ary
-    when (i < 0 || i >= oldLen) $ error "removeAt: invalid index"
+    when (i < 0 || i >= oldLen) $ errorWithoutStackTrace "removeAt: invalid index"
     let size   = sizeOf dummy
         newLen = oldLen - 1
     when (newLen > 0 && i < newLen) .
diff --git a/libraries/base/GHC/Event/Control.hs b/libraries/base/GHC/Event/Control.hs
index 5dcc66e6dc..0b0f5587a7 100644
--- a/libraries/base/GHC/Event/Control.hs
+++ b/libraries/base/GHC/Event/Control.hs
@@ -159,7 +159,7 @@ readControlMessage ctrl fd
                         r <- c_read (fromIntegral fd) (castPtr p_siginfo)
                              sizeof_siginfo_t
                         when (r /= fromIntegral sizeof_siginfo_t) $
-                            error "failed to read siginfo_t"
+                            errorWithoutStackTrace "failed to read siginfo_t"
                         let !s' = fromIntegral s
                         return $ CMsgSignal fp s'
 
@@ -195,7 +195,7 @@ sendMessage fd msg = alloca $ \p -> do
   case msg of
     CMsgWakeup        -> poke p io_MANAGER_WAKEUP
     CMsgDie           -> poke p io_MANAGER_DIE
-    CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
+    CMsgSignal _fp _s -> errorWithoutStackTrace "Signals can only be sent from within the RTS"
   fromIntegral `fmap` c_write (fromIntegral fd) p 1
 
 #if defined(HAVE_EVENTFD)
diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc
index 2cffb00931..26b6861004 100644
--- a/libraries/base/GHC/Event/EPoll.hsc
+++ b/libraries/base/GHC/Event/EPoll.hsc
@@ -29,7 +29,7 @@ import qualified GHC.Event.Internal as E
 import GHC.Base
 
 new :: IO E.Backend
-new = error "EPoll back end not implemented for this platform"
+new = errorWithoutStackTrace "EPoll back end not implemented for this platform"
 
 available :: Bool
 available = False
diff --git a/libraries/base/GHC/Event/KQueue.hsc b/libraries/base/GHC/Event/KQueue.hsc
index 2b8d443415..1068ec0136 100644
--- a/libraries/base/GHC/Event/KQueue.hsc
+++ b/libraries/base/GHC/Event/KQueue.hsc
@@ -19,7 +19,7 @@ import qualified GHC.Event.Internal as E
 import GHC.Base
 
 new :: IO E.Backend
-new = error "KQueue back end not implemented for this platform"
+new = errorWithoutStackTrace "KQueue back end not implemented for this platform"
 
 available :: Bool
 available = False
@@ -274,7 +274,7 @@ toEvent :: Filter -> E.Event
 toEvent (Filter f)
   | f == (#const EVFILT_READ) = E.evtRead
   | f == (#const EVFILT_WRITE) = E.evtWrite
-  | otherwise = error $ "toEvent: unknown filter " ++ show f
+  | otherwise = errorWithoutStackTrace $ "toEvent: unknown filter " ++ show f
 
 foreign import ccall unsafe "kqueue"
     c_kqueue :: IO CInt
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index 0ca02c45c4..013850b5d2 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -172,7 +172,7 @@ newDefaultBackend = EPoll.new
 #elif defined(HAVE_POLL)
 newDefaultBackend = Poll.new
 #else
-newDefaultBackend = error "no back end for this platform"
+newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
 #endif
 
 -- | Create a new event manager.
@@ -212,7 +212,7 @@ failOnInvalidFile loc fd m = do
   when (not ok) $
     let msg = "Failed while attempting to modify registration of file " ++
               show fd ++ " at location " ++ loc
-    in error msg
+    in errorWithoutStackTrace msg
 
 registerControlFd :: EventManager -> Fd -> Event -> IO ()
 registerControlFd mgr fd evs =
@@ -267,7 +267,7 @@ loop mgr@EventManager{..} = do
     -- in Thread.restartPollLoop.  See #8235
     Finished  -> return ()
     _         -> do cleanup mgr
-                    error $ "GHC.Event.Manager.loop: state is already " ++
+                    errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++
                             show state
  where
   go = do state <- step mgr
diff --git a/libraries/base/GHC/Event/PSQ.hs b/libraries/base/GHC/Event/PSQ.hs
index 3421b5a984..e61c31b1b4 100644
--- a/libraries/base/GHC/Event/PSQ.hs
+++ b/libraries/base/GHC/Event/PSQ.hs
@@ -458,7 +458,7 @@ tourView (Winner e (LLoser _ e' tl m tr) m') =
 -- Utility functions
 
 moduleError :: String -> String -> a
-moduleError fun msg = error ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg)
+moduleError fun msg = errorWithoutStackTrace ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg)
 {-# NOINLINE moduleError #-}
 
 ------------------------------------------------------------------------
diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc
index 6cbe14398b..b128572e71 100644
--- a/libraries/base/GHC/Event/Poll.hsc
+++ b/libraries/base/GHC/Event/Poll.hsc
@@ -17,7 +17,7 @@ import GHC.Base
 import qualified GHC.Event.Internal as E
 
 new :: IO E.Backend
-new = error "Poll back end not implemented for this platform"
+new = errorWithoutStackTrace "Poll back end not implemented for this platform"
 
 available :: Bool
 available = False
@@ -62,7 +62,7 @@ modifyFd p fd oevt nevt =
     return True
 
 modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool
-modifyFdOnce = error "modifyFdOnce not supported in Poll backend"
+modifyFdOnce = errorWithoutStackTrace "modifyFdOnce not supported in Poll backend"
 
 reworkFd :: Poll -> PollFd -> IO ()
 reworkFd p (PollFd fd npevt opevt) = do
@@ -72,7 +72,7 @@ reworkFd p (PollFd fd npevt opevt) = do
     else do
       found <- A.findIndex ((== fd) . pfdFd) ary
       case found of
-        Nothing        -> error "reworkFd: event not found"
+        Nothing        -> errorWithoutStackTrace "reworkFd: event not found"
         Just (i,_)
           | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0
           | otherwise  -> A.removeAt ary i
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index c1ab64c7a9..93b1766f5e 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -108,7 +108,7 @@ newDefaultBackend :: IO Backend
 #if defined(HAVE_POLL)
 newDefaultBackend = Poll.new
 #else
-newDefaultBackend = error "no back end for this platform"
+newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
 #endif
 
 -- | Create a new event manager.
@@ -168,7 +168,7 @@ loop mgr = do
     Created -> go `finally` cleanup mgr
     Dying   -> cleanup mgr
     _       -> do cleanup mgr
-                  error $ "GHC.Event.Manager.loop: state is already " ++
+                  errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++
                       show state
  where
   go = do running <- step mgr
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index 032e650c1e..dc943e068d 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -103,8 +103,8 @@ maxTupleSize = 62
 the :: Eq a => [a] -> a
 the (x:xs)
   | all (x ==) xs = x
-  | otherwise     = error "GHC.Exts.the: non-identical elements"
-the []            = error "GHC.Exts.the: empty list"
+  | otherwise     = errorWithoutStackTrace "GHC.Exts.the: non-identical elements"
+the []            = errorWithoutStackTrace "GHC.Exts.the: empty list"
 
 -- | The 'sortWith' function sorts a list of elements using the
 -- user supplied function to project something out of each element
diff --git a/libraries/base/GHC/Fingerprint.hs b/libraries/base/GHC/Fingerprint.hs
index 8a92cd0595..7b7f5c7115 100644
--- a/libraries/base/GHC/Fingerprint.hs
+++ b/libraries/base/GHC/Fingerprint.hs
@@ -95,7 +95,7 @@ getFileHash path = withBinaryFile path ReadMode $ \h -> do
       let loop = do
             count <- hGetBuf h arrPtr _BUFSIZE
             eof <- hIsEOF h
-            when (count /= _BUFSIZE && not eof) $ error $
+            when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $
               "GHC.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"
 
             f arrPtr count
diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs
index ddf9cf01ca..0ffefd5f67 100644
--- a/libraries/base/GHC/Float.hs
+++ b/libraries/base/GHC/Float.hs
@@ -658,7 +658,7 @@ formatRealFloatAlt fmt decs alt x
           "0"     -> "0.0e0"
           [d]     -> d : ".0e" ++ show_e'
           (d:ds') -> d : '.' : ds' ++ "e" ++ show_e'
-          []      -> error "formatRealFloat/doFmt/FFExponent: []"
+          []      -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []"
        Just dec ->
         let dec' = max dec 1 in
         case is of
@@ -704,7 +704,7 @@ roundTo base d is =
   case f d True is of
     x@(0,_) -> x
     (1,xs)  -> (1, 1:xs)
-    _       -> error "roundTo: bad Value"
+    _       -> errorWithoutStackTrace "roundTo: bad Value"
  where
   b2 = base `quot` 2
 
diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs
index d0688f0cbf..6d03967d3b 100644
--- a/libraries/base/GHC/ForeignPtr.hs
+++ b/libraries/base/GHC/ForeignPtr.hs
@@ -153,7 +153,7 @@ mallocForeignPtr :: Storable a => IO (ForeignPtr a)
 mallocForeignPtr = doMalloc undefined
   where doMalloc :: Storable b => b -> IO (ForeignPtr b)
         doMalloc a
-          | I# size < 0 = error "mallocForeignPtr: size must be >= 0"
+          | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0"
           | otherwise = do
           r <- newIORef NoFinalizers
           IO $ \s ->
@@ -168,7 +168,7 @@ mallocForeignPtr = doMalloc undefined
 -- size of the memory required is given explicitly as a number of bytes.
 mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
 mallocForeignPtrBytes size | size < 0 =
-  error "mallocForeignPtrBytes: size must be >= 0"
+  errorWithoutStackTrace "mallocForeignPtrBytes: size must be >= 0"
 mallocForeignPtrBytes (I# size) = do
   r <- newIORef NoFinalizers
   IO $ \s ->
@@ -182,7 +182,7 @@ mallocForeignPtrBytes (I# size) = do
 -- bytes.
 mallocForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)
 mallocForeignPtrAlignedBytes size _align | size < 0 =
-  error "mallocForeignPtrAlignedBytes: size must be >= 0"
+  errorWithoutStackTrace "mallocForeignPtrAlignedBytes: size must be >= 0"
 mallocForeignPtrAlignedBytes (I# size) (I# align) = do
   r <- newIORef NoFinalizers
   IO $ \s ->
@@ -208,7 +208,7 @@ mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a)
 mallocPlainForeignPtr = doMalloc undefined
   where doMalloc :: Storable b => b -> IO (ForeignPtr b)
         doMalloc a
-          | I# size < 0 = error "mallocForeignPtr: size must be >= 0"
+          | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0"
           | otherwise = IO $ \s ->
             case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
              (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
@@ -223,7 +223,7 @@ mallocPlainForeignPtr = doMalloc undefined
 -- exception to be thrown.
 mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a)
 mallocPlainForeignPtrBytes size | size < 0 =
-  error "mallocPlainForeignPtrBytes: size must be >= 0"
+  errorWithoutStackTrace "mallocPlainForeignPtrBytes: size must be >= 0"
 mallocPlainForeignPtrBytes (I# size) = IO $ \s ->
     case newPinnedByteArray# size s      of { (# s', mbarr# #) ->
        (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
@@ -236,7 +236,7 @@ mallocPlainForeignPtrBytes (I# size) = IO $ \s ->
 -- exception to be thrown.
 mallocPlainForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)
 mallocPlainForeignPtrAlignedBytes size _align | size < 0 =
-  error "mallocPlainForeignPtrAlignedBytes: size must be >= 0"
+  errorWithoutStackTrace "mallocPlainForeignPtrAlignedBytes: size must be >= 0"
 mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ \s ->
     case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
        (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
@@ -250,7 +250,7 @@ addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()
 addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of
   PlainForeignPtr r -> insertCFinalizer r fp 0# nullAddr# p ()
   MallocPtr     _ r -> insertCFinalizer r fp 0# nullAddr# p c
-  _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
+  _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
 
 -- Note [MallocPtr finalizers] (#10904)
 --
@@ -270,7 +270,7 @@ addForeignPtrFinalizerEnv ::
 addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of
   PlainForeignPtr r -> insertCFinalizer r fp 1# ep p ()
   MallocPtr     _ r -> insertCFinalizer r fp 1# ep p c
-  _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
+  _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
 
 addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()
 -- ^This function adds a finalizer to the given @ForeignPtr@.  The
@@ -311,7 +311,7 @@ addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do
     finalizer' = unIO (foreignPtrFinalizer r >> touch f)
 
 addForeignPtrConcFinalizer_ _ _ =
-  error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"
+  errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"
 
 insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool
 insertHaskellFinalizer r f = do
@@ -358,7 +358,7 @@ ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do
       update _ _ = noMixingError
 
 noMixingError :: a
-noMixingError = error $
+noMixingError = errorWithoutStackTrace $
    "GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++
    "in the same ForeignPtr"
 
@@ -441,5 +441,5 @@ finalizeForeignPtr (ForeignPtr _ foreignPtr) = foreignPtrFinalizer refFinalizers
                         (PlainForeignPtr ref) -> ref
                         (MallocPtr     _ ref) -> ref
                         PlainPtr _            ->
-                            error "finalizeForeignPtr PlainPtr"
+                            errorWithoutStackTrace "finalizeForeignPtr PlainPtr"
 
diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs
index 77f1d99f46..b2d4cd1843 100644
--- a/libraries/base/GHC/IO/Buffer.hs
+++ b/libraries/base/GHC/IO/Buffer.hs
@@ -287,5 +287,5 @@ checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
 
 check :: Buffer a -> Bool -> IO ()
 check _   True  = return ()
-check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)
+check buf False = errorWithoutStackTrace ("buffer invariant violation: " ++ summaryBuffer buf)
 
diff --git a/libraries/base/GHC/IO/Encoding/CodePage/API.hs b/libraries/base/GHC/IO/Encoding/CodePage/API.hs
index 103eb87a0d..5a48a9ee3d 100644
--- a/libraries/base/GHC/IO/Encoding/CodePage/API.hs
+++ b/libraries/base/GHC/IO/Encoding/CodePage/API.hs
@@ -83,7 +83,7 @@ instance Storable CPINFO where
 
 pokeArray' :: Storable a => String -> Int -> Ptr a -> [a] -> IO ()
 pokeArray' msg sz ptr xs | length xs == sz = pokeArray ptr xs
-                         | otherwise       = error $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs)
+                         | otherwise       = errorWithoutStackTrace $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs)
 
 
 foreign import WINDOWS_CCONV unsafe "windows.h GetCPInfo"
@@ -189,7 +189,7 @@ byteView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr b
 cwcharView :: Buffer Word8 -> Buffer CWchar
 cwcharView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = half bufSize, bufL = half bufL, bufR = half bufR }
   where half x = case x `divMod` 2 of (y, 0) -> y
-                                      _      -> error "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes"
+                                      _      -> errorWithoutStackTrace "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes"
 
 utf16_native_encode :: CodeBuffer Char CWchar
 utf16_native_encode ibuf obuf = do
@@ -227,9 +227,9 @@ cpDecode cp max_char_size = \ibuf obuf -> do
       -- If we successfully translate all of the UTF-16 buffer, we need to know why we couldn't get any more
       -- UTF-16 out of the Windows API
       InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf)
-                     | otherwise           -> error "cpDecode: impossible underflown UTF-16 buffer"
+                     | otherwise           -> errorWithoutStackTrace "cpDecode: impossible underflown UTF-16 buffer"
       -- InvalidSequence should be impossible since mbuf' is output from Windows.
-      InvalidSequence -> error "InvalidSequence on output of Windows API"
+      InvalidSequence -> errorWithoutStackTrace "InvalidSequence on output of Windows API"
       -- If we run out of space in obuf, we need to ask for more output buffer space, while also returning
       -- the characters we have managed to consume so far.
       OutputUnderflow -> do
@@ -287,7 +287,7 @@ cpEncode cp _max_char_size = \ibuf obuf -> do
       -- If we succesfully translate all of the UTF-16 buffer, we need to know why
       -- we weren't able to get any more UTF-16 out of the UTF-32 buffer
       InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf)
-                     | otherwise           -> error "cpEncode: impossible underflown UTF-16 buffer"
+                     | otherwise           -> errorWithoutStackTrace "cpEncode: impossible underflown UTF-16 buffer"
       -- With OutputUnderflow/InvalidSequence we only care about the failings of the UTF-16->CP translation.
       -- Yes, InvalidSequence is possible even though mbuf' is guaranteed to be valid UTF-16, because
       -- the code page may not be able to represent the encoded Unicode codepoint.
@@ -371,7 +371,7 @@ bSearch msg code ibuf mbuf target_to_elems = go
         LT -> go' (md+1) mx
         GT -> go' mn (md-1)
     go' mn mx | mn <= mx  = go mn (mn + ((mx - mn) `div` 2)) mx
-              | otherwise = error $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx)
+              | otherwise = errorWithoutStackTrace $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx)
 
 cpRecode :: forall from to. Storable from
          => (Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int))
diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index c1d15a93b7..ca5336955c 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -255,7 +255,7 @@ hSetEncoding hdl encoding = do
     closeTextCodecs h_
     openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do
     bbuf <- readIORef haByteBuffer
-    ref <- newIORef (error "last_decode")
+    ref <- newIORef (errorWithoutStackTrace "last_decode")
     return (Handle__{ haLastDecode = ref,
                       haDecoder = mb_decoder,
                       haEncoder = mb_encoder,
@@ -571,7 +571,7 @@ hSetBinaryMode handle bin =
                    | otherwise = nativeNewlineMode
 
          bbuf <- readIORef haByteBuffer
-         ref <- newIORef (error "codec_state", bbuf)
+         ref <- newIORef (errorWithoutStackTrace "codec_state", bbuf)
 
          return Handle__{ haLastDecode = ref,
                           haEncoder  = mb_encoder,
diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs
index 5d8ddfd981..48ece1dc5e 100644
--- a/libraries/base/GHC/IO/Handle/Internals.hs
+++ b/libraries/base/GHC/IO/Handle/Internals.hs
@@ -628,7 +628,7 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
    let buf_state = initBufferState ha_type
    bbuf <- Buffered.newBuffer dev buf_state
    bbufref <- newIORef bbuf
-   last_decode <- newIORef (error "codec_state", bbuf)
+   last_decode <- newIORef (errorWithoutStackTrace "codec_state", bbuf)
 
    (cbufref,bmode) <-
          if buffered then getCharBuffer dev buf_state
@@ -848,7 +848,7 @@ readTextDevice h_@Handle__{..} cbuf = do
   (bbuf2,cbuf') <-
       case haDecoder of
           Nothing      -> do
-               writeIORef haLastDecode (error "codec_state", bbuf1)
+               writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf1)
                latin1_decode bbuf1 cbuf
           Just decoder -> do
                state <- getState decoder
@@ -937,7 +937,7 @@ decodeByteBuf h_@Handle__{..} cbuf = do
   (bbuf2,cbuf') <-
       case haDecoder of
           Nothing      -> do
-               writeIORef haLastDecode (error "codec_state", bbuf0)
+               writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf0)
                latin1_decode bbuf0 cbuf
           Just decoder -> do
                state <- getState decoder
diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs
index c31ab70a4a..65832c79ec 100644
--- a/libraries/base/GHC/IO/Handle/Text.hs
+++ b/libraries/base/GHC/IO/Handle/Text.hs
@@ -564,7 +564,7 @@ getSpareBuffer Handle__{haCharBuffer=ref,
                         haBufferMode=mode}
  = do
    case mode of
-     NoBuffering -> return (mode, error "no buffer!")
+     NoBuffering -> return (mode, errorWithoutStackTrace "no buffer!")
      _ -> do
           bufs <- readIORef spare_ref
           buf  <- readIORef ref
diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs
index 195054a7aa..b7de4ab95b 100644
--- a/libraries/base/GHC/IO/Handle/Types.hs
+++ b/libraries/base/GHC/IO/Handle/Types.hs
@@ -185,10 +185,10 @@ checkHandleInvariants h_ = do
  cbuf <- readIORef (haCharBuffer h_)
  checkBuffer cbuf
  when (isWriteBuffer cbuf && not (isEmptyBuffer cbuf)) $
-   error ("checkHandleInvariants: char write buffer non-empty: " ++
+   errorWithoutStackTrace ("checkHandleInvariants: char write buffer non-empty: " ++
           summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf)
  when (isWriteBuffer bbuf /= isWriteBuffer cbuf) $
-   error ("checkHandleInvariants: buffer modes differ: " ++
+   errorWithoutStackTrace ("checkHandleInvariants: buffer modes differ: " ++
           summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf)
 
 #else
diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs
index bbaa0a2751..92ded0d413 100644
--- a/libraries/base/GHC/List.hs
+++ b/libraries/base/GHC/List.hs
@@ -841,8 +841,8 @@ concat = foldr (++) []
 -- which takes an index of any integral type.
 (!!)                    :: [a] -> Int -> a
 #ifdef USE_REPORT_PRELUDE
-xs     !! n | n < 0 =  error "Prelude.!!: negative index"
-[]     !! _         =  error "Prelude.!!: index too large"
+xs     !! n | n < 0 =  errorWithoutStackTrace "Prelude.!!: negative index"
+[]     !! _         =  errorWithoutStackTrace "Prelude.!!: index too large"
 (x:_)  !! 0         =  x
 (_:xs) !! n         =  xs !! (n-1)
 #else
@@ -852,10 +852,10 @@ xs     !! n | n < 0 =  error "Prelude.!!: negative index"
 -- if so we should be careful not to trip up known-bottom
 -- optimizations.
 tooLarge :: Int -> a
-tooLarge _ = error (prel_list_str ++ "!!: index too large")
+tooLarge _ = errorWithoutStackTrace (prel_list_str ++ "!!: index too large")
 
 negIndex :: a
-negIndex = error $ prel_list_str ++ "!!: negative index"
+negIndex = errorWithoutStackTrace $ prel_list_str ++ "!!: negative index"
 
 {-# INLINABLE (!!) #-}
 xs !! n
@@ -996,7 +996,7 @@ unzip3   =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
 
 errorEmptyList :: String -> a
 errorEmptyList fun =
-  error (prel_list_str ++ fun ++ ": empty list")
+  errorWithoutStackTrace (prel_list_str ++ fun ++ ": empty list")
 
 prel_list_str :: String
 prel_list_str = "Prelude."
diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs
index dedf4f8790..e756f0d07f 100644
--- a/libraries/base/GHC/Natural.hs
+++ b/libraries/base/GHC/Natural.hs
@@ -215,7 +215,7 @@ instance Enum Natural where
     fromEnum (NatS# w) | i >= 0 = i
       where
         i = fromIntegral (W# w)
-    fromEnum _ = error "fromEnum: out of Int range"
+    fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range"
 
     enumFrom x        = enumDeltaNatural      x (NatS# 1##)
     enumFromThen x y
@@ -304,10 +304,10 @@ instance Bits Natural where
     NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m))
     NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m)
 
-    complement _ = error "Bits.complement: Natural complement undefined"
+    complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined"
 
     bitSizeMaybe _ = Nothing
-    bitSize = error "Natural: bitSize"
+    bitSize = errorWithoutStackTrace "Natural: bitSize"
     isSigned _ = False
 
     bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i)
@@ -484,7 +484,7 @@ instance Bits Natural where
   {-# INLINE (.|.) #-}
   xor (Natural n) (Natural m) = Natural (xor n m)
   {-# INLINE xor #-}
-  complement _ = error "Bits.complement: Natural complement undefined"
+  complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined"
   {-# INLINE complement #-}
   shift (Natural n) = Natural . shift n
   {-# INLINE shift #-}
@@ -502,7 +502,7 @@ instance Bits Natural where
   {-# INLINE testBit #-}
   bitSizeMaybe _ = Nothing
   {-# INLINE bitSizeMaybe #-}
-  bitSize = error "Natural: bitSize"
+  bitSize = errorWithoutStackTrace "Natural: bitSize"
   {-# INLINE bitSize #-}
   isSigned _ = False
   {-# INLINE isSigned #-}
@@ -523,14 +523,14 @@ instance Real Natural where
   {-# INLINE toRational #-}
 
 instance Enum Natural where
-  pred (Natural 0) = error "Natural.pred: 0"
+  pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0"
   pred (Natural n) = Natural (pred n)
   {-# INLINE pred #-}
   succ (Natural n) = Natural (succ n)
   {-# INLINE succ #-}
   fromEnum (Natural n) = fromEnum n
   {-# INLINE fromEnum #-}
-  toEnum n | n < 0     = error "Natural.toEnum: negative"
+  toEnum n | n < 0     = errorWithoutStackTrace "Natural.toEnum: negative"
            | otherwise = Natural (toEnum n)
   {-# INLINE toEnum #-}
 
@@ -597,7 +597,7 @@ instance Data Natural where
   toConstr x = mkIntegralConstr naturalType x
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c
+                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c
                                  ++ " is not of type Natural"
   dataTypeOf _ = naturalType
 
diff --git a/libraries/base/GHC/Pack.hs b/libraries/base/GHC/Pack.hs
index 95ff849f31..73334b6c98 100644
--- a/libraries/base/GHC/Pack.hs
+++ b/libraries/base/GHC/Pack.hs
@@ -89,7 +89,7 @@ new_ps_array size = ST $ \ s ->
     case (newByteArray# size s)   of { (# s2#, barr# #) ->
     (# s2#, MutableByteArray bot bot barr# #) }
   where
-    bot = error "new_ps_array"
+    bot = errorWithoutStackTrace "new_ps_array"
 
 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
     case writeCharArray# barr# n ch s#  of { s2#   ->
diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc
index 62e720f7c0..12cead7821 100644
--- a/libraries/base/GHC/RTS/Flags.hsc
+++ b/libraries/base/GHC/RTS/Flags.hsc
@@ -87,7 +87,7 @@ instance Enum GiveGCStats where
     toEnum #{const ONELINE_GC_STATS} = OneLineGCStats
     toEnum #{const SUMMARY_GC_STATS} = SummaryGCStats
     toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats
-    toEnum e = error ("invalid enum for GiveGCStats: " ++ show e)
+    toEnum e = errorWithoutStackTrace ("invalid enum for GiveGCStats: " ++ show e)
 
 -- | Parameters of the garbage collector.
 --
@@ -185,7 +185,7 @@ instance Enum DoCostCentres where
     toEnum #{const COST_CENTRES_VERBOSE} = CostCentresVerbose
     toEnum #{const COST_CENTRES_ALL}     = CostCentresAll
     toEnum #{const COST_CENTRES_XML}     = CostCentresXML
-    toEnum e = error ("invalid enum for DoCostCentres: " ++ show e)
+    toEnum e = errorWithoutStackTrace ("invalid enum for DoCostCentres: " ++ show e)
 
 -- | Parameters pertaining to the cost-center profiler.
 --
@@ -228,7 +228,7 @@ instance Enum DoHeapProfile where
     toEnum #{const HEAP_BY_RETAINER}     = HeapByRetainer
     toEnum #{const HEAP_BY_LDV}          = HeapByLDV
     toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType
-    toEnum e = error ("invalid enum for DoHeapProfile: " ++ show e)
+    toEnum e = errorWithoutStackTrace ("invalid enum for DoHeapProfile: " ++ show e)
 
 -- | Parameters of the cost-center profiler
 --
@@ -267,7 +267,7 @@ instance Enum DoTrace where
     toEnum #{const TRACE_NONE}     = TraceNone
     toEnum #{const TRACE_EVENTLOG} = TraceEventLog
     toEnum #{const TRACE_STDERR}   = TraceStderr
-    toEnum e = error ("invalid enum for DoTrace: " ++ show e)
+    toEnum e = errorWithoutStackTrace ("invalid enum for DoTrace: " ++ show e)
 
 -- | Parameters pertaining to event tracing
 --
diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs
index 31381d6bd9..186be27cdf 100644
--- a/libraries/base/GHC/Real.hs
+++ b/libraries/base/GHC/Real.hs
@@ -205,7 +205,7 @@ class  (Real a, Fractional a) => RealFrac a  where
                                 -1 -> n
                                 0  -> if even n then n else m
                                 1  -> m
-                                _  -> error "round default defn: Bad value"
+                                _  -> errorWithoutStackTrace "round default defn: Bad value"
 
     ceiling x           =  if r > 0 then n + 1 else n
                            where (n,r) = properFraction x
@@ -476,7 +476,7 @@ odd             =  not . even
         Int -> Int -> Int #-}
 {-# INLINABLE [1] (^) #-}    -- See Note [Inlining (^)]
 (^) :: (Num a, Integral b) => a -> b -> a
-x0 ^ y0 | y0 < 0    = error "Negative exponent"
+x0 ^ y0 | y0 < 0    = errorWithoutStackTrace "Negative exponent"
         | y0 == 0   = 1
         | otherwise = f x0 y0
     where -- f : x0 ^ y0 = x ^ y
@@ -585,7 +585,7 @@ x ^^ n          =  if n >= 0 then x^n else recip (x^(negate n))
 {-# RULES "(^)/Rational"    (^) = (^%^) #-}
 (^%^)           :: Integral a => Rational -> a -> Rational
 (n :% d) ^%^ e
-    | e < 0     = error "Negative exponent"
+    | e < 0     = errorWithoutStackTrace "Negative exponent"
     | e == 0    = 1 :% 1
     | otherwise = (n ^ e) :% (d ^ e)
 
diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs
index 879d666bb0..4322aff2e8 100644
--- a/libraries/base/GHC/Show.hs
+++ b/libraries/base/GHC/Show.hs
@@ -396,7 +396,7 @@ intToDigit :: Int -> Char
 intToDigit (I# i)
     | isTrue# (i >=# 0#)  && isTrue# (i <=#  9#) = unsafeChr (ord '0' + I# i)
     | isTrue# (i >=# 10#) && isTrue# (i <=# 15#) = unsafeChr (ord 'a' + I# i - 10)
-    | otherwise =  error ("Char.intToDigit: not a digit " ++ show (I# i))
+    | otherwise =  errorWithoutStackTrace ("Char.intToDigit: not a digit " ++ show (I# i))
 
 showSignedInt :: Int -> Int -> ShowS
 showSignedInt (I# p) (I# n) r
@@ -464,7 +464,7 @@ integerToString n0 cs0
         (# q, r #) ->
             if q > 0 then q : r : jsplitb p ns
                      else     r : jsplitb p ns
-    jsplith _ [] = error "jsplith: []"
+    jsplith _ [] = errorWithoutStackTrace "jsplith: []"
 
     jsplitb :: Integer -> [Integer] -> [Integer]
     jsplitb _ []     = []
@@ -483,7 +483,7 @@ integerToString n0 cs0
                 r = fromInteger r'
             in if q > 0 then jhead q $ jblock r $ jprintb ns cs
                         else jhead r $ jprintb ns cs
-    jprinth [] _ = error "jprinth []"
+    jprinth [] _ = errorWithoutStackTrace "jprinth []"
 
     jprintb :: [Integer] -> String -> String
     jprintb []     cs = cs
diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs
index d7c5c94193..727910a659 100644
--- a/libraries/base/GHC/Stack.hs
+++ b/libraries/base/GHC/Stack.hs
@@ -15,7 +15,7 @@
 -- @since 4.5.0.0
 -----------------------------------------------------------------------------
 
-{-# LANGUAGE MagicHash, NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash, NoImplicitPrelude, ImplicitParams, RankNTypes #-}
 module GHC.Stack (
     -- * Call stacks
     currentCallStack,
@@ -23,7 +23,8 @@ module GHC.Stack (
     errorWithStackTrace,
 
     -- * Implicit parameter call stacks
-    CallStack, getCallStack, pushCallStack, prettyCallStack,
+    CallStack, emptyCallStack, freezeCallStack, getCallStack, popCallStack,
+    prettyCallStack, pushCallStack, withFrozenCallStack,
 
     -- * Source locations
     SrcLoc(..), prettySrcLoc,
@@ -62,3 +63,28 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do
    if null stack
       then throwIO (ErrorCall x)
       else throwIO (ErrorCallWithLocation x (renderStack stack))
+
+
+-- | Pop the most recent call-site off the 'CallStack'.
+--
+-- This function, like 'pushCallStack', has no effect on a frozen 'CallStack'.
+--
+-- @since 4.9.0.0
+popCallStack :: CallStack -> CallStack
+popCallStack stk = case stk of
+  EmptyCallStack       -> errorWithoutStackTrace "popCallStack: empty stack"
+  PushCallStack _ stk' -> stk'
+  FreezeCallStack _    -> stk
+
+
+-- | Perform some computation without adding new entries to the 'CallStack'.
+--
+-- @since 4.9.0.0
+withFrozenCallStack :: (?callStack :: CallStack)
+                    => ( (?callStack :: CallStack) => a )
+                    -> a
+withFrozenCallStack do_this =
+                   -- we pop the stack before freezing it to remove
+                   -- withFrozenCallStack's call-site
+  let ?callStack = freezeCallStack (popCallStack ?callStack)
+  in do_this
diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs
index ebe4591e3b..a971f7c86a 100644
--- a/libraries/base/GHC/Stack/Types.hs
+++ b/libraries/base/GHC/Stack/Types.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_HADDOCK hide #-}
+-- we hide this module from haddock to enforce GHC.Stack as the main
+-- access point.
 
 -----------------------------------------------------------------------------
 -- |
@@ -11,14 +14,14 @@
 -- Portability :  non-portable (GHC Extensions)
 --
 -- type definitions for call-stacks via implicit parameters.
--- Use GHC.Exts from the base package instead of importing this
+-- Use "GHC.Stack" from the base package instead of importing this
 -- module directly.
 --
 -----------------------------------------------------------------------------
 
 module GHC.Stack.Types (
     -- * Implicit parameter call stacks
-    CallStack, getCallStack, pushCallStack,
+    CallStack(..), emptyCallStack, freezeCallStack, getCallStack, pushCallStack,
     -- * Source locations
     SrcLoc(..)
   ) where
@@ -84,12 +87,26 @@ import GHC.Integer ()
 -- ordered with the most recently called function at the head.
 --
 -- @since 4.8.1.0
-data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)]
-                             -- ^ Get a list of stack frames with the most
-                             -- recently called function at the head.
-                           }
+data CallStack
+  = EmptyCallStack
+  | PushCallStack ([Char], SrcLoc) CallStack
+  | FreezeCallStack CallStack
+    -- ^ Freeze the stack at the given @CallStack@, preventing any further
+    -- call-sites from being pushed onto it.
+
   -- See Note [Overview of implicit CallStacks]
 
+-- | Extract a list of call-sites from the 'CallStack'.
+--
+-- The list is ordered by most recent call.
+--
+-- @since 4.8.1.0
+getCallStack :: CallStack -> [([Char], SrcLoc)]
+getCallStack stk = case stk of
+  EmptyCallStack        -> []
+  PushCallStack cs stk' -> cs : getCallStack stk'
+  FreezeCallStack stk'  -> getCallStack stk'
+
 
 -- Note [Definition of CallStack]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -109,10 +126,31 @@ data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)]
 
 -- | Push a call-site onto the stack.
 --
+-- This function has no effect on a frozen 'CallStack'.
+--
 -- @since 4.9.0.0
 pushCallStack :: ([Char], SrcLoc) -> CallStack -> CallStack
-pushCallStack callSite (CallStack stk)
-  = CallStack (callSite : stk)
+pushCallStack cs stk = case stk of
+  FreezeCallStack _ -> stk
+  _                 -> PushCallStack cs stk
+{-# INLINE pushCallStack #-}
+
+
+-- | The empty 'CallStack'.
+--
+-- @since 4.9.0.0
+emptyCallStack :: CallStack
+emptyCallStack = EmptyCallStack
+{-# INLINE emptyCallStack #-}
+
+-- | Freeze a call-stack, preventing any further call-sites from being appended.
+--
+-- prop> pushCallStack callSite (freezeCallStack callStack) = freezeCallStack callStack
+--
+-- @since 4.9.0.0
+freezeCallStack :: CallStack -> CallStack
+freezeCallStack stk = FreezeCallStack stk
+{-# INLINE freezeCallStack #-}
 
 
 -- | A single location in the source code.