update to current master againwip/T13904

3 files changed, 71 insertions, 81 deletions

diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs
index eb0bffe8b4..7b87adc7ea 100644
--- a/libraries/base/GHC/Conc/IO.hs
+++ b/libraries/base/GHC/Conc/IO.hs
@@ -85,7 +85,7 @@ ioManagerCapabilitiesChanged = return ()
 -- | Block the current thread until data is available to read on the
 -- given file descriptor (GHC only).
 --
--- This will throw an 'IOError' if the file descriptor was closed
+-- This will throw an 'Prelude.IOError' if the file descriptor was closed
 -- while this thread was blocked.  To safely close a file descriptor
 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
 threadWaitRead :: Fd -> IO ()
@@ -101,7 +101,7 @@ threadWaitRead fd
 -- | Block the current thread until data can be written to the
 -- given file descriptor (GHC only).
 --
--- This will throw an 'IOError' if the file descriptor was closed
+-- This will throw an 'Prelude.IOError' if the file descriptor was closed
 -- while this thread was blocked.  To safely close a file descriptor
 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
 threadWaitWrite :: Fd -> IO ()
@@ -188,8 +188,9 @@ threadDelay time
         case delay# time# s of { s' -> (# s', () #)
         }}
 
--- | Set the value of returned TVar to True after a given number of
--- microseconds. The caveats associated with threadDelay also apply.
+-- | Switch the value of returned 'TVar' from initial value 'False' to 'True'
+-- after a given number of microseconds. The caveats associated with
+-- 'threadDelay' also apply.
 --
 registerDelay :: Int -> IO (TVar Bool)
 registerDelay usecs
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index f9514d6681..6751de72a8 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -74,8 +74,6 @@ module GHC.Conc.Sync
         , orElse
         , throwSTM
         , catchSTM
-        , alwaysSucceeds
-        , always
         , TVar(..)
         , newTVar
         , newTVarIO
@@ -105,6 +103,7 @@ import Data.Maybe
 import GHC.Base
 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
+import GHC.Int
 import GHC.IO
 import GHC.IO.Encoding.UTF8
 import GHC.IO.Exception
@@ -194,18 +193,16 @@ instance Ord ThreadId where
 --
 -- @since 4.8.0.0
 setAllocationCounter :: Int64 -> IO ()
