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 Data.Maybe (fromJust)
import Control.Monad.ST
import Data.STRef
import qualified Data.Traversable as DT
import Data.List (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 _ _ _ = []