diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.7 *December 21st 2015* +* Support for `unbound-generics-0.3` +* New features: + * Only look for 'topEntity' in the root module. [#22](https://github.com/clash-lang/clash-compiler/issues/22) + ## 0.6.6 *December 11th 2015* * New features: * Remove all existing HDL files before generating new ones. This can be disabled by the `-clash-noclean` flag. [#96](https://github.com/clash-lang/clash-compiler/issues/96) 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.6.6 +Version: 0.6.7 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -108,7 +108,7 @@ text >= 0.11.3.1, time >= 1.4.0.1, transformers >= 0.3.0.0, - unbound-generics >= 0.1 && < 0.3, + unbound-generics >= 0.1 && < 0.4, unordered-containers >= 0.2.3.3, uu-parsinglib >= 2.8.1, wl-pprint-text >= 1.1.0.0 diff --git a/src/CLaSH/Core/DataCon.hs b/src/CLaSH/Core/DataCon.hs --- a/src/CLaSH/Core/DataCon.hs +++ b/src/CLaSH/Core/DataCon.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,10 +14,19 @@ ) where +#ifndef MIN_VERSION_unbound_generics +#define MIN_VERSION_unbound_generics(x,y,z)(1) +#endif + import Control.DeepSeq (NFData(..)) import GHC.Generics (Generic) import Unbound.Generics.LocallyNameless (Alpha(..),Name,Subst(..)) import Unbound.Generics.LocallyNameless.Extra () +#if MIN_VERSION_unbound_generics(0,3,0) +import Data.Monoid (All (..)) +import Unbound.Generics.LocallyNameless (NthPatFind (..), + NamePatFind (..)) +#endif import {-# SOURCE #-} CLaSH.Core.Type (TyName, Type) import CLaSH.Util @@ -59,10 +69,16 @@ open _ _ dc = dc isPat _ = mempty - isTerm _ = True +#if MIN_VERSION_unbound_generics(0,3,0) + isTerm _ = All True + nthPatFind _ = NthPatFind Left + namePatFind _ = NamePatFind (const (Left 0)) +#else + isTerm _ = True nthPatFind _ = Left namePatFind _ _ = Left 0 +#endif swaps' _ _ dc = dc lfreshen' _ dc cont = cont dc mempty diff --git a/src/CLaSH/Core/TyCon.hs b/src/CLaSH/Core/TyCon.hs --- a/src/CLaSH/Core/TyCon.hs +++ b/src/CLaSH/Core/TyCon.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,12 +15,21 @@ ) where +#ifndef MIN_VERSION_unbound_generics +#define MIN_VERSION_unbound_generics(x,y,z)(1) +#endif + -- External Import import Control.DeepSeq import GHC.Generics import Unbound.Generics.LocallyNameless (Alpha(..)) import Unbound.Generics.LocallyNameless.Extra () import Unbound.Generics.LocallyNameless.Name (Name,name2String) +#if MIN_VERSION_unbound_generics(0,3,0) +import Data.Monoid (All (..)) +import Unbound.Generics.LocallyNameless (NthPatFind (..), + NamePatFind (..)) +#endif -- Internal Imports import CLaSH.Core.DataCon (DataCon) @@ -93,10 +103,16 @@ open _ _ tc = tc isPat _ = mempty - isTerm _ = True +#if MIN_VERSION_unbound_generics(0,3,0) + isTerm _ = All True + nthPatFind _ = NthPatFind Left + namePatFind _ = NamePatFind (const (Left 0)) +#else + isTerm _ = True nthPatFind _ = Left namePatFind _ _ = Left 0 +#endif swaps' _ _ tc = tc lfreshen' _ tc cont = cont tc mempty diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -9,11 +9,9 @@ import Control.Monad (when) import Control.Monad.State (evalState, get) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import Data.IntMap (IntMap) -import Data.List (isSuffixOf) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as Text import qualified Data.Time.Clock as Clock import qualified System.Directory as Directory @@ -24,18 +22,17 @@ import CLaSH.Annotations.TopEntity (TopEntity) import CLaSH.Backend -import CLaSH.Core.Term (Term) +import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type) import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Driver.TestbenchGen import CLaSH.Driver.TopWrapper import CLaSH.Driver.Types -import CLaSH.Netlist (genNetlist) +import CLaSH.Netlist (genComponentName, genNetlist) import CLaSH.Netlist.Types (Component (..), HWType) import CLaSH.Normalize (checkNonRecursive, cleanupGraph, normalize, runNormalization) import CLaSH.Primitives.Types -import CLaSH.Util -- | Create a set of target HDL files for a set of functions generateHDL :: forall backend . Backend backend @@ -46,88 +43,72 @@ -> IntMap TyConName -- ^ Tuple TyCon cache -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) - -> Maybe TopEntity + -> (TmName,Maybe TopEntity) -- ^ topEntity bndr + (maybe) TopEntity annotation + -> Maybe TmName -- ^ testInput bndr + -> Maybe TmName -- ^ expectedOutput bndr -> CLaSHOpts -- ^ Debug information level for the normalization process -> IO () -generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval teM opts = do +generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval (topEntity,annM) testInpM expOutM opts = do start <- Clock.getCurrentTime prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime let prepStartDiff = Clock.diffUTCTime prepTime start putStrLn $ "Loading dependencies took " ++ show prepStartDiff - let topEntities = HashMap.filterWithKey - (\var _ -> isSuffixOf ".topEntity" $ name2String var) - bindingsMap - - testInputs = HashMap.filterWithKey - (\var _ -> isSuffixOf ".testInput" $ name2String var) - bindingsMap - - expectedOutputs = HashMap.filterWithKey - (\var _ -> isSuffixOf ".expectedOutput" $ name2String var) - bindingsMap - - case HashMap.toList topEntities of - [topEntity] -> do - -- Create unique supplies for normalisation and TB generation - (supplyN,supplyTB) <- Supply.splitSupply - . snd - . Supply.freshId - <$> Supply.newSupply + (supplyN,supplyTB) <- Supply.splitSupply + . snd + . Supply.freshId + <$> Supply.newSupply - let doNorm = do norm <- normalize [fst topEntity] - let normChecked = checkNonRecursive (fst topEntity) norm - cleanupGraph (fst topEntity) normChecked - transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval doNorm + let doNorm = do norm <- normalize [topEntity] + let normChecked = checkNonRecursive topEntity norm + cleanupGraph topEntity normChecked + transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval doNorm - normTime <- transformedBindings `deepseq` Clock.getCurrentTime - let prepNormDiff = Clock.diffUTCTime normTime prepTime - putStrLn $ "Normalisation took " ++ show prepNormDiff + normTime <- transformedBindings `deepseq` Clock.getCurrentTime + let prepNormDiff = Clock.diffUTCTime normTime prepTime + putStrLn $ "Normalisation took " ++ show prepNormDiff - let modName = takeWhile (/= '.') (name2String $ fst topEntity) - (netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm - typeTrans Nothing modName [] (fst topEntity) + let modName = takeWhile (/= '.') (name2String topEntity) + (netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm + typeTrans Nothing modName [] topEntity - netlistTime <- netlist `deepseq` Clock.getCurrentTime - let normNetDiff = Clock.diffUTCTime netlistTime normTime - putStrLn $ "Netlist generation took " ++ show normNetDiff + netlistTime <- netlist `deepseq` Clock.getCurrentTime + let normNetDiff = Clock.diffUTCTime netlistTime normTime + putStrLn $ "Netlist generation took " ++ show normNetDiff - let topComponent = head - $ filter (\(Component cName _ _ _ _) -> - Text.isSuffixOf (Text.pack "topEntity_0") - cName) - netlist + let topComponent = head + $ filter (\(Component cName _ _ _ _) -> + Text.isSuffixOf (genComponentName modName topEntity 0) + cName) + netlist - (testBench,dfiles') <- genTestBench opts supplyTB primMap - typeTrans tcm tupTcm eval cmpCnt bindingsMap - (listToMaybe $ map fst $ HashMap.toList testInputs) - (listToMaybe $ map fst $ HashMap.toList expectedOutputs) - modName - dfiles - topComponent + (testBench,dfiles') <- genTestBench opts supplyTB primMap + typeTrans tcm tupTcm eval cmpCnt bindingsMap + testInpM + expOutM + modName + dfiles + topComponent - testBenchTime <- testBench `seq` Clock.getCurrentTime - let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime - putStrLn $ "Testbench generation took " ++ show netTBDiff - - let hdlState' = fromMaybe (initBackend :: backend) hdlState - topWrapper = mkTopWrapper primMap teM modName topComponent - hdlDocs = createHDL hdlState' modName (topWrapper : netlist ++ testBench) - dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/" - , takeWhile (/= '.') (name2String $ fst topEntity) - , "/" - ] - prepareDir (opt_cleanhdl opts) (extension hdlState') dir - mapM_ (writeHDL hdlState' dir) hdlDocs - copyDataFiles dir dfiles' + testBenchTime <- testBench `seq` Clock.getCurrentTime + let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime + putStrLn $ "Testbench generation took " ++ show netTBDiff - end <- hdlDocs `seq` Clock.getCurrentTime - let startEndDiff = Clock.diffUTCTime end start - putStrLn $ "Total compilation took " ++ show startEndDiff + let hdlState' = fromMaybe (initBackend :: backend) hdlState + topWrapper = mkTopWrapper primMap annM modName topComponent + hdlDocs = createHDL hdlState' modName (topWrapper : netlist ++ testBench) + dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/" + , takeWhile (/= '.') (name2String topEntity) + , "/" + ] + prepareDir (opt_cleanhdl opts) (extension hdlState') dir + mapM_ (writeHDL hdlState' dir) hdlDocs + copyDataFiles dir dfiles' - [] -> error $ $(curLoc) ++ "No 'topEntity' found" - _ -> error $ $(curLoc) ++ "Multiple 'topEntity's found" + end <- hdlDocs `seq` Clock.getCurrentTime + let startEndDiff = Clock.diffUTCTime end start + putStrLn $ "Total compilation took " ++ show startEndDiff -- | Pretty print Components to HDL Documents createHDL :: Backend backend diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -109,17 +109,7 @@ componentNumber <- cmpCount <<%= (+1) modName <- Lens.use modNm - let componentName' = (Text.pack (modName ++ "_") `Text.append`) - . (`Text.append` (Text.pack $ show componentNumber)) - . ifThenElse Text.null - (`Text.append` Text.pack "Component_") - (`Text.append` Text.pack "_") - . mkBasicId' True - . stripDollarPrefixes - . last - . Text.splitOn (Text.pack ".") - . Text.pack - $ name2String compName + let componentName' = genComponentName modName compName componentNumber curCompNm .= componentName' tcm <- Lens.use tcCache @@ -152,6 +142,21 @@ compOutp = (mkBasicId . Text.pack $ name2String result, resType) component = Component componentName' (toList clks) compInps [compOutp] (netDecls ++ decls) return component + +genComponentName :: String -> TmName -> Int -> Identifier +genComponentName prefix nm i + = mkBasicId' True + . (Text.pack (prefix ++ "_") `Text.append`) + . (`Text.append` (Text.pack $ show i)) + . ifThenElse Text.null + (`Text.append` Text.pack "Component_") + (`Text.append` Text.pack "_") + . mkBasicId' True + . stripDollarPrefixes + . last + . Text.splitOn (Text.pack ".") + . Text.pack + $ name2String nm -- | Generate a list of Declarations for a let-binder mkDeclarations :: Id -- ^ LHS of the let-binder diff --git a/src/CLaSH/Netlist/Id.hs b/src/CLaSH/Netlist/Id.hs --- a/src/CLaSH/Netlist/Id.hs +++ b/src/CLaSH/Netlist/Id.hs @@ -31,7 +31,7 @@ . Text.group stripDollarPrefixes :: Text -> Text -stripDollarPrefixes = stripSpecPrefix . stripConPrefix +stripDollarPrefixes = stripWorkerPrefix . stripSpecPrefix . stripConPrefix . stripWorkerPrefix . stripDictFunPrefix where stripDictFunPrefix t = case Text.stripPrefix "$f" t of @@ -48,7 +48,9 @@ Just k -> k Nothing -> t - stripSpecPrefix t = snd (Text.breakOnEnd "$s" t) + stripSpecPrefix t = case Text.stripPrefix "$s" t of + Just k -> k + Nothing -> t -- snd (Text.breakOnEnd "$s" t) type UserString = Text -- As the user typed it diff --git a/src/Unbound/Generics/LocallyNameless/Extra.hs b/src/Unbound/Generics/LocallyNameless/Extra.hs --- a/src/Unbound/Generics/LocallyNameless/Extra.hs +++ b/src/Unbound/Generics/LocallyNameless/Extra.hs @@ -6,7 +6,7 @@ module Unbound.Generics.LocallyNameless.Extra where -#ifndef CABAL +#ifndef MIN_VERSION_unbound_generics #define MIN_VERSION_unbound_generics(x,y,z)(1) #endif @@ -15,9 +15,17 @@ import Control.DeepSeq #endif import Data.Hashable (Hashable(..),hash) +#if MIN_VERSION_unbound_generics(0,3,0) +import Data.Monoid +#endif import Data.Text (Text) import GHC.Real (Ratio) +#if MIN_VERSION_unbound_generics(0,3,0) +import Unbound.Generics.LocallyNameless.Alpha (Alpha (..), NamePatFind (..), + NthPatFind (..)) +#else import Unbound.Generics.LocallyNameless.Alpha (Alpha (..)) +#endif #if MIN_VERSION_unbound_generics(0,2,0) #else import Unbound.Generics.LocallyNameless.Bind (Bind (..)) @@ -61,9 +69,15 @@ close _ctx _b = id open _ctx _b = id isPat _ = mempty +#if MIN_VERSION_unbound_generics(0,3,0) + isTerm _ = All True + nthPatFind _ = NthPatFind Left + namePatFind _ = NamePatFind (const (Left 0)) +#else isTerm _ = True nthPatFind _ = Left namePatFind _ _ = Left 0 +#endif swaps' _ctx _p = id freshen' _ctx i = return (i, mempty) lfreshen' _ctx i cont = cont i mempty