module CLaSH.Backend.VHDL (VHDLState) where
import qualified Control.Applicative as A
import Control.Lens hiding (Indexed)
import Control.Monad (forM,join,liftM,zipWithM)
import Control.Monad.State (State)
import Data.Graph.Inductive (Gr, mkGraph, topsort')
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (mapAccumL,nubBy)
import Data.Maybe (catMaybes,mapMaybe)
import Data.Text.Lazy (unpack)
import qualified Data.Text.Lazy as T
import Prelude hiding ((<$>))
import Text.PrettyPrint.Leijen.Text.Monadic
import CLaSH.Backend
import CLaSH.Netlist.BlackBox.Types (HdlSyn (..))
import CLaSH.Netlist.BlackBox.Util (extractLiterals, renderBlackBox)
import CLaSH.Netlist.Id (mkBasicId')
import CLaSH.Netlist.Types hiding (_intWidth, intWidth)
import CLaSH.Netlist.Util hiding (mkBasicId)
import CLaSH.Util (clog2, curLoc, first, makeCached, on, (<:>))
#ifdef CABAL
import qualified Paths_clash_vhdl
#else
import qualified System.FilePath
#endif
data VHDLState =
VHDLState
{ _tyCache :: (HashSet HWType)
, _tySeen :: [Identifier]
, _nameCache :: (HashMap HWType Doc)
, _modNm :: String
, _intWidth :: Int
, _hdlsyn :: HdlSyn
}
makeLenses ''VHDLState
instance Backend VHDLState where
initBackend = VHDLState HashSet.empty [] HashMap.empty ""
#ifdef CABAL
primDir = const (Paths_clash_vhdl.getDataFileName "primitives")
#else
primDir _ = return ("clash-vhdl" System.FilePath.</> "primitives")
#endif
extractTypes = _tyCache
name = const "vhdl"
extension = const ".vhdl"
genHDL = genVHDL
mkTyPackage = mkTyPackage_
hdlType = vhdlType
hdlTypeErrValue = vhdlTypeErrValue
hdlTypeMark = vhdlTypeMark
hdlSig t ty = sigDecl (text t) ty
genStmt = const empty
inst = inst_
expr = expr_
iwWidth = use intWidth
toBV _ id_ = do
nm <- use modNm
text (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (text id_)
fromBV hty id_ = fromSLV hty id_ (typeSize hty 1) 0
hdlSyn = use hdlsyn
mkBasicId = return (filterReserved . T.toLower . mkBasicId' True)
setModName nm s = s {_modNm = nm}
type VHDLM a = State VHDLState a
reservedWords :: [Identifier]
reservedWords = ["abs","access","after","alias","all","and","architecture"
,"array","assert","assume","assume_guarantee","attribute","begin","block"
,"body","buffer","bus","case","component","configuration","constant","context"
,"cover","default","disconnect","downto","else","elsif","end","entity","exit"
,"fairness","file","for","force","function","generate","generic","group"
,"guarded","if","impure","in","inertial","inout","is","label","library"
,"linkage","literal","loop","map","mod","nand","new","next","nor","not","null"
,"of","on","open","or","others","out","package","parameter","port","postponed"
,"procedure","process","property","protected","pure","range","record"
,"register","reject","release","rem","report","restrict","restrict_guarantee"
,"return","rol","ror","select","sequence","severity","signal","shared","sla"
,"sll","sra","srl","strong","subtype","then","to","transport","type"
,"unaffected","units","until","use","variable","vmode","vprop","vunit","wait"
,"when","while","with","xnor","xor","toslv","fromslv","tagtoenum","datatotag"
,"integer", "boolean", "std_logic", "std_logic_vector", "signed", "unsigned"
,"to_integer", "to_signed", "to_unsigned", "string"]
filterReserved :: Identifier -> Identifier
filterReserved s = if s `elem` reservedWords
then s `T.append` "_r"
else s
genVHDL :: String -> Component -> VHDLM (String,Doc)
genVHDL nm c = (unpack cName,) A.<$> vhdl
where
cName = componentName c
vhdl = "-- Automatically generated VHDL-93" <$$>
tyImports nm <$$> linebreak <>
entity c <$$> linebreak <>
architecture c
mkTyPackage_ :: String
-> [HWType]
-> VHDLM [(String,Doc)]
mkTyPackage_ modName hwtys = do
{ syn <- hdlSyn
; mkId <- mkBasicId
; let usedTys = concatMap mkUsedTys hwtys
needsDec = nubBy (eqReprTy syn) . map mkVecZ $ (hwtys ++ usedTys)
hwTysSorted = topSortHWTys needsDec
packageDec = vcat $ mapM tyDec hwTysSorted
(funDecs,funBodies) = unzip . catMaybes $ map (funDec syn) (nubBy (eqTypM syn) hwTysSorted)
; (:[]) A.<$> (unpack $ mkId (T.pack modName `T.append` "_types"),) A.<$>
"library IEEE;" <$>
"use IEEE.STD_LOGIC_1164.ALL;" <$>
"use IEEE.NUMERIC_STD.ALL;" <$$> linebreak <>
"package" <+> text (mkId (T.pack modName `T.append` "_types")) <+> "is" <$>
indent 2 ( packageDec <$>
vcat (sequence funDecs)
) <$>
"end" <> semi <> packageBodyDec funBodies
}
where
packageBodyDec :: [VHDLM Doc] -> VHDLM Doc
packageBodyDec funBodies = case funBodies of
[] -> empty
_ -> do
{ mkId <- mkBasicId
; linebreak <$>
"package" <+> "body" <+> text (mkId (T.pack modName `T.append` "_types")) <+> "is" <$>
indent 2 (vcat (sequence funBodies)) <$>
"end" <> semi
}
eqReprTy :: HdlSyn -> HWType -> HWType -> Bool
eqReprTy h (Vector n ty1) (Vector m ty2) = n == m && eqReprTy h ty1 ty2
eqReprTy h ty1 ty2
| isUnsigned ty1 && isUnsigned ty2 ||
isSLV h ty1 && isSLV h ty2 = typeSize ty1 == typeSize ty2
| otherwise = ty1 == ty2
eqTypM :: HdlSyn -> HWType -> HWType -> Bool
eqTypM h (Vector n ty1) (Vector m ty2) = n == m && eqReprTy h ty1 ty2
eqTypM _ (Signed _) (Signed _) = True
eqTypM h ty1 ty2 = isUnsigned ty1 && isUnsigned ty2 ||
isSLV h ty1 && isSLV h ty2 ||
ty1 == ty2
isUnsigned :: HWType -> Bool
isUnsigned (Unsigned _) = True
isUnsigned (Index _) = True
isUnsigned (Sum _ _) = True
isUnsigned _ = False
isSLV :: HdlSyn -> HWType -> Bool
isSLV _ (BitVector _) = True
isSLV _ (SP _ _) = True
isSLV _ _ = False
mkUsedTys :: HWType
-> [HWType]
mkUsedTys v@(Vector _ elTy) = v : mkUsedTys elTy
mkUsedTys p@(Product _ elTys) = p : concatMap mkUsedTys elTys
mkUsedTys sp@(SP _ elTys) = sp : concatMap mkUsedTys (concatMap snd elTys)
mkUsedTys t = [t]
topSortHWTys :: [HWType]
-> [HWType]
topSortHWTys hwtys = sorted
where
nodes = zip [0..] hwtys
nodesI = HashMap.fromList (zip hwtys [0..])
edges = concatMap edge hwtys
graph = mkGraph nodes edges :: Gr HWType ()
sorted = reverse $ topsort' graph
edge t@(Vector _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "Vector") t nodesI,,()))
(HashMap.lookup (mkVecZ elTy) nodesI)
edge t@(Product _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI
in mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ ty) nodesI)) tys
edge t@(SP _ ctys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "SP") t nodesI
in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ ty) nodesI)) tys) ctys
edge _ = []
mkVecZ :: HWType -> HWType
mkVecZ (Vector _ elTy) = Vector 0 elTy
mkVecZ t = t
tyDec :: HWType -> VHDLM Doc
tyDec (Vector _ elTy) = do
syn <- hdlSyn
case syn of
Vivado -> "type" <+> "array_of_" <> tyName elTy <+> "is array (integer range <>) of"
<+> "std_logic_vector" <> parens (int (typeSize elTy 1) <+> "downto 0") <> semi
_ -> "type" <+> "array_of_" <> tyName elTy <+> "is array (integer range <>) of"
<+> vhdlType elTy <> semi
tyDec ty@(Product _ tys@(_:_:_)) = prodDec
where
prodDec = "type" <+> tName <+> "is record" <$>
indent 2 (vcat $ zipWithM (\x y -> x <+> colon <+> y <> semi) selNames selTys) <$>
"end record" <> semi
tName = tyName ty
selNames = map (\i -> tName <> "_sel" <> int i) [0..]
selTys = map vhdlType tys
tyDec _ = empty
funDec :: HdlSyn -> HWType -> Maybe (VHDLM Doc,VHDLM Doc)
funDec _ Bool = Just
( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <$>
"function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <> semi <$>
"function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <> semi <$>
"function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <> semi
, "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <+> "is" <$>
"begin" <$>
indent 2 (vcat $ sequence ["if" <+> "b" <+> "then"
, indent 2 ("return" <+> dquotes (int 1) <> semi)
,"else"
, indent 2 ("return" <+> dquotes (int 0) <> semi)
,"end" <+> "if" <> semi
]) <$>
"end" <> semi <$>
"function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <+> "is" <$>
"begin" <$>
indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then"
, indent 2 ("return" <+> "true" <> semi)
,"else"
, indent 2 ("return" <+> "false" <> semi)
,"end" <+> "if" <> semi
]) <$>
"end" <> semi <$>
"function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <+> "is" <$>
"begin" <$>
indent 2 (vcat $ sequence ["if" <+> "s" <+> "=" <+> "to_signed" <> parens (int 0 <> comma <> (use intWidth >>= int)) <+> "then"
, indent 2 ("return" <+> "false" <> semi)
,"else"
, indent 2 ("return" <+> "true" <> semi)
,"end" <+> "if" <> semi
]) <$>
"end" <> semi <$>
"function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <+> "is" <$>
"begin" <$>
indent 2 (vcat $ sequence ["if" <+> "b" <+> "then"
, indent 2 ("return" <+> "to_signed" <> parens (int 1 <> comma <> (use intWidth >>= int)) <> semi)
,"else"
, indent 2 ("return" <+> "to_signed" <> parens (int 0 <> comma <> (use intWidth >>= int)) <> semi)
,"end" <+> "if" <> semi
]) <$>
"end" <> semi
)
funDec _ (Index _) = Just unsignedToSlvDec
funDec _ (Signed _) = Just
( "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <> semi
, "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <+> "is" <$>
"begin" <$>
indent 2 ("return" <+> "std_logic_vector" <> parens ("s") <> semi) <$>
"end" <> semi
)
funDec _ (Unsigned _) = Just unsignedToSlvDec
funDec _ (Sum _ _) = Just unsignedToSlvDec
funDec _ t@(Product _ elTys) = Just
( "function" <+> "toSLV" <+> parens ("p :" <+> vhdlType t) <+> "return std_logic_vector" <> semi
, "function" <+> "toSLV" <+> parens ("p :" <+> vhdlType t) <+> "return std_logic_vector" <+> "is" <$>
"begin" <$>
indent 2 ("return" <+> parens (hcat (punctuate " & " elTyPrint)) <> semi) <$>
"end" <> semi
)
where
elTyPrint = forM [0..(length elTys 1)]
(\i -> "toSLV" <>
parens ("p." <> tyName t <> "_sel" <> int i))
funDec syn t@(Vector _ elTy) = Just
( "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <> semi
, "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <+> "is" <$>
indent 2
( "alias ivalue :" <+> vhdlTypeMark t <> "(1 to value'length) is value;" <$>
"variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi
) <$>
"begin" <$>
indent 2
("for i in ivalue'range loop" <$>
indent 2
( "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+>
"to i*" <> int (typeSize elTy)) <+>
":=" <+> (case syn of
Vivado -> "ivalue" <> parens ("i")
_ -> "toSLV" <> parens ("ivalue" <> parens ("i"))) <> semi
) <$>
"end" <+> "loop" <> semi <$>
"return" <+> "result" <> semi
) <$>
"end" <> semi
)
funDec _ (BitVector _) = Just slvToSlvDec
funDec _ (SP _ _) = Just slvToSlvDec
funDec _ _ = Nothing
unsignedToSlvDec :: (VHDLM Doc, VHDLM Doc)
unsignedToSlvDec =
( "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <> semi
, "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <+> "is" <$>
"begin" <$>
indent 2 ("return" <+> "std_logic_vector" <> parens ("u") <> semi) <$>
"end" <> semi
)
slvToSlvDec :: (VHDLM Doc, VHDLM Doc)
slvToSlvDec =
( "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi
, "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <$>
"begin" <$>
indent 2 ("return" <+> "slv" <> semi) <$>
"end" <> semi
)
tyImports :: String -> VHDLM Doc
tyImports nm = do
mkId <- mkBasicId
punctuate' semi $ sequence
[ "library IEEE"
, "use IEEE.STD_LOGIC_1164.ALL"
, "use IEEE.NUMERIC_STD.ALL"
, "use IEEE.MATH_REAL.ALL"
, "use std.textio.all"
, "use work.all"
, "use work." <+> text (mkId (T.pack nm `T.append` "_types")) <> ".all"
]
entity :: Component -> VHDLM Doc
entity c = do
rec (p,ls) <- fmap unzip (ports (maximum ls))
"entity" <+> text (componentName c) <+> "is" <$>
(case p of
[] -> empty
_ -> indent 2 ("port" <>
parens (align $ vcat $ punctuate semi (A.pure p)) <>
semi)
) <$>
"end" <> semi
where
ports l = sequence
$ [ (,fromIntegral $ T.length i) A.<$> (encodingNote ty <$> fill l (text i) <+> colon <+> "in" <+> vhdlType ty)
| (i,ty) <- inputs c ] ++
[ (,fromIntegral $ T.length i) A.<$> (encodingNote ty <$> fill l (text i) <+> colon <+> "in" <+> vhdlType ty)
| (i,ty) <- hiddenPorts c ] ++
[ (,fromIntegral $ T.length i) A.<$> (encodingNote ty <$> fill l (text i) <+> colon <+> "out" <+> vhdlType ty)
| (i,ty) <- outputs c ]
architecture :: Component -> VHDLM Doc
architecture c =
nest 2
("architecture structural of" <+> text (componentName c) <+> "is" <$$>
decls (declarations c)) <$$>
nest 2
("begin" <$$>
insts (declarations c)) <$$>
"end" <> semi
vhdlType :: HWType -> VHDLM Doc
vhdlType hwty = do
tyCache %= HashSet.insert hwty
vhdlType' hwty
vhdlType' :: HWType -> VHDLM Doc
vhdlType' Bool = "boolean"
vhdlType' (Clock _ _) = "std_logic"
vhdlType' (Reset _ _) = "std_logic"
vhdlType' (BitVector n) = case n of
0 -> "std_logic_vector (0 downto 1)"
_ -> "std_logic_vector" <> parens (int (n1) <+> "downto 0")
vhdlType' (Index u) = "unsigned" <> parens (int (clog2 (max 2 u) 1) <+> "downto 0")
vhdlType' (Signed n) = if n == 0 then "signed (0 downto 1)"
else "signed" <> parens (int (n1) <+> "downto 0")
vhdlType' (Unsigned n) = if n == 0 then "unsigned (0 downto 1)"
else "unsigned" <> parens ( int (n1) <+> "downto 0")
vhdlType' (Vector n elTy) = do
nm <- use modNm
text (T.toLower $ T.pack nm) <> "_types.array_of_" <> tyName elTy <> parens ("0 to " <> int (n1))
vhdlType' t@(SP _ _) = "std_logic_vector" <> parens (int (typeSize t 1) <+> "downto 0")
vhdlType' t@(Sum _ _) = case typeSize t of
0 -> "unsigned (0 downto 1)"
n -> "unsigned" <> parens (int (n 1) <+> "downto 0")
vhdlType' t@(Product _ _) = do
nm <- use modNm
text (T.toLower $ T.pack nm) <> "_types." <> tyName t
vhdlType' Void = "std_logic_vector" <> parens (int (1) <+> "downto 0")
vhdlType' String = "string"
sigDecl :: VHDLM Doc -> HWType -> VHDLM Doc
sigDecl d t = d <+> colon <+> vhdlType t
vhdlTypeMark :: HWType -> VHDLM Doc
vhdlTypeMark hwty = do
tyCache %= HashSet.insert hwty
vhdlTypeMark' hwty
where
vhdlTypeMark' Bool = "boolean"
vhdlTypeMark' (Clock _ _) = "std_logic"
vhdlTypeMark' (Reset _ _) = "std_logic"
vhdlTypeMark' (BitVector _) = "std_logic_vector"
vhdlTypeMark' (Index _) = "unsigned"
vhdlTypeMark' (Signed _) = "signed"
vhdlTypeMark' (Unsigned _) = "unsigned"
vhdlTypeMark' (Vector _ elTy) = do
nm <- use modNm
text (T.toLower $ T.pack nm) <> "_types.array_of_" <> tyName elTy
vhdlTypeMark' (SP _ _) = "std_logic_vector"
vhdlTypeMark' (Sum _ _) = "unsigned"
vhdlTypeMark' t@(Product _ _) = do
nm <- use modNm
text (T.toLower $ T.pack nm) <> "_types." <> tyName t
vhdlTypeMark' t = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t
tyName :: HWType -> VHDLM Doc
tyName Bool = "boolean"
tyName (Clock _ _) = "std_logic"
tyName (Reset _ _) = "std_logic"
tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy
tyName (BitVector n) = "std_logic_vector_" <> int n
tyName t@(Index _) = "unsigned_" <> int (typeSize t)
tyName (Signed n) = "signed_" <> int n
tyName (Unsigned n) = "unsigned_" <> int n
tyName t@(Sum _ _) = "unsigned_" <> int (typeSize t)
tyName t@(Product nm _) = makeCached t nameCache prodName
where
prodName = do
seen <- use tySeen
mkId <- mkBasicId
let nm' = (mkId . last . T.splitOn ".") nm
nm'' = if T.null nm'
then "product"
else nm'
nm3 = if nm'' `elem` seen
then go mkId seen (0::Integer) nm''
else nm''
tySeen %= (nm3:)
text nm3
go mkId s i n =
let n' = n `T.append` T.pack ('_':show i)
in if n' `elem` s
then go mkId s (i+1) n
else n'
tyName t@(SP _ _) = "std_logic_vector_" <> int (typeSize t)
tyName _ = empty
vhdlTypeErrValue :: HWType -> VHDLM Doc
vhdlTypeErrValue Bool = "true"
vhdlTypeErrValue t@(Vector n elTy) = do
syn <-hdlSyn
case syn of
Vivado -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (n1) <+> rarrow <+>
"std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy 1) <+>
rarrow <+> "'X'"))
_ -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (n1) <+> rarrow <+> vhdlTypeErrValue elTy)
vhdlTypeErrValue t@(Product _ elTys) = vhdlTypeMark t <> "'" <> tupled (mapM vhdlTypeErrValue elTys)
vhdlTypeErrValue (Reset _ _) = "'X'"
vhdlTypeErrValue (Clock _ _) = "'X'"
vhdlTypeErrValue Void = "std_logic_vector'(0 downto 1 => 'X')"
vhdlTypeErrValue String = "\"ERROR\""
vhdlTypeErrValue t = vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (typeSize t 1) <+> rarrow <+> "'X'")
decls :: [Declaration] -> VHDLM Doc
decls [] = empty
decls ds = do
rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds
case dsDoc of
[] -> empty
_ -> punctuate' semi (A.pure dsDoc)
decl :: Int -> Declaration -> VHDLM (Maybe (Doc,Int))
decl l (NetDecl id_ ty) = Just A.<$> (,fromIntegral (T.length id_)) A.<$>
"signal" <+> fill l (text id_) <+> colon <+> vhdlType ty
decl _ _ = return Nothing
insts :: [Declaration] -> VHDLM Doc
insts [] = empty
insts is = vcat . punctuate linebreak . fmap catMaybes $ mapM inst_ is
inst_ :: Declaration -> VHDLM (Maybe Doc)
inst_ (Assignment id_ e) = fmap Just $
text id_ <+> larrow <+> expr_ False e <> semi
inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $
text id_ <+> larrow
<+> align (vsep (sequence [expr_ False t <+> "when" <+>
expr_ False scrut <+> "else"
,expr_ False f <> semi
]))
where
(t,f) = if b then (l,r) else (r,l)
inst_ (CondAssignment id_ _ scrut scrutTy es) = fmap Just $
"with" <+> parens (expr_ True scrut) <+> "select" <$>
indent 2 (text id_ <+> larrow <+> align (vcat (punctuate comma (conds esNub)) <> semi))
where
esMod = map (first (fmap (patMod scrutTy))) es
esNub = nubBy ((==) `on` fst) esMod
conds :: [(Maybe Literal,Expr)] -> VHDLM [Doc]
conds [] = return []
conds [(_,e)] = expr_ False e <+> "when" <+> "others" <:> return []
conds ((Nothing,e):_) = expr_ False e <+> "when" <+> "others" <:> return []
conds ((Just c ,e):es') = expr_ False e <+> "when" <+> patLit scrutTy c <:> conds es'
inst_ (InstDecl nm lbl pms) = fmap Just $
nest 2 $ text lbl <+> colon <+> "entity"
<+> text nm <$$> pms' <> semi
where
pms' = do
rec (p,ls) <- fmap unzip $ sequence [ (,fromIntegral (T.length i)) A.<$> fill (maximum ls) (text i) <+> "=>" <+> expr_ False e | (i,_,_,e) <- pms]
nest 2 $ "port map" <$$> tupled (A.pure p)
inst_ (BlackBoxD _ bs bbCtx) = do t <- renderBlackBox bs bbCtx
fmap Just (string t)
inst_ _ = return Nothing
expr_ :: Bool
-> Expr
-> VHDLM Doc
expr_ _ (Literal sizeM lit) = exprLit sizeM lit
expr_ _ (Identifier id_ Nothing) = text id_
expr_ _ (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = fromSLV argTy id_ start end
where
argTys = snd $ args !! dcI
argTy = argTys !! fI
argSize = typeSize argTy
other = otherSize argTys (fI1)
start = typeSize ty 1 conSize ty other
end = start argSize + 1
expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ _),_,fI)))) =
text id_ <> dot <> tyName ty <> "_sel" <> int fI
expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,1)))) = do
syn <- hdlSyn
case syn of
Vivado -> do
id' <- fmap (displayT . renderOneLine) (text id_ <> parens (int 0))
fromSLV elTy id' (typeSize elTy 1) 0
_ -> text id_ <> parens (int 0)
expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,2)))) = text id_ <> parens (int 1 <+> "to" <+> int (n1))
expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),10,fI)))) = do
syn <- hdlSyn
case syn of
Vivado -> do
id' <- fmap (displayT . renderOneLine) (text id_ <> parens (int fI))
fromSLV elTy id' (typeSize elTy 1) 0
_ -> text id_ <> parens (int fI)
expr_ _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = text id_ <> parens (int start <+> "downto" <+> int end)
where
start = typeSize ty 1
end = typeSize ty conSize ty
expr_ _ (Identifier id_ (Just (Indexed ((Signed _ ),_,_)))) = do
iw <- use intWidth
"resize" <> parens (text id_ <> "," <> int iw)
expr_ _ (Identifier id_ (Just (Indexed ((Unsigned _),_,_)))) = do
iw <- use intWidth
"resize" <> parens (text id_ <> "," <> int iw)
expr_ _ (Identifier id_ (Just _)) = text id_
expr_ b (DataCon _ (DC (Void, 1)) [e]) = expr_ b e
expr_ _ (DataCon (Vector 0 _) _ _) =
error $ $(curLoc) ++ "VHDL: Trying to create a Nil vector."
expr_ _ (DataCon ty@(Vector 1 elTy) _ [e]) = do
syn <- hdlSyn
case syn of
Vivado -> vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> toSLV elTy e)
_ -> vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> expr_ False e)
expr_ _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = do
syn <- hdlSyn
case syn of
Vivado -> vhdlTypeMark ty <> "'" <> case vectorChain e of
Just es -> tupled (mapM (toSLV elTy) es)
Nothing -> parens ("std_logic_vector'" <> parens (toSLV elTy e1) <+> "&" <+> expr_ False e2)
_ -> vhdlTypeMark ty <> "'" <> case vectorChain e of
Just es -> tupled (mapM (expr_ False) es)
Nothing -> parens (vhdlTypeMark elTy <> "'" <> parens (expr_ False e1) <+> "&" <+> expr_ False e2)
expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr
where
argTys = snd $ args !! i
dcSize = conSize ty + sum (map typeSize argTys)
dcExpr = expr_ False (dcToExpr ty i)
argExprs = zipWith toSLV argTys es
extraArg = case typeSize ty dcSize of
0 -> []
n -> [exprLit (Just (ty,n)) (NumLit 0)]
assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg))
expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = "to_unsigned" <> tupled (sequence [int i,int (typeSize ty)])
expr_ _ (DataCon ty@(Product _ _) _ es) =
tupled $ zipWithM (\i e' -> tyName ty <> "_sel" <> int i <+> rarrow <+> expr_ False e') [0..] es
expr_ _ (BlackBoxE pNm _ bbCtx _)
| pNm == "CLaSH.Sized.Internal.Signed.fromInteger#"
, [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx
= exprLit (Just (Signed (fromInteger n),fromInteger n)) i
expr_ _ (BlackBoxE pNm _ bbCtx _)
| pNm == "CLaSH.Sized.Internal.Unsigned.fromInteger#"
, [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx
= exprLit (Just (Unsigned (fromInteger n),fromInteger n)) i
expr_ _ (BlackBoxE pNm _ bbCtx _)
| pNm == "CLaSH.Sized.Internal.BitVector.fromInteger#"
, [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx
= exprLit (Just (BitVector (fromInteger n),fromInteger n)) i
expr_ _ (BlackBoxE pNm _ bbCtx _)
| pNm == "GHC.Types.I#"
, [Literal _ (NumLit n)] <- extractLiterals bbCtx
= do iw <- use intWidth
exprLit (Just (Signed iw,iw)) (NumLit n)
expr_ _ (BlackBoxE pNm _ bbCtx _)
| pNm == "GHC.Types.W#"
, [Literal _ (NumLit n)] <- extractLiterals bbCtx
= do iw <- use intWidth
exprLit (Just (Unsigned iw,iw)) (NumLit n)
expr_ b (BlackBoxE _ bs bbCtx b') = do
t <- renderBlackBox bs bbCtx
parenIf (b || b') $ string t
expr_ _ (DataTag Bool (Left id_)) = "tagToEnum" <> parens (text id_)
expr_ _ (DataTag Bool (Right id_)) = "dataToTag" <> parens (text id_)
expr_ _ (DataTag hty@(Sum _ _) (Left id_)) =
"resize" <> parens ("unsigned" <> parens ("std_logic_vector" <> parens (text id_)) <> "," <> int (typeSize hty))
expr_ _ (DataTag (Sum _ _) (Right id_)) = do
iw <- use intWidth
"signed" <> parens ("std_logic_vector" <> parens ("resize" <> parens (text id_ <> "," <> int iw)))
expr_ _ (DataTag (Product _ _) (Right _)) = do
iw <- use intWidth
"to_signed" <> parens (int 0 <> "," <> int iw)
expr_ _ (DataTag hty@(SP _ _) (Right id_)) = do {
; iw <- use intWidth
; "signed" <> parens ("std_logic_vector" <> parens (
"resize" <> parens ("unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))
<> "," <> int iw)))
}
where
start = typeSize hty 1
end = typeSize hty conSize hty
expr_ _ (DataTag (Vector 0 _) (Right _)) = do
iw <- use intWidth
"to_signed" <> parens (int 0 <> "," <> int iw)
expr_ _ (DataTag (Vector _ _) (Right _)) = do
iw <- use intWidth
"to_signed" <> parens (int 1 <> "," <> int iw)
expr_ _ e = error $ $(curLoc) ++ (show e)
otherSize :: [HWType] -> Int -> Int
otherSize _ n | n < 0 = 0
otherSize [] _ = 0
otherSize (a:as) n = typeSize a + otherSize as (n1)
vectorChain :: Expr -> Maybe [Expr]
vectorChain (DataCon (Vector 0 _) _ _) = Just []
vectorChain (DataCon (Vector 1 _) _ [e]) = Just [e]
vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2
vectorChain _ = Nothing
exprLit :: Maybe (HWType,Size) -> Literal -> VHDLM Doc
exprLit Nothing (NumLit i) = integer i
exprLit (Just (hty,sz)) (NumLit i) = case hty of
Unsigned n
| i < 2^(31 :: Integer) -> "to_unsigned" <> parens (integer i <> "," <> int n)
| otherwise -> "unsigned'" <> parens blit
Signed n
| i < 2^(31 :: Integer) && i > (2^(31 :: Integer)) -> "to_signed" <> parens (integer i <> "," <> int n)
| otherwise -> "signed'" <> parens blit
BitVector _ -> "std_logic_vector'" <> parens blit
_ -> blit
where
blit = bits (toBits sz i)
exprLit _ (BoolLit t) = if t then "true" else "false"
exprLit _ (BitLit b) = squotes $ bit_char b
exprLit _ (StringLit s) = text . T.pack $ show s
exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l
patLit :: HWType -> Literal -> VHDLM Doc
patLit hwTy (NumLit i) = bits (toBits (conSize hwTy) i)
patLit _ l = exprLit Nothing l
patMod :: HWType -> Literal -> Literal
patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy))
patMod _ l = l
toBits :: Integral a => Int -> a -> [Bit]
toBits size val = map (\x -> if odd x then H else L)
$ reverse
$ take size
$ map (`mod` 2)
$ iterate (`div` 2) val
bits :: [Bit] -> VHDLM Doc
bits = dquotes . hcat . mapM bit_char
bit_char :: Bit -> VHDLM Doc
bit_char H = char '1'
bit_char L = char '0'
bit_char U = char 'U'
bit_char Z = char 'Z'
toSLV :: HWType -> Expr -> VHDLM Doc
toSLV Bool e = do
nm <- use modNm
text (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e)
toSLV (BitVector _) e = expr_ False e
toSLV (Signed _) e = "std_logic_vector" <> parens (expr_ False e)
toSLV (Unsigned _) e = "std_logic_vector" <> parens (expr_ False e)
toSLV (Index _) e = "std_logic_vector" <> parens (expr_ False e)
toSLV (Sum _ _) e = "std_logic_vector" <> parens (expr_ False e)
toSLV t@(Product _ tys) (Identifier id_ Nothing) = do
selIds' <- sequence selIds
encloseSep lparen rparen " & " (zipWithM toSLV tys selIds')
where
tName = tyName t
selNames = map (fmap (displayT . renderOneLine) ) [text id_ <> dot <> tName <> "_sel" <> int i | i <- [0..(length tys)1]]
selIds = map (fmap (\n -> Identifier n Nothing)) selNames
toSLV (Product _ tys) (DataCon _ _ es) = do
encloseSep lparen rparen " & " (zipWithM toSLV tys es)
toSLV (SP _ _) e = expr_ False e
toSLV (Vector n elTy) (Identifier id_ Nothing) = do
selIds' <- sequence selIds
syn <- hdlSyn
parens (vcat $ punctuate " & "
(case syn of
Vivado -> mapM (expr_ False) selIds'
_ -> mapM (toSLV elTy) selIds'))
where
selNames = map (fmap (displayT . renderOneLine) ) $ [text id_ <> parens (int i) | i <- [0 .. (n1)]]
selIds = map (fmap (`Identifier` Nothing)) selNames
toSLV (Vector n elTy) (DataCon _ _ es) = parens $ vcat $ punctuate " & " (zipWithM toSLV [elTy,Vector (n1) elTy] es)
toSLV (Vector _ _) e = "toSLV" <> parens (expr_ False e)
toSLV hty e = error $ $(curLoc) ++ "toSLV: ty:" ++ show hty ++ "\n expr: " ++ show e
fromSLV :: HWType -> Identifier -> Int -> Int -> VHDLM Doc
fromSLV Bool id_ start _ = do
nm <- use modNm
text (T.toLower $ T.pack nm) <> "_types.fromSLV" <> parens (text id_ <> parens (int start <+> "downto" <+> int start))
fromSLV (BitVector _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end)
fromSLV (Index _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))
fromSLV (Signed _) id_ start end = "signed" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))
fromSLV (Unsigned _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))
fromSLV (Sum _ _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))
fromSLV t@(Product _ tys) id_ start _ = do
tupled $ zipWithM (\s e -> s <+> rarrow <+> e) selNames args
where
tName = tyName t
selNames = [tName <> "_sel" <> int i | i <- [0..]]
argLengths = map typeSize tys
starts = start : snd (mapAccumL ((join (,) .) . ()) start argLengths)
ends = map (+1) (tail starts)
args = zipWith3 (`fromSLV` id_) tys starts ends
fromSLV (SP _ _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end)
fromSLV (Vector n elTy) id_ start _ =
if n > 1 then tupled args
else parens (int 0 <+> rarrow <+> fmap head args)
where
argLength = typeSize elTy
starts = take (n + 1) $ iterate (subtract argLength) start
ends = map (+1) (tail starts)
args = do syn <- hdlSyn
let elTy' = case syn of
Vivado -> BitVector (argLength 1)
_ -> elTy
zipWithM (fromSLV elTy' id_) starts ends
fromSLV hty _ _ _ = error $ $(curLoc) ++ "fromSLV: " ++ show hty
dcToExpr :: HWType -> Int -> Expr
dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i))
larrow :: VHDLM Doc
larrow = "<="
rarrow :: VHDLM Doc
rarrow = "=>"
parenIf :: Monad m => Bool -> m Doc -> m Doc
parenIf True = parens
parenIf False = id
punctuate' :: Monad m => m Doc -> m [Doc] -> m Doc
punctuate' s d = vcat (punctuate s d) <> s
encodingNote :: HWType -> VHDLM Doc
encodingNote (Clock _ _) = "-- clock"
encodingNote (Reset _ _) = "-- asynchronous reset: active low"
encodingNote _ = empty