diff options
| -rw-r--r-- | libraries/base/Control/Monad/Fail.hs | 3 | ||||
| -rw-r--r-- | libraries/base/GHC/Base.hs | 9 | ||||
| -rw-r--r-- | libraries/base/GHC/IO.hs | 12 | ||||
| -rw-r--r-- | libraries/base/GHC/IO.hs-boot | 3 |
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 |