module Language.KansasLava.RTL (
RTL(..),
Reg,
Cond(..),
runRTL,
reg, var,
newReg, newArr,
match
) where
import Language.KansasLava.Protocols
import Language.KansasLava.Rep
import Language.KansasLava.Signal
import Language.KansasLava.Types
import Language.KansasLava.Utils
import Language.KansasLava.Probes
import Data.Sized.Matrix
import Control.Applicative
import Control.Monad.ST
import Data.STRef
import Data.List as L
import Control.Monad.ST.Unsafe (unsafeInterleaveST)
import Prelude
data Reg s c a = Reg (Signal c a)
(Signal c a)
(STRef s [Signal c a -> Signal c a])
(STRef s (Maybe String))
Int
| forall ix . (Rep ix) =>
Arr (Signal c a)
(Signal c ix)
(STRef s [Signal c (Maybe (ix,a)) -> Signal c (Maybe (ix,a))])
Int
reg :: Reg s c a -> Signal c a
reg (Reg iseq _ _ _ _) = iseq
reg (Arr iseq _ _ _) = iseq
var :: Reg s c a -> Signal c a
var (Reg _ iseq _ _ _) = iseq
var (Arr _ _ _ _) = error "can not take the var of an array"
data Pred c = Pred (Maybe (Signal c Bool))
truePred :: Pred c
truePred = Pred Nothing
andPred :: Pred c -> Signal c Bool -> Pred c
andPred (Pred Nothing) c = Pred (Just c)
andPred (Pred (Just c1)) c2 = Pred (Just (c1 .&&. c2))
muxPred :: (Rep a) => Pred c -> (Signal c a, Signal c a) -> Signal c a
muxPred (Pred Nothing) (_,t) = t
muxPred (Pred (Just p)) (f,t) = mux p (f,t)
data RTL s c a where
RTL :: (Pred c -> STRef s Int -> ST s (a,[Int])) -> RTL s c a
(:=) :: forall c b s . (Rep b) => Reg s c b -> Signal c b -> RTL s c ()
CASE :: [Cond s c] -> RTL s c ()
WHEN :: Signal c Bool -> RTL s c () -> RTL s c ()
DEBUG :: forall c b s . (Rep b) => String -> Reg s c b -> RTL s c ()
infixr 0 :=
instance Functor (RTL s c) where
fmap f m = RTL $ \ c u -> do
(x, us) <- unRTL m c u
return (f x, us)
instance Applicative (RTL s c) where
pure x = RTL $ \ _ _ -> return (x, [])
mf <*> mx = RTL $ \ c u -> do
(f, us1) <- unRTL mf c u
(x, us2) <- unRTL mx c u
return (f x, us1 ++ us2)
instance Monad (RTL s c) where
return = pure
m >>= k = RTL $ \ c u -> do (r1,f1) <- unRTL m c u
(r2,f2) <- unRTL (k r1) c u
return (r2,f1 ++ f2)
runRTL :: forall c a . (Clock c) => (forall s . RTL s c a) -> a
runRTL rtl = runST (do
u <- newSTRef 0
(r,_) <- unRTL rtl truePred u
return r)
unRTL :: RTL s c a -> Pred c -> STRef s Int -> ST s (a,[Int])
unRTL (RTL m) = m
unRTL (Reg _ _ varSt _ uq := ss) = \ c _u -> do
modifySTRef varSt ((:) (\ r -> muxPred c (r,ss)))
return ((), [uq])
unRTL (Arr _ ix varSt uq := ss) = \ c _u -> do
modifySTRef varSt ((:) (\ r -> muxPred c (r,enabledS (pack (ix,ss)))))
return ((), [uq])
unRTL (CASE alts) = \ c u -> do
let conds = [ p | IF p _ <- alts ]
other_p = bitNot $ foldr (.||.) low conds
res <- sequence
[ case alt of
IF p m -> unRTL m (andPred c p) u
OTHERWISE m -> unRTL m (andPred c other_p) u
| alt <- alts
]
let assignments = L.nub $ concat [ xs | (_,xs) <- res ]
return ((),assignments)
unRTL (DEBUG msg (Reg _ _ _ debugSt _)) = \ _c _u -> do
writeSTRef debugSt (Just msg)
return ((),[])
unRTL (DEBUG _msg _) = \ _c _u -> return ((),[])
unRTL (WHEN p m) = unRTL (CASE [IF p m])
data Cond s c
= IF (Signal c Bool) (RTL s c ())
| OTHERWISE (RTL s c ())
newReg :: forall a c s . (Clock c, Rep a) => a -> RTL s c (Reg s c a)
newReg def = RTL $ \ _ u -> do
uq <- readSTRef u
writeSTRef u (uq + 1)
varSt <- newSTRef []
debugSt <- newSTRef Nothing
~(regRes,variable) <- unsafeInterleaveST $ do
assigns <- readSTRef varSt
debugs <- readSTRef debugSt
let v_old = register def v_new
v_new = foldr (.) id (reverse assigns) v_old
v_old' = case debugs of
Nothing -> v_old
Just msg -> probeS msg v_old
return (v_old',v_new)
return (Reg regRes variable varSt debugSt uq,[])
newArr :: forall a c ix s . (Size ix, Clock c, Rep a, Num ix, Rep ix) => Witness ix -> RTL s c (Signal c ix -> Reg s c a)
newArr Witness = RTL $ \ _ u -> do
uq <- readSTRef u
writeSTRef u (uq + 1)
varSt <- newSTRef []
proj <- unsafeInterleaveST $ do
assigns <- readSTRef varSt
let ass = foldr (.) id (reverse assigns) (pureS Nothing)
let look ix = writeMemory (ass :: Signal c (Maybe (ix,a)))
`asyncRead` ix
return look
return (\ ix -> Arr (proj ix) ix varSt uq, [])
match :: (Rep a) => Signal c (Enabled a) -> (Signal c a -> RTL s c ()) -> Cond s c
match inp fn = IF (isEnabled inp) (fn (enabledVal inp))