module Lava.Bit
( Bit
, low
, high
, inv
, delayBit
, delayBitEn
, and2
, (<&>)
, or2
, (<|>)
, xor2
, (<#>)
, xorcy
, eq2
, (<=>)
, muxBit
, muxcy
, name
, RamInps(..)
, RamAlgorithm(..)
, primRam
, primDualRam
, Generic(..)
, BitContainer
, cons
, (><)
, structure
, bits
, mapG
, zipWithG
, lazyZipWithG
, boolToBit
, simulate
, simulateN
, simulateSeq
, bitToBool
, Net(..)
, Netlist(..)
, netlist
, makeComponent
, Signal
, InstanceId
, OutputNumber
, Wire
, Parameter(..)
, lookupParam
) where
import Data.IORef
import System.IO.Unsafe(unsafePerformIO)
import Data.List
import qualified Lava.JList as JL
import qualified Data.IntMap as IM
import Lava.Binary
type InstanceId = Int
type OutputNumber = Int
type Wire = (InstanceId, OutputNumber)
type Signal = [Bool]
data Parameter = String :-> String deriving Show
data Bit =
Symbol { componentName :: String
, numOutputs :: Int
, parameters :: [Parameter]
, inputs :: [Bit]
, instanceRef :: IORef (Maybe InstanceId)
, outputNumber :: OutputNumber
, outputSignal :: Signal
}
lookupParam :: [Parameter] -> String -> String
lookupParam ps p = case [v | (k :-> v) <- ps, p == k] of
[] -> error ("Unrecognised parameter '" ++ p ++ "'")
v:vs -> v
class Generic a where
generic :: a -> BitContainer a
type BitContainer a = (JL.JList Bit, JL.JList Bit -> a)
cons :: a -> BitContainer a
cons a = (JL.Zero, \JL.Zero -> a)
(><) :: Generic a => BitContainer (a -> b) -> a -> BitContainer b
(a, f) >< x = (a JL.:+: b, \(a JL.:+: b) -> f a (g b))
where (b, g) = generic x
instance Generic () where
generic = cons
instance Generic Bit where
generic a = (JL.One a, \(JL.One a) -> a)
instance Generic a => Generic (Maybe a) where
generic Nothing = cons Nothing
generic (Just a) = cons Just >< a
instance Generic a => Generic [a] where
generic [] = cons []
generic (a:as) = cons (:) >< a >< as
instance (Generic a, Generic b) => Generic (Either a b) where
generic (Left a) = cons Left >< a
generic (Right b) = cons Right >< b
instance (Generic a, Generic b) => Generic (a, b) where
generic (a, b) = cons (,) >< a >< b
instance (Generic a, Generic b, Generic c) => Generic (a, b, c) where
generic (a, b, c) = cons (,,) >< a >< b >< c
instance (Generic a, Generic b, Generic c,
Generic d) => Generic (a, b, c, d) where
generic (a, b, c, d) = cons (,,,) >< a >< b >< c >< d
instance (Generic a, Generic b, Generic c,
Generic d, Generic e) => Generic (a, b, c, d, e) where
generic (a, b, c, d, e) = cons (,,,,) >< a >< b >< c >< d >< e
instance (Generic a, Generic b, Generic c,
Generic d, Generic e, Generic f) => Generic (a, b, c, d, e, f) where
generic (a, b, c, d, e, f) = cons (,,,,,) >< a >< b >< c >< d >< e >< f
instance (Generic a, Generic b, Generic c,
Generic d, Generic e, Generic f,
Generic g) => Generic (a, b, c, d, e, f, g) where
generic (a, b, c, d, e, f, g) =
cons (,,,,,,) >< a >< b >< c >< d >< e >< f >< g
instance (Generic a, Generic b, Generic c,
Generic d, Generic e, Generic f,
Generic g, Generic h) => Generic (a, b, c, d, e, f, g, h) where
generic (a, b, c, d, e, f, g, h) =
cons (,,,,,,,) >< a >< b >< c >< d >< e >< f >< g >< h
structure :: Generic a => a -> JL.JList Bit
structure = fst . generic
bits :: Generic a => a -> [Bit]
bits = JL.toList . structure
mapG :: Generic a => (Bit -> Bit) -> a -> a
mapG f a = ca (JL.map f sa)
where
(sa, ca) = generic a
zipWithG :: Generic a => (Bit -> Bit -> Bit) -> a -> a -> a
zipWithG f a b = ca (JL.zipWith f sa sb)
where
(sa, ca) = generic a
(sb, cb) = generic b
lazyZipWithG :: Generic a => (Bit -> Bit -> Bit) -> a -> a -> a
lazyZipWithG f a b = ca (JL.lazyZipWith f sa sb)
where
(sa, ca) = generic a
(sb, cb) = generic b
makeComponent ::
String
-> [Bit]
-> Int
-> ([Signal] -> [Signal])
-> [Parameter]
-> ([Bit] -> a)
-> a
makeComponent comp inps numOuts sim params k = k outBits
where
outBits = map (\i -> Symbol {
componentName = comp
, numOutputs = numOuts
, parameters = params
, inputs = inps
, instanceRef = ref
, outputNumber = i
, outputSignal = outSigs !! i
}
) [0 .. numOuts1]
outSigs = sim (map outputSignal inps)
ref = unsafePerformIO (newIORef Nothing)
low :: Bit
low = makeComponent "low"
[]
1
(\[] -> [repeat False])
[]
(\[o] -> o)
high :: Bit
high = makeComponent "high"
[]
1
(\[] -> [repeat True])
[]
(\[o] -> o)
name :: String -> Bit
name s = makeComponent "name"
[]
1
(\[] -> [error msg])
["name" :-> s]
(\[o] -> o)
where msg = "Can't simulate circuit containing a name ('" ++ s ++ "')"
inv :: Bit -> Bit
inv a = makeComponent "inv"
[a]
1
(\[a] -> [map not a])
[]
(\[o] -> o)
delayBit :: Bit -> Bit -> Bit
delayBit init a =
makeComponent "delay"
[init, a]
1
(\[init, a] -> [head init:a])
["init" :-> getConst (componentName init)]
(\[o] -> o)
getConst "low" = "0"
getConst "high" = "1"
getConst _ = error "'delayBit' must have constant initialiser"
delayBitEn :: Bit -> Bit -> Bit -> Bit
delayBitEn en init a =
makeComponent "delayEn"
[init, en, a]
1
(\[init, en, a] -> [simDelayEn (head init) en a])
["init" :-> getConst (componentName init)]
(\[o] -> o)
logic2 :: String -> (Bool -> Bool -> Bool) -> (Bit, Bit) -> Bit
logic2 name f (a, b) =
makeComponent name
[a, b]
1
(\[a, b] -> [zipWith f a b])
[]
(\[o] -> o)
and2 :: (Bit, Bit) -> Bit
and2 = logic2 "and2" (&&)
infixr 3 <&>
(<&>) :: Bit -> Bit -> Bit
a <&> b = and2 (a, b)
or2 :: (Bit, Bit) -> Bit
or2 = logic2 "or2" (||)
infixr 2 <|>
(<|>) :: Bit -> Bit -> Bit
a <|> b = or2 (a, b)
xor2 :: (Bit, Bit) -> Bit
xor2 = logic2 "xor2" (/=)
infixr 2 <#>
(<#>) :: Bit -> Bit -> Bit
a <#> b = xor2 (a, b)
xorcy :: (Bit, Bit) -> Bit
xorcy = logic2 "xorcy" (/=)
eq2 :: (Bit, Bit) -> Bit
eq2 = logic2 "eq2" (==)
infixr 4 <=>
(<=>) :: Bit -> Bit -> Bit
a <=> b = eq2 (a, b)
muxBit :: Bit -> Bit -> Bit -> Bit
muxBit sel a b = (sel <&> b) <|> (inv sel <&> a)
muxcy :: Bit -> (Bit, Bit) -> Bit
muxcy sel (a, b) =
makeComponent "muxcy"
[b, a, sel]
1
(\[b, a, sel] -> [zipWith3 f sel a b])
[]
(\[o] -> o)
where f sel a b = if sel then b else a
data RamInps =
RamInps {
dataBus :: [Bit]
, addressBus :: [Bit]
, writeEnable :: Bit
}
data RamAlgorithm =
MinArea | Width1 | Width2 | Width4 | Width9 | Width18 | Width36
encodeRamAlgorithm :: RamAlgorithm -> String
encodeRamAlgorithm MinArea = ""
encodeRamAlgorithm Width1 = "16kx1"
encodeRamAlgorithm Width2 = "8kx2"
encodeRamAlgorithm Width4 = "4kx4"
encodeRamAlgorithm Width9 = "2kx9"
encodeRamAlgorithm Width18 = "1kx18"
encodeRamAlgorithm Width36 = "512x36"
primRam :: [Integer] -> RamAlgorithm -> RamInps -> [Bit]
primRam init ramAlg ins =
makeComponent "ram"
([writeEnable ins] ++ dataBus ins ++ addressBus ins)
dwidth
(simRam dwidth awidth init)
[ "init" :-> show init
, "dwidth" :-> show dwidth
, "awidth" :-> show awidth
, "primtype" :-> pt
]
id
where
pt = encodeRamAlgorithm ramAlg
dwidth = length (dataBus ins)
awidth = length (addressBus ins)
primDualRam :: [Integer] -> RamAlgorithm -> (RamInps, RamInps) -> ([Bit], [Bit])
primDualRam init ramAlg (ins1, ins2) =
makeComponent "dualRam"
([writeEnable ins1] ++ [writeEnable ins2] ++
dataBus ins1 ++ dataBus ins2 ++
addressBus ins1 ++ addressBus ins2 )
(2*dwidth)
(simDualRam dwidth awidth init)
[ "init" :-> show init
, "dwidth" :-> show dwidth
, "awidth" :-> show awidth
, "primtype" :-> pt
]
(splitAt dwidth)
where
pt = encodeRamAlgorithm ramAlg
dwidth = sameLength (dataBus ins1) (dataBus ins2)
awidth = sameLength (addressBus ins1) (addressBus ins2)
sameLength xs ys = if length xs == length ys then length xs else
error "BlockRam ports must have same bus-widths"
boolToBit :: Bool -> Bit
boolToBit False = low
boolToBit True = high
bitToBool :: Bit -> Bool
bitToBool s = head $ outputSignal s
instance Show Bit where
show b = if bitToBool b then "high" else "low"
simulate :: Generic a => a -> [a]
simulate a = a : simulate (step a)
where
step a = mapG rest a
rest b = b { outputSignal = tail (outputSignal b) }
simulateN :: Generic a => Int -> a -> [a]
simulateN n a = take n (simulate a)
simulateSeq :: (Generic a, Generic b) => (a -> b) -> [a] -> [b]
simulateSeq f as = simulateN (length as) (f $ trans as)
where
trans [x] = x
trans (x:xs) = zipWithG cons x (trans xs)
cons x xs = x { outputSignal = head (outputSignal x) : outputSignal xs }
simDelayEn :: Bool -> [Bool] -> [Bool] -> [Bool]
simDelayEn init en d = unfoldr step (init, en, d)
where
step (x, ens, ds) = Just (x, (y, tail ens, tail ds))
where y = if head ens then head ds else x
simRam :: Int -> Int -> [Integer] -> [[Bool]] -> [[Bool]]
simRam dwidth awidth init (we:sigs) =
trans $ unfoldr step (zero, initialMap, we, dbus, abus)
where
(dbus, abus) = splitAt dwidth sigs
init' = map (\x -> natToSizedBin x dwidth) init
initialMap = IM.fromList $ zip [0..2^awidth1] init'
zero = replicate dwidth False
step (o, m, we, dbus, abus) = Just (o, next)
where i = binToNat (map head abus)
m' = if head we then IM.insert i (map head dbus) m else m
output = IM.findWithDefault zero i m'
next = (output, m', tail we, map tail dbus, map tail abus)
simDualRam :: Int -> Int -> [Integer] -> [[Bool]] -> [[Bool]]
simDualRam dwidth awidth init (we1:we2:sigs) = trans $
unfoldr step (zero, zero, initial, we1, we2, dbus1, dbus2, abus1, abus2)
where
(dbus, abus) = splitAt (2*dwidth) sigs
(abus1, abus2) = splitAt awidth abus
(dbus1, dbus2) = splitAt dwidth dbus
init' = map (\x -> natToSizedBin x dwidth) init
initial = IM.fromList $ zip [0..2^awidth1] init'
zero = replicate dwidth False
step (o1, o2, m, we1, we2, dbus1, dbus2, abus1, abus2) =
Just (o1 ++ o2, next)
where i = binToNat (map head abus1)
j = binToNat (map head abus2)
output1 = IM.findWithDefault zero i m''
output2 = IM.findWithDefault zero j m''
m' = if head we1 then IM.insert i (map head dbus1) m else m
m'' = if head we2 then IM.insert j (map head dbus2) m' else m'
next = (output1, output2,
m'',
tail we1, tail we2,
map tail dbus1, map tail dbus2,
map tail abus1, map tail abus2)
data Net =
Net { netName :: String
, netParams :: [Parameter]
, netId :: InstanceId
, netNumOuts :: Int
, netInputs :: [Wire]
} deriving Show
data Netlist =
Netlist { namedOutputs :: [(String, Wire)]
, nets :: [Net]
} deriving Show
bitToNetlist :: IORef Int -> Bit -> IO (JL.JList Net, Wire)
bitToNetlist i bit =
do val <- readIORef (instanceRef bit)
num <- readIORef i
case val of
Nothing ->
do writeIORef (instanceRef bit) (Just num)
writeIORef i (num+1)
rest <- Prelude.mapM (bitToNetlist i) (inputs bit)
let (nls, wires) = unzip rest
let net = Net { netName = componentName bit
, netParams = parameters bit
, netId = num
, netNumOuts = numOutputs bit
, netInputs = wires
}
return (foldr (JL.:+:) (JL.One net) nls, (num, outputNumber bit))
Just j -> return (JL.Zero, (j, outputNumber bit))
netlist :: Generic a => a -> a -> IO Netlist
netlist a b =
do i <- newIORef (0 :: Int)
result <- JL.mapM (bitToNetlist i) sa
let nls = JL.map fst result
let wires = JL.map snd result
let outs = JL.zipWith (\w b -> (getName b, w)) wires sb
return (Netlist { namedOutputs = JL.toList outs
, nets = JL.toList (JL.concat nls)
})
where
sa = structure a
sb = structure b
getName b | componentName b == "name" = lookupParam (parameters b) "name"
getName _ = error $ "Blarney.Netlist: only names expected in "
++ "second argument to 'netlist'"
lazyZipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
lazyZipWith f [] bs = []
lazyZipWith f (a:as) bs = f a (hd bs) : lazyZipWith f as (tail bs)
where
hd [] = error "lazyZipWith: incompatible structures"
hd (a:as) = a
trans :: [[a]] -> [[a]]
trans (x:xs) = lazyZipWith (:) x (trans xs)
groupN :: Int -> [a] -> [[a]]
groupN n [] = []
groupN n xs = take n xs : groupN n (drop n xs)