diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for the [`clash-vhdl`](http://hackage.haskell.org/package/clash-vhdl) package +## 0.7.1 *April 11th 2017* +* Fixes bugs: + * resize `Integer` multiplication result + ## 0.7 *January 16th 2017* * New features: * Support `clash-prelude` 0.11 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.7 +Version: 0.7.1 Synopsis: CAES Language for Synchronous Hardware - VHDL backend Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -63,12 +63,14 @@ primitives/CLaSH.Sized.RTree.json primitives/CLaSH.Sized.Vector.json primitives/CLaSH.Transformations.json + primitives/CLaSH.XException.json primitives/Control.Exception.Base.json primitives/Debug.Trace.json primitives/GHC.Base.json primitives/GHC.Classes.json primitives/GHC.CString.json primitives/GHC.Err.json + primitives/GHC.IO.Exception.json primitives/GHC.Int.json primitives/GHC.Integer.Logarithms.json primitives/GHC.Integer.Type.json diff --git a/primitives/CLaSH.Prelude.BlockRam.json b/primitives/CLaSH.Prelude.BlockRam.json --- a/primitives/CLaSH.Prelude.BlockRam.json +++ b/primitives/CLaSH.Prelude.BlockRam.json @@ -1,41 +1,40 @@ [ { "BlackBox" : { "name" : "CLaSH.Prelude.BlockRam.blockRam#" , "type" : -"blockRam# :: KnownNat n -- ARG[0] - => SClock clk -- clk, ARG[1] - -> Vec n a -- init, ARG[2] - -> Signal' clk Int -- rd, ARG[3] - -> Signal' clk Bool -- wren, ARG[4] - -> Signal' clk Int -- wr, ARG[5] - -> Signal' clk a -- din, ARG[6] +"blockRam# :: SClock clk -- clk, ARG[0] + -> Vec n a -- init, ARG[1] + -> Signal' clk Int -- rd, ARG[2] + -> Signal' clk Bool -- wren, ARG[3] + -> Signal' clk Int -- wr, ARG[4] + -> Signal' clk a -- din, ARG[5] -> Signal' clk a" , "templateD" : "-- blockRam begin ~GENSYM[~COMPNAME_blockRam][0] : block - signal ~GENSYM[RAM][1] : ~TYP[2] := ~LIT[2];~IF ~VIVADO ~THEN - signal ~GENSYM[dout][2] : std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE - signal ~SYM[2] : ~TYP[6];~FI - signal ~GENSYM[rd][3] : integer range 0 to ~LIT[0] - 1; - signal ~GENSYM[wr][4] : integer range 0 to ~LIT[0] - 1; + signal ~GENSYM[RAM][1] : ~TYP[1] := ~LIT[1];~IF ~VIVADO ~THEN + signal ~GENSYM[dout][2] : std_logic_vector(~SIZE[~TYP[5]]-1 downto 0);~ELSE + signal ~SYM[2] : ~TYP[5];~FI + signal ~GENSYM[rd][3] : integer range 0 to ~LENGTH[~TYP[1]] - 1; + signal ~GENSYM[wr][4] : integer range 0 to ~LENGTH[~TYP[1]] - 1; begin - ~SYM[3] <= to_integer(~ARG[3]) + ~SYM[3] <= to_integer(~ARG[2]) -- pragma translate_off - mod ~LIT[0] + mod ~LENGTH[~TYP[1]] -- pragma translate_on ; - ~SYM[4] <= to_integer(~ARG[5]) + ~SYM[4] <= to_integer(~ARG[4]) -- pragma translate_off - mod ~LIT[0] + mod ~LENGTH[~TYP[1]] -- pragma translate_on ; - ~GENSYM[blockRam_sync][5] : process(~CLK[1]) + ~GENSYM[blockRam_sync][5] : process(~CLK[0]) begin - if rising_edge(~CLK[1]) then - if ~ARG[4] then~IF ~VIVADO ~THEN - ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[6]][~TYP[6]];~ELSE - ~SYM[1](~SYM[4]) <= ~ARG[6];~FI + if rising_edge(~CLK[0]) then + if ~ARG[3] then~IF ~VIVADO ~THEN + ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[5]][~TYP[5]];~ELSE + ~SYM[1](~SYM[4]) <= ~ARG[5];~FI end if; ~SYM[2] <= ~SYM[1](~SYM[3]); end if; diff --git a/primitives/CLaSH.Sized.RTree.json b/primitives/CLaSH.Sized.RTree.json --- a/primitives/CLaSH.Sized.RTree.json +++ b/primitives/CLaSH.Sized.RTree.json @@ -12,8 +12,9 @@ textract_~SYM[0] : block signal ~SYM[1] : ~TYP[0]; begin - ~SYM[1] <= ~ARG[0]; - ~RESULT <= ~SYM[1](0); + ~SYM[1] <= ~ARG[0];~IF ~VIVADO ~THEN + ~RESULT <= ~FROMBV[~SYM[1](0)][~TYPO];~ELSE + ~RESULT <= ~SYM[1](0);~FI end block; -- textract end" } diff --git a/primitives/CLaSH.XException.json b/primitives/CLaSH.XException.json new file mode 100644 --- /dev/null +++ b/primitives/CLaSH.XException.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "CLaSH.XException.seqX" + , "type" : "seqX :: a -> b -> b" + , "templateE" : "~ARG[1]" + } + } +] diff --git a/primitives/GHC.IO.Exception.json b/primitives/GHC.IO.Exception.json new file mode 100644 --- /dev/null +++ b/primitives/GHC.IO.Exception.json @@ -0,0 +1,12 @@ +[ { "BlackBox" : + { "name" : "GHC.IO.Exception.assertError" + , "type" : "assertError :: HasCallStack => Bool -> a -> a" + , "comment" : "It would be nice if we could use a HDL assertion, however, + because in HDL, case alternatives are evaluated + concurrently, we would end up with the assertion being + triggered, even when the result of that branch is not + chosen in the multiplexer" + , "templateE" : "~ARG[2]" + } + } +] 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 @@ -25,7 +25,7 @@ , { "BlackBox" : { "name" : "GHC.Integer.Type.timesInteger" , "type" : "timesInteger :: Integer -> Integer -> Integer" - , "templateE" : "~ARG[0] * ~ARG[1]" + , "templateE" : "resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])" } } , { "BlackBox" : @@ -155,6 +155,18 @@ { "name" : "GHC.Integer.Type.shiftLInteger" , "type" : "shiftLInteger :: Integer -> Int# -> Integer" , "templateE" : "shift_left(~ARG[0],to_integer(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.wordToInteger" + , "type" : "wordToInteger :: Word# -> Integer" + , "templateE" : "signed(std_logic_vector(~ARG[0]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.integerToWord" + , "type" : "integerToWord :: Integer -> Word#" + , "templateE" : "unsigned(std_logic_vector(~ARG[0]))" } } ] diff --git a/primitives/GHC.Types.json b/primitives/GHC.Types.json --- a/primitives/GHC.Types.json +++ b/primitives/GHC.Types.json @@ -1,9 +1,4 @@ [ { "Primitive" : - { "name" : "GHC.Types.Eq#" - , "primType" : "Constructor" - } - } -, { "Primitive" : { "name" : "GHC.Types.MkCoercible" , "primType" : "Constructor" } 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 @@ -33,6 +33,7 @@ import Text.Printf import Text.PrettyPrint.Leijen.Text.Monadic +import CLaSH.Annotations.Primitive (HDL (..)) import CLaSH.Backend import CLaSH.Driver.Types (SrcSpan, noSrcSpan) import CLaSH.Netlist.BlackBox.Types (HdlSyn (..)) @@ -67,6 +68,7 @@ instance Backend VHDLState where initBackend = VHDLState HashSet.empty [] HashMap.empty "" noSrcSpan [] [] [] + hdlKind = const VHDL #ifdef CABAL primDir = const (Paths_clash_vhdl.getDataFileName "primitives") #else @@ -647,7 +649,13 @@ _ -> text id_ <> parens (int 0) expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,2)))) = text id_ <> parens (int 1 <+> "to" <+> int (n-1)) -expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 _),0,1)))) = text id_ <> parens (int 0) +expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 elTy),0,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 ((RTree n _),1,1)))) = let z = 2^(n-1) in text id_ <> parens (int 0 <+> "to" <+> int (z-1)) @@ -670,7 +678,13 @@ -- 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 _ _),10,fI)))) = text id_ <> parens (int fI) +expr_ _ (Identifier id_ (Just (Indexed ((RTree _ 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 @@ -710,17 +724,10 @@ 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]) = do - syn <- hdlSyn - case syn of - Vivado -> vhdlTypeMark ty <> "'" <> case rtreeChain e of - Just es -> tupled (mapM (toSLV elTy) es) - Nothing -> parens ("std_logic_vector'" <> parens (toSLV elTy e1) <+> - "&" <+> expr_ False 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_ _ 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 @@ -859,16 +866,23 @@ 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 (if sz `mod` 4 == 0 then hlit else blit) + | otherwise -> "unsigned'" <> parens lit Signed n | i < 2^(31 :: Integer) && i > (-2^(31 :: Integer)) -> "to_signed" <> parens (integer i <> "," <> int n) - | otherwise -> "signed'" <> parens (if sz `mod` 4 == 0 then hlit else blit) - BitVector _ -> "std_logic_vector'" <> parens (if sz `mod` 4 == 0 then hlit else blit) + | otherwise -> "signed'" <> parens lit + BitVector _ -> "std_logic_vector'" <> parens lit _ -> blit where + validHexLit = sz `mod` 4 == 0 && sz /= 0 + lit = if validHexLit then hlit else blit blit = bits (toBits sz i) - hlit = (if i < 0 then "-" else empty) <> hex (toHex 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 empty) <> hex (toHex 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