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 +Version: 0.2.0.1 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -42,7 +42,7 @@ source-repository head type: git - location: git@github.com:christiaanb/clash2.git + location: https://github.com/christiaanb/clash2.git Library HS-Source-Dirs: src @@ -50,30 +50,30 @@ default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs - Build-depends: aeson >= 0.6.0.2, - attoparsec >= 0.10.2.0, - base >= 4.3.1.0 && < 5, - bytestring >= 0.9.2.1, - concurrent-supply >= 0.1.3, - containers >= 0.4.2.1, - directory >= 1.1.0.2, - errors >= 1.4.1, + Build-depends: aeson >= 0.6.2.0, + attoparsec >= 0.10.4.0, + base >= 4.6.0.1 && < 5, + bytestring >= 0.10.0.2, + concurrent-supply >= 0.1.7, + containers >= 0.5.0.0, + directory >= 1.2.0.1, + errors >= 1.4.2, fgl >= 5.4.2.4, - filepath >= 1.3.0.0, - hashable >= 1.1.2.3, - lens >= 3.7.1, - listlike-instances >= 0.2.3.1, - mtl >= 2.0.1.0, + filepath >= 1.3.0.1, + hashable >= 1.2.1.0, + lens >= 3.9.2, + ListLike >= 4.0.0, + mtl >= 2.1.2, pretty >= 1.1.1.0, process >= 1.1.0.2, - template-haskell >= 2.7.0.0, - text >= 0.11.1.13, + template-haskell >= 2.8.0.0, + text >= 0.11.3.1, time >= 1.4.0.1, - transformers >= 0.2.2.0, - unbound >= 0.4.0.2, - unordered-containers >= 0.2.1.0, - uu-parsinglib >= 2.7.4, - wl-pprint-text >= 1.0.0.0 + transformers >= 0.3.0.0, + unbound >= 0.4.2, + unordered-containers >= 0.2.3.3, + uu-parsinglib >= 2.8.1, + wl-pprint-text >= 1.1.0.0 Exposed-modules: CLaSH.Core.DataCon CLaSH.Core.FreeVars diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | Module that connects all the parts of the CLaSH compiler library @@ -59,7 +56,7 @@ (\var _ -> isSuffixOf "expectedOutput" $ name2String var) bindingsMap - case topEntities of + start `seq` case topEntities of [topEntity] -> do -- Create unique supplies for normalisation and TB generation (supplyN,supplyTB) <- Supply.splitSupply diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -10,7 +10,6 @@ import qualified Control.Monad as Monad import Control.Monad.State (runStateT) import Control.Monad.Writer (listen, runWriterT) -import qualified Data.ByteString.Lazy.Char8 as LZ import Data.Either (partitionEithers) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap @@ -253,7 +252,7 @@ | all (\e -> isConstant e || isVar e) args' -> mkDcApplication hwTy dc args' | otherwise -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments" Prim nm _ -> do - bbM <- fmap (HashMap.lookup . LZ.pack $ name2String nm) $ Lens.use primitives + bbM <- fmap (HashMap.lookup . Text.pack $ name2String nm) $ Lens.use primitives case bbM of Just p@(P.BlackBox {}) -> case template p of @@ -299,10 +298,8 @@ EQ -> return (HW.DataCon dstHType (Just $ DC (dstHType,0)) argExprs) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" - Sum _ dcs -> - let dcNameBS = Text.pack . name2String $ dcName dc - dcI = fromMaybe (error "Sum: dc not found") $ elemIndex dcNameBS dcs - in return (HW.DataCon dstHType (Just $ DC (dstHType,dcI)) []) + 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) diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs --- a/src/CLaSH/Netlist/BlackBox.hs +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -13,7 +13,6 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) import Control.Monad.Writer (tell) -import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Either (lefts, partitionEithers) import qualified Data.HashMap.Lazy as HashMap import Data.List (partition) @@ -96,7 +95,7 @@ _ -> fmap (first (first Left)) $ mkLitInput e where mkInput' nm args = do - bbM <- fmap (HashMap.lookup . BSL.pack $ name2String nm) $ Lens.use primitives + bbM <- fmap (HashMap.lookup . pack $ name2String nm) $ Lens.use primitives case bbM of Just p@(P.BlackBox {}) -> do i <- lift $ varCount <<%= (+1) @@ -142,7 +141,7 @@ -> MaybeT NetlistMonad ((BlackBoxTemplate,BlackBoxContext),[Declaration]) mkFunInput resId e = case collectArgs e of (Prim nm _, args) -> do - bbM <- fmap (HashMap.lookup . BSL.pack $ name2String nm) $ Lens.use primitives + bbM <- fmap (HashMap.lookup . pack $ name2String nm) $ Lens.use primitives case bbM of Just p@(P.BlackBox {}) -> do (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args) diff --git a/src/CLaSH/Netlist/BlackBox/Types.hs b/src/CLaSH/Netlist/BlackBox/Types.hs --- a/src/CLaSH/Netlist/BlackBox/Types.hs +++ b/src/CLaSH/Netlist/BlackBox/Types.hs @@ -2,6 +2,7 @@ -- | Types used in BlackBox modules module CLaSH.Netlist.BlackBox.Types where +import Control.Applicative (Applicative) import Control.Monad.State (MonadState, State) import Control.Monad.Writer (MonadWriter,WriterT) import Data.Text.Lazy (Text) @@ -53,4 +54,4 @@ -- | Monad that caches VHDL information and remembers hidden inputs of -- black boxes that are being generated (WriterT) newtype BlackBoxMonad a = B { runBlackBoxM :: WriterT [(Identifier,HWType)] (State VHDLState) a } - deriving (Functor, Monad, MonadWriter [(Identifier,HWType)], MonadState VHDLState) + deriving (Functor, Applicative, Monad, MonadWriter [(Identifier,HWType)], MonadState VHDLState) diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs --- a/src/CLaSH/Netlist/Types.hs +++ b/src/CLaSH/Netlist/Types.hs @@ -7,7 +7,6 @@ import Control.Monad.State (MonadIO, MonadState, StateT) import Control.Monad.Writer (MonadWriter, WriterT) -import Data.ByteString.Lazy (ByteString) import Data.Hashable import Data.HashMap.Lazy (HashMap) import Data.HashSet (HashSet) @@ -19,7 +18,7 @@ import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type) import CLaSH.Core.Util (Gamma) -import CLaSH.Primitives.Types (Primitive) +import CLaSH.Primitives.Types (PrimMap) import CLaSH.Util -- | Monad that caches generated components (StateT) and remembers hidden inputs @@ -45,7 +44,7 @@ , _varCount :: Int -- ^ Number of signal declarations , _cmpCount :: Int -- ^ Number of create components , _components :: HashMap TmName Component -- ^ Cached components - , _primitives :: HashMap ByteString Primitive -- ^ Primitive Definitions + , _primitives :: PrimMap -- ^ Primitive Definitions , _vhdlMState :: VHDLState -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad , _typeTranslator :: Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator } diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -25,6 +25,7 @@ splitTyConAppM, tyView) import CLaSH.Core.Util (collectBndrs, termType) import CLaSH.Core.Var (Id, Var (..), modifyVarName) +import CLaSH.Netlist.Id import CLaSH.Netlist.Types import CLaSH.Util @@ -168,7 +169,7 @@ -- is not a variable. varToExpr :: Term -> Expr -varToExpr (Var _ var) = Identifier (pack $ name2String var) Nothing +varToExpr (Var _ var) = Identifier (mkBasicId . pack $ name2String var) Nothing varToExpr _ = error "not a var" -- | Uniquely rename all the variables and their references in a normalized 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 @@ -17,12 +17,11 @@ import qualified Control.Applicative as A import Control.Lens hiding (Indexed) -import Control.Monad (liftM,zipWithM) +import Control.Monad (liftM,when,zipWithM) import Control.Monad.State (State) import Data.Graph.Inductive (Gr, mkGraph, topsort') import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashSet as HashSet -import Data.List (nub) import Data.Maybe (catMaybes,mapMaybe) import Data.Text.Lazy (unpack) import qualified Data.Text.Lazy as T @@ -36,20 +35,13 @@ -- | Generate VHDL for a Netlist component genVHDL :: Component -> VHDLM (String,Doc) -genVHDL c = do - _1 %= (\s -> foldr HashSet.insert s needsDec) - (unpack cName,) A.<$> vhdl +genVHDL c = (unpack cName,) A.<$> vhdl where cName = componentName c - vhdl = tyImports (not $ null needsDec) <$$> linebreak <> + vhdl = tyImports <$$> linebreak <> entity c <$$> linebreak <> architecture c - tys = snd (output c) - : map snd (inputs c) - ++ concatMap (\d -> case d of {(NetDecl _ ty _) -> [ty]; _ -> []}) (declarations c) - needsDec = nub $ concatMap needsTyDec tys - -- | Generate a VHDL package containing type definitions for the given HWTypes mkTyPackage :: [HWType] -> VHDLM Doc @@ -90,14 +82,14 @@ in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup ty nodesI)) tys) ctys edge _ = [] -needsTyDec :: HWType -> [HWType] -needsTyDec (Vector _ Bit) = [] -needsTyDec (Vector _ elTy) = needsTyDec elTy ++ [Vector 0 elTy] -needsTyDec ty@(Product _ tys) = concatMap needsTyDec tys ++ [ty] -needsTyDec (SP _ tys) = concatMap (concatMap needsTyDec . snd) tys -needsTyDec Bool = [Bool] -needsTyDec Integer = [Integer] -needsTyDec _ = [] +needsTyDec :: HWType -> Bool +needsTyDec (Vector _ Bit) = False +needsTyDec (Vector _ _) = True +needsTyDec (Product _ _) = True +needsTyDec (SP _ _) = True +needsTyDec Bool = True +needsTyDec Integer = True +needsTyDec _ = False tyDec :: HWType -> VHDLM Doc tyDec Bool = "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi @@ -137,29 +129,14 @@ funDec _ = return Nothing -tyName :: HWType -> VHDLM Doc -tyName Integer = "integer" -tyName Bit = "std_logic" -tyName (Vector n Bit) = "std_logic_vector_" <> int n -tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy -tyName (Signed n) = "signed_" <> int n -tyName (Unsigned n) = "unsigned_" <> int n -tyName t@(Sum _ _) = "unsigned_" <> int (typeSize t) -tyName t@(Product _ _) = makeCached t _3 prodName - where - prodName = do i <- _2 <<%= (+1) - "product" <> int i - -tyName _ = empty - -tyImports :: Bool -> VHDLM Doc -tyImports needsDec = - punctuate' semi $ sequence $ concat - [ [ "library IEEE" - , "use IEEE.STD_LOGIC_1164.ALL" - , "use IEEE.NUMERIC_STD.ALL" - , "use work.all" ] - , if needsDec then ["use work.types.all"] else [] +tyImports :: VHDLM Doc +tyImports = + punctuate' semi $ sequence + [ "library IEEE" + , "use IEEE.STD_LOGIC_1164.ALL" + , "use IEEE.NUMERIC_STD.ALL" + , "use work.all" + , "use work.types.all" ] @@ -195,25 +172,30 @@ -- | Convert a Netlist HWType to a VHDL type vhdlType :: HWType -> VHDLM Doc -vhdlType Bit = "std_logic" -vhdlType Bool = "boolean" -vhdlType (Clock _) = "std_logic" -vhdlType (Reset _) = "std_logic" -vhdlType Integer = "integer" -vhdlType (Signed n) = "signed" <> +vhdlType hwty = do + when (needsTyDec hwty) (_1 %= HashSet.insert hwty) + vhdlType' hwty + +vhdlType' :: HWType -> VHDLM Doc +vhdlType' Bit = "std_logic" +vhdlType' Bool = "boolean" +vhdlType' (Clock _) = "std_logic" +vhdlType' (Reset _) = "std_logic" +vhdlType' Integer = "integer" +vhdlType' (Signed n) = "signed" <> parens ( int (n-1) <+> "downto 0") -vhdlType (Unsigned n) = "unsigned" <> +vhdlType' (Unsigned n) = "unsigned" <> parens ( int (n-1) <+> "downto 0") -vhdlType (Vector n Bit) = "std_logic_vector" <> parens ( int (n-1) <+> "downto 0") -vhdlType (Vector n elTy) = "array_of_" <> tyName elTy <> parens ( int (n-1) <+> "downto 0") -vhdlType t@(SP _ _) = "std_logic_vector" <> +vhdlType' (Vector n Bit) = "std_logic_vector" <> parens ( int (n-1) <+> "downto 0") +vhdlType' (Vector n elTy) = "array_of_" <> tyName elTy <> parens ( int (n-1) <+> "downto 0") +vhdlType' t@(SP _ _) = "std_logic_vector" <> parens ( int (typeSize t - 1) <+> "downto 0" ) -vhdlType t@(Sum _ _) = "unsigned" <> +vhdlType' t@(Sum _ _) = "unsigned" <> parens ( int (typeSize t -1) <+> "downto 0") -vhdlType t@(Product _ _) = tyName t -vhdlType t = error $ "vhdlType: " ++ show t +vhdlType' t@(Product _ _) = tyName t +vhdlType' t = error $ "vhdlType: " ++ show t -- | Convert a Netlist HWType to the root of a VHDL type vhdlTypeMark :: HWType -> VHDLM Doc @@ -231,6 +213,22 @@ vhdlTypeMark t@(Product _ _) = tyName t vhdlTypeMark t = error $ "vhdlTypeMark: " ++ show t +tyName :: HWType -> VHDLM Doc +tyName Integer = "integer" +tyName Bit = "std_logic" +tyName Bool = "boolean" +tyName (Vector n Bit) = "std_logic_vector_" <> int n +tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy +tyName (Signed n) = "signed_" <> int n +tyName (Unsigned n) = "unsigned_" <> int n +tyName t@(Sum _ _) = "unsigned_" <> int (typeSize t) +tyName t@(Product _ _) = makeCached t _3 prodName + where + prodName = do i <- _2 <<%= (+1) + "product" <> int i + +tyName _ = empty + -- | Convert a Netlist HWType to a default VHDL value for that type vhdlTypeDefault :: HWType -> VHDLM Doc vhdlTypeDefault Bit = "'0'" @@ -270,11 +268,13 @@ text id_ <+> larrow <+> expr False e <> semi inst (CondAssignment id_ scrut es) = fmap Just $ - text id_ <+> larrow <+> align (vcat (mapM cond es)) <> semi + text id_ <+> larrow <+> align (vcat (conds es)) <> semi where - cond :: (Maybe Expr,Expr) -> VHDLM Doc - cond (Nothing,e) = expr False e - cond (Just c ,e) = expr False e <+> "when" <+> parens (expr True scrut <+> "=" <+> expr True c) <+> "else" + conds :: [(Maybe Expr,Expr)] -> VHDLM [Doc] + conds [] = return [] + conds [(_,e)] = expr False e <:> return [] + conds ((Nothing,e):_) = expr False e <:> return [] + conds ((Just c ,e):es') = (expr False e <+> "when" <+> parens (expr True scrut <+> "=" <+> expr True c) <+> "else") <:> conds es' inst (InstDecl nm lbl pms) = fmap Just $ nest 2 $ text lbl <> "_comp_inst" <+> colon <+> "entity" diff --git a/src/CLaSH/Primitives/Types.hs b/src/CLaSH/Primitives/Types.hs --- a/src/CLaSH/Primitives/Types.hs +++ b/src/CLaSH/Primitives/Types.hs @@ -5,24 +5,23 @@ import Control.Applicative ((<$>), (<*>), (<|>)) import Data.Aeson (FromJSON (..), Value (..), (.:)) -import Data.ByteString.Lazy (ByteString) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Strict as H import Data.Text.Lazy (Text) -- | Primitive Definitions -type PrimMap = HashMap ByteString Primitive +type PrimMap = HashMap Text Primitive -- | Externally defined primitive data Primitive -- | A primitive that has a template that can be filled out by the backend render = BlackBox - { name :: ByteString -- ^ Name of the primitive + { name :: Text -- ^ Name of the primitive , template :: Either Text Text -- ^ Either a /declaration/ or an /expression/ template. } -- | A primitive that carries additional information | Primitive - { name :: ByteString -- ^ Name of the primitive + { name :: Text -- ^ Name of the primitive , primType :: Text -- ^ Additional information } diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs --- a/src/CLaSH/Rewrite/Types.hs +++ b/src/CLaSH/Rewrite/Types.hs @@ -74,8 +74,9 @@ -- | MTL convenience wrapper around 'RewriteMonad' newtype R m a = R { runR :: RewriteMonad m a } - deriving ( Monad - , Functor + deriving ( Functor + , Applicative + , Monad , MonadReader RewriteEnv , MonadState RewriteState , MonadWriter Any