clash-lib 0.2.1 → 0.2.2
raw patch · 8 files changed
+125/−62 lines, 8 files
Files
- LICENSE +1/−1
- clash-lib.cabal +5/−2
- src/CLaSH/Core/Term.hs +5/−1
- src/CLaSH/Driver/TestbenchGen.hs +55/−10
- src/CLaSH/Netlist.hs +8/−8
- src/CLaSH/Netlist/VHDL.hs +48/−37
- src/CLaSH/Normalize.hs +2/−2
- src/CLaSH/Rewrite/Util.hs +1/−1
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012-2013, University of Twente+Copyright (c) 2012-2014, University of Twente All rights reserved. Redistribution and use in source and binary forms, with or without
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.2.1+Version: 0.2.2 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -26,13 +26,16 @@ * <https://github.com/christiaanb/Idris-dev Idris Frontend> . * <https://github.com/christiaanb/clash2 GHC/Haskell Frontend>+ .+ .+ Prelude library: http://hackage.haskell.org/package/clash-prelude Homepage: http://christiaanb.github.io/clash2 bug-reports: http://github.com/christiaanb/clash2/issues License: OtherLicense License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij <christiaan.baaij@gmail.com>-Copyright: Copyright (c) 2012-2014 University of Twente+Copyright: Copyright © 2012-2014 University of Twente Category: Hardware Build-type: Simple
src/CLaSH/Core/Term.hs view
@@ -18,7 +18,7 @@ -- External Modules import Control.DeepSeq import Unbound.LocallyNameless as Unbound hiding (Data,rnf)-import Unbound.LocallyNameless.Alpha (aeqR1, fvR1)+import Unbound.LocallyNameless.Alpha (acompareR1, aeqR1, fvR1) import Unbound.LocallyNameless.Name (Name(Nm,Bn),isFree) import Unbound.LocallyNameless.Ops (unsafeUnbind) import Data.Text (Text)@@ -75,6 +75,10 @@ instance Alpha Term where fv' c (Var _ n) = fv' c n fv' c t = fvR1 rep1 c t++ acompare' c (Var _ n) (Var _ m) = acompare' c n m+ acompare' _ (Prim t1 _) (Prim t2 _) = compare t1 t2+ acompare' c t1 t2 = acompareR1 rep1 c t1 t2 aeq' c (Var _ n) (Var _ m) = aeq' c n m aeq' _ (Prim t1 _) (Prim t2 _) = t1 == t2
src/CLaSH/Driver/TestbenchGen.hs view
@@ -13,6 +13,8 @@ import Control.Error (EitherT, eitherT, hoistEither, left, note, right)+import Control.Monad (forM)+import Control.Monad.State (State,runState) import Control.Monad.Trans.Class (lift) import Data.Either (lefts) import Data.HashMap.Lazy (HashMap)@@ -24,9 +26,11 @@ import qualified Data.Text.Lazy.Builder.RealFloat as Builder import Text.PrettyPrint.Leijen.Text ((<+>), (<>)) import qualified Text.PrettyPrint.Leijen.Text as PP+import Text.PrettyPrint.Leijen.Text.Monadic ()+import qualified Text.PrettyPrint.Leijen.Text.Monadic as PPM import Unbound.LocallyNameless (bind, makeName, name2Integer,- name2String, rec, unrec)-import Unbound.LocallyNameless.Ops (unsafeUnbind)+ name2String, rec, runFreshM,+ unbind, unrec) import CLaSH.Core.DataCon import CLaSH.Core.Pretty@@ -37,10 +41,13 @@ import CLaSH.Netlist import CLaSH.Netlist.Types as N+import CLaSH.Netlist.Util (typeSize)+import CLaSH.Netlist.VHDL (vhdlType,vhdlTypeMark) import CLaSH.Normalize (cleanupGraph, normalize, runNormalization) import CLaSH.Primitives.Types import CLaSH.Rewrite.Types+import CLaSH.Rewrite.Util (substituteBinders) import CLaSH.Util @@ -81,8 +88,10 @@ (expDecls,expComps,vhdlState'',expCnt) <- flip (maybe emptyExpected) expectedNmM $ \expectedNm -> do (decls,sigVs,comps,vhdlState'') <- prepareSignals vhdlState' primMap globals typeTrans tcm normalizeSignal (Just inpCnt) expectedNm let asserts = map (genAssert (fst outp)) sigVs+ (toStrDecls,vhdlState3) = runState (mkToStringDecls (snd outp)) vhdlState'' procDecl = PP.vsep [ "process is"+ , PP.indent 2 toStrDecls , "begin" , PP.indent 2 ( PP.vsep $ map (<> PP.semi) $@@ -94,7 +103,7 @@ , "end process" <> PP.semi ] procDecl' = BlackBoxD (PP.displayT $ PP.renderPretty 0.4 80 procDecl)- return (procDecl':decls,comps,vhdlState'',length sigVs)+ return (procDecl':decls,comps,vhdlState3,length sigVs) let finExpr = "'1' after" <+> renderFloat2Dec (rateF * (fromIntegral (max inpCnt expCnt) - 0.5)) <+> "ns" finDecl = [ NetDecl "finished" Bit (Just (N.Literal Nothing (BitLit L)))@@ -174,6 +183,39 @@ , PP.text "severity error" ] +mkToStringDecls :: HWType -> State VHDLState PP.Doc+mkToStringDecls t@(Product _ elTys) =+ PPM.vcat (mapM mkToStringDecls elTys) PPM.<$>+ "function to_string" PPM.<+> PPM.parens ("value :" PPM.<+> vhdlType t) PPM.<+> "return STRING is" PPM.<$>+ "begin" PPM.<$>+ PPM.indent 2 ("return" PPM.<+> PPM.parens (PPM.hcat (PPM.punctuate " & " elTyPrint)) PPM.<> PPM.semi) PPM.<$>+ "end function to_string;"+ where+ elTyPrint = forM [0..(length elTys - 1)]+ (\i -> "to_string" PPM.<>+ PPM.parens ("value." PPM.<> vhdlType t PPM.<> "_sel" PPM.<> PPM.int i))+mkToStringDecls (Vector _ Bit) = PPM.empty+mkToStringDecls t@(Vector _ elTy) =+ mkToStringDecls elTy PPM.<$>+ "function to_string" PPM.<+> PPM.parens ("value : " PPM.<+> vhdlTypeMark t) PPM.<+> "return STRING is" PPM.<$>+ PPM.indent 2+ ( "alias ivalue : " PPM.<+> vhdlTypeMark t PPM.<> "(1 to value'length) is value;" PPM.<$>+ "variable result : STRING" PPM.<> PPM.parens ("1 to value'length * " PPM.<> PPM.int (typeSize elTy)) PPM.<> PPM.semi+ ) PPM.<$>+ "begin" PPM.<$>+ PPM.indent 2+ ("for i in ivalue'range loop" PPM.<$>+ PPM.indent 2+ ( "result" PPM.<> PPM.parens (PPM.parens ("(i - 1) * " PPM.<> PPM.int (typeSize elTy)) PPM.<+> "+ 1" PPM.<+>+ "to i*" PPM.<> PPM.int (typeSize elTy)) PPM.<+>+ ":= to_string" PPM.<> PPM.parens (if elTy == Bool then "toSLV(ivalue(i))" else "ivalue(i)") PPM.<> PPM.semi+ ) PPM.<$>+ "end loop;" PPM.<$>+ "return result;"+ ) PPM.<$>+ "end function to_string;"+mkToStringDecls _ = PPM.empty+ prepareSignals :: VHDLState -> PrimMap -> HashMap TmName (Type,Term)@@ -205,13 +247,17 @@ termToList :: Monad m => Term -> EitherT String m [Term] termToList e = case second lefts $ collectArgs e of (Data dc,[])- | name2String (dcName dc) == "[]" -> pure []+ | name2String (dcName dc) == "GHC.Types.[]" -> pure [] | name2String (dcName dc) == "Prelude.List.Nil" -> pure []- | otherwise -> errNoConstruct $(curLoc)+ | otherwise -> errNoConstruct $(curLoc) (Data dc,[hdArg,tlArg])- | name2String (dcName dc) == ":" -> (hdArg:) <$> termToList tlArg- | name2String (dcName dc) == "Prelude.List.::" -> (hdArg:) <$> termToList tlArg- | otherwise -> errNoConstruct $(curLoc)+ | name2String (dcName dc) == "GHC.Types.:" -> (hdArg:) <$> termToList tlArg+ | name2String (dcName dc) == "Prelude.List.::" -> (hdArg:) <$> termToList tlArg+ | otherwise -> errNoConstruct $(curLoc)+ (Letrec b,[]) -> case (runFreshM $ unbind b) of+ (bndrs,body) -> case substituteBinders (unrec bndrs) [] body of+ ([],bodyS) -> termToList bodyS+ _ -> errNoConstruct $(curLoc) _ -> errNoConstruct $(curLoc) where errNoConstruct l = left $ l ++ "Can't deconstruct list literal: " ++ show (second lefts $ collectArgs e)@@ -233,8 +279,7 @@ -> IO ([Declaration],[Identifier],[Component],VHDLState) createSignal vhdlState primMap typeTrans tcm mStart normalizedSignals = do let (signalHds,signalTls) = unzip $ map ((\(l:ls) -> (l,ls)) . HashMap.toList) normalizedSignals- sigEs = map (\(_,(_,Letrec b)) -> unrec . fst $ unsafeUnbind b- ) signalHds+ sigEs = runFreshM $ mapM (\(_,(_,Letrec b)) -> (unrec . fst) <$> unbind b) signalHds newExpr = Letrec $ bind (rec $ concat sigEs) (Var (fst . snd $ head signalHds) (fst $ head signalHds))
src/CLaSH/Netlist.hs view
@@ -318,16 +318,16 @@ Sum _ _ -> return (HW.DataCon dstHType (Just $ DC (dstHType,dcTag dc - 1)) []) Bool ->- let dc' = case name2String $ dcName dc of- "True" -> HW.Literal Nothing (BoolLit True)- "False" -> HW.Literal Nothing (BoolLit False)- _ -> error $ $(curLoc) ++ "unknown bool literal: " ++ show dc+ let dc' = case dcTag dc of+ 2 -> HW.Literal Nothing (BoolLit True)+ 1 -> HW.Literal Nothing (BoolLit False)+ tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" in return dc' Bit ->- let dc' = case name2String $ dcName dc of- "H" -> HW.Literal Nothing (BitLit H)- "L" -> HW.Literal Nothing (BitLit L)- _ -> error $ $(curLoc) ++ "unknown bit literal: " ++ show dc+ let dc' = case dcTag dc of+ 1 -> HW.Literal Nothing (BitLit H)+ 2 -> HW.Literal Nothing (BitLit L)+ tg -> error $ $(curLoc) ++ "unknown bit literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" in return dc' Vector 0 _ -> return (HW.DataCon dstHType Nothing []) Vector 1 _ -> return (HW.DataCon dstHType (Just VecAppend) [head argExprs])
src/CLaSH/Netlist/VHDL.hs view
@@ -23,7 +23,7 @@ import Data.Graph.Inductive (Gr, mkGraph, topsort') import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashSet as HashSet-import Data.List (mapAccumL)+import Data.List (mapAccumL,nub) import Data.Maybe (catMaybes,mapMaybe) import Data.Text.Lazy (unpack) import qualified Data.Text.Lazy as T@@ -52,21 +52,31 @@ "use IEEE.STD_LOGIC_1164.ALL;" <$> "use IEEE.NUMERIC_STD.ALL;" <$$> linebreak <> "package" <+> "types" <+> "is" <$>- packageDec <$>+ indent 2 ( packageDec <$>+ vcat (sequence funDecs)+ ) <$> "end" <> semi <> packageBodyDec where hwTysSorted = topSortHWTys hwtys- packageDec = indent 2 (vcat $ mapM tyDec hwTysSorted)+ usedTys = nub $ concatMap mkUsedTys hwtys+ packageDec = vcat $ mapM tyDec hwTysSorted+ (funDecs,funBodys) = unzip . catMaybes $ map funDec usedTys - packageBodyDec = do- funDecs <- catMaybes A.<$> mapM funDec hwTysSorted- case funDecs of+ packageBodyDec :: VHDLM Doc+ packageBodyDec = case funBodys of [] -> empty _ -> linebreak <$> "package" <+> "body" <+> "types" <+> "is" <$>- indent 2 (vcat $ return funDecs) <$>+ indent 2 (vcat (sequence funBodys)) <$> "end" <> semi +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@@ -99,10 +109,6 @@ needsTyDec _ = False tyDec :: HWType -> VHDLM Doc-tyDec Bool = "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <$>- "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <> semi-tyDec Integer = "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <> semi- tyDec (Vector _ elTy) = "type" <+> "array_of_" <> tyName elTy <+> "is array (natural range <>) of" <+> vhdlType elTy <> semi tyDec ty@(Product _ tys) = prodDec@@ -117,34 +123,39 @@ tyDec _ = empty -funDec :: HWType -> VHDLM (Maybe Doc)-funDec Bool = fmap Just $- "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" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <+> "is" <$>- "begin" <$>- indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> squotes (int 1) <+> "then"- , indent 2 ("return" <+> "true" <> semi)- ,"else"- , indent 2 ("return" <+> "false" <> semi)- ,"end" <+> "if" <> semi- ]) <$>- "end" <> semi+funDec :: HWType -> Maybe (VHDLM Doc,VHDLM Doc)+funDec Bool = Just+ ( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <$>+ "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <> 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" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <+> "is" <$>+ "begin" <$>+ indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> squotes (int 1) <+> "then"+ , indent 2 ("return" <+> "true" <> semi)+ ,"else"+ , indent 2 ("return" <+> "false" <> semi)+ ,"end" <+> "if" <> semi+ ]) <$>+ "end" <> semi+ ) -funDec Integer = fmap Just $- "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <+> "is" <$>- "begin" <$>- indent 2 ("return" <+> "i" <> semi) <$>- "end" <> semi+funDec Integer = Just+ ( "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <> semi+ , "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <+> "is" <$>+ "begin" <$>+ indent 2 ("return" <+> "i" <> semi) <$>+ "end" <> semi+ ) -funDec _ = return Nothing+funDec _ = Nothing tyImports :: VHDLM Doc tyImports =
src/CLaSH/Normalize.hs view
@@ -30,7 +30,7 @@ import CLaSH.Normalize.Transformations ( bindConstantVar, topLet ) import CLaSH.Normalize.Types import CLaSH.Normalize.Util-import CLaSH.Rewrite.Combinators ((!->),topdownR)+import CLaSH.Rewrite.Combinators ((!->),repeatR,topdownR) import CLaSH.Rewrite.Types (DebugLevel (..), RewriteState (..), bindings, dbgLevel, tcCache) import CLaSH.Rewrite.Util (liftRS, runRewrite,@@ -192,7 +192,7 @@ let (toInline,il_used) = unzip il_ct newExpr <- case toInline of [] -> return tm- _ -> rewriteExpr ("bindConstants",(topdownR bindConstantVar) !-> topLet) (showDoc nm, substTms toInline tm)+ _ -> rewriteExpr ("bindConstants",(topdownR (repeatR $ bindConstantVar)) !-> topLet) (showDoc nm, substTms toInline tm) return (CBranch (nm,(ty,newExpr)) (newUsed ++ (concat il_used))) callTreeToList :: [TmName]
src/CLaSH/Rewrite/Util.hs view
@@ -461,7 +461,7 @@ case specM of -- Use previously specialized function Just (fname,fty) ->- traceIf (lvl >= DebugApplied) ("Using previous specialization: " ++ showDoc fname) $+ traceIf (lvl >= DebugApplied) ("Using previous specialization of " ++ showDoc f ++ " on " ++ (either showDoc showDoc) specAbs ++ ": " ++ showDoc fname) $ changed $ mkApps (Var fty fname) (args ++ specVars) -- Create new specialized function Nothing -> do