[Git][ghc/ghc][wip/T24625] Improve efficiency of `assertError` (#24625)

[Sebastian Graf (@sgraf812)]

Sebastian Graf pushed to branch wip/T24625 at Glasgow Haskell Compiler / GHC


Commits:
8d3cb8f5 by Sebastian Graf at 2024-08-18T12:31:19+02:00
Improve efficiency of `assertError` (#24625)

... by moving `lazy` to the exception-throwing branch.
It's all documented in `Note [Strictness of assertError]`.

- - - - -


3 changed files:

- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
- + testsuite/tests/simplCore/should_compile/T24625.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
=====================================
@@ -438,13 +438,10 @@ instance Show IOException where
          "" -> id
          _  -> showString " (" . showString s . showString ")")
 
--- Note the use of "lazy". This means that
---     assert False (throw e)
--- will throw the assertion failure rather than e. See trac #5561.
 assertError :: (?callStack :: CallStack) => Bool -> a -> a
 assertError predicate v
-  | predicate = lazy v
-  | otherwise = unsafeDupablePerformIO $ do
+  | predicate = v
+  | otherwise = lazy $ unsafeDupablePerformIO $ do -- lazy: See Note [Strictness of assertError]
     ccsStack <- currentCallStack
     let
       implicitParamCallStack = prettyCallStackLines ?callStack
@@ -452,6 +449,44 @@ assertError predicate v
       stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
     throwIO (AssertionFailed ("Assertion failed\n" ++ stack))
 
+{- Note [Strictness of assertError]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is vital that Demand Analysis does not see `assertError p e` as strict in e.
+#5561 details what happens otherwise, tested by libraries/base/tests/assert.hs:
+
+  let e1 i = throw Overflow
+  in assertError False (e1 5)
+
+This should *not* throw the Overflow exception; rather it should throw an
+AssertionError.
+Hence we use GHC.Exts.lazy to make assertError appear lazy in e, so that it
+is not called by-value.
+(Note that the reason we need `lazy` in the first place is that error has a
+bottoming result, which is strict in all free variables.)
+The way we achieve this is a bit subtle; before #24625 we defined it as
+
+  assertError p e | p         = lazy e
+                  | otherwise = error "assertion"
+
+but this means that in the following example (full code in T24625) we cannot
+cancel away the allocation of `Just x` because of the intervening `lazy`:
+
+  case assertError False (Just x) of Just y -> y
+  ==> { simplify }
+  case lazy (Just x) of Just y -> y
+
+Instead, we put `lazy` in the otherwise branch, thus
+
+  assertError p e | p         = e
+                  | otherwise = lazy $ error "assertion"
+
+The effect on #5561 is the same: since the otherwise branch appears lazy in e,
+the overall demand on `e` must be lazy as well.
+Furthermore, since there is no intervening `lazy` on the expected code path,
+the Simplifier may perform case-of-case on e and simplify the `Just x` example
+to `x`.
+-}
+
 unsupportedOperation :: IOError
 unsupportedOperation =
    (IOError Nothing UnsupportedOperation ""
@@ -480,4 +515,3 @@ untangle coded message
           _         -> (loc, "")
         }
     not_bar c = c /= '|'
-


=====================================
testsuite/tests/simplCore/should_compile/T24625.hs
=====================================
@@ -0,0 +1,14 @@
+module T24625 where
+
+import GHC.IO.Exception
+import GHC.Exts
+
+data Foo = Foo !Int !Int String
+
+true :: Bool
+true = True
+{-# NOINLINE true #-}
+
+function :: Int -> Int -> String -> Int
+function !a !b c = case assertError true (Foo a b c) of
+  Foo a b c -> a + b


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -526,5 +526,6 @@ test('T24808', [ grep_errmsg(r'myFunction') ], compile, ['-O -ddump-simpl'])
 # T24944 needs -O2 because it's about SpecConstr
 test('T24944', [extra_files(['T24944a.hs'])], multimod_compile, ['T24944', '-v0 -O2'])
 
+test('T24625', [ grep_errmsg(r'case lazy') ], compile, ['-O -fno-ignore-asserts -ddump-simpl -dsuppress-uniques'])
 test('T24725a', [ grep_errmsg(r'testedRule')], compile, ['-O -ddump-rule-firings'])
 test('T25033', normal, compile, ['-O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d3cb8f5532be876ae4c1eace2d6099a326754ab

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d3cb8f5532be876ae4c1eace2d6099a326754ab
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240818/2fdd440a/attachment-0001.html>