module Lava.Prelude
(
Word
, andG
, orG
, delay
, delayEn
, (?)
, nameList
, nameWord
, select
, selectG
, pick
, pickG
, decode
, decodeTwos
, encode
, tally
, oneHot
, tal
, tal'
, rotr
, rotateRight
, rotl
, rotateLeft
, dot
, RamInputs(..)
, ram
, dualRam
, Unsigned
, Signed(..)
, natSub
, complement
, bitPlus
, wordToInt
, extend
, (===)
, (=/=)
, Ordered(..)
, tree1
, tree
, groupN
, halve
) where
import Lava.Bit
import Lava.Vector
import Lava.Binary
import Data.List(transpose, inits, tails)
tree1 :: (a -> a -> a) -> [a] -> a
tree1 f [x] = x
tree1 f (x:y:ys) = tree1 f (ys ++ [f x y])
tree :: (a -> a -> a) -> a -> [a] -> a
tree f z xs = if null xs then z else tree1 f xs
groupN :: Int -> [a] -> [[a]]
groupN n [] = []
groupN n xs = take n xs : groupN n (drop n xs)
andG :: Generic a => a -> Bit
andG = tree (<&>) high . bits
orG :: Generic a => a -> Bit
orG = tree (<|>) low . bits
infix 4 ===
(===) :: Generic a => a -> a -> Bit
a === b = andG $ bits $ zipWithG (<=>) a b
infix 4 =/=
(=/=) :: Generic a => a -> a -> Bit
a =/= b = inv $ andG $ bits $ zipWithG (<=>) a b
delay :: Generic a => a -> a -> a
delay init a = lazyZipWithG delayBit init a
delayEn :: Generic a => a -> Bit -> a -> a
delayEn init en a = lazyZipWithG (delayBitEn en) init a
(?) :: Generic a => Bit -> (a, a) -> a
cond ? (a, b) = zipWithG (muxBit cond) b a
select :: [Bit] -> [[Bit]] -> [Bit]
select sels inps = map orG
$ transpose
$ zipWith (\sel -> map (sel <&>)) sels inps
selectG :: Generic a => [Bit] -> [a] -> a
selectG sels inps = tree1 (zipWithG (<|>))
$ zipWith (\sel -> mapG (sel <&>)) sels inps
pick :: [(Bit, [Bit])] -> [Bit]
pick choices = select sels inps
where (sels, inps) = unzip choices
pickG :: Generic a => [(Bit, a)] -> a
pickG choices = selectG sels inps
where (sels, inps) = unzip choices
decode :: [Bit] -> [Bit]
decode [] = [high]
decode [x] = [inv x, x]
decode (x:xs) = concatMap (\y -> [inv x <&> y, x <&> y]) rest
where rest = decode xs
decodeTwos :: [Bit] -> [Bit]
decodeTwos xs = zipWith (<|>) ys zs
where (ys, zs) = halve (decode xs)
halve :: [a] -> ([a], [a])
halve xs = splitAt (length xs `div` 2) xs
encode :: [Bit] -> [Bit]
encode [_] = []
encode as = zipWith (<|>) (encode ls) (encode rs) ++ [orG rs]
where (ls,rs) = splitAt (length as `div` 2) as
tally :: [Bit] -> [Bit]
tally = tal . decode
tal :: [Bit] -> [Bit]
tal = map orG . tail . tails
tal' :: [Bit] -> [Bit]
tal' = map orG . init . tails
split :: [a] -> [([a], [a])]
split [] = []
split (x:xs) = ([x], xs) : [(x:y, z) | (y, z) <- split xs]
tac :: ([a], [a]) -> [a]
tac (xs, ys) = reverse xs ++ reverse ys
dot :: [Bit] -> [Bit] -> Bit
dot xs ys = orG (zipWith (<&>) xs ys)
rotr :: [Bit] -> [Bit] -> [Bit]
rotr a b = map (dot a) (map tac (split b))
rotateRight :: [Bit] -> [[Bit]] -> [[Bit]]
rotateRight n = transpose . map (rotr n) . transpose
rotl :: [Bit] -> [Bit] -> [Bit]
rotl (a:as) b = rotr (a:reverse as) b
rotateLeft :: [Bit] -> [[Bit]] -> [[Bit]]
rotateLeft n = transpose . map (rotl n) . transpose
extend :: N n => Vec (S m) c -> Vec n c
extend n = vextend (vlast n) n
intToOneHot :: Int -> Int -> [Bit]
intToOneHot i w
| i < 0 = reverse bits
| otherwise = bits
where bits = [if abs i == j then high else low | j <- [0..w1]]
oneHot :: N n => Int -> Word n
oneHot i = sized (Vec . intToOneHot i)
data RamInputs n m =
RamInputs {
ramData :: Word n
, ramAddress :: Word m
, ramWrite :: Bit
}
ram :: (N n, N m) => [Integer] -> RamAlgorithm -> RamInputs n m -> Word n
ram init pt inps = Vec $ primRam init pt $
RamInps {
dataBus = velems (vrigid $ ramData inps)
, addressBus = velems (vrigid $ ramAddress inps)
, writeEnable = ramWrite inps
}
dualRam :: (N n, N m) => [Integer] -> RamAlgorithm
-> (RamInputs n m, RamInputs n m) -> (Word n, Word n)
dualRam init pt (inps0, inps1) = (Vec out0, Vec out1)
where
(out0, out1) =
primDualRam init pt
( RamInps {
dataBus = velems (vrigid $ ramData inps0)
, addressBus = velems (vrigid $ ramAddress inps0)
, writeEnable = ramWrite inps0
}
, RamInps {
dataBus = velems (vrigid $ ramData inps1)
, addressBus = velems (vrigid $ ramAddress inps1)
, writeEnable = ramWrite inps1
}
)
fullAdd :: Bit -> Bit -> Bit -> (Bit, Bit)
fullAdd cin a b = (sum, cout)
where sum' = a <#> b
sum = xorcy (sum', cin)
cout = muxcy sum' (a, cin)
binAdd :: Bit -> [Bit] -> [Bit] -> [Bit]
binAdd c a b = add c a b
where
add c [a] [b] = [sum, cout]
where (sum, cout) = fullAdd c a b
add c (a:as) [b] = add c (a:as) [b,b]
add c [a] (b:bs) = add c [a,a] (b:bs)
add c (a:as) (b:bs) = sum : add cout as bs
where (sum, cout) = fullAdd c a b
infixl 6 /+/
(/+/) :: [Bit] -> [Bit] -> [Bit]
a /+/ b = init (binAdd low a b)
infixl 6 /-/
(/-/) :: [Bit] -> [Bit] -> [Bit]
a /-/ b = init (binAdd high a (map inv b))
infix 4 /</
(/</) :: [Bit] -> [Bit] -> Bit
a /</ b = last (a /-/ b)
infix 4 /<=/
(/<=/) :: [Bit] -> [Bit] -> Bit
a /<=/ b = inv (b /</ a)
infix 4 />/
(/>/) :: [Bit] -> [Bit] -> Bit
a />/ b = b /</ a
infix 4 />=/
(/>=/) :: [Bit] -> [Bit] -> Bit
a />=/ b = b /<=/ a
ult :: [Bit] -> [Bit] -> Bit
a `ult` b = inv $ last $ binAdd high a (map inv b)
ule :: [Bit] -> [Bit] -> Bit
a `ule` b = inv (b `ult` a)
ugt :: [Bit] -> [Bit] -> Bit
a `ugt` b = b `ult` a
uge :: [Bit] -> [Bit] -> Bit
a `uge` b = b `ule` a
complement :: [Bit] -> [Bit]
complement a = init $ binAdd high (map inv a) [low]
bitPlus :: Bit -> [Bit] -> [Bit]
bitPlus a b = init (binAdd a (map (const low) b) b)
instance Generic a => Generic (Vec n a) where
generic (Vec []) = cons (Vec [])
generic (Vec (x:xs)) = cons (\x xs -> Vec (x:xs)) >< x >< xs
type Word n = Vec n Bit
type Unsigned n = Word n
wordToInt :: Integral a => Word n -> a
wordToInt = binToNat . map bitToBool . velems
instance Eq (Vec n Bit) where
a == b = error msg
where msg = "== and /= on bit-vectors is not supported: try === and =/="
instance N n => Num (Vec n Bit) where
a + b = vec (velems a /+/ velems b)
a b = vec (velems a /-/ velems b)
a * b = error "Multiplication of bit-vectors is not yet supported"
abs a = a
signum v = vec (map (b <&>) xs)
where xs = velems v
b = orG xs
fromInteger i = sized (\n -> Vec (fromInteger i `ofWidth` n))
ofWidth :: Integral a => a -> Int -> [Bit]
n `ofWidth` s = map boolToBit (intToSizedBin n s)
infix 4 |<=|, |<|, |>|, |>=|
class Ordered a where
(|<=|) :: a -> a -> Bit
(|<|) :: a -> a -> Bit
(|>=|) :: a -> a -> Bit
(|>|) :: a -> a -> Bit
instance Ordered (Vec n Bit) where
a |<=| b = velems a `ule` velems b
a |<| b = velems a `ult` velems b
a |>=| b = velems a `uge` velems b
a |>| b = velems a `ugt` velems b
natSub :: N n => Word n -> Word n -> Word n
natSub a b = Vec $ mapG (last r <&>) (init r)
where (x, y) = (velems a, velems b)
r = binAdd high x (map inv y)
newtype Signed n = Signed (Vec n Bit)
deriving Show
instance Generic (Signed n) where
generic (Signed n) = cons Signed >< n
instance Eq (Signed n) where
a == b = error msg
where msg = "== and /= on bit-vectors is not supported: try === and =/="
instance N n => Num (Signed n) where
Signed a + Signed b = Signed (a + b)
Signed a Signed b = Signed (a b)
a * b = error "(*) on bit-vectors is not yet supported"
abs (Signed a) = last (velems a) ? (negate (Signed a), Signed a)
signum (Signed a) = error "signum on bit-vectors is not yet supported"
fromInteger i = Signed $ sized (\n -> Vec (fromInteger i `ofWidth` n))
instance Ordered (Signed n) where
Signed a |<=| Signed b = ext1 (velems a) /<=/ ext1 (velems b)
Signed a |<| Signed b = ext1 (velems a) /</ ext1 (velems b)
Signed a |>=| Signed b = ext1 (velems a) />=/ ext1 (velems b)
Signed a |>| Signed b = ext1 (velems a) />/ ext1 (velems b)
ext1 :: [Bit] -> [Bit]
ext1 [] = [low]
ext1 xs = xs ++ take 1 (reverse xs)
nameList :: Int -> String -> [Bit]
nameList n s = map (name . (s ++) . show) [1..n]
nameWord :: N n => String -> Word n
nameWord s = sized (\n -> Vec $ nameList n s)
instance Eq Bit where
a == b = error "== and /= on bits is not supported."
instance Num Bit where
a + b = a <#> b
a b = a <&> inv b
a * b = a <&> b
abs a = a
signum a = a
fromInteger i = if i == 0 then low else high