diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Changelog for the [`clash-vhdl`](http://hackage.haskell.org/package/clash-vhdl) package +## 0.6.14 *July 15th 2016* +* New features: + * Support clash-lib-0.6.18 +* Fixes bugs: + * Incorrect primitive specifications for Integer's `shiftL` and `shiftR` + * Types in generated types.vhdl incorrectly sorted + ## 0.6.13 *June 9th 2016* * Fixes bugs: * Converting product types to std_logic_vector fails when the `clash-hdlsyn Vivado` flag is enabled diff --git a/clash-vhdl.cabal b/clash-vhdl.cabal --- a/clash-vhdl.cabal +++ b/clash-vhdl.cabal @@ -1,5 +1,5 @@ Name: clash-vhdl -Version: 0.6.13 +Version: 0.6.14 Synopsis: CAES Language for Synchronous Hardware - VHDL backend Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -98,7 +98,7 @@ ViewPatterns Build-depends: base >= 4.6.0.1 && < 5, - clash-lib >= 0.6.13 && < 0.7, + clash-lib >= 0.6.18 && < 0.7, clash-prelude >= 0.10.1 && < 0.11, fgl >= 5.4.2.4 && < 5.6, lens >= 3.9.2 && < 4.15, diff --git a/primitives/GHC.Integer.Type.json b/primitives/GHC.Integer.Type.json --- a/primitives/GHC.Integer.Type.json +++ b/primitives/GHC.Integer.Type.json @@ -148,13 +148,13 @@ , { "BlackBox" : { "name" : "GHC.Integer.Type.shiftRInteger" , "type" : "shiftRInteger :: Integer -> Int# -> Integer" - , "templateE" : "~ARG[0] / (2**to_integer(~ARG[1]))" + , "templateE" : "shift_right(~ARG[0],to_integer(~ARG[1]))" } } , { "BlackBox" : { "name" : "GHC.Integer.Type.shiftLInteger" , "type" : "shiftLInteger :: Integer -> Int# -> Integer" - , "templateE" : "~ARG[0] * (2**to_integer(~ARG[1]))" + , "templateE" : "shift_left(~ARG[0],to_integer(~ARG[1]))" } } ] diff --git a/src/CLaSH/Backend/VHDL.hs b/src/CLaSH/Backend/VHDL.hs --- a/src/CLaSH/Backend/VHDL.hs +++ b/src/CLaSH/Backend/VHDL.hs @@ -24,7 +24,7 @@ import qualified Data.HashMap.Lazy as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.List (mapAccumL,nubBy) +import Data.List (mapAccumL,nub,nubBy) import Data.Maybe (catMaybes,mapMaybe) import Data.Text.Lazy (unpack) import qualified Data.Text.Lazy as T @@ -32,12 +32,13 @@ import Text.PrettyPrint.Leijen.Text.Monadic 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 (mkBasicId') import CLaSH.Netlist.Types hiding (_intWidth, intWidth) import CLaSH.Netlist.Util hiding (mkBasicId) -import CLaSH.Util (clog2, curLoc, first, makeCached, on, (<:>)) +import CLaSH.Util (curLoc, first, makeCached, on, (<:>)) #ifdef CABAL import qualified Paths_clash_vhdl @@ -52,6 +53,7 @@ , _tySeen :: [Identifier] -- ^ Generated product types , _nameCache :: (HashMap HWType Doc) -- ^ Cache for previously generated product type names , _modNm :: String + , _srcSpan :: SrcSpan , _intWidth :: Int -- ^ Int/Word/Integer bit-width , _hdlsyn :: HdlSyn -- ^ For which HDL synthesis tool are we generating VHDL } @@ -59,7 +61,7 @@ makeLenses ''VHDLState instance Backend VHDLState where - initBackend = VHDLState HashSet.empty [] HashMap.empty "" + initBackend = VHDLState HashSet.empty [] HashMap.empty "" noSrcSpan #ifdef CABAL primDir = const (Paths_clash_vhdl.getDataFileName "primitives") #else @@ -86,6 +88,8 @@ hdlSyn = use hdlsyn mkBasicId = return (filterReserved . T.toLower . mkBasicId' True) setModName nm s = s {_modNm = nm} + setSrcSpan = (srcSpan .=) + getSrcSpan = use srcSpan type VHDLM a = State VHDLState a @@ -117,8 +121,10 @@ else s -- | Generate VHDL for a Netlist component -genVHDL :: String -> Component -> VHDLM (String,Doc) -genVHDL nm c = (unpack cName,) A.<$> vhdl +genVHDL :: String -> SrcSpan -> Component -> VHDLM (String,Doc) +genVHDL nm sp c = do + setSrcSpan sp + (unpack cName,) A.<$> vhdl where cName = componentName c vhdl = "-- Automatically generated VHDL-93" <$$> @@ -134,10 +140,10 @@ { 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) + normTys = nub $ map (mkVecZ . normaliseType) (hwtys ++ usedTys) + sortedTys = topSortHWTys normTys + packageDec = vcat $ mapM tyDec sortedTys + (funDecs,funBodies) = unzip . mapMaybe (funDec syn) $ nubBy eqTypM sortedTys ; (:[]) A.<$> (unpack $ mkId (T.pack modName `T.append` "_types"),) A.<$> "library IEEE;" <$> @@ -161,30 +167,11 @@ "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 + eqTypM :: HWType -> HWType -> Bool + eqTypM (Signed _) (Signed _) = True + eqTypM (Unsigned _) (Unsigned _) = True + eqTypM (BitVector _) (BitVector _) = True + eqTypM ty1 ty2 = ty1 == ty2 mkUsedTys :: HWType -> [HWType] @@ -207,10 +194,16 @@ (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 _ = [] +normaliseType :: HWType -> HWType +normaliseType (Vector n ty) = Vector n (normaliseType ty) +normaliseType (Product nm tys) = Product nm (map normaliseType tys) +normaliseType ty@(SP _ _) = BitVector (typeSize ty) +normaliseType ty@(Index _) = Unsigned (typeSize ty) +normaliseType ty@(Sum _ _) = Unsigned (typeSize ty) +normaliseType ty = ty + mkVecZ :: HWType -> HWType mkVecZ (Vector _ elTy) = Vector 0 elTy mkVecZ t = t @@ -281,8 +274,6 @@ "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" <$> @@ -291,9 +282,13 @@ "end" <> semi ) -funDec _ (Unsigned _) = Just unsignedToSlvDec - -funDec _ (Sum _ _) = Just unsignedToSlvDec +funDec _ (Unsigned _) = Just + ( "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 + ) funDec _ t@(Product _ elTys) = Just ( "function" <+> "toSLV" <+> parens ("p :" <+> vhdlType t) <+> "return std_logic_vector" <> semi @@ -330,22 +325,7 @@ "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 = +funDec _ (BitVector _) = Just ( "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" <$> @@ -353,6 +333,8 @@ "end" <> semi ) +funDec _ _ = Nothing + tyImports :: String -> VHDLM Doc tyImports nm = do mkId <- mkBasicId @@ -366,7 +348,6 @@ , "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)) @@ -400,33 +381,32 @@ -- | Convert a Netlist HWType to a VHDL type 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 (n-1) <+> "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 (n-1) <+> "downto 0") -vhdlType' (Unsigned n) = if n == 0 then "unsigned (0 downto 1)" - else "unsigned" <> parens ( int (n-1) <+> "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 (n-1)) -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" + let hwty' = normaliseType hwty + tyCache %= HashSet.insert hwty' + go hwty' + where + go :: HWType -> VHDLM Doc + go Bool = "boolean" + 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 <- use modNm + text (T.toLower $ T.pack nm) <> "_types.array_of_" <> tyName elTy <> parens ("0 to " <> int (n-1)) + go t@(Product _ _) = do + nm <- use modNm + text (T.toLower $ T.pack nm) <> "_types." <> tyName t + go Void = "std_logic_vector" <> parens (int (-1) <+> "downto 0") + 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 @@ -434,25 +414,23 @@ -- | Convert a Netlist HWType to the root of a VHDL type vhdlTypeMark :: HWType -> VHDLM Doc vhdlTypeMark hwty = do - tyCache %= HashSet.insert hwty - vhdlTypeMark' hwty + let hwty' = normaliseType hwty + tyCache %= HashSet.insert hwty' + go 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 + go Bool = "boolean" + go (Clock _ _) = "std_logic" + go (Reset _ _) = "std_logic" + go (BitVector _) = "std_logic_vector" + go (Signed _) = "signed" + go (Unsigned _) = "unsigned" + go (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 + go t@(Product _ _) = do nm <- use modNm text (T.toLower $ T.pack nm) <> "_types." <> tyName t - vhdlTypeMark' t = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t + go t = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t tyName :: HWType -> VHDLM Doc tyName Bool = "boolean" @@ -464,7 +442,7 @@ 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 +tyName t@(Product nm _) = makeCached (normaliseType t) nameCache prodName where prodName = do seen <- use tySeen