STM contention in the RTS

[shirouto]

Description

On running the current STM atomic transactions the thread seems to hang indefinitely.

Expected Behavior

The code should run successfully.

Actual Behavior

The program never ends.

Possible Fix

At first sight, it seems to be related to this ghc rts issue, but looking at rts/src/main/java/eta/runtime/stm/TransactionRecord.java's checkReadOnly it appears the patch from ghc 7.7 was already applied.

Steps to Reproduce

import GHC.Conc.Sync
import Control.Monad
import System.Environment

test n = do
  dog <- newTVarIO False
  cat <- newTVarIO False
  let unset = do
        d <- readTVar dog
        c <- readTVar cat
        if (d || c) then retry else return ()
      setDog = unset >> writeTVar dog True
      setCat = unset >> writeTVar cat True
      reset = do
        d <- readTVar dog
        c <- readTVar cat
        guard (d || c)
        writeTVar dog False
        writeTVar cat False

  replicateM_ n (do
    forkIO (atomically setDog)
    forkIO (atomically setCat)
    atomically reset
    atomically reset)

main = do
  test 50000

And a relevant stack:

"Thread-0" #9 prio=5 os_prio=0 tid=0x00007fe870455000 nid=0x294b runnable [0x00007fe8549ea000]
   java.lang.Thread.State: RUNNABLE
        at eta.runtime.stm.TVar.currentValue(TVar.java:30)
        at eta.runtime.stm.TVar.lock(TVar.java:69)
        at eta.runtime.stm.TransactionRecord.getInvariantsToCheck(TransactionRecord.java:144)
        at eta.runtime.stm.STM.atomically(STM.java:73)
        at main.Main$sat$4.applyV(T7815.hs)
        at eta.runtime.exception.Exception.catch_(Exception.java:133)
        at main.Main$lvl1.applyV(T7815.hs)
        at eta.runtime.stg.Closures$EvalLazyIO.enter(Closures.java:125)
        at eta.runtime.stg.Capability.schedule(Capability.java:260)
        at eta.runtime.concurrent.WorkerThread.run(WorkerThread.java:16)

Context

I ran into this while trying to put together some tests to exercise the eta rts with respect to #847.

Your Environment

eta on master HEAD