New magic function for applying realWorld#

Test Plan: validate

Reviewers: goldfire, erikd, rwbarton, simonpj, austin, simonmar, hvr

Reviewed By: simonpj

Subscribers: simonmar, thomie

Differential Revision: https://phabricator.haskell.org/D1103

GHC Trac Issues: #10678

5 files changed, 24 insertions, 62 deletions

diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index 1e8c74e5c1..f38c88f009 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -176,11 +176,8 @@ like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'.
 
 @since 4.4.0.0
 -}
-{-# NOINLINE unsafeDupablePerformIO #-}
-    -- See Note [unsafeDupablePerformIO is NOINLINE]
 unsafeDupablePerformIO  :: IO a -> a
-unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
-     -- See Note [unsafeDupablePerformIO has a lazy RHS]
+unsafeDupablePerformIO (IO m) = case runRW# m of (# _, a #) -> a
 
 -- Note [unsafeDupablePerformIO is NOINLINE]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs
index 46c5196c9e..d84dd4d9d1 100644
--- a/libraries/base/GHC/ST.hs
+++ b/libraries/base/GHC/ST.hs
@@ -18,7 +18,7 @@
 
 module GHC.ST (
         ST(..), STret(..), STRep,
-        fixST, runST, runSTRep,
+        fixST, runST,
 
         -- * Unsafe functions
         liftST, unsafeInterleaveST
@@ -103,62 +103,10 @@ instance  Show (ST s a)  where
     showsPrec _ _  = showString "<<ST action>>"
     showList       = showList__ (showsPrec 0)
 
-{-
-Definition of runST
-~~~~~~~~~~~~~~~~~~~
-
-SLPJ 95/04: Why @runST@ must not have an unfolding; consider:
-\begin{verbatim}
-f x =
-  runST ( \ s -> let
-                    (a, s')  = newArray# 100 [] s
-                    (_, s'') = fill_in_array_or_something a x s'
-                  in
-                  freezeArray# a s'' )
-\end{verbatim}
-If we inline @runST@, we'll get:
-\begin{verbatim}
-f x = let
-        (a, s')  = newArray# 100 [] realWorld#{-NB-}
-        (_, s'') = fill_in_array_or_something a x s'
-      in
-      freezeArray# a s''
-\end{verbatim}
-And now the @newArray#@ binding can be floated to become a CAF, which
-is totally and utterly wrong:
-\begin{verbatim}
-f = let
-    (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
-    in
-    \ x ->
-        let (_, s'') = fill_in_array_or_something a x s' in
-        freezeArray# a s''
-\end{verbatim}
-All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.
--}
-
 {-# INLINE runST #-}
--- The INLINE prevents runSTRep getting inlined in *this* module
--- so that it is still visible when runST is inlined in an importing
--- module.  Regrettably delicate.  runST is behaving like a wrapper.
-
 -- | Return the value computed by a state transformer computation.
 -- The @forall@ ensures that the internal state used by the 'ST'
 -- computation is inaccessible to the rest of the program.
 runST :: (forall s. ST s a) -> a
-runST st = runSTRep (case st of { ST st_rep -> st_rep })
-
--- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness
--- That's what the "INLINE [0]" says.
---              SLPJ Apr 99
--- {-# INLINE [0] runSTRep #-}
-
--- SDM: further to the above, inline phase 0 is run *before*
--- full-laziness at the moment, which means that the above comment is
--- invalid.  Inlining runSTRep doesn't make a huge amount of
--- difference, anyway.  Hence:
-
-{-# NOINLINE runSTRep #-}
-runSTRep :: (forall s. STRep s a) -> a
-runSTRep st_rep = case st_rep realWorld# of
-                        (# _, r #) -> r
+runST (ST st_rep) = case runRW# st_rep of (# _, a #) -> a
+-- See Note [Definition of runRW#] in GHC.Magic
diff --git a/libraries/ghc-prim/GHC/Magic.hs b/libraries/ghc-prim/GHC/Magic.hs
index 740abb729e..495705b3b4 100644
--- a/libraries/ghc-prim/GHC/Magic.hs
+++ b/libraries/ghc-prim/GHC/Magic.hs
@@ -1,5 +1,9 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Magic
@@ -17,8 +21,9 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.Magic ( inline, lazy, oneShot ) where
+module GHC.Magic ( inline, lazy, oneShot, runRW# ) where
 
+import GHC.Prim
 import GHC.CString ()
 
 -- | The call @inline f@ arranges that 'f' is inlined, regardless of
@@ -82,3 +87,15 @@ oneShot :: (a -> b) -> (a -> b)
 oneShot f = f
 -- Implementation note: This is wired in in MkId.lhs, so the code here is
 -- mostly there to have a place for the documentation.
+
+-- | Apply a function to a 'RealWorld' token.
+runRW# :: (State# RealWorld -> (# State# RealWorld, o #))
+       -> (# State# RealWorld, o #)
+-- See Note [runRW magic] in MkId
+#if !defined(__HADDOCK_VERSION__)
+runRW# m = m realWorld#
+#else
+runRW# = runRW#   -- The realWorld# is too much for haddock
+#endif
+{-# NOINLINE runRW# #-}
+-- This is inlined manually in CorePrep
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 2e4288622b..45daa64b26 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -27,6 +27,7 @@
 
         getSizeofMutableByteArray# :: MutableByteArray# d -> State# d -> (# State# d, Int# #)
         subWordC# :: Word# -> Word# -> (# Word#, Int# #)
+        runRW# :: (State# RealWorld -> (# State# RealWorld, o #)) -> (# State# RealWorld, o #)
 
 - Added to `GHC.Types`:
 
diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs
index 5bc52539fd..167492d34d 100644
--- a/libraries/integer-gmp/src/GHC/Integer/Type.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs
@@ -1934,8 +1934,7 @@ liftIO (IO m) = m
 
 -- NB: equivalent of GHC.IO.unsafeDupablePerformIO, see notes there
 runS :: S RealWorld a -> a
-runS m = lazy (case m realWorld# of (# _, r #) -> r)
-{-# NOINLINE runS #-}
+runS m = case runRW# m of (# _, a #) -> a
 
 -- stupid hack
 fail :: [Char] -> S s a