Haskell forkIO threads writing on top of each other with putStrLn - multithreading

Question

I was playing around with Haskell lightweight threads (forkIO) with the following code:
import Control.Concurrent
beginTest :: IO ()
beginTest = go
where
go = do
putStrLn "Very interesting string"
go
return ()
main = do
threadID1 <- forkIO $ beginTest
threadID2 <- forkIO $ beginTest
threadID3 <- forkIO $ beginTest
threadID4 <- forkIO $ beginTest
threadID5 <- forkIO $ beginTest
let tID1 = show threadID1
let tID2 = show threadID2
let tID3 = show threadID3
let tID4 = show threadID4
let tID5 = show threadID5
putStrLn "Main Thread"
putStrLn $ tID1 ++ ", " ++ tID2 ++ ", " ++ tID3 ++ ", " ++ tID4 ++ ", " ++ tID5
getLine
putStrLn "Done"
Now the expected output to this would be a whole bunch of these:
Very interesting string
Very interesting string
Very interesting string
Very interesting string
with one of these somewhere in there:
Main Thread
However, the output (or first several lines anyway) turned out to be this:
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very VVVViMeeeenarrrrtiyyyyen r iiiieTnnnnshtttttreeeeierrrrnaeeeegdssss
ttttsiiiitTnnnnrhggggir nessssgatttt
drrrrIiiiiVdnnnne ggggr5
y1 ,VVVVi eeeenTrrrrthyyyyer reiiiieannnnsdtttttIeeeeidrrrrn eeeeg5ssss 2tttts,iiiit nnnnrTggggih nrssssgetttt
arrrrdiiiiVInnnnedggggr
y5 3VVVVi,eeeen rrrrtTyyyyeh rriiiieennnnsatttttdeeeeiIrrrrndeeeeg ssss 5tttts4iiiit,nnnnr ggggiT nhssssgrtttt
errrraiiiiVdnnnneIggggrd
y 5VVVVi5eeeen
rrrrtyyyye riiiiennnnsttttteeeeirrrrneeeegssss ttttsiiiitnnnnrggggi nssssgtttt
rrrriiiiVnnnneggggr
y VVVVieeeenrrrrtyyyye riiiiennnnsttttteeeeirrrrneeeegssss ttttsiiiitnnnnrggggi nssssgtttt
rrrriiiiVnnnneggggr
Every few lines the text would shift, though it's pretty clear that the Very interesting strings ended up on top of each other, because somehow the threads using putStrLn at the same time ended up writing to stdout on top of each other. Why is this, and how (without resorting to message passing, timing, or some other overcomplicated and convoluted solution) can it be overcome?

Answer 1

Simply put, putStrLn is not an atomic operation. Every character may be interleaved with any other from a different thread.
(I am also not sure about whether in multi-byte encodings such as UTF8 it is guaranteed that a multi-byte character is atomically handled.)
If you want atomicity, you can use a shared mutex e.g.
do lock <- newMVar ()
let atomicPutStrLn str = takeMVar lock >> putStrLn str >> putMVar lock ()
forkIO $ forever (atomicPutStrLn "hello")
forkIO $ forever (atomicPutStrLn "world")
As suggested in the comments below, we can also simplify and make the above exception-safe as follows:
do lock <- newMVar ()
let atomicPutStrLn str = withMVar lock (\_ -> putStrLn str)
forkIO $ forever (atomicPutStrLn "hello")
forkIO $ forever (atomicPutStrLn "world")

Answer 2

A version using global lock.
import Control.Concurrent.MVar (newMVar, takeMVar, putMVar, MVar)
import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE lock #-}
lock :: MVar ()
lock = unsafePerformIO $ newMVar ()
printer :: String -> IO ()
printer x= do
() <- takeMVar lock
let atomicPutStrLn str = putStrLn str >> putMVar lock ()
atomicPutStrLn x