fixIO can choke, and report a loop where there is none

This program was written by Matthew Craven:

import System.IO( fixIO )
import GHC.Exts (noinline)

main :: IO ()
main = do
  r <- fixIO $ \p -> let
    {-# NOINLINE q #-}
    q = noinline id p
    in pure (True : q)
  print $! case r of { _:v:_ -> v ; _ -> False }

For any law-abiding MonadFix instance, such a call to mfix should be semantically equivalent to pure (repeat True). (Specifically, this follows from the 'Purity' law.) So the print should work fine. But actually we get (with -O)

run-it: cyclic evaluation in fixIO

Diagnosis

What is going on? Here is the code after optimisation:

Main.main1
  = \ (s_aRX :: GHC.Prim.State# GHC.Prim.RealWorld) ->
      case GHC.Prim.newMVar#
             @GHC.Types.Lifted @GHC.Prim.RealWorld @[Bool] s_aRX
      of
      { (# ipv_aUk, ipv1_aUl #) ->
      case GHC.IO.Unsafe.unsafeDupableInterleaveIO1
             @[Bool]
             ((\ (eta_aSp [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
                 GHC.Prim.catch# @GHC.Types.LiftedRep @GHC.Types.Lifted  @[Bool]
                   @GHC.Exception.Type.SomeException
                   (\ (eta1_aUj [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
                      GHC.Prim.readMVar#
                        @GHC.Types.Lifted @GHC.Prim.RealWorld @[Bool] ipv1_aUl eta1_aUj)
                   (System.IO.fixIO2 @[Bool])
                   eta_aSp)
              `cast` (Sym (GHC.Types.N:IO[0] <[Bool]>_R)
                      :: (GHC.Prim.State# GHC.Prim.RealWorld
                          -> (# GHC.Prim.State# GHC.Prim.RealWorld, [Bool] #))
                         ~R# IO [Bool]))
             ipv_aUk
      of
      { (# ipv2_aUp, ipv3_aUq #) ->
      let {
        q_s1HX [InlPrag=NOINLINE, Dmd=SL] :: [Bool]
        q_s1HX = noinline @(forall a. a -> a) id @[Bool] ipv3_aUq } in
      case GHC.Prim.putMVar# @GHC.Types.Lifted @GHC.Prim.RealWorld @[Bool]
             ipv1_aUl
             (GHC.Types.: @Bool GHC.Types.True q_s1HX)
             ipv2_aUp
      of s2#_aUw
      { __DEFAULT ->
      case q_s1HX of {
        [] ->
          GHC.IO.Handle.Text.hPutStr2
            GHC.IO.Handle.FD.stdout
            GHC.Show.$fShowBool5
            GHC.Types.True
            s2#_aUw;
        : v_aJ6 ds2_dRE ->
          case v_aJ6 of vx_aV1 { __DEFAULT ->
          GHC.IO.Handle.Text.hPutStr2
            GHC.IO.Handle.FD.stdout
            (case vx_aV1 of {
               False -> GHC.Show.$fShowBool5;
               True -> GHC.Show.$fShowBool4
             })
            GHC.Types.True
            s2#_aUw
          } } } } }

• The MVar stuff is to "tie the knot" in fixIO.
• The putMVar# fills in the MVar
• The unsafeDupableInterleaveIO1 call returns a thunk in ipv3 which reads the MVar when forced.

Now, alas the strictness analyser works out that q i used strictly in the continuation, so the binding for q is done with a case not a let (look at CorePrep output). So we force ipv3 too early, before the putMVar# has run.

Cure

The code for fixIO is this:

fixIO :: (a -> IO a) -> IO a
fixIO k = do
    m <- newEmptyMVar
    ans <- unsafeDupableInterleaveIO
             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
                                    throwIO FixIOException)
    result <- k ans
    putMVar m result
    return result

Why all this MVar stuff? See Note [fixST] in base:Control.Monad.ST.Imp. (And this comment.)

Looking at this code it's clear that we must do the putMVar before evaluating result. But if we inline fixIO, the consumer will consume the return result, and the consumer may well be strict in result. Something like

   do { result <- fixIO m
      ; f result }   -- where f is strict

Two simple solutions

• Do not inline fixIO.
• Wrap the result of fixIO in lazy, thus

     putMVar m restult
     return (lazy result)

I am not sure which is best. But the lazy solution is the one adopted by Note [unsafePerformIO and strictness] in GHC.IO.Unsafe, for a very very similar problem.