-setAllocationCounter i = do
-  ThreadId t <- myThreadId
-  rts_setThreadAllocationCounter t i
+setAllocationCounter (I64# i) = IO $ \s ->
+  case setThreadAllocationCounter# i s of s' -> (# s', () #)
 
 -- | Return the current value of the allocation counter for the
 -- current thread.
 --
 -- @since 4.8.0.0
 getAllocationCounter :: IO Int64
-getAllocationCounter = do
-  ThreadId t <- myThreadId
-  rts_getThreadAllocationCounter t
+getAllocationCounter = IO $ \s ->
+  case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #)
 
 -- | Enables the allocation counter to be treated as a limit for the
 -- current thread.  When the allocation limit is enabled, if the
@@ -242,16 +239,6 @@ disableAllocationLimit = do
   ThreadId t <- myThreadId
   rts_disableThreadAllocationLimit t
 
--- We cannot do these operations safely on another thread, because on
--- a 32-bit machine we cannot do atomic operations on a 64-bit value.
--- Therefore, we only expose APIs that allow getting and setting the
--- limit of the current thread.
-foreign import ccall unsafe "rts_setThreadAllocationCounter"
-  rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO ()
-
-foreign import ccall unsafe "rts_getThreadAllocationCounter"
-  rts_getThreadAllocationCounter :: ThreadId# -> IO Int64
-
 foreign import ccall unsafe "rts_enableThreadAllocationLimit"
   rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
 
@@ -487,7 +474,7 @@ myThreadId = IO $ \s ->
    case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
 
 
--- |The 'yield' action allows (forces, in a co-operative multitasking
+-- | The 'yield' action allows (forces, in a co-operative multitasking
 -- implementation) a context-switch to any other currently runnable
 -- threads (if any), and is occasionally useful when implementing
 -- concurrency abstractions.
@@ -556,9 +543,12 @@ data BlockReason
         -- ^currently in a foreign call
   | BlockedOnOther
         -- ^blocked on some other resource.  Without @-threaded@,
-        -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
-        -- they show up as 'BlockedOnMVar'.
-  deriving (Eq,Ord,Show)
+        -- I\/O and 'Control.Concurrent.threadDelay' show up as
+        -- 'BlockedOnOther', with @-threaded@ they show up as 'BlockedOnMVar'.
+  deriving ( Eq   -- ^ @since 4.3.0.0
+           , Ord  -- ^ @since 4.3.0.0
+           , Show -- ^ @since 4.3.0.0
+           )
 
 -- | The current status of a thread
 data ThreadStatus
@@ -570,7 +560,10 @@ data ThreadStatus
         -- ^the thread is blocked on some resource
   | ThreadDied
         -- ^the thread received an uncaught exception
-  deriving (Eq,Ord,Show)
+  deriving ( Eq   -- ^ @since 4.3.0.0
+           , Ord  -- ^ @since 4.3.0.0
+           , Show -- ^ @since 4.3.0.0
+           )
 
 threadStatus :: ThreadId -> IO ThreadStatus
 threadStatus (ThreadId t) = IO $ \s ->
@@ -591,7 +584,7 @@ threadStatus (ThreadId t) = IO $ \s ->
      mk_stat 17 = ThreadDied
      mk_stat _  = ThreadBlocked BlockedOnOther
 
--- | returns the number of the capability on which the thread is currently
+-- | Returns the number of the capability on which the thread is currently
 -- running, and a boolean indicating whether the thread is locked to
 -- that capability or not.  A thread is locked to a capability if it
 -- was created with @forkOn@.
@@ -602,7 +595,7 @@ threadCapability (ThreadId t) = IO $ \s ->
    case threadStatus# t s of
      (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #)
 
--- | make a weak pointer to a 'ThreadId'.  It can be important to do
+-- | Make a weak pointer to a 'ThreadId'.  It can be important to do
 -- this if you want to hold a reference to a 'ThreadId' while still
 -- allowing the thread to receive the @BlockedIndefinitely@ family of
 -- exceptions (e.g. 'BlockedIndefinitelyOnMVar').  Holding a normal
@@ -714,32 +707,45 @@ instance MonadPlus STM
 unsafeIOToSTM :: IO a -> STM a
 unsafeIOToSTM (IO m) = STM m
 
--- |Perform a series of STM actions atomically.
+-- | Perform a series of STM actions atomically.
 --
--- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
--- Any attempt to do so will result in a runtime error.  (Reason: allowing
--- this would effectively allow a transaction inside a transaction, depending
--- on exactly when the thunk is evaluated.)
+-- Using 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'
+-- subverts some of guarantees that STM provides. It makes it possible to
+-- run a transaction inside of another transaction, depending on when the
+-- thunk is evaluated. If a nested transaction is attempted, an exception
+-- is thrown by the runtime. It is possible to safely use 'atomically' inside
+-- 'unsafePerformIO' or 'unsafeInterleaveIO', but the typechecker does not
+-- rule out programs that may attempt nested transactions, meaning that
+-- the programmer must take special care to prevent these.
 --
--- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
--- and which allows top-level TVars to be allocated.
+-- However, there are functions for creating transactional variables that
+-- can always be safely called in 'unsafePerformIO'. See: 'newTVarIO',
+-- 'Control.Concurrent.STM.TChan.newTChanIO',
+-- 'Control.Concurrent.STM.TChan.newBroadcastTChanIO',
+-- 'Control.Concurrent.STM.TQueue.newTQueueIO',
+-- 'Control.Concurrent.STM.TBQueue.newTBQueueIO', and
+-- 'Control.Concurrent.STM.TMVar.newTMVarIO'.
+--
+-- Using 'unsafePerformIO' inside of 'atomically' is also dangerous but for
+-- different reasons. See 'unsafeIOToSTM' for more on this.
 
 atomically :: STM a -> IO a
 atomically (STM m) = IO (\s -> (atomically# m) s )
 
--- |Retry execution of the current memory transaction because it has seen
--- values in TVars which mean that it should not continue (e.g. the TVars
+-- | Retry execution of the current memory transaction because it has seen
+-- values in 'TVar's which mean that it should not continue (e.g. the 'TVar's
 -- represent a shared buffer that is now empty).  The implementation may
--- block the thread until one of the TVars that it has read from has been
+-- block the thread until one of the 'TVar's that it has read from has been
 -- updated. (GHC only)
 retry :: STM a
 retry = STM $ \s# -> retry# s#
 
--- |Compose two alternative STM actions (GHC only).  If the first action
--- completes without retrying then it forms the result of the orElse.
--- Otherwise, if the first action retries, then the second action is
--- tried in its place.  If both actions retry then the orElse as a
--- whole retries.
+-- | Compose two alternative STM actions (GHC only).
+--
+-- If the first action completes without retrying then it forms the result of
+-- the 'orElse'. Otherwise, if the first action retries, then the second action
+-- is tried in its place. If both actions retry then the 'orElse' as a whole
+-- retries.
 orElse :: STM a -> STM a -> STM a
 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 
@@ -772,30 +778,6 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
                      Just e' -> unSTM (handler e')
                      Nothing -> raiseIO# e
 
--- | Low-level primitive on which always and alwaysSucceeds are built.
--- checkInv differs form these in that (i) the invariant is not
--- checked when checkInv is called, only at the end of this and
--- subsequent transcations, (ii) the invariant failure is indicated
--- by raising an exception.
-checkInv :: STM a -> STM ()
-checkInv (STM m) = STM (\s -> case (check# m) s of s' -> (# s', () #))
-
--- | alwaysSucceeds adds a new invariant that must be true when passed
--- to alwaysSucceeds, at the end of the current transaction, and at
--- the end of every subsequent transaction.  If it fails at any
--- of those points then the transaction violating it is aborted
--- and the exception raised by the invariant is propagated.
-alwaysSucceeds :: STM a -> STM ()
-alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
-                      checkInv i
-
--- | always is a variant of alwaysSucceeds in which the invariant is
--- expressed as an STM Bool action that must return True.  Returning
--- False or raising an exception are both treated as invariant failures.
-always :: STM Bool -> STM ()
-always i = alwaysSucceeds ( do v <- i
-                               if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) )
-
 -- |Shared memory locations that support atomic memory transactions.
 data TVar a = TVar (TVar# RealWorld a)
 
@@ -803,13 +785,13 @@ data TVar a = TVar (TVar# RealWorld a)
 instance Eq (TVar a) where
         (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#)
 
--- |Create a new TVar holding a value supplied
+-- | Create a new 'TVar' holding a value supplied
 newTVar :: a -> STM (TVar a)
 newTVar val = STM $ \s1# ->
     case newTVar# val s1# of
          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 
--- |@IO@ version of 'newTVar'.  This is useful for creating top-level
+-- | @IO@ version of 'newTVar'.  This is useful for creating top-level
 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
 -- possible.
@@ -818,7 +800,7 @@ newTVarIO val = IO $ \s1# ->
     case newTVar# val s1# of
          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 
--- |Return the current value stored in a TVar.
+-- | Return the current value stored in a 'TVar'.
 -- This is equivalent to
 --
 -- >  readTVarIO = atomically . readTVar
@@ -828,11 +810,11 @@ newTVarIO val = IO $ \s1# ->
 readTVarIO :: TVar a -> IO a
 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
 
--- |Return the current value stored in a TVar
+-- |Return the current value stored in a 'TVar'.
 readTVar :: TVar a -> STM a
 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
 
--- |Write the supplied value into a TVar
+-- |Write the supplied value into a 'TVar'.
 writeTVar :: TVar a -> a -> STM ()
 writeTVar (TVar tvar#) val = STM $ \s1# ->
     case writeTVar# tvar# val s1# of
@@ -842,6 +824,8 @@ writeTVar (TVar tvar#) val = STM $ \s1# ->
 -- MVar utilities
 -----------------------------------------------------------------------------
 
+-- | Provide an 'IO' action with the current value of an 'MVar'. The 'MVar'
+-- will be empty for the duration that the action is running.
 withMVar :: MVar a -> (a -> IO b) -> IO b
 withMVar m io =
   mask $ \restore -> do
@@ -851,6 +835,7 @@ withMVar m io =
     putMVar m a
     return b
 
+-- | Modify the value of an 'MVar'.
 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
 modifyMVar_ m io =
   mask $ \restore -> do
diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs
index 6b87b06fe7..ed5e0452a0 100644
--- a/libraries/base/GHC/Conc/Windows.hs
+++ b/libraries/base/GHC/Conc/Windows.hs
@@ -131,7 +131,7 @@ waitForDelayEvent :: Int -> IO ()
 waitForDelayEvent usecs = do
   m <- newEmptyMVar
   target <- calculateTarget usecs
-  atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
+  _ <- atomicModifyIORef'_ pendingDelays (\xs -> Delay target m : xs)
   prodServiceThread
   takeMVar m
 
@@ -140,7 +140,7 @@ waitForDelayEventSTM :: Int -> IO (TVar Bool)
 waitForDelayEventSTM usecs = do
    t <- atomically $ newTVar False
    target <- calculateTarget usecs
-   atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
+   _ <- atomicModifyIORef'_ pendingDelays (\xs -> DelaySTM target t : xs)
    prodServiceThread
    return t
 
@@ -219,10 +219,10 @@ foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
 
 prodServiceThread :: IO ()
 prodServiceThread = do
-  -- NB. use atomicModifyIORef here, otherwise there are race
+  -- NB. use atomicSwapIORef here, otherwise there are race
   -- conditions in which prodding is left at True but the server is
   -- blocked in select().
-  was_set <- atomicModifyIORef prodding $ \b -> (True,b)
+  was_set <- atomicSwapIORef prodding True
   when (not was_set) wakeupIOManager
 
 -- ----------------------------------------------------------------------------
@@ -239,7 +239,7 @@ service_loop :: HANDLE          -- read end of pipe
 
 service_loop wakeup old_delays = do
   -- pick up new delay requests
-  new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
+  new_delays <- atomicSwapIORef pendingDelays []
   let  delays = foldr insertDelay old_delays new_delays
 
   now <- getMonotonicUSec
@@ -262,8 +262,7 @@ service_loop wakeup old_delays = do
 
 service_cont :: HANDLE -> [DelayReq] -> IO ()
 service_cont wakeup delays = do
-  r <- atomicModifyIORef prodding (\_ -> (False,False))
-  r `seq` return () -- avoid space leak
+  _ <- atomicSwapIORef prodding False
   service_loop wakeup delays
 
 -- must agree with rts/win32/ThrIOManager.c
@@ -278,7 +277,12 @@ data ConsoleEvent
     -- these are sent to Services only.
  | Logoff
  | Shutdown
- deriving (Eq, Ord, Enum, Show, Read)
+ deriving ( Eq   -- ^ @since 4.3.0.0
+          , Ord  -- ^ @since 4.3.0.0
+          , Enum -- ^ @since 4.3.0.0
+          , Show -- ^ @since 4.3.0.0
+          , Read -- ^ @since 4.3.0.0
+          )
 
 start_console_handler :: Word32 -> IO ()
 start_console_handler r =