module Lava.Sequential
( simulateSeq
)
where
import Lava.Ref
import Lava.Signal
import Lava.Netlist
import Lava.Sequent
import Lava.Generic
import Lava.MyST
( ST
, STRef
, newSTRef
, readSTRef
, writeSTRef
, unsafeInterleaveST
, runST
)
type Var s
= (STRef s (S Symbol), STRef s (Wire s))
data Wire s
= Wire
{ Wire s -> [Var s]
dependencies :: [Var s]
, Wire s -> ST s ()
kick :: ST s ()
}
simulateSeq :: (Generic a, Generic b) => (a -> b) -> [a] -> [b]
simulateSeq :: (a -> b) -> [a] -> [b]
simulateSeq circ :: a -> b
circ [] = []
simulateSeq circ :: a -> b
circ inps :: [a]
inps = (forall s. ST s [b]) -> [b]
forall a. (forall s. ST s a) -> a
runST (
do STRef s [(STRef s (S Symbol), STRef s (Wire s))]
roots <- [(STRef s (S Symbol), STRef s (Wire s))]
-> ST s (STRef s [(STRef s (S Symbol), STRef s (Wire s))])
forall a s. a -> ST s (STRef s a)
newSTRef []
let root :: (STRef s (S Symbol), STRef s (Wire s)) -> ST s ()
root r :: (STRef s (S Symbol), STRef s (Wire s))
r =
do [(STRef s (S Symbol), STRef s (Wire s))]
rs <- STRef s [(STRef s (S Symbol), STRef s (Wire s))]
-> ST s [(STRef s (S Symbol), STRef s (Wire s))]
forall s a. STRef s a -> ST s a
readSTRef STRef s [(STRef s (S Symbol), STRef s (Wire s))]
roots
STRef s [(STRef s (S Symbol), STRef s (Wire s))]
-> [(STRef s (S Symbol), STRef s (Wire s))] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [(STRef s (S Symbol), STRef s (Wire s))]
roots ((STRef s (S Symbol), STRef s (Wire s))
r(STRef s (S Symbol), STRef s (Wire s))
-> [(STRef s (S Symbol), STRef s (Wire s))]
-> [(STRef s (S Symbol), STRef s (Wire s))]
forall a. a -> [a] -> [a]
:[(STRef s (S Symbol), STRef s (Wire s))]
rs)
new :: ST s (STRef s a, STRef s a)
new =
do STRef s a
rval <- a -> ST s (STRef s a)
forall a s. a -> ST s (STRef s a)
newSTRef ([Char] -> a
forall a. HasCallStack => [Char] -> a
error "val?")
STRef s a
rwir <- a -> ST s (STRef s a)
forall a s. a -> ST s (STRef s a)
newSTRef ([Char] -> a
forall a. HasCallStack => [Char] -> a
error "wire?")
(STRef s a, STRef s a) -> ST s (STRef s a, STRef s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (STRef s a
rval, STRef s a
rwir)
define :: (STRef s (S Symbol), STRef s (Wire s))
-> S (STRef s (S Symbol), STRef s (Wire s)) -> ST s ()
define r :: (STRef s (S Symbol), STRef s (Wire s))
r s :: S (STRef s (S Symbol), STRef s (Wire s))
s =
case S (STRef s (S Symbol), STRef s (Wire s))
s of
DelayBool s :: (STRef s (S Symbol), STRef s (Wire s))
s s' :: (STRef s (S Symbol), STRef s (Wire s))
s' -> (STRef s (S Symbol), STRef s (Wire s))
-> (STRef s (S Symbol), STRef s (Wire s)) -> ST s ()
delay (STRef s (S Symbol), STRef s (Wire s))
s (STRef s (S Symbol), STRef s (Wire s))
s'
DelayInt s :: (STRef s (S Symbol), STRef s (Wire s))
s s' :: (STRef s (S Symbol), STRef s (Wire s))
s' -> (STRef s (S Symbol), STRef s (Wire s))
-> (STRef s (S Symbol), STRef s (Wire s)) -> ST s ()
delay (STRef s (S Symbol), STRef s (Wire s))
s (STRef s (S Symbol), STRef s (Wire s))
s'
_ ->
do (STRef s (S Symbol), STRef s (Wire s))
-> [(STRef s (S Symbol), STRef s (Wire s))]
-> ST s (S Symbol)
-> ST s ()
forall s. Var s -> [Var s] -> ST s (S Symbol) -> ST s ()
relate (STRef s (S Symbol), STRef s (Wire s))
r (S (STRef s (S Symbol), STRef s (Wire s))
-> [(STRef s (S Symbol), STRef s (Wire s))]
forall a. S a -> [a]
arguments S (STRef s (S Symbol), STRef s (Wire s))
s) (ST s (S Symbol) -> ST s ()) -> ST s (S Symbol) -> ST s ()
forall a b. (a -> b) -> a -> b
$
S (S Symbol) -> S Symbol
forall a. S (S a) -> S a
eval (S (S Symbol) -> S Symbol)
-> ST s (S (S Symbol)) -> ST s (S Symbol)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((STRef s (S Symbol), STRef s (Wire s)) -> ST s (S Symbol))
-> S (STRef s (S Symbol), STRef s (Wire s)) -> ST s (S (S Symbol))
forall (m :: * -> *) (s :: * -> *) a b.
(Monad m, Sequent s) =>
(a -> m b) -> s a -> m (s b)
mmap (STRef s (S Symbol) -> ST s (S Symbol)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (S Symbol) -> ST s (S Symbol))
-> ((STRef s (S Symbol), STRef s (Wire s)) -> STRef s (S Symbol))
-> (STRef s (S Symbol), STRef s (Wire s))
-> ST s (S Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (STRef s (S Symbol), STRef s (Wire s)) -> STRef s (S Symbol)
forall a b. (a, b) -> a
fst) S (STRef s (S Symbol), STRef s (Wire s))
s
where
delay :: (STRef s (S Symbol), STRef s (Wire s))
-> (STRef s (S Symbol), STRef s (Wire s)) -> ST s ()
delay ri :: (STRef s (S Symbol), STRef s (Wire s))
ri@(rinit :: STRef s (S Symbol)
rinit,_) r1 :: (STRef s (S Symbol), STRef s (Wire s))
r1@(pre :: STRef s (S Symbol)
pre,_) =
do STRef s (Maybe (S Symbol))
state <- Maybe (S Symbol) -> ST s (STRef s (Maybe (S Symbol)))
forall a s. a -> ST s (STRef s a)
newSTRef Maybe (S Symbol)
forall a. Maybe a
Nothing
(STRef s (S Symbol), STRef s (Wire s))
r2 <- ST s (STRef s (S Symbol), STRef s (Wire s))
forall s a a. ST s (STRef s a, STRef s a)
new
(STRef s (S Symbol), STRef s (Wire s)) -> ST s ()
root (STRef s (S Symbol), STRef s (Wire s))
r2
(STRef s (S Symbol), STRef s (Wire s))
-> [(STRef s (S Symbol), STRef s (Wire s))]
-> ST s (S Symbol)
-> ST s ()
forall s. Var s -> [Var s] -> ST s (S Symbol) -> ST s ()
relate (STRef s (S Symbol), STRef s (Wire s))
r [(STRef s (S Symbol), STRef s (Wire s))
ri] (ST s (S Symbol) -> ST s ()) -> ST s (S Symbol) -> ST s ()
forall a b. (a -> b) -> a -> b
$
do Maybe (S Symbol)
ms <- STRef s (Maybe (S Symbol)) -> ST s (Maybe (S Symbol))
forall s a. STRef s a -> ST s a
readSTRef STRef s (Maybe (S Symbol))
state
case Maybe (S Symbol)
ms of
Just s :: S Symbol
s -> S Symbol -> ST s (S Symbol)
forall (m :: * -> *) a. Monad m => a -> m a
return S Symbol
s
Nothing ->
do S Symbol
s <- STRef s (S Symbol) -> ST s (S Symbol)
forall s a. STRef s a -> ST s a
readSTRef STRef s (S Symbol)
rinit
STRef s (Maybe (S Symbol)) -> Maybe (S Symbol) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Maybe (S Symbol))
state (S Symbol -> Maybe (S Symbol)
forall a. a -> Maybe a
Just S Symbol
s)
S Symbol -> ST s (S Symbol)
forall (m :: * -> *) a. Monad m => a -> m a
return S Symbol
s
(STRef s (S Symbol), STRef s (Wire s))
-> [(STRef s (S Symbol), STRef s (Wire s))]
-> ST s (S Symbol)
-> ST s ()
forall s. Var s -> [Var s] -> ST s (S Symbol) -> ST s ()
relate (STRef s (S Symbol), STRef s (Wire s))
r2 [(STRef s (S Symbol), STRef s (Wire s))
r,(STRef s (S Symbol), STRef s (Wire s))
r1] (ST s (S Symbol) -> ST s ()) -> ST s (S Symbol) -> ST s ()
forall a b. (a -> b) -> a -> b
$
do S Symbol
s <- STRef s (S Symbol) -> ST s (S Symbol)
forall s a. STRef s a -> ST s a
readSTRef STRef s (S Symbol)
pre
STRef s (Maybe (S Symbol)) -> Maybe (S Symbol) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Maybe (S Symbol))
state (S Symbol -> Maybe (S Symbol)
forall a. a -> Maybe a
Just S Symbol
s)
S Symbol -> ST s (S Symbol)
forall (m :: * -> *) a. Monad m => a -> m a
return S Symbol
s
Struct (STRef s (S Symbol), STRef s (Wire s))
sr <- ST s (STRef s (S Symbol), STRef s (Wire s))
-> ((STRef s (S Symbol), STRef s (Wire s))
-> S (STRef s (S Symbol), STRef s (Wire s)) -> ST s ())
-> Struct Symbol
-> ST s (Struct (STRef s (S Symbol), STRef s (Wire s)))
forall (f :: * -> *) s v.
Sequent f =>
ST s v -> (v -> S v -> ST s ()) -> f Symbol -> ST s (f v)
netlistST ST s (STRef s (S Symbol), STRef s (Wire s))
forall s a a. ST s (STRef s a, STRef s a)
new (STRef s (S Symbol), STRef s (Wire s))
-> S (STRef s (S Symbol), STRef s (Wire s)) -> ST s ()
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)))
[(STRef s (S Symbol), STRef s (Wire s))]
rs <- STRef s [(STRef s (S Symbol), STRef s (Wire s))]
-> ST s [(STRef s (S Symbol), STRef s (Wire s))]
forall s a. STRef s a -> ST s a
readSTRef STRef s [(STRef s (S Symbol), STRef s (Wire s))]
roots
ST s ()
step <- [(STRef s (S Symbol), STRef s (Wire s))] -> ST s (ST s ())
forall s. [Var s] -> ST s (ST s ())
drive (Struct (STRef s (S Symbol), STRef s (Wire s))
-> [(STRef s (S Symbol), STRef s (Wire s))]
forall a. Struct a -> [a]
flatten Struct (STRef s (S Symbol), STRef s (Wire s))
sr [(STRef s (S Symbol), STRef s (Wire s))]
-> [(STRef s (S Symbol), STRef s (Wire s))]
-> [(STRef s (S Symbol), STRef s (Wire s))]
forall a. [a] -> [a] -> [a]
++ [(STRef s (S Symbol), STRef s (Wire s))]
rs)
[b]
outs <- ST s b -> ST s [b]
forall s a. ST s a -> ST s [a]
lazyloop (ST s b -> ST s [b]) -> ST s b -> ST s [b]
forall a b. (a -> b) -> a -> b
$
do ST s ()
step
Struct Symbol
s <- ((STRef s (S Symbol), STRef s (Wire s)) -> ST s Symbol)
-> Struct (STRef s (S Symbol), STRef s (Wire s))
-> ST s (Struct Symbol)
forall (m :: * -> *) (s :: * -> *) a b.
(Monad m, Sequent s) =>
(a -> m b) -> s a -> m (s b)
mmap ((S Symbol -> Symbol) -> ST s (S Symbol) -> ST s Symbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap S Symbol -> Symbol
symbol (ST s (S Symbol) -> ST s Symbol)
-> ((STRef s (S Symbol), STRef s (Wire s)) -> ST s (S Symbol))
-> (STRef s (S Symbol), STRef s (Wire s))
-> ST s Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STRef s (S Symbol) -> ST s (S Symbol)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (S Symbol) -> ST s (S Symbol))
-> ((STRef s (S Symbol), STRef s (Wire s)) -> STRef s (S Symbol))
-> (STRef s (S Symbol), STRef s (Wire s))
-> ST s (S Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (STRef s (S Symbol), STRef s (Wire s)) -> STRef s (S Symbol)
forall a b. (a, b) -> a
fst) Struct (STRef s (S Symbol), STRef s (Wire s))
sr
b -> ST s b
forall (m :: * -> *) a. Monad m => a -> m a
return (Struct Symbol -> b
forall a. Generic a => Struct Symbol -> a
construct Struct Symbol
s)
let res :: [b]
res = [a] -> [b] -> [b]
forall a b. [a] -> [b] -> [b]
takes [a]
inps [b]
outs
[b] -> ST s [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b]
res
)
relate :: Var s -> [Var s] -> ST s (S Symbol) -> ST s ()
relate :: Var s -> [Var s] -> ST s (S Symbol) -> ST s ()
relate (rval :: STRef s (S Symbol)
rval, rwir :: STRef s (Wire s)
rwir) rs :: [Var s]
rs f :: ST s (S Symbol)
f =
do STRef s (Wire s) -> Wire s -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Wire s)
rwir (Wire s -> ST s ()) -> Wire s -> ST s ()
forall a b. (a -> b) -> a -> b
$
Wire :: forall s. [Var s] -> ST s () -> Wire s
Wire{ dependencies :: [Var s]
dependencies = [Var s]
rs
, kick :: ST s ()
kick = do S Symbol
b <- ST s (S Symbol)
f
STRef s (S Symbol) -> S Symbol -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (S Symbol)
rval S Symbol
b
}
drive :: [Var s] -> ST s (ST s ())
drive :: [Var s] -> ST s (ST s ())
drive [] =
do ST s () -> ST s (ST s ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
drive ((rval :: STRef s (S Symbol)
rval,rwir :: STRef s (Wire s)
rwir):rs :: [Var s]
rs) =
do Wire s
wire <- STRef s (Wire s) -> ST s (Wire s)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Wire s)
rwir
STRef s (Wire s) -> Wire s -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Wire s)
rwir ([Char] -> Wire s
forall a. HasCallStack => [Char] -> a
error "detected combinational loop")
ST s ()
driv1 <- [Var s] -> ST s (ST s ())
forall s. [Var s] -> ST s (ST s ())
drive (Wire s -> [Var s]
forall s. Wire s -> [Var s]
dependencies Wire s
wire)
STRef s (Wire s) -> Wire s -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Wire s)
rwir (Wire s -> ST s ()) -> Wire s -> ST s ()
forall a b. (a -> b) -> a -> b
$
Wire :: forall s. [Var s] -> ST s () -> Wire s
Wire { dependencies :: [Var s]
dependencies = [], kick :: ST s ()
kick = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
ST s ()
driv2 <- [Var s] -> ST s (ST s ())
forall s. [Var s] -> ST s (ST s ())
drive [Var s]
rs
ST s () -> ST s (ST s ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ST s () -> ST s (ST s ())) -> ST s () -> ST s (ST s ())
forall a b. (a -> b) -> a -> b
$
do ST s ()
driv1
Wire s -> ST s ()
forall s. Wire s -> ST s ()
kick Wire s
wire
ST s ()
driv2
lazyloop :: ST s a -> ST s [a]
lazyloop :: ST s a -> ST s [a]
lazyloop m :: ST s a
m =
do a
a <- ST s a
m
[a]
as <- ST s [a] -> ST s [a]
forall s a. ST s a -> ST s a
unsafeInterleaveST (ST s a -> ST s [a]
forall s a. ST s a -> ST s [a]
lazyloop ST s a
m)
[a] -> ST s [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