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