unsafePerformIO duped on multithread if within the same IO thunk

Unlike unsafeDupablePerformIO, an unsafePerformIO block is not supposed to be executed more than once when two threads race to evaluate it, and yet the following program detects that the counter is sometimes incremented twice:

{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -O0 -threaded -rtsopts -with-rtsopts=-N #-}
module Main where
import Control.Concurrent
import System.IO.Unsafe

runThreads :: IO () -> IO () -> IO ()
runThreads body1 body2 = do
  var1 <- newEmptyMVar
  var2 <- newEmptyMVar
  _ <- forkIO $ do { !_ <- body1; putMVar var1 () }
  _ <- forkIO $ do { !_ <- body2; putMVar var2 () }
  takeMVar var1
  takeMVar var2

main :: IO ()
main = do
  counter <- newMVar (0 :: Int)
  let sharedThunk = unsafePerformIO
                  $ modifyMVar_ counter (return . (+1))
  let sharedIO = return sharedThunk
  _ <- runThreads sharedIO sharedIO
  n <- takeMVar counter
  if n == 1 then main else print n

Note that optimizations are turned off, so this isn't due to inlining. In fact, if I inline sharedIO and write

  _ <- runThreads (return sharedThunk) (return sharedThunk)

instead, the problem disappears. So it seems that in order to reproduce the problem, two threads must race to evaluate an IO thunk containing an unsafePerformIO block; a race to evaluate the unsafePerformIO block is not sufficient.

Trac metadata

Trac field	Value
Version	8.0.2-rc2
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture