module Recipe
(
Recipe ( Skip, Tick, Seq, Par, While, Do )
, (|>)
, call
, Var ( val, (<==) )
, (!)
, (-->)
, New
, Reg
, newReg
, newRegInit
, Sig
, newSig
, newSigDef
, Proc()
, newProc
, recipe
, simRecipe
) where
import Lava
import List
import Maybe
type VarId = Int
data Recipe
= Skip
| Tick
| VarId := [Bit]
| Seq [Recipe]
| Par [Recipe]
| Cond Bit Recipe
| While Bit Recipe
| Do Recipe Bit
infixr 1 |>
(|>) :: Bit -> Recipe -> Recipe
b |> r = Cond b r
time :: Recipe -> Maybe Int
time Skip = Just 0
time Tick = Just 1
time (v := e) = Just 0
time (Seq rs) = sum `fmap` mapM time rs
time (Par rs) = foldr max 0 `fmap` mapM time rs
time (Cond b r)
| time r == Just 0 = Just 0
| otherwise = Nothing
time (While b r) = Nothing
time (Do r b) = Nothing
finite :: Recipe -> Bool
finite r = isJust (time r)
slowest :: [Recipe] -> Int
slowest = snd . maximum . flip zip [0..] . map time
type Schedule = [(Bit, VarId, [Bit])]
sched :: Bit -> Recipe -> (Bit, Schedule)
sched go Skip = (go, [])
sched go Tick = (delay low go, [])
sched go (v := e) = (go, [(go, v, e)])
sched go (Seq rs) = (done, concat ss)
where (done, ss) = mapAccumL sched go rs
sched go (Par rs)
| all finite rs = (dones !! slowest rs, concat ss)
| otherwise = (sync dones, concat ss)
where (dones, ss) = unzip (map (sched go) rs)
sched go (Cond c r)
| time r == Just 0 = (go, s)
| otherwise = (done <|> (go <&> inv c), s)
where (done, s) = sched (go <&> c) r
sched go (While c r) = (ready <&> inv c, s)
where ready = go <|> done
(done, s) = sched (ready <&> c) r
sched go (Do r c) = (done <&> inv c, s)
where ready = go <|> (done <&> c)
(done, s) = sched ready r
sync :: [Bit] -> Bit
sync [x] = x
sync xs = let done = andG [setReset x done | x <- xs] in done
setReset :: Bit -> Bit -> Bit
setReset s r = let out = s <|> delay low (out <&> inv r) in out
infix 5 <==
class Var v where
val :: v n -> Word n
(<==) :: v n -> Word n -> Recipe
data Sig n = Sig { sigId :: VarId, sigVal :: Word n }
data Reg n = Reg { regId :: VarId, regVal :: Word n }
instance Generic (Sig n) where
generic (Sig v x) = cons (Sig v) >< x
instance Show (Sig n) where
show (Sig v x) = show x
instance Generic (Reg n) where
generic (Reg v x) = cons (Reg v) >< x
instance Show (Reg n) where
show (Reg v x) = show x
instance Var Sig where
val s = sigVal s
s <== x = sigId s := velems x
instance Var Reg where
val r = regVal r
r <== x = regId r := velems x
type New a = RWS Schedule (Bit, Recipe) VarId a
fresh :: New VarId
fresh = do { v <- get ; set (v+1) ; return v }
newSig :: N n => New (Sig n)
newSig = do { v <- fresh ; s <- ask ; return $ sig v $ assigns v s }
newSigDef :: N n => Word n -> New (Sig n)
newSigDef d = do { v <- fresh ; s <- ask ; return $ sigDef d v $ assigns v s }
assigns :: VarId -> Schedule -> [(Bit, [Bit])]
assigns v s = [(b, e) | (b, w, e) <- s, v == w]
sig :: N n => VarId -> [(Bit, [Bit])] -> Sig n
sig v as = Sig v (if null as then 0 else Vec $ pick as)
sigDef :: N n => Word n -> VarId -> [(Bit, [Bit])] -> Sig n
sigDef d v as = Sig v (if null as then d else Vec $ pickDef (velems d) as)
pickDef :: [Bit] -> [(Bit,[Bit])] -> [Bit]
pickDef def ps = pick ((sel, def):ps)
where sel = inv (orG (map fst ps))
newRegInit :: N n => Word n -> New (Reg n)
newRegInit i = do { v <- fresh ; s <- ask ; return $ reg v i $ assigns v s }
newReg :: N n => New (Reg n)
newReg = newRegInit 0
reg :: N n => VarId -> Word n -> [(Bit, [Bit])] -> Reg n
reg v i as = Reg v (if null as then i else Vec out)
where out = delayEn (velems i) (orG $ map fst as) (pick as)
recipe :: New a
-> (a -> Recipe)
-> Bit
-> (a, Bit)
recipe n f go =
let (_, rs, a) = runRWS n (s ++ concat ss) 0
ss = map (snd . uncurry sched) rs
(done, s) = sched go (f a)
in (a, done)
simRecipe :: Generic b
=> New a
-> (a -> Recipe)
-> (a -> b)
-> b
simRecipe n f k = fst
$ head
$ dropWhile (not . bitToBool . snd)
$ simulate
$ first k
$ recipe n f (delay high low)
where first f (a, b) = (f a, b)
infixl 9 !
(!) :: a -> (a -> b) -> b
x ! f = f x
infix 1 -->
(-->) :: a -> b -> (a, b)
a --> b = (a, b)
data Proc = Proc { procGo :: Sig N1, procDone :: Bit }
newProc :: Recipe -> New Proc
newProc r =
do { go <- newSig
; done <- newSig
; write (go!val!vhead, Seq [ r, done <== vsingle high ])
; return (Proc go (done!val!vhead))
}
call :: Proc -> Recipe
call p = Seq [ p!procGo <== 1, While (p!procDone!inv) Tick ]
data RWS r w s a = RWS { runRWS :: r -> s -> (s, [w], a) }
instance Monad (RWS r w s) where
return a = RWS (\r s -> (s, [], a))
m >>= f = RWS (\r s -> let (s0, w0, a) = runRWS m r s
(s1, w1, b) = runRWS (f a) r s0
in (s1, w0 ++ w1, b))
get :: RWS r w s s
get = RWS (\r s -> (s, [], s))
set :: s -> RWS r w s ()
set s' = RWS (\r s -> (s', [], ()))
ask :: RWS r w s r
ask = RWS (\r s -> (s, [], r))
write :: w -> RWS r w s ()
write w = RWS (\r s -> (s, [w], ()))