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

2 files changed, 4 insertions, 4 deletions

diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc
index 410e3acda2..8b6c7b6c57 100644
--- a/libraries/base/System/Environment/ExecutablePath.hsc
+++ b/libraries/base/System/Environment/ExecutablePath.hsc
@@ -84,7 +84,7 @@ _NSGetExecutablePath =
                         status2 <- c__NSGetExecutablePath newBuf bufsize
                         if status2 == 0
                              then peekFilePath newBuf
-                             else error "_NSGetExecutablePath: buffer too small"
+                             else errorWithoutStackTrace "_NSGetExecutablePath: buffer too small"
 
 foreign import ccall unsafe "stdlib.h realpath"
     c_realpath :: CString -> CString -> IO CString
@@ -145,7 +145,7 @@ getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32
     go size = allocaArray (fromIntegral size) $ \ buf -> do
         ret <- c_GetModuleFileName nullPtr buf size
         case ret of
-            0 -> error "getExecutablePath: GetModuleFileNameW returned an error"
+            0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error"
             _ | ret < size -> peekFilePath buf
               | otherwise  -> go (size * 2)
 
@@ -166,7 +166,7 @@ getExecutablePath =
             -- If argc > 0 then argv[0] is guaranteed by the standard
             -- to be a pointer to a null-terminated string.
             then peek p_argv >>= peek >>= peekFilePath
-            else error $ "getExecutablePath: " ++ msg
+            else errorWithoutStackTrace $ "getExecutablePath: " ++ msg
   where msg = "no OS specific implementation and program name couldn't be " ++
               "found in argv"
 
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index e0ee9b15be..04e976a85b 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -480,7 +480,7 @@ openTempFile' loc tmp_dir template binary mode = findTempName
          -- Otherwise, something is wrong, because (break (== '.')) should
          -- always return a pair with either the empty string or a string
          -- beginning with '.' as the second component.
-         _                      -> error "bug in System.IO.openTempFile"
+         _                      -> errorWithoutStackTrace "bug in System.IO.openTempFile"
 
     findTempName = do
       rs <- rand_string