[GHC] #13052: unsafePerformIO duped on multithread if within the same IO thunk

[GHC]

#13052: unsafePerformIO duped on multithread if within the same IO thunk
-------------------------------------+-------------------------------------
           Reporter:  gelisam        |             Owner:
               Type:  bug            |            Status:  new
           Priority:  normal         |         Milestone:
          Component:  Compiler       |           Version:  8.0.2-rc2
           Keywords:                 |  Operating System:  MacOS X
       Architecture:  x86_64         |   Type of failure:  Incorrect result
  (amd64)                            |  at runtime
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 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:

 {{{#!hs
 {-# 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

 {{{#!hs
   _ <- 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.

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