unsafeInterleaveIO duplicates computation when evaluated by multiple threads

When the following code is compiled with -O1 or -O2, the interleaved computation (putStrLn "eval") is performed 1000 times, rather than once:

import Control.Concurrent
import Control.Exception (evaluate)
import Control.Monad
import System.IO.Unsafe

main :: IO ()
main = do
    x <- unsafeInterleaveIO $ putStrLn "eval"
    replicateM_ 1000 $ forkIO $ evaluate x >> return ()
    threadDelay 1000000

Taking a look at the source to unsafeInterleaveIO:

{-# INLINE unsafeInterleaveIO #-}
unsafeInterleaveIO :: IO a -> IO a
unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)

-- We believe that INLINE on unsafeInterleaveIO is safe, because the
-- state from this IO thread is passed explicitly to the interleaved
-- IO, so it cannot be floated out and shared.

It seems the comment about INLINE is not true. If I define the following function:

interleave :: IO a -> IO a
interleave = unsafeInterleaveIO
{-# NOINLINE interleave #-}

and replace unsafeInterleaveIO with interleave, "eval" is printed only once. If I change NOINLINE to INLINE, or if I remove the pragma altogether, "eval" is printed 1000 times.

I believe unsafeInterleaveIO should guarantee that computations are not repeated. Otherwise, we end up with strangeness like this:

import Control.Applicative
import Control.Concurrent
import Control.Monad

main :: IO ()
main = do
    chan <- newChan :: IO (Chan Int)
    mapM_ (writeChan chan) [0..999]
    items <- take 10 <$> getChanContents chan
    replicateM_ 5 $ forkIO $ putStrLn $ "items = " ++ show items
    threadDelay 1000000

which prints:

items = [0,1,2,3,4,5,6,7,8,9]
items = [10,11,12,13,14,15,16,17,18,19]
items = [20,21,22,23,24,25,26,27,28,29]
items = [30,31,32,33,34,35,36,37,38,39]
items = [40,41,42,43,44,45,46,47,48,49]

For the time being, programs can work around this by using a NOINLINE wrapper:

getChanContents' :: Chan a -> IO [a]
getChanContents' = getChanContents
{-# NOINLINE getChanContents' #-}

I tested this on Linux 64-bit with GHC 7.2.2 and ghc-7.4.0.20120111, and on Windows 32-bit with GHC 7.0.3 and 7.2.2. All of these platforms and versions exhibit the same behavior. The bug goes away when the program is compiled with -O0, or when functions returning interleaved computations are marked NOINLINE (e.g. getChanContents').

Trac metadata

Trac field	Value
Version	7.2.2
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	libraries/base
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture