[GHC] #15349: fixST is a bit wrong

[GHC]

#15349: fixST is a bit wrong
-------------------------------------+-------------------------------------
        Reporter:  dfeuer            |                Owner:  dfeuer
            Type:  bug               |               Status:  merge
        Priority:  normal            |            Milestone:  8.6.1
       Component:  Core Libraries    |              Version:  8.5
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
 Type of failure:  Incorrect result  |  Unknown/Multiple
  at runtime                         |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):  Phab:D4948
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by dfeuer):

 I took a deep dive into lazy `ST` and came up with an absurdly inefficient
 "reference implementation" that I believe should be extremely correct. How
 inefficient? The monadic bind creates three `MVar`s and two green threads!
 I wonder if someone has a good idea about how to turn that into something
 both correct and efficient. The idea here is to turn each suspended
 computation into its very own green thread, and to use `MVar`s to
 communicate between them. One `MVar` requests a state token, while another
 is used to transfer one.

 {{{#!hs
 {-# language MagicHash, UnboxedTuples, GADTs, RankNTypes, BangPatterns #-}
 module Control.Monad.ST.Lazy.Imp where
 import qualified Control.Monad.ST as ST
 import qualified GHC.ST as ST

 import GHC.IO
 import GHC.Exts
 import Control.Concurrent.MVar
 import Control.Monad
 import Control.Applicative
 import Control.Concurrent

 infixl 1 :>>=

 data ST s a where
   Pure :: a -> ST s a
   StrictToLazyST :: ST.ST s a -> ST s a
   (:>>=) :: ST s a -> (a -> ST s b) -> ST s b
   FixST :: (a -> ST s a) -> ST s a

 strictToLazyST :: ST.ST s a -> ST s a
 strictToLazyST = StrictToLazyST

 instance Functor (ST s) where
   fmap = liftM
 instance Applicative (ST s) where
   pure = Pure
   (<*>) = ap
   liftA2 = liftM2
 instance Monad (ST s) where
   (>>=) = (:>>=)

 data State s = State (State# s)

 -- We don't care about thread IDs
 forkIO_ :: IO () -> IO ()
 forkIO_ m = void (forkIO m)

 run
      -- Request and receive a state token
   :: MVar () -> MVar (State RealWorld)
      -- Wait for a request and provide a state token
   -> MVar () -> MVar (State RealWorld)
   -> ST RealWorld a -> IO a

 run !s_in !m_in !s_out !m_out (Pure a) = do
   forkIO_ $ do
     readMVar s_out                  -- If we need the state,
     _ <- tryPutMVar s_in ()         -- request the state
     takeMVar m_in >>= putMVar m_out -- and transfer it
     pure ()
   pure a

 run s_in m_in _s_out m_out (StrictToLazyST (ST.ST m)) = do
   putMVar s_in () -- Request the state
   State s <- takeMVar m_in -- Get the state
   case m s of
     (# s', a #) -> do
       putMVar m_out (State s') -- Put the new state
       pure a

 -- This is the hard case. We have to 'run' @n@ if we need
 -- *either* its state token *or* its value.
 run s_in m_in s_out m_out (n :>>= f) = do
   sn_out <- newEmptyMVar
   n_out <- newEmptyMVar
   resv <- newEmptyMVar
   -- run_it gets filled if we need to run @n@, either for its
   -- value or for its state.
   run_it <- newEmptyMVar
   forkIO_ $ readMVar sn_out >> tryPutMVar run_it () >> return ()
   forkIO_ $ do
     readMVar run_it
     res <- run s_in m_in sn_out n_out n
     putMVar resv res
   run sn_out n_out s_out m_out
     (f $ unsafeDupablePerformIO $
            tryPutMVar run_it () >> readMVar resv)

 run s_in m_in s_out m_out (FixST f) = do
   resv <- newEmptyMVar
   res <- run s_in m_in s_out m_out (f $ unsafeDupablePerformIO $ readMVar
 resv)
   putMVar resv res
   pure res

 runST :: (forall s. ST s a) -> a
 runST st = runRW# $ \s ->
   let ss = State s
   in case unIO
     (do
        s_in <- newEmptyMVar
        m_in <- newMVar ss
        s_out <- newEmptyMVar
        m_out <- newEmptyMVar
        run s_in m_in s_out m_out st) s of
     (# _, a #) -> a
 }}}

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