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

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

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

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

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

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

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

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