[Haskell-cafe] stack overflow when using ST monad

[Gregory Wright]

Hi,

I have a program, abstracted from a larger application that I am
writing for a customer, that persistently overflows its stack.  The
program is a simulation of the communication protocol of a
sensor tag.  The code is below.

The program mimics a hardware state machine.  In the example
below, the internal state is just a counter and a another register
that holds what is called the tag's "state": Syncing, Listening or
Sleeping.  The simulation just advances the tags internal
state until the counter reaches zero.  (In the real application, there
are external inputs that can change the state, but that's not needed
to see the problem.)

The simulation crashes, running out of stack space after only about
400000 cycles on my machine  (OS X 10.4.7 ppc).  Both hugs and
ghci show it:

hugs -98 Test2.hs

Hugs mode: Restart with command line option +98 for Haskell 98 mode

Type :? for help
Main> main

ERROR - Garbage collection fails to reclaim sufficient space
Main>

and ghci:

Prelude> :load "/Users/gwright/src/haskell/simulator/test2.hs"
Compiling Main             ( /Users/gwright/src/haskell/simulator/ 
test2.hs, interpreted )
Ok, modules loaded: Main.
*Main> main
FrozenTag {ft_tagID = 1, ft_state = *** Exception: stack overflow
*Main>


Searches through old mailing lists warn me that it can be hard to tell
if evaluation is truly tail recursive, and I saw a discussion of this  
in the
context of "monadic loops", but I never saw a solution.  Perhaps
in my sleep deprived condition I am missing the obvious, but any
help would be appreciated.

Best,
Greg



--
-- Test the state transformer calculation.
--
-- 21 August 2006
--


module Main where


import Control.Monad.ST
import Control.Monad.Writer
import Data.STRef
import Maybe


data TagState = Syncing | Listening | Sleeping
                 deriving (Eq, Show)


-- A structure with internal state:
--
data Tag s = Tag {
         tagID :: Int,
         state :: STRef s TagState,
         count :: STRef s Integer
}


data FrozenTag = FrozenTag {
         ft_tagID :: Int,
         ft_state :: TagState,
         ft_count :: Integer
} deriving Show



-- Repeat a computation until it returns Nothing:
--
until_ :: Monad m => m (Maybe a) -> m ()
until_ action = do
         result <- action
         if isNothing result
            then return ()
            else until_ action


-- Here is a toy stateful computation:
--
runTag :: ST s (FrozenTag)
runTag = do
         tag <- initialize
         until_ (step tag)
         freezeTag tag


initialize :: ST s (Tag s)
initialize = do
         init_count <- newSTRef 1000000
         init_state <- newSTRef Syncing

         return (Tag { tagID = 1,
                       state = init_state,
                       count = init_count })


step :: Tag s -> ST s (Maybe Integer)
step t = do
         c <- readSTRef (count t)
         s <- readSTRef (state t)
         writeSTRef (count t) (c - 1)
         writeSTRef (state t) (nextState s)
         if (c <= 0) then return Nothing else return (Just c)


nextState :: TagState -> TagState
nextState s = case s of
         Syncing   -> Listening
         Listening -> Sleeping
         Sleeping  -> Syncing


freezeTag :: Tag s -> ST s (FrozenTag)
freezeTag t = do
         frozen_count <- readSTRef (count t)
         frozen_state <- readSTRef (state t)

         return (FrozenTag { ft_tagID = tagID t,
                             ft_count = frozen_count,
                             ft_state = frozen_state })


main :: IO ()
main = do
         putStrLn (show (runST runTag))