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 inipv3
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
inlazy
, thusputMVar 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.