{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Language.KansasLava.Netlist.Utils
(
ToTypedExpr(..),
ToStdLogicExpr(..), toStdLogicTy,
AddNext(..),
toIntegerExpr,
sizedRange, sigName,
isHigh,
lookupInput, lookupInputType,
isMatrixStdLogicTy, isStdLogicTy, isStdLogicVectorTy,
sanitizeName,
active_high, stdLogicToMem, memToStdLogic,
addNum, prodSlices, toMemIndex,
mkExprConcat,
assignStmt, assignDecl
) where
import Language.KansasLava.Types
import Language.Netlist.AST hiding (U)
import Language.Netlist.Util
import Language.KansasLava.Rep
import Data.Reify.Graph (Unique)
import Data.List(find,mapAccumL)
class ToTypedExpr v where
toTypedExpr :: Type -> v -> Expr
instance (Integral a, Show a) => ToTypedExpr (Driver a) where
toTypedExpr ty (Lit n) = toTypedExpr ty n
toTypedExpr ty (Generic n) = toTypedExpr ty n
toTypedExpr ty (Port v n) = toTypedExpr ty (sigName v (fromIntegral n))
toTypedExpr ty (Pad nm) = toTypedExpr ty nm
toTypedExpr _ other = error $ "toTypedExpr(Driver a): " ++ show other
instance ToTypedExpr String where
toTypedExpr B nm = ExprVar nm
toTypedExpr ClkTy nm = ExprVar nm
toTypedExpr (V _) nm = ExprVar nm
toTypedExpr (S _) nm = signed $ ExprVar nm
toTypedExpr (U _) nm = unsigned $ ExprVar nm
toTypedExpr (TupleTy _) nm = ExprVar nm
toTypedExpr (MatrixTy _ _) nm = ExprVar nm
toTypedExpr (SampledTy {}) nm = ExprVar nm
toTypedExpr _other nm = error $ show ("toTypedExpr",_other,nm)
instance ToTypedExpr Integer where
toTypedExpr = fromIntegerToExpr
fromIntegerToExpr :: Type -> Integer -> Expr
fromIntegerToExpr t i =
case toStdLogicTy t of
B -> ExprLit Nothing (ExprBit (b (fromInteger i)))
V n -> ExprLit (Just n) (ExprNum i)
GenericTy -> ExprLit Nothing (ExprNum i)
ty -> error $ unwords ["fromIntegerToExpr: was expecting B or V from normalized number:", show ty, show i]
where b :: Int -> Bit
b 0 = F
b 1 = T
b _ = error "fromIntegerExpr: bit not of a value 0 or 1"
fromBoolToExpr :: Type -> Bool -> Expr
fromBoolToExpr t b =
case toStdLogicTy t of
B -> ExprLit Nothing (ExprBit (if b then T else F))
_ -> error "fromBoolToExpr: was expecting B from normalized number"
instance ToTypedExpr RepValue where
toTypedExpr (S n) r = ExprFunCall "to_signed"
[ ExprLit Nothing $ ExprNum $ fromRepToInteger r
, ExprLit Nothing $ ExprNum $ fromIntegral n
]
toTypedExpr (U n) r = ExprFunCall "to_unsigned"
[ ExprLit Nothing $ ExprNum $ fromRepToInteger r
, ExprLit Nothing $ ExprNum $ fromIntegral n
]
toTypedExpr t r = toTypedExpr t (fromRepToInteger r)
class ToStdLogicExpr v where
toStdLogicExpr :: Type -> v -> Expr
toStdLogicExpr' :: Type -> v -> Expr
toStdLogicExpr' = toStdLogicExpr
toStdLogicEleExpr :: Int -> Type -> v -> Expr
toStdLogicEleExpr = error "toStdLogicEleExpr"
instance (Integral a, Show a) => ToStdLogicExpr (Driver a) where
toStdLogicExpr ty _
| typeWidth ty == 0 = ExprVar "\"\""
toStdLogicExpr ty (Lit n) = toStdLogicExpr ty n
toStdLogicExpr ty (Generic n) = toStdLogicExpr ty n
toStdLogicExpr (MatrixTy w ty') (Port v n)
= mkExprConcat
[ (ty', memToStdLogic ty' $
ExprIndex (sigName v (fromIntegral n))
(ExprLit Nothing $ ExprNum $ fromIntegral (i)))
| i <- reverse [0..(w-1)]
]
toStdLogicExpr _ (Port v n) = ExprVar (sigName v (fromIntegral n))
toStdLogicExpr _ (Pad v) = ExprVar v
toStdLogicExpr _ other = error $ show other
toStdLogicExpr' (MatrixTy 1 _) (Port v n) =
memToStdLogic B $
ExprIndex (sigName v (fromIntegral n))
(ExprLit Nothing $ ExprNum $ 0)
toStdLogicExpr' _ _ = error "missing pattern in toStdLogicExpr'"
toStdLogicEleExpr i ty (Port v n) =
memToStdLogic ty $
ExprIndex (sigName v (fromIntegral n))
(ExprLit Nothing $ ExprNum $ fromIntegral i)
toStdLogicEleExpr _ _ _ = error "missing pattern in toStdLogicEleExpr"
instance ToStdLogicExpr Integer where
toStdLogicExpr = fromIntegerToExpr
instance ToStdLogicExpr Bool where
toStdLogicExpr = fromBoolToExpr
instance ToStdLogicExpr RepValue where
toStdLogicExpr t r = toTypedExpr t (fromRepToInteger r)
instance ToStdLogicExpr Expr where
toStdLogicExpr B e = e
toStdLogicExpr ClkTy e = e
toStdLogicExpr (V _) e = e
toStdLogicExpr (TupleTy _) e = e
toStdLogicExpr (MatrixTy _n _) (ExprVar _nm) = error "BBB"
toStdLogicExpr (S _) e = std_logic_vector e
toStdLogicExpr (U _) e = std_logic_vector e
toStdLogicExpr(SampledTy {}) e = e
toStdLogicExpr _other e = error $ show ("toStdLogicExpr", _other,e)
class ToIntegerExpr v where
toIntegerExpr :: Type -> v -> Expr
instance (Integral i, Show i) => ToIntegerExpr (Driver i) where
toIntegerExpr _ (Lit v) = ExprLit Nothing $ ExprNum (fromRepToInteger v)
toIntegerExpr GenericTy other = toTypedExpr GenericTy other
toIntegerExpr ty other = to_integer (toTypedExpr ty other)
toStdLogicTy :: Type -> Type
toStdLogicTy B = B
toStdLogicTy ClkTy = B
toStdLogicTy (V n) = V n
toStdLogicTy GenericTy = GenericTy
toStdLogicTy (MatrixTy i ty) = MatrixTy i (V $ fromIntegral size)
where size = typeWidth ty
toStdLogicTy ty = V $ fromIntegral size
where size = typeWidth ty
isMatrixStdLogicTy :: Type -> Bool
isMatrixStdLogicTy ty = case toStdLogicType ty of
SLVA {} -> True
_ -> False
isStdLogicTy :: Type -> Bool
isStdLogicTy ty = case toStdLogicType ty of
SL {} -> True
_ -> False
isStdLogicVectorTy :: Type -> Bool
isStdLogicVectorTy ty = case toStdLogicType ty of
SLV {} -> True
_ -> False
sigName :: String -> Unique -> String
sigName v d = "sig_" ++ show d ++ "_" ++ v
sizedRange :: Type -> Maybe Range
sizedRange ty = case toStdLogicTy ty of
B -> Nothing
V n -> Just $ Range high low
where high = ExprLit Nothing (ExprNum (fromIntegral n - 1))
low = ExprLit Nothing (ExprNum 0)
MatrixTy _ _ -> error "sizedRange: does not support matrix types"
sty -> error $ "sizedRange: does not support type " ++ show sty
active_high :: Expr -> Expr
active_high d = ExprCond d (ExprLit Nothing (ExprBit T)) (ExprLit Nothing (ExprBit F))
std_logic_vector :: Expr -> Expr
std_logic_vector d = ExprFunCall "std_logic_vector" [d]
unsigned :: Expr -> Expr
unsigned x = ExprFunCall "unsigned" [x]
signed :: Expr -> Expr
signed x = ExprFunCall "signed" [x]
to_integer :: Expr -> Expr
to_integer e = ExprFunCall "to_integer" [e]
isHigh :: Expr -> Expr
isHigh (ExprLit Nothing (ExprBit T)) = ExprVar "true"
isHigh d = ExprBinary Equals d (ExprLit Nothing (ExprBit T))
toMemIndex :: (Integral t, Show t) => Type -> Driver t -> Expr
toMemIndex ty _ | typeWidth ty == 0 = ExprLit Nothing (ExprNum 0)
toMemIndex _ (Lit n) = ExprLit Nothing $ ExprNum $ fromRepToInteger n
toMemIndex ty dr = to_integer $ unsigned $ toStdLogicExpr ty dr
memToStdLogic :: Type -> Expr -> Expr
memToStdLogic B e = ExprFunCall "lava_to_std_logic" [e]
memToStdLogic _ e = e
stdLogicToMem :: Type -> Expr -> Expr
stdLogicToMem B e = ExprConcat [ExprLit Nothing $ ExprBitVector [],e]
stdLogicToMem _ e = e
mkExprConcat :: [(Type,Expr)] -> Expr
mkExprConcat [(B,e)] = ExprConcat [ExprVar "\"\"",e]
mkExprConcat xs = ExprConcat $ map snd xs
prodSlices :: Driver Unique -> [Type] -> [Expr]
prodSlices d tys = reverse $ snd $ mapAccumL f size $ reverse tys
where size = fromIntegral $ sum (map typeWidth tys) - 1
nm = case d of
Port v n -> sigName v n
Pad v -> v
Lit {} -> error "projecting into a literal (not implemented yet!)"
driver -> error "projecting into " ++ show driver ++ " not implemented"
f :: Integer -> Type -> (Integer,Expr)
f i B = (i-1,ExprIndex nm (ExprLit Nothing (ExprNum i)))
f i ty = let w = fromIntegral $ typeWidth ty
nextIdx = i - w
in (nextIdx, ExprSlice nm (ExprLit Nothing (ExprNum i))
(ExprLit Nothing (ExprNum (nextIdx + 1))))
lookupInput :: (Show b) => String -> Entity b -> Driver b
lookupInput i (Entity _ _ inps) = case find (\(v,_,_) -> v == i) inps of
Just (_,_,d) -> d
Nothing -> error $ "lookupInput: Can't find input" ++ show (i,inps)
lookupInputType :: String -> Entity t -> Type
lookupInputType i (Entity _ _ inps) = case find (\(v,_,_) -> v == i) inps of
Just (_,ty,_) -> ty
Nothing -> error "lookupInputType: Can't find input"
addNum :: Integer -> [(String,Type,Driver Unique)] -> [(String,Type,Driver Unique)]
addNum i [("i0",ty,d)] = [("i0",GenericTy,Generic i),("i1",ty,d)]
addNum _ _ = error "addNum"
class AddNext s where
next :: s -> s
instance AddNext String where
next nm = nm ++ "_next"
instance AddNext (Driver i) where
next (Port v i) = Port (next v) i
next other = other
sanitizeName :: String -> String
sanitizeName "+" = "add"
sanitizeName "-" = "sub"
sanitizeName "*" = "mul"
sanitizeName ".>." = "gt"
sanitizeName ".<." = "lt"
sanitizeName ".<=." = "ge"
sanitizeName ".>=." = "le"
sanitizeName other = other
assignStmt :: String -> Unique -> Type -> Driver Unique -> Stmt
assignStmt nm i ty d =
case toStdLogicType ty of
SL -> Assign (ExprVar $ sigName nm i) (toStdLogicExpr ty d)
SLV {} -> Assign (ExprVar $ sigName nm i) (toStdLogicExpr ty d)
SLVA n m -> statements $
[ Assign (ExprIndex (sigName nm i)
(ExprLit Nothing $ ExprNum $ fromIntegral j))
$ toStdLogicEleExpr j (V m) d
| j <- [0..(n-1)]
]
G {} -> error "assignStmt {G} ?"
assignDecl :: String -> Unique -> Type -> ((Driver Unique -> Expr) -> Expr) -> [Decl]
assignDecl nm i ty f =
case toStdLogicType ty of
SL -> [ NetAssign (sigName nm i)
(f $ toStdLogicExpr ty)
]
SLV {} -> [ NetAssign (sigName nm i)
(f $ toStdLogicExpr ty)
]
SLVA n m -> [ MemAssign (sigName "o0" i)
(ExprLit Nothing $ ExprNum $ fromIntegral j)
(f $ toStdLogicEleExpr j (V m))
| j <- [0..(n-1)]
]
G {} -> error "assignDecl {G} ?"