module GHC.IOBase(
IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO,
unsafePerformIO, unsafeInterleaveIO,
+ unsafeDupablePerformIO, unsafeDupableInterleaveIO,
+ noDuplicate,
-- To and from from ST
stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
import GHC.Show
import GHC.List
import GHC.Read
+import Foreign.C.Types (CInt)
#ifndef __HADDOCK__
import {-# SOURCE #-} GHC.Dynamic
possible to write @coerce :: a -> b@ with the
help of 'unsafePerformIO'. So be careful!
-}
-{-# NOINLINE unsafePerformIO #-}
unsafePerformIO :: IO a -> a
-unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
+unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
+
+{-|
+This version of 'unsafePerformIO' is slightly more efficient,
+because it omits the check that the IO is only being performed by a
+single thread. Hence, when you write 'unsafeDupablePerformIO',
+there is a possibility that the IO action may be performed multiple
+times (on a multiprocessor), and you should therefore ensure that
+it gives the same results each time.
+-}
+{-# NOINLINE unsafeDupablePerformIO #-}
+unsafeDupablePerformIO :: IO a -> a
+unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
--- Why do we NOINLINE unsafePerformIO? See the comment with
+-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with
-- GHC.ST.runST. Essentially the issue is that the IO computation
-- inside unsafePerformIO must be atomic: it must either all run, or
-- not at all. If we let the compiler see the application of the IO
-- to realWorld#, it might float out part of the IO.
--- Why is there a call to 'lazy' in unsafePerformIO?
+-- Why is there a call to 'lazy' in unsafeDupablePerformIO?
-- If we don't have it, the demand analyser discovers the following strictness
--- for unsafePerformIO: C(U(AV))
+-- for unsafeDupablePerformIO: C(U(AV))
-- But then consider
--- unsafePerformIO (\s -> let r = f x in
+-- unsafeDupablePerformIO (\s -> let r = f x in
-- case writeIORef v r s of (# s1, _ #) ->
-- (# s1, r #)
-- The strictness analyser will find that the binding for r is strict,
-- doing the writeIORef. This actually makes tests/lib/should_run/memo002
-- get a deadlock!
--
--- Solution: don't expose the strictness of unsafePerformIO,
+-- Solution: don't expose the strictness of unsafeDupablePerformIO,
-- by hiding it with 'lazy'
-
{-|
'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
When passed a value of type @IO a@, the 'IO' will only be performed
-}
{-# INLINE unsafeInterleaveIO #-}
unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO (IO m)
+unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)
+
+-- We believe that INLINE on unsafeInterleaveIO is safe, because the
+-- state from this IO thread is passed explicitly to the interleaved
+-- IO, so it cannot be floated out and shared.
+
+{-# INLINE unsafeDupableInterleaveIO #-}
+unsafeDupableInterleaveIO :: IO a -> IO a
+unsafeDupableInterleaveIO (IO m)
= IO ( \ s -> let
r = case m s of (# _, res #) -> res
in
(# s, r #))
--- We believe that INLINE on unsafeInterleaveIO is safe, because the
--- state from this IO thread is passed explicitly to the interleaved
--- IO, so it cannot be floated out and shared.
+{-|
+Ensures that the suspensions under evaluation by the current thread
+are unique; that is, the current thread is not evaluating anything
+that is also under evaluation by another thread that has also executed
+'noDuplicate'.
+
+This operation is used in the definition of 'unsafePerformIO' to
+prevent the IO action from being executed multiple times, which is usually
+undesirable.
+-}
+noDuplicate :: IO ()
+noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)
-- ---------------------------------------------------------------------------
-- Handle type
(DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2
_ == _ = False
-type FD = Int -- XXX ToDo: should be CInt
+type FD = CInt
data Handle__
= Handle__ {
-- Although 'throwIO' has a type that is an instance of the type of 'throw', the
-- two functions are subtly different:
--
--- > throw e `seq` return () ===> throw e
--- > throwIO e `seq` return () ===> return ()
+-- > throw e `seq` x ===> throw e
+-- > throwIO e `seq` x ===> x
--
-- The first example will cause the exception @e@ to be raised,
-- whereas the second one won\'t. In fact, 'throwIO' will only cause