{-| Copyright : (C) 2015-2016, University of Twente, 2017, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij Generate VHDL for assorted Netlist datatypes -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Clash.Backend.VHDL (VHDLState) where import Control.Applicative (liftA2) 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,nub,nubBy) import Data.Maybe (catMaybes,fromMaybe,mapMaybe) #if !MIN_VERSION_base(4,11,0) import Data.Monoid hiding (Sum, Product) #endif import Data.Semigroup.Monad.Extra import Data.Text.Lazy (unpack) import qualified Data.Text.Lazy as T import Data.Text.Prettyprint.Doc.Extra import qualified System.FilePath import Text.Printf import Clash.Annotations.Primitive (HDL (..)) import Clash.Backend import Clash.Driver.Types (SrcSpan, noSrcSpan) import Clash.Netlist.BlackBox.Types (HdlSyn (..)) import Clash.Netlist.BlackBox.Util (extractLiterals, renderBlackBox) import Clash.Netlist.Id (IdType (..), mkBasicId') import Clash.Netlist.Types hiding (_intWidth, intWidth) import Clash.Netlist.Util hiding (mkIdentifier) import Clash.Signal.Internal (ClockKind (..)) import Clash.Util (clogBase, curLoc, first, makeCached, on, (<:>)) #ifdef CABAL import qualified Paths_clash_lib #endif -- | State for the 'Clash.Netlist.VHDL.VHDLM' monad: data VHDLState = VHDLState { _tyCache :: (HashSet HWType) -- ^ Previously encountered HWTypes , _tySeen :: [Identifier] -- ^ Generated product types , _nameCache :: (HashMap HWType Doc) -- ^ Cache for previously generated product type names , _modNm :: String , _srcSpan :: SrcSpan , _libraries :: [T.Text] , _packages :: [T.Text] , _includes :: [(String,Doc)] , _intWidth :: Int -- ^ Int/Word/Integer bit-width , _hdlsyn :: HdlSyn -- ^ For which HDL synthesis tool are we generating VHDL } makeLenses ''VHDLState primsRoot :: IO FilePath #ifdef CABAL primsRoot = Paths_clash_lib.getDataFileName "prims" #else primsRoot = return ("clash-lib" System.FilePath. "prims") #endif instance Backend VHDLState where initBackend = VHDLState HashSet.empty [] HashMap.empty "" noSrcSpan [] [] [] hdlKind = const VHDL primDirs = const $ do root <- primsRoot return [ root System.FilePath. "common" , root System.FilePath. "vhdl" ] extractTypes = _tyCache name = const "vhdl" extension = const ".vhdl" genHDL = genVHDL mkTyPackage = mkTyPackage_ hdlType Internal ty = vhdlType ty hdlType (External nm) ty = case ty of Vector _ _ -> pretty nm <> dot <> vhdlType ty RTree _ _ -> pretty nm <> dot <> vhdlType ty Product _ _ -> pretty nm <> dot <> vhdlType ty _ -> vhdlType ty hdlTypeErrValue = vhdlTypeErrValue hdlTypeMark = vhdlTypeMark hdlRecSel = vhdlRecSel hdlSig t ty = sigDecl (pretty t) ty genStmt = const emptyDoc inst = inst_ expr = expr_ iwWidth = use intWidth toBV _ id_ = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (pretty id_) fromBV _ id_ = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.fromSLV" <> parens (pretty id_) hdlSyn = use hdlsyn mkIdentifier = return go where go Basic nm = filterReserved (T.toLower (mkBasicId' True nm)) go Extended (rmSlash -> nm) = case go Basic nm of nm' | nm /= nm' -> T.concat ["\\",nm,"\\"] |otherwise -> nm' extendIdentifier = return go where go Basic nm ext = filterReserved (T.toLower (mkBasicId' True (nm `T.append` ext))) go Extended ((rmSlash . escapeTemplate) -> nm) ext = let nmExt = nm `T.append` ext in case go Basic nm ext of nm' | nm' /= nmExt -> case T.head nmExt of '#' -> T.concat ["\\",nmExt,"\\"] _ -> T.concat ["\\#",nmExt,"\\"] | otherwise -> nm' setModName nm s = s {_modNm = nm} setSrcSpan = (srcSpan .=) getSrcSpan = use srcSpan blockDecl nm ds = do decs <- decls ds if isEmpty decs then insts ds else nest 2 (pretty nm <+> colon <+> "block" <> line <> pure decs) <> line <> nest 2 ("begin" <> line <> insts ds) <> line <> "end block" <> semi unextend = return rmSlash addInclude inc = includes %= (inc:) addLibraries libs = libraries %= (libs ++) addImports imps = packages %= (imps ++) rmSlash :: Identifier -> Identifier rmSlash nm = fromMaybe nm $ do nm1 <- T.stripPrefix "\\" nm pure (T.filter (not . (== '\\')) nm1) type VHDLM a = Mon (State VHDLState) a -- List of reserved VHDL-2008 keywords -- + used internal names: toslv, fromslv, tagtoenum, datatotag -- + used IEEE library names: integer, boolean, std_logic, std_logic_vector, -- signed, unsigned, to_integer, to_signed, to_unsigned, string 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 -- | Generate VHDL for a Netlist component genVHDL :: String -> SrcSpan -> Component -> VHDLM ((String,Doc),[(String,Doc)]) genVHDL nm sp c = do Mon $ setSrcSpan sp v <- vhdl i <- Mon $ use includes Mon $ libraries .= [] Mon $ packages .= [] return ((unpack cName,v),i) where cName = componentName c vhdl = do ent <- entity c arch <- architecture c imps <- tyImports nm ("-- Automatically generated VHDL-93" <> line <> pure imps <> line <> line <> pure ent <> line <> line <> pure arch) -- | Generate a VHDL package containing type definitions for the given HWTypes mkTyPackage_ :: String -> [HWType] -> VHDLM [(String,Doc)] mkTyPackage_ modName hwtys = do { syn <- Mon hdlSyn ; mkId <- Mon (mkIdentifier <*> pure Basic) ; let usedTys = concatMap mkUsedTys hwtys ; normTys <- nub <$> mapM (fmap mkVecZ . normaliseType) (hwtys ++ usedTys) ; let sortedTys = topSortHWTys normTys packageDec = vcat $ mapM tyDec sortedTys (funDecs,funBodies) = unzip . mapMaybe (funDec syn) $ nubBy eqTypM sortedTys ; (:[]) <$> (unpack $ mkId (T.pack modName `T.append` "_types"),) <$> "library IEEE;" <> line <> "use IEEE.STD_LOGIC_1164.ALL;" <> line <> "use IEEE.NUMERIC_STD.ALL;" <> line <> line <> "package" <+> pretty (mkId (T.pack modName `T.append` "_types")) <+> "is" <> line <> indent 2 ( packageDec <> line <> vcat (sequence funDecs) ) <> line <> "end" <> semi <> packageBodyDec funBodies } where packageBodyDec :: [VHDLM Doc] -> VHDLM Doc packageBodyDec funBodies = case funBodies of [] -> emptyDoc _ -> do { mkId <- Mon (mkIdentifier <*> pure Basic) ; line <> line <> "package" <+> "body" <+> pretty (mkId (T.pack modName `T.append` "_types")) <+> "is" <> line <> indent 2 (vcat (sequence funBodies)) <> line <> "end" <> semi } eqTypM :: HWType -> HWType -> Bool eqTypM (Signed _) (Signed _) = True eqTypM (Unsigned _) (Unsigned _) = True eqTypM (BitVector _) (BitVector _) = True eqTypM (Clock _ _ g) (Clock _ _ g') = g == g' eqTypM ty1 ty2 = ty1 == ty2 mkUsedTys :: HWType -> [HWType] mkUsedTys v@(Vector _ elTy) = v : mkUsedTys elTy mkUsedTys v@(RTree _ 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@(RTree _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "RTree") 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 _ = [] normaliseType :: HWType -> VHDLM HWType normaliseType (Vector n ty) = Vector n <$> (normaliseType ty) normaliseType (RTree d ty) = RTree d <$> (normaliseType ty) normaliseType (Product nm tys) = Product nm <$> (mapM normaliseType tys) normaliseType ty@(SP _ elTys) = do Mon $ mapM_ ((tyCache %=) . HashSet.insert) (concatMap snd elTys) return (BitVector (typeSize ty)) normaliseType ty@(Index _) = return (Unsigned (typeSize ty)) normaliseType ty@(Sum _ _) = return (BitVector (typeSize ty)) normaliseType (Clock _ _ Gated) = return (Product "GatedClock" [Bit,Bool]) normaliseType (Clock {}) = return Bit normaliseType (Reset {}) = return Bit normaliseType ty = return ty mkVecZ :: HWType -> HWType mkVecZ (Vector _ elTy) = Vector 0 elTy mkVecZ (RTree _ elTy) = RTree 0 elTy mkVecZ t = t tyDec :: HWType -> VHDLM Doc tyDec (Vector _ elTy) = do syn <- Mon 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 (RTree _ elTy) = do syn <- Mon hdlSyn case syn of Vivado -> "type" <+> "tree_of_" <> tyName elTy <+> "is array (integer range <>) of" <+> "std_logic_vector" <> parens (int (typeSize elTy - 1) <+> "downto 0") <> semi _ -> "type" <+> "tree_of_" <> tyName elTy <+> "is array (integer range <>) of" <+> vhdlType elTy <> semi tyDec ty@(Product _ tys@(_:_:_)) = prodDec where prodDec = "type" <+> tName <+> "is record" <> line <> indent 2 (vcat $ zipWithM (\x y -> x <+> colon <+> y <> semi) selNames selTys) <> line <> "end record" <> semi tName = tyName ty selNames = map (\i -> tName <> "_sel" <> int i) [0..] selTys = map vhdlType tys tyDec _ = emptyDoc funDec :: HdlSyn -> HWType -> Maybe (VHDLM Doc,VHDLM Doc) funDec _ Bool = Just ( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <> semi <> line <> "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <> semi <> line <> "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <> semi , "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> 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 ]) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <+> "is" <> line <> "begin" <> line <> indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then" , indent 2 ("return" <+> "true" <> semi) ,"else" , indent 2 ("return" <+> "false" <> semi) ,"end" <+> "if" <> semi ]) <> line <> "end" <> semi <> line <> "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <+> "is" <> line <> "begin" <> line <> indent 2 (vcat $ sequence ["if" <+> "s" <+> "=" <+> "to_signed" <> parens (int 0 <> comma <> (Mon (use intWidth) >>= int)) <+> "then" , indent 2 ("return" <+> "false" <> semi) ,"else" , indent 2 ("return" <+> "true" <> semi) ,"end" <+> "if" <> semi ]) <> line <> "end" <> semi <> line <> "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <+> "is" <> line <> "begin" <> line <> indent 2 (vcat $ sequence ["if" <+> "b" <+> "then" , indent 2 ("return" <+> "to_signed" <> parens (int 1 <> comma <> (Mon (use intWidth) >>= int)) <> semi) ,"else" , indent 2 ("return" <+> "to_signed" <> parens (int 0 <> comma <> (Mon (use intWidth) >>= int)) <> semi) ,"end" <+> "if" <> semi ]) <> line <> "end" <> semi ) funDec _ Bit = Just ( "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic" <> semi , "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "std_logic_vector'" <> parens (int 0 <+> rarrow <+> "sl") <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic" <+> "is" <> line <> indent 2 ( "alias islv : std_logic_vector (0 to slv'length - 1) is slv;" ) <> line <> "begin" <> line <> indent 2 ("return" <+> "islv" <> parens (int 0) <> semi) <> line <> "end" <> semi ) funDec _ (Signed _) = Just ( "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <> semi , "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "std_logic_vector" <> parens ("s") <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "signed" <> parens ("slv") <> semi) <> line <> "end" <> semi ) funDec _ (Unsigned _) = Just ( "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <> semi , "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "std_logic_vector" <> parens ("u") <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "unsigned" <> parens ("slv") <> semi) <> line <> "end" <> semi ) funDec _ t@(Product _ elTys) = Just ( "function" <+> "toSLV" <+> parens ("p :" <+> vhdlType t) <+> "return std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlType t <> semi , "function" <+> "toSLV" <+> parens ("p :" <+> vhdlType t) <+> "return std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> parens (hcat (punctuate " & " elTyToSLV)) <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlType t <+> "is" <> line <> "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <> "begin" <> line <> indent 2 ("return" <+> parens (hcat (punctuate "," elTyFromSLV)) <> semi) <> line <> "end" <> semi ) where elTyToSLV = forM [0..(length elTys - 1)] (\i -> "toSLV" <> parens ("p." <> tyName t <> "_sel" <> int i)) argLengths = map typeSize elTys starts = 0 : snd (mapAccumL ((join (,) .) . (+)) 0 argLengths) ends = map (subtract 1) (tail starts) elTyFromSLV = forM (zip starts ends) (\(s,e) -> "fromSLV" <> parens ("islv" <> parens (int s <+> "to" <+> int e))) funDec syn t@(Vector _ elTy) = Just ( "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <> semi , "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <+> "is" <> line <> indent 2 ( "alias ivalue :" <+> vhdlTypeMark t <> "(1 to value'length) is value;" <> line <> "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in ivalue'range loop" <> line <> 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 ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <+> "is" <> line <> indent 2 ( "alias islv :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <> "variable result :" <+> vhdlTypeMark t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in result'range loop" <> line <> indent 2 ( "result" <> parens "i" <+> ":=" <+> case syn of Vivado -> getElem <> semi _ | BitVector _ <- elTy -> getElem <> semi | otherwise -> "fromSLV" <> parens getElem <> semi ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi ) where eSz = int (typeSize elTy) getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1") funDec _ (BitVector _) = Just ( "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> 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" <> line <> "begin" <> line <> indent 2 ("return" <+> "slv" <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "slv" <> semi) <> line <> "end" <> semi ) funDec syn t@(RTree _ elTy) = Just ( "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <> semi , "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <+> "is" <> line <> indent 2 ( "alias ivalue :" <+> vhdlTypeMark t <> "(1 to value'length) is value;" <> line <> "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in ivalue'range loop" <> line <> 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 ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <+> "is" <> line <> indent 2 ( "alias islv :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <> "variable result :" <+> vhdlTypeMark t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in result'range loop" <> line <> indent 2 ( "result" <> parens "i" <+> ":=" <+> case syn of Vivado -> getElem <> semi _ | BitVector _ <- elTy -> getElem <> semi | otherwise -> "fromSLV" <> parens getElem <> semi ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi ) where eSz = int (typeSize elTy) getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1") funDec _ _ = Nothing tyImports :: String -> VHDLM Doc tyImports nm = do mkId <- Mon (mkIdentifier <*> pure Basic) libs <- Mon $ use libraries packs <- Mon $ use packages 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." <> pretty (mkId (T.pack nm `T.append` "_types")) <> ".all" ] ++ (map (("library" <+>) . pretty) (nub libs)) ++ (map (("use" <+>) . pretty) (nub packs))) entity :: Component -> VHDLM Doc entity c = do rec (p,ls) <- fmap unzip (ports (maximum ls)) "entity" <+> pretty (componentName c) <+> "is" <> line <> (case p of [] -> emptyDoc _ -> indent 2 ("port" <> parens (align $ vcat $ punctuate semi (pure p)) <> semi) ) <> line <> "end" <> semi where ports l = sequence $ [ (,fromIntegral $ T.length i) <$> (encodingNote ty <> fill l (pretty i) <+> colon <+> "in" <+> vhdlType ty) | (i,ty) <- inputs c ] ++ [ (,fromIntegral $ T.length i) <$> (encodingNote ty <> fill l (pretty i) <+> colon <+> "out" <+> vhdlType ty) | (_,(i,ty)) <- outputs c ] architecture :: Component -> VHDLM Doc architecture c = nest 2 ("architecture structural of" <+> pretty (componentName c) <+> "is" <> line <> decls (declarations c)) <> line <> nest 2 ("begin" <> line <> insts (declarations c)) <> line <> "end" <> semi -- | Convert a Netlist HWType to a VHDL type vhdlType :: HWType -> VHDLM Doc vhdlType hwty = do hwty' <- normaliseType hwty Mon (tyCache %= HashSet.insert hwty') go hwty' where go :: HWType -> VHDLM Doc go Bool = "boolean" go Bit = "std_logic" go (Clock {}) = "std_logic" go (Reset {}) = "std_logic" go (BitVector n) = case n of 0 -> "std_logic_vector (0 downto 1)" _ -> "std_logic_vector" <> parens (int (n-1) <+> "downto 0") go (Signed n) = case n of 0 -> "signed (0 downto 1)" _ -> "signed" <> parens (int (n-1) <+> "downto 0") go (Unsigned n) = case n of 0 -> "unsigned (0 downto 1)" _ -> "unsigned" <> parens ( int (n-1) <+> "downto 0") go (Vector n elTy) = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.array_of_" <> tyName elTy <> parens ("0 to " <> int (n-1)) go (RTree d elTy) = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.tree_of_" <> tyName elTy <> parens ("0 to " <> int ((2^d)-1)) go t@(Product _ _) = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types." <> tyName t go (Void {}) = "std_logic_vector (0 downto 1)" go String = "string" go ty = error $ $(curLoc) ++ "vhdlType: type is not normalised: " ++ show ty sigDecl :: VHDLM Doc -> HWType -> VHDLM Doc sigDecl d t = d <+> colon <+> vhdlType t -- | Convert a Netlist HWType to the root of a VHDL type vhdlTypeMark :: HWType -> VHDLM Doc vhdlTypeMark hwty = do hwty' <- normaliseType hwty Mon (tyCache %= HashSet.insert hwty') go hwty' where go Bool = "boolean" go Bit = "std_logic" go (Clock {}) = "std_logic" go (Reset {}) = "std_logic" go (BitVector _) = "std_logic_vector" go (Signed _) = "signed" go (Unsigned _) = "unsigned" go (Vector _ elTy) = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.array_of_" <> tyName elTy go (RTree _ elTy) = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.tree_of_" <> tyName elTy go t@(Product _ _) = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types." <> tyName t go t = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t tyName :: HWType -> VHDLM Doc tyName Bool = "boolean" tyName Bit = "std_logic" tyName (Clock {}) = "std_logic" tyName (Reset {}) = "std_logic" tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy tyName (RTree n elTy) = "tree_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 _ _) = "std_logic_vector_" <> int (typeSize t) tyName t@(Product nm _) = do tN <- normaliseType t Mon $ makeCached tN nameCache prodName where prodName = do tyCache %= HashSet.insert t seen <- use tySeen mkId <- mkIdentifier <*> pure Basic 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:) pretty 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 _ = emptyDoc -- | Convert a Netlist HWType to an error VHDL value for that type vhdlTypeErrValue :: HWType -> VHDLM Doc vhdlTypeErrValue Bool = "true" vhdlTypeErrValue Bit = "'-'" vhdlTypeErrValue t@(Vector n elTy) = do syn <-Mon hdlSyn case syn of Vivado -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+> "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+> rarrow <+> "'-'")) _ -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+> vhdlTypeErrValue elTy) vhdlTypeErrValue t@(RTree n elTy) = do syn <-Mon hdlSyn case syn of Vivado -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+> rarrow <+> "'-'")) _ -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> vhdlTypeErrValue elTy) vhdlTypeErrValue t@(Product _ elTys) = vhdlTypeMark t <> "'" <> tupled (mapM vhdlTypeErrValue elTys) vhdlTypeErrValue (Reset {}) = "'-'" vhdlTypeErrValue (Clock _ _ Source) = "'-'" vhdlTypeErrValue (Clock _ _ Gated) = "('-',false)" vhdlTypeErrValue (Void {}) = "std_logic_vector'(0 downto 1 => '-')" vhdlTypeErrValue String = "\"ERROR\"" vhdlTypeErrValue t = vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (typeSize t - 1) <+> rarrow <+> "'-'") vhdlRecSel :: HWType -> Int -> VHDLM Doc vhdlRecSel ty i = tyName ty <> "_sel" <> int i decls :: [Declaration] -> VHDLM Doc decls [] = emptyDoc decls ds = do rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds case dsDoc of [] -> emptyDoc _ -> punctuate' semi (pure dsDoc) decl :: Int -> Declaration -> VHDLM (Maybe (Doc,Int)) decl l (NetDecl' noteM _ id_ ty) = Just <$> (,fromIntegral (T.length id_)) <$> maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> either pretty vhdlType ty) where addNote n = mappend ("--" <+> pretty n <> line) decl _ _ = return Nothing insts :: [Declaration] -> VHDLM Doc insts [] = emptyDoc insts is = vcat . punctuate line . fmap catMaybes $ mapM inst_ is -- | Turn a Netlist Declaration to a VHDL concurrent block inst_ :: Declaration -> VHDLM (Maybe Doc) inst_ (Assignment id_ e) = fmap Just $ pretty id_ <+> larrow <+> align (expr_ False e) <> semi inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ pretty 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" <> line <> indent 2 (pretty 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 libM nm lbl pms) = do maybe (return ()) (\lib -> Mon (libraries %= (lib:))) libM fmap Just $ nest 2 $ pretty lbl <+> colon <+> "entity" <+> maybe emptyDoc ((<> ".") . pretty) libM <> pretty nm <> line <> pms' <> semi where pms' = do rec (p,ls) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> "=>" <+> expr_ False e | (i,_,_,e) <- pms] nest 2 $ "port map" <> line <> tupled (pure p) formalLength (Identifier i _) = fromIntegral (T.length i) formalLength _ = 0 inst_ (BlackBoxD _ libs imps inc bs bbCtx) = fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx))) inst_ _ = return Nothing -- | Turn a Netlist expression into a VHDL expression expr_ :: Bool -- ^ Enclose in parenthesis? -> Expr -- ^ Expr to convert -> VHDLM Doc expr_ _ (Literal sizeM lit) = exprLit sizeM lit expr_ _ (Identifier id_ Nothing) = pretty 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 (fI-1) start = typeSize ty - 1 - conSize ty - other end = start - argSize + 1 expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ _),_,fI)))) = pretty id_ <> dot <> tyName ty <> "_sel" <> int fI expr_ _ (Identifier id_ (Just (Indexed (ty@(Clock _ _ Gated),_,fI)))) = do ty' <- normaliseType ty pretty id_ <> dot <> tyName ty' <> "_sel" <> int fI expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do syn <- Mon hdlSyn case syn of Vivado -> do id' <- fmap renderOneLine (pretty id_ <> parens (int 0)) fromSLV elTy id' (typeSize elTy - 1) 0 _ -> pretty id_ <> parens (int 0) expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,1)))) = pretty id_ <> parens (int 1 <+> "to" <+> int (n-1)) -- This is a "Hack", we cannot construct trees with a negative depth. This is -- here so that we can recognise merged RTree modifiers. See the code in -- @Clash.Backend.nestM@ which construct these tree modifiers. expr_ _ (Identifier id_ (Just (Indexed (RTree (-1) _,l,r)))) = pretty id_ <> parens (int l <+> "to" <+> int (r-1)) expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 elTy),0,0)))) = do syn <- Mon hdlSyn case syn of Vivado -> do id' <- fmap renderOneLine (pretty id_ <> parens (int 0)) fromSLV elTy id' (typeSize elTy - 1) 0 _ -> pretty id_ <> parens (int 0) expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,0)))) = let z = 2^(n-1) in pretty id_ <> parens (int 0 <+> "to" <+> int (z-1)) expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,1)))) = let z = 2^(n-1) z' = 2^n in pretty id_ <> parens (int z <+> "to" <+> int (z'-1)) -- This is a HACK for Clash.Driver.TopWrapper.mkOutput -- Vector's don't have a 10'th constructor, this is just so that we can -- recognize the particular case expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),10,fI)))) = do syn <- Mon hdlSyn case syn of Vivado -> do id' <- fmap renderOneLine (pretty id_ <> parens (int fI)) fromSLV elTy id' (typeSize elTy - 1) 0 _ -> pretty id_ <> parens (int fI) -- This is a HACK for Clash.Driver.TopWrapper.mkOutput -- RTree's don't have a 10'th constructor, this is just so that we can -- recognize the particular case expr_ _ (Identifier id_ (Just (Indexed ((RTree _ elTy),10,fI)))) = do syn <- Mon hdlSyn case syn of Vivado -> do id' <- fmap renderOneLine (pretty id_ <> parens (int fI)) fromSLV elTy id' (typeSize elTy - 1) 0 _ -> pretty id_ <> parens (int fI) expr_ _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = pretty 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 <- Mon $ use intWidth "resize" <> parens (pretty id_ <> "," <> int iw) expr_ _ (Identifier id_ (Just (Indexed ((Unsigned _),_,_)))) = do iw <- Mon $ use intWidth "resize" <> parens (pretty id_ <> "," <> int iw) expr_ b (Identifier id_ (Just (Nested m1 m2))) = case nestM m1 m2 of Just m3 -> expr_ b (Identifier id_ (Just m3)) _ -> do k <- expr_ b (Identifier id_ (Just m1)) expr_ b (Identifier (renderOneLine k) (Just m2)) expr_ _ (Identifier id_ (Just _)) = pretty id_ expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e expr_ _ (DataCon ty@(Vector 0 _) _ _) = vhdlTypeErrValue ty expr_ _ (DataCon ty@(Vector 1 elTy) _ [e]) = do syn <- Mon 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 <- Mon hdlSyn case syn of Vivado -> vhdlTypeMark ty <> "'" <> case vectorChain e of Just es -> align (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 -> align (tupled (mapM (expr_ False) es)) Nothing -> parens (vhdlTypeMark elTy <> "'" <> parens (expr_ False e1) <+> "&" <+> expr_ False e2) expr_ _ (DataCon ty@(RTree 0 elTy) _ [e]) = do syn <- Mon 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@(RTree d elTy) _ [e1,e2]) = vhdlTypeMark ty <> "'" <> case rtreeChain e of Just es -> tupled (mapM (expr_ False) es) Nothing -> parens (vhdlTypeMark (RTree (d-1) 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 = map parens (zipWith toSLV argTys es) extraArg = case typeSize ty - dcSize of 0 -> [] n -> [bits (replicate n U)] assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg)) expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = expr_ False (dcToExpr ty i) expr_ _ (DataCon ty@(Product _ _) _ es) = tupled $ zipWithM (\i e' -> tyName ty <> "_sel" <> int i <+> rarrow <+> expr_ False e') [0..] es expr_ _ (DataCon ty@(Clock _ _ Gated) _ es) = do ty' <- normaliseType ty 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 == "Clash.Sized.Internal.BitVector.fromInteger##" , [Literal _ i] <- extractLiterals bbCtx = exprLit (Just (Bit,1)) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx , Just k <- clogBase 2 n , let k' = max 1 k = exprLit (Just (Unsigned k',k')) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.maxBound#" , [Literal _ (NumLit n)] <- extractLiterals bbCtx , n > 0 , Just k <- clogBase 2 n , let k' = max 1 k = exprLit (Just (Unsigned k',k')) (NumLit (n-1)) expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "GHC.Types.I#" , [Literal _ (NumLit n)] <- extractLiterals bbCtx = do iw <- Mon $ use intWidth exprLit (Just (Signed iw,iw)) (NumLit n) expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "GHC.Types.W#" , [Literal _ (NumLit n)] <- extractLiterals bbCtx = do iw <- Mon $ use intWidth exprLit (Just (Unsigned iw,iw)) (NumLit n) expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = do parenIf (b || b') (Mon (renderBlackBox libs imps inc bs bbCtx <*> pure 0)) expr_ _ (DataTag Bool (Left id_)) = "tagToEnum" <> parens (pretty id_) expr_ _ (DataTag Bool (Right id_)) = "dataToTag" <> parens (pretty id_) expr_ _ (DataTag hty@(Sum _ _) (Left id_)) = "std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens ("std_logic_vector" <> parens (pretty id_)) <> "," <> int (typeSize hty))) expr_ _ (DataTag (Sum _ _) (Right id_)) = do iw <- Mon $ use intWidth "signed" <> parens ("std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens (pretty id_) <> "," <> int iw))) expr_ _ (DataTag (Product _ _) (Right _)) = do iw <- Mon $ use intWidth "to_signed" <> parens (int 0 <> "," <> int iw) expr_ _ (DataTag hty@(SP _ _) (Right id_)) = do { ; iw <- Mon $ use intWidth ; "signed" <> parens ("std_logic_vector" <> parens ( "resize" <> parens ("unsigned" <> parens (pretty 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 <- Mon $ use intWidth "to_signed" <> parens (int 0 <> "," <> int iw) expr_ _ (DataTag (Vector _ _) (Right _)) = do iw <- Mon $ use intWidth "to_signed" <> parens (int 1 <> "," <> int iw) expr_ _ (DataTag (RTree 0 _) (Right _)) = do iw <- Mon $ use intWidth "to_signed" <> parens (int 0 <> "," <> int iw) expr_ _ (DataTag (RTree _ _) (Right _)) = do iw <- Mon $ use intWidth "to_signed" <> parens (int 1 <> "," <> int iw) expr_ _ (ConvBV topM hwty True e) = do nm <- Mon $ use modNm case topM of Nothing -> pretty (T.pack nm) <> "_types" <> dot <> "toSLV" <> parens (vhdlTypeMark hwty <> "'" <> parens (expr_ False e)) Just t -> pretty t <> dot <> pretty t <> "_types" <> dot <> "toSLV" <> parens (expr_ False e) expr_ _ (ConvBV topM _ False e) = do nm <- Mon $ use modNm maybe (pretty (T.pack nm) <> "_types" ) (\t -> pretty t <> dot <> pretty t <> "_types") topM <> dot <> "fromSLV" <> parens (expr_ False e) expr_ _ e = error $ $(curLoc) ++ (show e) -- empty otherSize :: [HWType] -> Int -> Int otherSize _ n | n < 0 = 0 otherSize [] _ = 0 otherSize (a:as) n = typeSize a + otherSize as (n-1) 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 rtreeChain :: Expr -> Maybe [Expr] rtreeChain (DataCon (RTree 1 _) _ [e]) = Just [e] rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = liftA2 (++) (rtreeChain e1) (rtreeChain e2) rtreeChain _ = 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 lit Signed n | i < 2^(31 :: Integer) && i > (-2^(31 :: Integer)) -> "to_signed" <> parens (integer i <> "," <> int n) | otherwise -> "signed'" <> parens lit BitVector _ -> "std_logic_vector'" <> parens lit Bit -> squotes (int (fromInteger i `mod` 2)) _ -> blit where validHexLit = sz `mod` 4 == 0 && sz /= 0 lit = if validHexLit then hlit else blit blit = bits (toBits sz i) i' = case hty of Signed _ -> let mask = 2^(sz-1) in case divMod i mask of (s,i'') | even s -> i'' | otherwise -> i'' - mask _ -> i `mod` 2^sz hlit = (if i' < 0 then "-" else emptyDoc) <> hex (toHex sz i') exprLit _ (BoolLit t) = if t then "true" else "false" exprLit _ (BitLit b) = squotes $ bit_char b exprLit _ (StringLit s) = pretty . T.pack $ show s exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l patLit :: HWType -> Literal -> VHDLM Doc patLit Bit (NumLit i) = if i == 0 then "'0'" else "'1'" patLit hwTy (NumLit i) = let sz = conSize hwTy in case sz `mod` 4 of 0 -> hex (toHex sz i) _ -> bits (toBits sz 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 toHex :: Int -> Integer -> String toHex sz i = let Just d = clogBase 16 (2^sz) in printf ("%0" ++ show d ++ "X") (abs i) hex :: String -> VHDLM Doc hex s = char 'x' <> dquotes (pretty (T.pack s)) bit_char :: Bit -> VHDLM Doc bit_char H = char '1' bit_char L = char '0' bit_char U = char '-' bit_char Z = char 'Z' toSLV :: HWType -> Expr -> VHDLM Doc toSLV Bool e = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) toSLV Bit e = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) toSLV (Clock {}) e = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) toSLV (Reset {}) e = do nm <- Mon $ use modNm pretty (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 = 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 renderOneLine ) [pretty 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 (Product _ _) e = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) toSLV (SP _ _) e = expr_ False e toSLV (Vector n elTy) (Identifier id_ Nothing) = do selIds' <- sequence selIds syn <- Mon hdlSyn parens (vcat $ punctuate " & " (case syn of Vivado -> mapM (expr_ False) selIds' _ -> mapM (toSLV elTy) selIds')) where selNames = map (fmap renderOneLine ) $ [pretty id_ <> parens (int i) | i <- [0 .. (n-1)]] selIds = map (fmap (`Identifier` Nothing)) selNames toSLV (Vector n elTy) (DataCon _ _ es) = parens $ vcat $ punctuate " & " (zipWithM toSLV [elTy,Vector (n-1) elTy] es) toSLV (Vector _ _) e = do nm <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.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 <- Mon $ use modNm pretty (T.toLower $ T.pack nm) <> "_types.fromSLV" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int start)) fromSLV Bit id_ start _ = pretty id_ <> parens (int start) fromSLV (BitVector _) id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end) fromSLV (Index _) id_ start end = "unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) fromSLV (Signed _) id_ start end = "signed" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) fromSLV (Unsigned _) id_ start end = "unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) fromSLV (Sum _ _) id_ start end = pretty 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 = pretty 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 <- Mon hdlSyn let elTy' = case syn of Vivado -> BitVector (argLength - 1) _ -> elTy zipWithM (fromSLV elTy' id_) starts ends fromSLV (Clock {}) id_ start _ = pretty id_ <> parens (int start) fromSLV (Reset {}) id_ start _ = pretty id_ <> parens (int start) 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 -> Mon m Doc -> Mon m Doc parenIf True = parens parenIf False = id punctuate' :: Monad m => Mon m Doc -> Mon m [Doc] -> Mon m Doc punctuate' s d = vcat (punctuate s d) <> s encodingNote :: HWType -> VHDLM Doc encodingNote (Clock _ _ Gated) = "-- gated clock" <> line encodingNote (Clock {}) = "-- clock" <> line encodingNote (Reset {}) = "-- asynchronous reset: active high" <> line encodingNote _ = emptyDoc