module Lava.SequentialConstructive
( simulateCon
)
where
import Lava.Ref
import Lava.Signal
import Lava.Netlist
import Lava.Sequent
import Lava.Generic
import Lava.Error
import Data.IORef
import System.IO.Unsafe
type Time
= IORef ()
data Timed a
= a `At` Time
| Uninitialized
data Wire
= Wire
{ components :: [Component]
, value :: Timed (S Symbol)
}
type Component
= Time -> IO ()
simulateCon :: (Generic a, Generic b) => (a -> b) -> [a] -> [b]
simulateCon circ inps = unsafePerformIO $
do micro <- newSet
macro <- newSet
time0 <- newIORef ()
let new =
do rwire <- newIORef (Wire{ components = [], value = Uninitialized })
return rwire
define rwire (DelayBool init next) =
do delay rwire init next
define rwire (DelayInt init next) =
do delay rwire init next
define rwire sym =
case arguments sym of
[] -> addSet macro constant
args -> sequence_ [ compWire rarg propagate | rarg <- args ]
where
propagate time =
do sym' <- mmap (`valueWire` time) sym
case evalLazy sym' of
Nothing -> return ()
Just v -> updateWire rwire time v
constant time =
do propagate time
addSet macro constant
delay rwire init next =
do compWire next nextState
compWire init initState
where
nextState time =
do mv <- valueWire next time
case mv of
Nothing -> return ()
Just v -> addSet macro (\t -> updateWire rwire t v)
initState time
| time == time0 = do mv <- valueWire init time
case mv of
Nothing -> return ()
Just v -> updateWire rwire time v
| otherwise = do return ()
compWire rwire comp =
do wire <- readIORef rwire
writeIORef rwire (wire{ components = comp : components wire })
valueWire rwire time =
do wire <- readIORef rwire
return $
case value wire of
v `At` time'
| time == time' -> Just v
_ -> Nothing
actualValueWire rwire time =
do mv <- valueWire rwire time
case mv of
Just v -> return v
Nothing -> wrong Lava.Error.UndefinedWire
updateWire rwire time v =
do wire <- readIORef rwire
mv <- valueWire rwire time
case mv of
Just v' | v =/= v' -> wrong Lava.Error.BadCombinationalLoop
| otherwise -> return ()
_ -> do writeIORef rwire (wire{ value = v `At` time })
sequence_ [ addSet micro comp | comp <- components wire ]
Bool b1 =/= Bool b2 = b1 /= b2
Int n1 =/= Int n2 = n1 /= n2
_ =/= _ = True
sr <- netlistIO new define (struct (circ (input inps)))
outs <- timedLazyLoop time0 $ \time ->
do emptySet macro ($ time)
while (emptySet micro ($ time))
s <- mmap (`actualValueWire` time) sr
return (construct (symbol `fmap` s))
let res = takes inps outs
return res
newSet :: IO (IORef [a])
newSet = newIORef []
addSet :: IORef [a] -> a -> IO ()
addSet rset x =
do xs <- readIORef rset
writeIORef rset (x:xs)
emptySet :: IORef [a] -> (a -> IO ()) -> IO Bool
emptySet rset action =
do xs <- readIORef rset
writeIORef rset []
case xs of
[] -> do return False
_ -> do sequence [ action x | x <- xs ]
return True
while :: Monad m => m Bool -> m ()
while m =
do b <- m
if b then while m
else return ()
timedLazyLoop :: Time -> (Time -> IO a) -> IO [a]
timedLazyLoop t m =
do a <- m t
t' <- newIORef ()
as <- unsafeInterleaveIO (timedLazyLoop t' m)
return (a:as)
input :: Generic a => [a] -> a
input xs = out
where
out = foldr delay out xs
takes :: [a] -> [b] -> [b]
takes [] _ = []
takes (_:xs) (y:ys) = y : takes xs ys