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
  )

----------------------------------------------------------------
-- wire datatype

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 ()
    }

----------------------------------------------------------------
-- simulate

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
  )

-- evaluation order

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

----------------------------------------------------------------
-- helper functions

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

----------------------------------------------------------------
-- the end.