TL;DR: I have a haskell project where everything is in a single thread, without any concurrency, but crashes like this:
program1: thread blocked indefinitely in an MVar operation
Longer description:
I am trying to locate the bug when working on https://github.com/carldong/timeless-tutorials/blob/master/src/Tutorial1.hs, which depends on another library, timeless. You would notice that all concurrency code are commented out, and doing a grep on the timeless repo will show that no concurrency code is involved. Then I am totally confused about this crash, and I don't know how to get more detailed information, like stack trace. I tried running with some RTS parameters:
$ stack exec -- Tutorial1 +RTS -p -M4m -xc
*** Exception (reporting due to +RTS -xc): (THUNK_STATIC), stack trace:
FRP.Timeless.Internal.Signal.loop.\,
called from FRP.Timeless.Internal.Signal.loop,
called from FRP.Timeless.state,
called from FRP.Timeless.Internal.Signal.first.\,
called from FRP.Timeless.Internal.Signal.first,
called from FRP.Timeless.Internal.Signal...\,
called from FRP.Timeless.Internal.Signal..,
called from Tutorial1.test0,
called from FRP.Timeless.Internal.Signal.stepSignal.step,
called from FRP.Timeless.Internal.Signal.stepSignal,
called from FRP.Timeless.Run.runBox,
called from Tutorial1.main
*** Exception (reporting due to +RTS -xc): (THUNK_STATIC), stack trace:
FRP.Timeless.Internal.Signal.loop.\,
called from FRP.Timeless.Internal.Signal.loop,
called from FRP.Timeless.state,
called from FRP.Timeless.Internal.Signal.first.\,
called from FRP.Timeless.Internal.Signal.first,
called from FRP.Timeless.Internal.Signal...\,
called from FRP.Timeless.Internal.Signal..,
called from Tutorial1.test0,
called from FRP.Timeless.Internal.Signal.stepSignal.step,
called from FRP.Timeless.Internal.Signal.stepSignal,
called from FRP.Timeless.Run.runBox,
called from Tutorial1.main
Tutorial1: thread blocked indefinitely in an MVar operation
And I cannot find what THUNK_STATIC is, because nothing on Google says about it. From recursive update a "Behaviour" in Sodium yields 'thread blocked ...' I might guess that the bug might have some relationship with the magical ArrowLoop which originally comes from Netwire, but I can't really make sense out of it.
I stripped down the entire Timeless and my test case into the smallest sample, which is self-contained and contains the bug. I cannot strip down the Signals any more because these are originally forked from Netwire, and I don't fully understand how ArrowLoop stuff really work under the hood.
Update I made the example even smaller. I also confirmed that this bug is present without the -threaded flag
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GADTs #-}
import Prelude hiding ((.),id)
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Fix
-- import Data.Monoid
import Control.Category
import Data.Maybe
---------
-- Stripped down Timeless here
---------
data Signal a b where
SGen ::
(Maybe a -> IO (Maybe b, Signal a b)) -> Signal a b
instance Category Signal where
id = SGen (\ma -> return (ma, id))
s2 . s1 = SGen $ \mx0 -> do
(mx1, s1') <- stepSignal s1 mx0
(mx2, s2') <- stepSignal s2 mx1
mx2 `seq` return (mx2, s2'. s1')
instance Arrow Signal where
arr f = SGen $ \ma -> case ma of
Just a -> return (Just (f a), arr f)
Nothing -> return (Nothing, arr f)
first s' =
SGen $ \mxy' ->
fmap (\(mx, s) -> lstrict (liftA2 (,) mx (fmap snd mxy'), first s))
(stepSignal s' (fmap fst mxy'))
instance ArrowLoop Signal where
loop s =
SGen $ \mx ->
fmap (fmap fst ***! loop) .
mfix $ \ ~(mx',_) ->
let d | Just (_,d) <- mx' = d
| otherwise = error "Feedback broken by inhibition"
in stepSignal s (fmap (,d) mx)
-- | Steps a signal in certain time step
stepSignal ::
Signal a b
-- ^ Signal to be stepped
-> Maybe a
-- ^ Input
-- | Stateful output
-> IO (Maybe b, Signal a b)
stepSignal s Nothing = return (Nothing, s)
stepSignal s (Just x) = x `seq` step s (Just x)
where
step (SGen f) = f
-- | Left-strict version of '&&&' for functions.
(&&&!) :: (a -> b) -> (a -> c) -> (a -> (b, c))
(&&&!) f g x' =
let (x, y) = (f x', g x')
in x `seq` (x, y)
-- | Left-strict version of '***' for functions.
(***!) :: (a -> c) -> (b -> d) -> ((a, b) -> (c, d))
(***!) f g (x', y') =
let (x, y) = (f x', g y')
in x `seq` (x, y)
-- | Left strict tuple
lstrict :: (a,b) -> (a,b)
lstrict (x,y) = x `seq` (x,y)
-- | Make a pure stateful signal from given transition function
mkPure :: (a -> (Maybe b, Signal a b)) -> Signal a b
mkPure f =
SGen $ \mx ->
case mx of
Just x -> return . lstrict $ f x
-- | Make a pure stateful signal from given signal function
mkSF :: (a -> (b, Signal a b)) -> Signal a b
mkSF f = mkPure (lstrict . first Just . f)
-- | Make a pure stateless signal from given signal function
mkSF_ :: (a -> b) -> Signal a b
mkSF_ = arr
delay :: a -> Signal a a
delay x' = mkSF $ \x -> (x', delay x)
-- | Make a stateful wire from chained state transition
-- function. Notice that the output will always be the new value
mkSW_ :: b -> (b -> a -> b) -> Signal a b
mkSW_ b0 f = mkSF $ g b0
where
g b0 x = let b1 = f b0 x in
lstrict (b1, mkSW_ b1 f)
-- | This command drives a black box of signal network. The driver
-- knows nothing about the internals of the network, only stops when
-- the network is inhibited.
runBox :: Signal () () -> IO ()
runBox n = do
(mq, n') <- stepSignal n (Just ())
case mq of
Just _ -> n' `seq` runBox n'
Nothing -> return ()
-- | Holds a discrete value to be continuous. An initial value must be given
hold :: a -> Signal (Maybe a) a
hold a0 = mkSW_ a0 fromMaybe
-- | Takes a snapshot of b when an event a comes. Meanwhile, transform the
-- 'Stream' with the 'Cell' value
snapshot :: ((a,b) -> c) -> Signal (Maybe a, b) (Maybe c)
snapshot f = mkSF_ $ \(ma, b) ->
case ma of
Just a -> Just $ f (a,b)
Nothing -> Nothing
state :: s -> ((a, s) -> s) -> Signal (Maybe a) s
state s0 update = loop $ proc (ma, s) -> do
sDelay <- delay s0 -< s
s' <- hold s0 <<< snapshot update -< (ma, sDelay)
returnA -< (s', s')
------
-- Stripped down Timeless ends
------
-- | Problematic Arrow
test0 = proc () -> do
s <- state 0 (\(_, coin) -> coin + 1) -< Nothing
returnA -< ()
main :: IO ()
main = runBox test0
