-- Written by Bertram Felgenhauer
--
-- https://gitlab.haskell.org/ghc/ghc/issues/11760#note_131217
--
-- Compile with -threaded -with-rtsopts=-N2

{-# LANGUAGE BangPatterns #-}
import Control.Concurrent
import Control.Monad
import Control.Monad.ST.Lazy
import Control.Exception
import Data.STRef
import Data.IORef
import Control.Concurrent.MVar
import Data.List (foldl')

-- evil ST action that tries to synchronize (by busy waiting on the
-- shared STRef) with a concurrent evaluation
evil :: ST s [Int]
evil = do
    r <- strictToLazyST $ newSTRef 0
    replicateM 100 $ do
        i <- strictToLazyST $ readSTRef r
        let !j = i + 1
        strictToLazyST $ writeSTRef r j
        let go 0 = return ()
            go n = do
                i' <- strictToLazyST $ readSTRef r
                when (j == i') $ go (n-1)
        go 100
        return j

main = do
    let res = runST evil
    s0 <- newIORef (map pred (0 : res))
    s1 <- newIORef (map pred (1 : res))
    m0 <- newMVar ()
    m1 <- newMVar ()
    forkIO $ do
        putMVar m0 ()
        readIORef s0 >>= evaluate . foldl' (+) 0
        putMVar m0 ()
    forkIO $ do
        putMVar m1 ()
        readIORef s1 >>= evaluate . foldl' (+) 0
        putMVar m1 ()
    threadDelay 10000
    replicateM 3 $ takeMVar m0 >> takeMVar m1
    v0 <- tail <$> readIORef s0
    v1 <- tail <$> readIORef s1
    print (v0 == v1)