diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -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 @@ * . * + . + . + 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 -Copyright: Copyright (c) 2012-2014 University of Twente +Copyright: Copyright © 2012-2014 University of Twente Category: Hardware Build-type: Simple diff --git a/src/CLaSH/Core/Term.hs b/src/CLaSH/Core/Term.hs --- a/src/CLaSH/Core/Term.hs +++ b/src/CLaSH/Core/Term.hs @@ -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 diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs --- a/src/CLaSH/Driver/TestbenchGen.hs +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -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)) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -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]) diff --git a/src/CLaSH/Netlist/VHDL.hs b/src/CLaSH/Netlist/VHDL.hs --- a/src/CLaSH/Netlist/VHDL.hs +++ b/src/CLaSH/Netlist/VHDL.hs @@ -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 = diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -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] diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs --- a/src/CLaSH/Rewrite/Util.hs +++ b/src/CLaSH/Rewrite/Util.hs @@ -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