base: Ensure that failIO isn't SOURCE imported

failIO has useful information in its demand signature (specifically that
it bottoms) which is hidden if it is SOURCE imported, as noted
in #16588. Rejigger things such that we don't SOURCE import it.

Metric Increase:
    T13701

4 files changed, 18 insertions, 9 deletions

diff --git a/libraries/base/Control/Monad/Fail.hs b/libraries/base/Control/Monad/Fail.hs
index ecf974bc79..3d7da77134 100644
--- a/libraries/base/Control/Monad/Fail.hs
+++ b/libraries/base/Control/Monad/Fail.hs
@@ -38,8 +38,7 @@
 --
 module Control.Monad.Fail ( MonadFail(fail) ) where
 
-import GHC.Base (String, Monad(), Maybe(Nothing), IO())
-import {-# SOURCE #-} GHC.IO (failIO)
+import GHC.Base (String, Monad(), Maybe(Nothing), IO(), failIO)
 
 -- | When a value is bound in @do@-notation, the pattern on the left
 -- hand side of @<-@ might not match. In this case, this class
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index 54c6f91280..5c60be83f0 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -130,7 +130,7 @@ import GHC.Prim
 import GHC.Prim.Ext
 import GHC.Err
 import GHC.Maybe
-import {-# SOURCE #-} GHC.IO (failIO,mplusIO)
+import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)
 
 import GHC.Tuple ()              -- Note [Depend on GHC.Tuple]
 import GHC.Integer ()            -- Note [Depend on GHC.Integer]
@@ -1517,6 +1517,13 @@ bindIO (IO m) k = IO (\ s -> case m s of (# new_s, a #) -> unIO (k a) new_s)
 thenIO :: IO a -> IO b -> IO b
 thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s)
 
+-- Note that it is import that we do not SOURCE import this as
+-- its demand signature encodes knowledge of its bottoming
+-- behavior, which can expose useful simplifications. See
+-- #16588.
+failIO :: String -> IO a
+failIO s = IO (raiseIO# (mkUserError s))
+
 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
 unIO (IO a) = a
 
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index 0c28cf0352..8fbdc8ef24 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -24,7 +24,7 @@
 -----------------------------------------------------------------------------
 
 module GHC.IO (
-        IO(..), unIO, failIO, liftIO, mplusIO,
+        IO(..), unIO, liftIO, mplusIO,
         unsafePerformIO, unsafeInterleaveIO,
         unsafeDupablePerformIO, unsafeDupableInterleaveIO,
         noDuplicate,
@@ -38,7 +38,8 @@ module GHC.IO (
         mask, mask_, uninterruptibleMask, uninterruptibleMask_,
         MaskingState(..), getMaskingState,
         unsafeUnmask, interruptible,
-        onException, bracket, finally, evaluate
+        onException, bracket, finally, evaluate,
+        mkUserError
     ) where
 
 import GHC.Base
@@ -78,9 +79,6 @@ Libraries - parts of hslibs/lang.
 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
 
-failIO :: String -> IO a
-failIO s = IO (raiseIO# (toException (userError s)))
-
 -- ---------------------------------------------------------------------------
 -- Coercions between IO and ST
 
@@ -457,3 +455,7 @@ Since this strictness is a small optimization and may lead to surprising
 results, all of the @catch@ and @handle@ variants offered by "Control.Exception"
 use 'catch' rather than 'catchException'.
 -}
+
+-- For SOURCE import by GHC.Base to define failIO.
+mkUserError       :: [Char]  -> SomeException
+mkUserError str   = toException (userError str)
diff --git a/libraries/base/GHC/IO.hs-boot b/libraries/base/GHC/IO.hs-boot
index aa2e5ccd2d..1aeadd5932 100644
--- a/libraries/base/GHC/IO.hs-boot
+++ b/libraries/base/GHC/IO.hs-boot
@@ -5,6 +5,7 @@ module GHC.IO where
 
 import GHC.Types
 import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base
+import {-# SOURCE #-} GHC.Exception.Type (SomeException)
 
-failIO :: [Char] -> IO a
 mplusIO :: IO a -> IO a -> IO a
+mkUserError :: [Char] -> SomeException