module ForSyDe.Backend.Simulate (simulate) where
import ForSyDe.OSharing
import ForSyDe.Netlist
import ForSyDe.Netlist.Traverse
import ForSyDe.System.SysDef
import ForSyDe.System.SysFun(SysFunToSimFun(..))
import ForSyDe.ForSyDeErr
import ForSyDe.Process.ProcVal
import Control.Monad (liftM, mapM_, zipWithM_)
import Data.Maybe (fromJust)
import Control.Monad.ST
import Data.STRef
import qualified Data.Traversable as DT
import Data.List (lookup, transpose)
import Data.Dynamic
simulate :: SysFunToSimFun sysFun simFun => SysDef sysFun -> simFun
simulate sysDef = fromDynSimFun (simulateDyn (unSysDef sysDef)) []
type Var s
= (STRef s Dynamic, STRef s (Wire s))
data Wire s
= Wire
{ dependencies :: [Var s]
, kick :: ST s ()
}
simulateDyn :: PrimSysDef -> [[Dynamic]] -> [[Dynamic]]
simulateDyn pSysDef inps | any null inps = replicate outN []
where outN = (length . oIface . readURef . unPrimSysDef) pSysDef
simulateDyn pSysDef inps = runST (
do let sysDefVal = (readURef . unPrimSysDef) pSysDef
sysDefInIface = iIface sysDefVal
roots <- newSTRef []
inpPairs <- zipWithM (\(id,_) inputL ->
do {ref <- newSTRef inputL; return (id,ref)})
sysDefInIface inps
let
root r =
do rs <- readSTRef roots
writeSTRef roots (r:rs)
empty = do rval <- newSTRef (error "val?")
rwir <- newSTRef (error "wire?")
return (rval, rwir)
new node =
do mapM (\tag -> do {e <- empty; return (tag, e)}) (outTags node)
newInstance varPairs node =
let funName = "ForSyDe.Backend.Simulate.simulateDyn"
in case node of
InPort id ->
case lookup id varPairs of
Nothing -> intError funName (Other "inconsistency")
Just var -> return [(InPortOut, var)]
_ -> new node
define nodeVarPairs childVars =
case (nodeVarPairs,childVars) of
([(InPortOut, var)], InPort name) -> do
let inputRef = fromJust $ lookup name inpPairs
relate var [] $
do (curr:rest) <- readSTRef inputRef
writeSTRef inputRef rest
return curr
_ -> defineShared nodeVarPairs childVars
defineInstance nodeVarPairs childVars =
case (nodeVarPairs,childVars) of
([(InPortOut, _)], InPort _) -> return ()
_ -> defineShared nodeVarPairs childVars
defineShared nodeVarPairs childVars =
case (nodeVarPairs,childVars) of
([(InPortOut, _)], InPort _) -> return ()
(nodeVarPairs,
Proc _ (SysIns pSysDef ins)) ->
do let sysDefVal = (readURef . unPrimSysDef) pSysDef
taggedIns = zipWith (\(id,_) var -> (id,var))
(iIface sysDefVal) ins
sr <- traverseST
(newInstance taggedIns)
defineInstance
(netlist sysDefVal)
let relateIns prevVar@(prevValR,_) (_,nextVar) =
relate nextVar [prevVar] (readSTRef prevValR)
zipWithM_ relateIns sr nodeVarPairs
([(DelaySYOut, nodeVar)],
Proc _ (DelaySY (ProcVal init _) sigVar)) ->
do valVar <- empty
relate valVar [] (return init)
delay nodeVar valVar sigVar
_ ->
do let evalPairs = eval `fmap` DT.mapM (readSTRef.fst) childVars
args = arguments childVars
relEval (tag, var) =
relate var args $
liftM (fromJust.(lookup tag)) evalPairs
mapM_ relEval nodeVarPairs
where
delay r ri@(rinit,_) r1@(pre,_) =
do state <- newSTRef Nothing
r2 <- empty
root r2
relate r [ri] $
do ms <- readSTRef state
case ms of
Just s -> return s
Nothing ->
do s <- readSTRef rinit
writeSTRef state (Just s)
return s
relate r2 [r,r1] $
do s <- readSTRef pre
writeSTRef state (Just s)
return s
sr <- traverseST new define (netlist sysDefVal)
rs <- readSTRef roots
step <- drive (sr ++ rs)
outs <- lazyloop $
do step
s <- DT.mapM (readSTRef . fst) sr
return s
let inN = length sysDefInIface
res = if inN == 0 then
transpose outs
else transpose (checkIns inN (transpose inps) outs)
return res
)
relate :: Var s -> [Var s] -> ST s Dynamic -> ST s ()
relate (rval, rwir) rs f =
do writeSTRef rwir $
Wire{ dependencies = rs
, kick = do b <- f
writeSTRef rval b
}
drive :: [Var s] -> ST s (ST s ())
drive [] =
do return (return ())
drive ((_,rwir):rs) =
do wire <- readSTRef rwir
writeSTRef rwir (error "detected combinational loop")
driv1 <- drive (dependencies wire)
writeSTRef rwir $
Wire { dependencies = [], kick = return () }
driv2 <- drive rs
return $
do driv1
kick wire
driv2
lazyloop :: ST s a -> ST s [a]
lazyloop m =
do a <- m
as <- unsafeInterleaveST (lazyloop m)
return (a:as)
checkIns :: Int
-> [[a]]
-> [[b]]
-> [[b]]
checkIns nIns (i:is) ~(o:os) | length i == nIns = o : checkIns nIns is os
checkIns _ _ _ = []