Test Trac #3959

testsuite/tests/ghc-regress/simplCore/should_run/T3959.hs

+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
+module Main(main,f) where
+
+import Data.List (isPrefixOf)
+import Data.Dynamic
+import Control.Exception as E
+
+data Failure = Failure
+    deriving (Show, Typeable)
+
+instance Exception Failure
+
+test = (E.throw Failure >> return ())
+          `E.catch` 
+       (\(x::Failure) -> return ())
+
+main :: IO ()
+main = print =<< test
+
+f :: Bool -> Bool -> Bool
+f True = error "urk"
+-- f False = \y -> y
+
+{-
+Uderlying cause: we call
+	  catch# thing handler
+and expect that (thing state-token) will
+    - either diverge/throw an exception
+    - or return (# x,y #)
+But it does neither: it returns a PAP, because
+    thing = \p q. blah
+
+In particular, 'thing = lvl_sxo' is 
+  lvl_sxc :: IO Any
+  lvl_sxc = error "urk"
+
+  lvl_sxo :: IO ()
+    = lvl_sxc >> return ()
+
+          -- inline (>>) --
+
+    = (\(eta::S#). case lvl_sxc |> g1 eta of ...) |> g2
+    where 
+      g1 :: IO Any ~ S# -> (# S#, Any #)
+      g2 :: S# -> (# S#, () #) -> IO ()
+
+          -- case-of-bottomming function --
+
+    = (\ (eta::S#). lvl_sxc |> g1 |> ug3) |> g2
+    where 
+      ug3(unsafe) :: S# -> (S#, Any) ~ (# S#, () #)
+
+This is all fine.  But it's crucial that lvl_sxc actually diverges.
+Do not eta-expand it to
+
+   lvl_sxc :: IO Any
+   lvl_sxc = \eta. error "urk" |> ug4
+       where
+         ug4(unsafe) :: S# -> (# S#, Any #) ~ IO Any
+
+In contrast, if we had
+   case x of
+     True  -> \a -> 3
+     False -> error "urk"
+we can, and must, eta-expand the error
+
+-}
\ No newline at end of file

testsuite/tests/ghc-regress/simplCore/should_run/T3959.stdout

+()

testsuite/tests/ghc-regress/simplCore/should_run/all.T

@@ -35,6 +35,7 @@ test('T3403', normal, compile_and_run, ['-package containers'])
 test('T3591', normal, compile_and_run, [''])
 
 # Run this test *without* optimisation too
+test('T3959', only_ways(['normal','optc','optasm']), compile_and_run, [''])
 test('T3983', [only_ways(['normal','optc','optasm']),
                extra_clean(['T3983_Foo.hi','T3983_Foo.o','T3983_Bar.hi','T3983_Bar.o',])], 
               multimod_compile_and_run,