[GHC] #15136: High CPU when asynchronous exception and unblocking retry on TVar raced

[GHC]

#15136: High CPU when asynchronous exception and unblocking retry on TVar raced
-------------------------------------+-------------------------------------
           Reporter:  nshimaza       |             Owner:  (none)
               Type:  bug            |            Status:  new
           Priority:  highest        |         Milestone:  8.6.1
          Component:  Runtime        |           Version:  8.4.2
  System                             |
           Keywords:                 |  Operating System:  Unknown/Multiple
       Architecture:                 |   Type of failure:  Runtime crash
  Unknown/Multiple                   |
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 Detail:  https://github.com/nshimaza/race-tmvar-async-exception

 Runtime falls into high CPU under racing condition between async exception
 and unblocking retry on TVar.

 * Reproduces with +RTS -Nx where x > 1
 * Does NOT reproduce with +RTS -N1
 * Program stalls at `killThread`
 * High CPU based on given -Nx
     * CPU won't be 100% if you gave x smaller than available hardware
 threads of your platform.
 * Does NOT reproduce if TVar/retry is replaced by MVar
 * Reproduced with GHC 8.4.2 (macOS High Sierra (10.13.4))
 * Reproduced with GHC 8.4.2 (Docker for Mac Version 18.03.1-ce-mac65)
 * Reproduced with ghc-8.5.20180506 (Docker for Mac Version 18.03.1-ce-
 mac65)


 Minimal reproducing code here.  (You can find more verbose code on the
 above github repo.)
 {{{#!hs
 main :: IO ()
 main = do
     let volume = 1000
     forM_ [1..1000] $ \i -> do
         putStrFlush $ show i ++ " "

         -- Spawn massive number of threads.
         threads <- replicateM volume $ do
             trigger <- newTVarIO False
             tid <- forkIO $ void $ atomically $ do
                 t <- readTVar trigger
                 if t then pure t else retry
             pure (trigger, tid)

         -- Make sure all threads are spawned.
         threadDelay 30000

         -- Let threads start to exit normally.
         forkIO $ forM_ threads $ \(trigger, _) -> threadDelay 1 *>
 atomically (writeTVar trigger True)

         -- Concurrently kill threads in order to create race.
         -- TMVar operation and asynchronous exception can hit same thread
 simultaneously.
         -- Adjust threadDelay if you don't reproduce very well.
         threadDelay 1000
         forM_ threads $ \(_, tid) -> do
             putCharFlush 'A'
             killThread tid      -- When the issue reproduced, this
 killThread doesn't return.
             putCharFlush '\b'
 }}}

 This program intentionally creates race condition between asynchronous
 exception
 and unblocking operation of `retry` on TVar.  From one side, a `writeTVar
 trigger True` is attempted from external thread while target thread is
 blocking
 at `retry` on the same `TVar`.  On the other side, an asynchronous
 exception
 `ThreadKilled` is thrown by yet another external thread to the same target
 thread.

 In other word, it attempts to kill a thread about to unblock.

 I guess when the above two operation hit the same thread at the same time
 in
 parallel in SMP environment, GHC runtime falls into high CPU.

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/15136>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler