diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,33 +1,47 @@ -# Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +# Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package -## 0.4 *November 17th 2014* +## 0.5 *March 11th 2015* * New features: - * Support for clash-prelude 0.6 + * Simplify BlackBox handling, and improve VHDL generation. [#47](https://github.com/clash-lang/clash-compiler/issues/47) + * Use unbound-generics. [#48](https://github.com/clash-lang/clash-compiler/issues/48) * Fixes bugs: - * clash-ghc ignores "-package-db" flag [#35](https://github.com/christiaanb/clash2/issues/35) + * VHDL generation error: wrapper for sum-of-products type. [#44](https://github.com/clash-lang/clash-compiler/issues/44) -## 0.3.3 *August 12th 2014* +## 0.4.1 *February 4th 2015* * Fixes bugs: - * Compile with GHC 7.8.3 [#31](https://github.com/christiaanb/clash2/issues/31) + * Treat BlackBox expressions as declarations when DC args. [#37](https://github.com/christiaanb/clash2/issues/33) + * Don't inline recursive closed bindings +## 0.4 *November 17th 2014* +* New features: + * Support for clash-prelude 0.6 + +* Fixes bugs: + * Ambiguous type: 'std_logic_vector' or 'std_ulogic_vector' [#33](https://github.com/christiaanb/clash2/issues/33) + ## 0.3.2 *June 5th 2014* * Fixes bugs: - * Type synonym improperly expanded [#17](https://github.com/christiaanb/clash2/issues/17) - * BlackBox for `Signed` `maxBound` and `minBound` generate incorrect VHDL. [#19](https://github.com/christiaanb/clash2/issues/19) - * Generate failure code in the VHDL for recSelError [#23](https://github.com/christiaanb/clash2/issues/23) + * VHDL array constant ambiguous [#18](https://github.com/christiaanb/clash2/issues/18) + * Exception: can't create selector [#24](https://github.com/christiaanb/clash2/issues/24) + * Calls to `vhdlTypeMark` don't result to inclusion of VHDL type in types.vhdl [#28](https://github.com/christiaanb/clash2/issues/28) ## 0.3.1 *May 15th 2014* * New features: + * Make ANF lift non-representable values [#7](https://github.com/christiaanb/clash2/issues/7) * Hardcode `fromInteger` for `Signed` and `Unsigned` [#9](https://github.com/christiaanb/clash2/issues/9) - * Better blackbox operation for vindex [#12](https://github.com/christiaanb/clash2/issues/12) * Replace VHDL default hole by error hole [#13](https://github.com/christiaanb/clash2/issues/13) * Fixes bugs: - * Update GHC2Core.hs [#1](https://github.com/christiaanb/clash2/issues/1) - * primitives (clash.sized.vector) [#2](https://github.com/christiaanb/clash2/issues/2) * Type families are not expanded [#3](https://github.com/christiaanb/clash2/issues/3) + * Exception: CLaSH.Netlist.VHDL(512): fromSLV: Vector 13 Bool [#5](https://github.com/christiaanb/clash2/issues/5) * Incorrect vhdl generation for default value in blackbox [#6](https://github.com/christiaanb/clash2/issues/6) - * Missing begin keyword in Signed/Unsigned JSON files [#16](https://github.com/christiaanb/clash2/issues/16) + * Duplicate type names when multiple ADTs need the same amount of bits [#8](https://github.com/christiaanb/clash2/issues/8) + * Circuit testbench generation with MAC example fails[#15](https://github.com/christiaanb/clash2/issues/15) + +* Code improvements: + * Refactor Netlist/BlackBox [#10](https://github.com/christiaanb/clash2/issues/10) + * CPP special-case conversion of `Control.Exception.Base.irrefutPatError` [#11](https://github.com/christiaanb/clash2/issues/11) + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012-2014, University of Twente +Copyright (c) 2012-2015, University of Twente All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,2 @@ -# Support -For updates and questions join the mailing list clash-language+subscribe@googlegroups.com or read the [forum](https://groups.google.com/d/forum/clash-language) - # `clash-lib` * See the LICENSE file for license and copyright details - -# `clash-ghc` - * See the LICENSE file for license and copyright details - * Contains code from the [GHC compiler](http://haskell.org/ghc), see the - LICENSE_GHC file for license and copyright details pertaining to that code. 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.4.1 +Version: 0.5 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -16,8 +16,6 @@ * The normalisation process that brings CoreHW in a normal form that can be converted to a netlist . - * VHDL Backend - . * Blackbox/Primitive Handling . . @@ -29,13 +27,13 @@ . . Prelude library: -Homepage: http://christiaanb.github.io/clash2 -bug-reports: http://github.com/christiaanb/clash2/issues -License: OtherLicense +Homepage: http://www.clash-lang.org/ +bug-reports: http://github.com/clash-lang/clash-compiler/issues +License: BSD2 License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij -Copyright: Copyright © 2012-2014 University of Twente +Copyright: Copyright © 2012-2015 University of Twente Category: Hardware Build-type: Simple @@ -46,13 +44,13 @@ source-repository head type: git - location: https://github.com/christiaanb/clash2.git + location: https://github.com/clash-lang/clash-compiler.git Library HS-Source-Dirs: src default-language: Haskell2010 - ghc-options: -O2 -Wall -fwarn-tabs + ghc-options: -Wall -fwarn-tabs CPP-Options: -DCABAL Build-depends: aeson >= 0.6.2.0, @@ -61,7 +59,6 @@ bytestring >= 0.10.0.2, concurrent-supply >= 0.1.7, containers >= 0.5.0.0, - contravariant >= 0.4.4, deepseq >= 1.3.0.2, directory >= 1.2.0.1, errors >= 1.4.2, @@ -69,7 +66,6 @@ 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, @@ -77,12 +73,14 @@ text >= 0.11.3.1, time >= 1.4.0.1, transformers >= 0.3.0.0, - unbound >= 0.4.2, + unbound-generics >= 0.1, unordered-containers >= 0.2.3.3, uu-parsinglib >= 2.8.1, wl-pprint-text >= 1.1.0.0 - Exposed-modules: CLaSH.Core.DataCon + Exposed-modules: CLaSH.Backend + + CLaSH.Core.DataCon CLaSH.Core.FreeVars CLaSH.Core.Literal CLaSH.Core.Pretty @@ -106,7 +104,6 @@ CLaSH.Netlist.Id CLaSH.Netlist.Types CLaSH.Netlist.Util - CLaSH.Netlist.VHDL CLaSH.Normalize CLaSH.Normalize.Strategy diff --git a/src/CLaSH/Backend.hs b/src/CLaSH/Backend.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Backend.hs @@ -0,0 +1,42 @@ +module CLaSH.Backend where + +import Data.HashSet (HashSet) +import Data.Text.Lazy (Text) +import Control.Monad.State (State) +import Text.PrettyPrint.Leijen.Text.Monadic (Doc) + +import CLaSH.Netlist.Types + +class Backend state where + -- | Initial state for state monad + initBackend :: state + + -- | Location for the primitive definitions + primDir :: state -> IO FilePath + + -- | Name of backend, used for directory to put output files in. Should be + -- | constant function / ignore argument. + name :: state -> String + + -- | File extension for target langauge + extension :: state -> String + + -- | Get the set of types out of state + extractTypes :: state -> HashSet HWType + + -- | Generate HDL for a Netlist component + genHDL :: Component -> State state (String, Doc) + -- | Generate a HDL package containing type definitions for the given HWTypes + mkTyPackage :: [HWType] -> State state Doc + -- | Convert a Netlist HWType to a target HDL type + hdlType :: HWType -> State state Doc + -- | Convert a Netlist HWType to an HDL error value for that type + hdlTypeErrValue :: HWType -> State state Doc + -- | Convert a Netlist HWType to the root of a target HDL type + hdlTypeMark :: HWType -> State state Doc + -- | Create a signal declaration from an identifier (Text) and Netlist HWType + hdlSig :: Text -> HWType -> State state Doc + -- | Turn a Netlist Declaration to a HDL concurrent block + inst :: Declaration -> State state (Maybe Doc) + -- | Turn a Netlist expression into a HDL expression + expr :: Bool -> Expr -> State state Doc 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,11 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -- | Data Constructors in CoreHW module CLaSH.Core.DataCon ( DataCon (..) @@ -15,13 +13,16 @@ ) where -import Control.DeepSeq -import Unbound.LocallyNameless as Unbound hiding (rnf) -import Unbound.LocallyNameless.Name (Name(Nm,Bn)) +import Data.Monoid (mempty) +import Data.Typeable (Typeable) +import Control.DeepSeq (NFData(..)) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha(..),Subst,substs) +import Unbound.Generics.LocallyNameless.Name (Name(..)) -import {-# SOURCE #-} CLaSH.Core.Term (Term) -import {-# SOURCE #-} CLaSH.Core.Type (TyName, Type) -import CLaSH.Util +import {-# SOURCE #-} CLaSH.Core.Term (Term) +import {-# SOURCE #-} CLaSH.Core.Type (TyName, Type) +import CLaSH.Util -- | Data Constructor data DataCon @@ -36,7 +37,7 @@ -- these type variables are not part of the result -- of the DataCon, but only of the arguments. , dcArgTys :: [Type] -- ^ Argument types - } + } deriving (Generic,Typeable) instance Show DataCon where show = show . dcName @@ -52,22 +53,25 @@ -- | DataCon reference type DcName = Name DataCon -Unbound.derive [''DataCon] - instance Alpha DataCon where - swaps' _ _ d = d - fv' _ _ = emptyC - lfreshen' _ a f = f a empty - freshen' _ a = return (a,empty) - aeq' c dc1 dc2 = aeq' c (dcName dc1) (dcName dc2) + aeq' c dc1 dc2 = aeq' c (dcName dc1) (dcName dc2) + + fvAny' _ _ dc = pure dc + + close _ _ dc = dc + open _ _ dc = dc + + isPat _ = mempty + isTerm _ = True + + nthPatFind _ = Left + namePatFind _ _ = Left 0 + + swaps' _ _ dc = dc + lfreshen' _ dc cont = cont dc mempty + freshen' _ dc = return (dc,mempty) + acompare' c dc1 dc2 = acompare' c (dcName dc1) (dcName dc2) - open _ _ d = d - close _ _ d = d - isPat _ = error "isPat DataCon" - isTerm _ = error "isTerm DataCon" - isEmbed _ = error "isEmbed DataCon" - nthpatrec _ = error "nthpatrec DataCon" - findpatrec _ _ = error "findpatrec DataCon" instance Subst Type DataCon instance Subst Term DataCon @@ -79,8 +83,8 @@ instance NFData (Name DataCon) where rnf nm = case nm of - (Nm _ s) -> rnf s - (Bn _ l r) -> rnf l `seq` rnf r + (Fn s i) -> rnf s `seq` rnf i + (Bn l r) -> rnf l `seq` rnf r -- | Given a DataCon and a list of types, the type variables of the DataCon -- type are substituted for the list of types. The argument types are returned. diff --git a/src/CLaSH/Core/DataCon.hs-boot b/src/CLaSH/Core/DataCon.hs-boot --- a/src/CLaSH/Core/DataCon.hs-boot +++ b/src/CLaSH/Core/DataCon.hs-boot @@ -1,19 +1,23 @@ {-# LANGUAGE MultiParamTypeClasses #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + module CLaSH.Core.DataCon where -import Control.DeepSeq -import Unbound.LocallyNameless +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha,Subst) -import {-# SOURCE #-} CLaSH.Core.Term (Term) -import {-# SOURCE #-} CLaSH.Core.Type (Type) +import {-# SOURCE #-} CLaSH.Core.Term (Term) +import {-# SOURCE #-} CLaSH.Core.Type (Type) data DataCon -instance Eq DataCon -instance Ord DataCon -instance Rep DataCon -instance Show DataCon -instance Alpha DataCon -instance Subst Type DataCon -instance Subst Term DataCon -instance NFData DataCon +instance Eq DataCon +instance Ord DataCon +instance Generic DataCon +instance Show DataCon +instance Alpha DataCon +instance Subst Type DataCon +instance Subst Term DataCon +instance NFData DataCon diff --git a/src/CLaSH/Core/FreeVars.hs b/src/CLaSH/Core/FreeVars.hs --- a/src/CLaSH/Core/FreeVars.hs +++ b/src/CLaSH/Core/FreeVars.hs @@ -1,31 +1,20 @@ -- | Free variable calculations module CLaSH.Core.FreeVars where -import Unbound.LocallyNameless (Collection, fv) +import Control.Lens.Fold (Fold) +import Unbound.Generics.LocallyNameless (fv) -import CLaSH.Core.Term (Term, TmName) -import CLaSH.Core.Type (TyName, Type) +import CLaSH.Core.Term (Term, TmName) +import CLaSH.Core.Type (TyName, Type) -- | Gives the free type-variables in a Type -typeFreeVars :: Collection c - => Type - -> c TyName +typeFreeVars :: Fold Type TyName typeFreeVars = fv --- | Gives the free type-variables and free term-variables of a Term -termFreeVars :: Collection c - => Term - -> (c TyName, c TmName) -termFreeVars tm = (termFreeTyVars tm, termFreeIds tm) - -- | Gives the free term-variables of a Term -termFreeIds :: Collection c - => Term - -> c TmName +termFreeIds :: Fold Term TmName termFreeIds = fv -- | Gives the free type-variables of a Term -termFreeTyVars :: Collection c - => Term - -> c TyName +termFreeTyVars :: Fold Term TyName termFreeTyVars = fv diff --git a/src/CLaSH/Core/Literal.hs b/src/CLaSH/Core/Literal.hs --- a/src/CLaSH/Core/Literal.hs +++ b/src/CLaSH/Core/Literal.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Term Literal module CLaSH.Core.Literal @@ -13,32 +11,28 @@ ) where -import Control.DeepSeq -import Unbound.LocallyNameless as Unbound hiding (rnf) -import Unbound.LocallyNameless.Alpha +import Control.DeepSeq (NFData (..)) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha (..), Subst (..)) -import {-# SOURCE #-} CLaSH.Core.Term (Term) -import {-# SOURCE #-} CLaSH.Core.Type (Type) -import CLaSH.Core.TysPrim (intPrimTy, voidPrimTy) +import {-# SOURCE #-} CLaSH.Core.Term (Term) +import {-# SOURCE #-} CLaSH.Core.Type (Type) +import CLaSH.Core.TysPrim (intPrimTy, voidPrimTy) +import CLaSH.Util -- | Term Literal data Literal = IntegerLiteral Integer | StringLiteral String | RationalLiteral Rational - deriving (Eq,Ord,Show) - -Unbound.derive [''Literal] + deriving (Eq,Ord,Show,Generic) -instance Alpha Rational -instance Subst b Rational +instance Subst b Rational where + subst _ _ = id + substs _ = id instance Alpha Literal where - fv' _ _ = emptyC - - acompare' _ (IntegerLiteral i) (IntegerLiteral j) = compare i j - acompare' _ (RationalLiteral i) (RationalLiteral j) = compare i j - acompare' c l1 l2 = acompareR1 rep1 c l1 l2 + fvAny' _ _ l = pure l instance Subst Type Literal instance Subst Term Literal diff --git a/src/CLaSH/Core/Pretty.hs b/src/CLaSH/Core/Pretty.hs --- a/src/CLaSH/Core/Pretty.hs +++ b/src/CLaSH/Core/Pretty.hs @@ -9,27 +9,27 @@ ) where -import Data.Char (isSymbol, isUpper, ord) -import Data.Traversable (sequenceA) -import Data.Text (unpack) -import GHC.Show (showMultiLineString) -import Text.PrettyPrint (Doc, char, comma, empty, equals, hang, - hsep, int, integer, parens, punctuate, - render, sep, text, vcat, ($$), ($+$), - (<+>), (<>), rational, nest) -import Unbound.LocallyNameless (Embed (..), LFresh, Name, lunbind, - name2String, runLFreshM, unembed, - unrebind, unrec) +import Data.Char (isSymbol, isUpper, ord) +import Data.Traversable (sequenceA) +import Data.Text (unpack) +import GHC.Show (showMultiLineString) +import Text.PrettyPrint (Doc, char, comma, empty, equals, hang, + hsep, int, integer, parens, punctuate, + render, sep, text, vcat, ($$), ($+$), + (<+>), (<>), rational, nest) +import Unbound.Generics.LocallyNameless (Embed (..), LFresh, Name, lunbind, + name2String, runLFreshM, unembed, + unrebind, unrec) -import CLaSH.Core.DataCon (DataCon (..)) -import CLaSH.Core.Literal (Literal (..)) -import CLaSH.Core.Term (Pat (..), Term (..)) -import CLaSH.Core.TyCon (TyCon (..), TyConName, isTupleTyConLike) -import CLaSH.Core.Type (ConstTy (..), Kind, LitTy (..), - Type (..), TypeView (..), tyView) -import CLaSH.Core.Var (Id, TyVar, Var, varKind, varName, - varType) -import CLaSH.Util +import CLaSH.Core.DataCon (DataCon (..)) +import CLaSH.Core.Literal (Literal (..)) +import CLaSH.Core.Term (Pat (..), Term (..)) +import CLaSH.Core.TyCon (TyCon (..), TyConName, isTupleTyConLike) +import CLaSH.Core.Type (ConstTy (..), Kind, LitTy (..), + Type (..), TypeView (..), tyView) +import CLaSH.Core.Var (Id, TyVar, Var, varKind, varName, + varType) +import CLaSH.Util -- | Pretty printing Show-like typeclass class Pretty p where diff --git a/src/CLaSH/Core/Subst.hs b/src/CLaSH/Core/Subst.hs --- a/src/CLaSH/Core/Subst.hs +++ b/src/CLaSH/Core/Subst.hs @@ -1,10 +1,10 @@ -- | Capture-free substitution function for CoreHW module CLaSH.Core.Subst where -import Unbound.LocallyNameless (subst, substs) +import Unbound.Generics.LocallyNameless (subst, substs) -import CLaSH.Core.Term (Term, TmName) -import {-# SOURCE #-} CLaSH.Core.Type (KiName, Kind, TyName, Type) +import CLaSH.Core.Term (Term, TmName) +import {-# SOURCE #-} CLaSH.Core.Type (KiName, Kind, TyName, Type) -- | Substitutes types in a type substTys :: [(TyName,Type)] 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 @@ -1,10 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Term representation in the CoreHW language: System F + LetRec + Case module CLaSH.Core.Term @@ -16,19 +16,21 @@ where -- External Modules -import Control.DeepSeq -import Unbound.LocallyNameless as Unbound hiding (Data,rnf) -import Unbound.LocallyNameless.Alpha (acompareR1, aeqR1, fvR1) -import Unbound.LocallyNameless.Name (Name(Nm,Bn),isFree) -import Unbound.LocallyNameless.Ops (unsafeUnbind) -import Data.Text (Text) +import Control.DeepSeq +import Data.Monoid (mempty) +import Data.Text (Text) +import Data.Typeable +import GHC.Generics +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.Name (Name(..)) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -- Internal Modules -import CLaSH.Core.DataCon (DataCon) -import CLaSH.Core.Literal (Literal) -import {-# SOURCE #-} CLaSH.Core.Type (Type) -import CLaSH.Core.Var (Id, TyVar) -import CLaSH.Util +import CLaSH.Core.DataCon (DataCon) +import CLaSH.Core.Literal (Literal) +import {-# SOURCE #-} CLaSH.Core.Type (Type) +import CLaSH.Core.Var (Id, TyVar) +import CLaSH.Util -- | Term representation in the CoreHW language: System F + LetRec + Case data Term @@ -43,7 +45,7 @@ | Letrec (Bind (Rec [LetBinding]) Term) -- ^ Recursive let-binding | Case Term Type [Bind Pat Term] -- ^ Case-expression: subject, type of -- alternatives, list of alternatives - deriving Show + deriving (Show,Typeable,Generic) -- | Term reference type TmName = Name Term @@ -59,12 +61,21 @@ -- ^ Literal pattern | DefaultPat -- ^ Default pattern - deriving (Show) - -Unbound.derive_abstract [''Text] -instance Alpha Text + deriving (Show,Typeable,Generic) -Unbound.derive [''Term,''Pat] +instance Alpha Text where + aeq' _ctx = (==) + fvAny' _ctx _nfn i = pure i + close _ctx _b = id + open _ctx _b = id + isPat _ = mempty + isTerm _ = True + nthPatFind _ = Left + namePatFind _ _ = Left 0 + swaps' _ctx _p = id + freshen' _ctx i = return (i, mempty) + lfreshen' _ctx i cont = cont i mempty + acompare' _ctx = compare instance Eq Term where (==) = aeq @@ -73,17 +84,17 @@ compare = acompare 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 + fvAny' c nfn (Var t n) = fmap (Var t) $ fvAny' c nfn n + fvAny' c nfn t = fmap to . gfvAny c nfn $ from t aeq' c (Var _ n) (Var _ m) = aeq' c n m aeq' _ (Prim t1 _) (Prim t2 _) = t1 == t2 - aeq' c t1 t2 = aeqR1 rep1 c t1 t2 + aeq' c t1 t2 = gaeq c (from t1) (from t2) + acompare' c (Var _ n) (Var _ m) = acompare' c n m + acompare' _ (Prim t1 _) (Prim t2 _) = compare t1 t2 + acompare' c t1 t2 = gacompare c (from t1) (from t2) + instance Alpha Pat instance Subst Term Pat @@ -93,7 +104,7 @@ instance Subst Type Pat instance Subst Type Term where - subst tvN u x | isFree tvN = case x of + subst tvN u x | isFreeName tvN = case x of Lam b -> Lam (subst tvN u b ) TyLam b -> TyLam (subst tvN u b ) App fun arg -> App (subst tvN u fun) (subst tvN u arg) @@ -107,8 +118,12 @@ e -> e subst m _ _ = error $ $(curLoc) ++ "Cannot substitute for bound variable: " ++ show m -instance Subst Term Text -instance Subst Type Text +instance Subst Term Text where + subst _ _ = id + substs _ = id +instance Subst Type Text where + subst _ _ = id + substs _ = id instance NFData Term where rnf tm = case tm of @@ -117,11 +132,11 @@ Literal l -> rnf l Prim nm ty -> rnf nm `seq` rnf ty Lam b -> case unsafeUnbind b of - (id_,tm) -> rnf id_ `seq` rnf tm + (id_,tm') -> rnf id_ `seq` rnf tm' TyLam b -> case unsafeUnbind b of - (tv,tm) -> rnf tv `seq` rnf tm + (tv,tm') -> rnf tv `seq` rnf tm' App tmL tmR -> rnf tmL `seq` rnf tmR - TyApp tm ty -> rnf tm `seq` rnf ty + TyApp tm' ty -> rnf tm' `seq` rnf ty Letrec b -> case unsafeUnbind b of (bs,e) -> rnf (map (second unembed) (unrec bs)) `seq` rnf e Case sc ty alts -> rnf sc `seq` rnf ty `seq` rnf (map unsafeUnbind alts) @@ -134,5 +149,5 @@ instance NFData (Name Term) where rnf nm = case nm of - (Nm _ s) -> rnf s - (Bn _ l r) -> rnf l `seq` rnf r + (Fn s i) -> rnf s `seq` rnf i + (Bn l r) -> rnf l `seq` rnf r diff --git a/src/CLaSH/Core/Term.hs-boot b/src/CLaSH/Core/Term.hs-boot --- a/src/CLaSH/Core/Term.hs-boot +++ b/src/CLaSH/Core/Term.hs-boot @@ -1,13 +1,17 @@ {-# LANGUAGE MultiParamTypeClasses #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + module CLaSH.Core.Term where -import Unbound.LocallyNameless +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha,Name,Subst) data Term type TmName = Name Term -instance Rep Term -instance Show Term -instance Alpha Term -instance Subst Term Term +instance Generic Term +instance Show Term +instance Alpha Term +instance Subst Term Term 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,12 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -- | Type Constructors in CoreHW module CLaSH.Core.TyCon ( TyCon (..) @@ -19,15 +15,18 @@ where -- External Import -import Control.DeepSeq -import Unbound.LocallyNameless as Unbound hiding (rnf) -import Unbound.LocallyNameless.Name (Name(Nm,Bn)) +import Control.DeepSeq +import Data.Monoid (mempty) +import Data.Typeable hiding (TyCon,tyConName) +import GHC.Generics +import Unbound.Generics.LocallyNameless (Alpha(..),Subst(..)) +import Unbound.Generics.LocallyNameless.Name (Name(..),name2String) -- Internal Imports -import {-# SOURCE #-} CLaSH.Core.DataCon (DataCon) -import {-# SOURCE #-} CLaSH.Core.Term (Term) -import {-# SOURCE #-} CLaSH.Core.Type (Kind, TyName, Type) -import CLaSH.Util +import {-# SOURCE #-} CLaSH.Core.DataCon (DataCon) +import {-# SOURCE #-} CLaSH.Core.Term (Term) +import {-# SOURCE #-} CLaSH.Core.Type (Kind, TyName, Type) +import CLaSH.Util -- | Type Constructor data TyCon @@ -55,6 +54,7 @@ | SuperKindTyCon { tyConName :: TyConName -- ^ Name of the TyCon } + deriving (Generic,Typeable) instance Show TyCon where show (AlgTyCon {tyConName = n}) = "AlgTyCon: " ++ show n @@ -84,25 +84,29 @@ -- The TyName's are the type-variables from -- the corresponding TyCon. } - deriving Show - -Unbound.derive [''TyCon,''AlgTyConRhs] + deriving (Show,Generic) instance Alpha TyCon where - swaps' _ _ d = d - fv' _ _ = emptyC - lfreshen' _ a f = f a empty - freshen' _ a = return (a,empty) - aeq' _ tc1 tc2 = aeq (tyConName tc1) (tyConName tc2) - acompare' _ tc1 tc2 = acompare (tyConName tc1) (tyConName tc2) - open _ _ d = d - close _ _ d = d - isPat _ = error "isPat TyCon" - isTerm _ = error "isTerm TyCon" - isEmbed _ = error "isEmbed TyCon" - nthpatrec _ = error "nthpatrec TyCon" - findpatrec _ _ = error "findpatrec TyCon" + aeq' c tc1 tc2 = aeq' c (tyConName tc1) (tyConName tc2) + fvAny' _ _ tc = pure tc + + close _ _ tc = tc + open _ _ tc = tc + + isPat _ = mempty + isTerm _ = True + + nthPatFind _ = Left + namePatFind _ _ = Left 0 + + swaps' _ _ tc = tc + lfreshen' _ tc cont = cont tc mempty + freshen' _ tc = return (tc,mempty) + + acompare' c tc1 tc2 = acompare' c (tyConName tc1) (tyConName tc2) + + instance Alpha AlgTyConRhs instance Subst Type TyCon @@ -113,15 +117,15 @@ instance NFData TyCon where rnf tc = case tc of - AlgTyCon nm ki ar rhs -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rhs - FunTyCon nm ki ar subst -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf subst - PrimTyCon nm ki ar -> rnf nm `seq` rnf ki `seq` rnf ar - SuperKindTyCon nm -> rnf nm + AlgTyCon nm ki ar rhs -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rhs + FunTyCon nm ki ar tcSubst -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf tcSubst + PrimTyCon nm ki ar -> rnf nm `seq` rnf ki `seq` rnf ar + SuperKindTyCon nm -> rnf nm instance NFData (Name TyCon) where rnf nm = case nm of - (Nm _ s) -> rnf s - (Bn _ l r) -> rnf l `seq` rnf r + (Fn s i) -> rnf s `seq` rnf i + (Bn l r) -> rnf l `seq` rnf r instance NFData AlgTyConRhs where rnf rhs = case rhs of @@ -139,10 +143,10 @@ isTupleTyConLike :: TyConName -> Bool isTupleTyConLike nm = tupleName (name2String nm) where - tupleName nm - | '(' <- head nm - , ')' <- last nm - = all (== ',') (init $ tail nm) + tupleName nm' + | '(' <- head nm' + , ')' <- last nm' + = all (== ',') (init $ tail nm') tupleName _ = False -- | Get the DataCons belonging to a TyCon diff --git a/src/CLaSH/Core/TyCon.hs-boot b/src/CLaSH/Core/TyCon.hs-boot --- a/src/CLaSH/Core/TyCon.hs-boot +++ b/src/CLaSH/Core/TyCon.hs-boot @@ -1,6 +1,6 @@ module CLaSH.Core.TyCon where -import Unbound.LocallyNameless (Name) +import Unbound.Generics.LocallyNameless (Name) data TyCon type TyConName = Name TyCon diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs --- a/src/CLaSH/Core/Type.hs +++ b/src/CLaSH/Core/Type.hs @@ -1,15 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 -{-# OPTIONS_GHC -fno-warn-duplicate-constraints #-} -#endif - -- | Types in CoreHW module CLaSH.Core.Type ( Type (..) @@ -43,23 +38,29 @@ where -- External import -import Control.DeepSeq as DS -import Control.Monad (zipWithM) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (isJust) -import Unbound.LocallyNameless as Unbound hiding (Arrow,rnf) -import Unbound.LocallyNameless.Alpha (aeqR1,fvR1) -import Unbound.LocallyNameless.Name (Name(Nm,Bn)) -import Unbound.LocallyNameless.Ops (unsafeUnbind) +import Control.DeepSeq as DS +import Control.Monad (zipWithM) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (isJust) +import Data.Typeable hiding (TyCon,mkFunTy, + mkTyConApp) +import GHC.Generics (Generic(..)) +import Unbound.Generics.LocallyNameless (Alpha(..),Bind,Fresh, + Subst(..),SubstName(..), + acompare,aeq,bind, + gacompare,gaeq,gfvAny, + runFreshM,unbind) +import Unbound.Generics.LocallyNameless.Name (Name(..), name2String) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -- Local imports -import CLaSH.Core.Subst +import CLaSH.Core.Subst import {-# SOURCE #-} CLaSH.Core.Term -import CLaSH.Core.TyCon -import CLaSH.Core.TysPrim -import CLaSH.Core.Var -import CLaSH.Util +import CLaSH.Core.TyCon +import CLaSH.Core.TysPrim +import CLaSH.Core.Var +import CLaSH.Util -- | Types in CoreHW: function and polymorphic types data Type @@ -68,7 +69,7 @@ | ForAllTy (Bind TyVar Type) -- ^ Polymorphic Type | AppTy Type Type -- ^ Type Application | LitTy LitTy -- ^ Type literal - deriving Show + deriving (Show,Generic,Typeable) -- | An easier view on types data TypeView @@ -81,13 +82,13 @@ data ConstTy = TyCon TyConName -- ^ TyCon type | Arrow -- ^ Function type - deriving Show + deriving (Show,Generic,Typeable) -- | Literal Types data LitTy = NumTy Int | SymTy String - deriving Show + deriving (Show,Generic,Typeable) -- | The level above types type Kind = Type @@ -99,15 +100,16 @@ -- | Reference to a Kind type KiName = Name Kind -Unbound.derive [''Type,''LitTy,''ConstTy] - instance Alpha Type where - fv' c (VarTy _ n) = fv' c n - fv' c t = fvR1 rep1 c t + fvAny' c nfn (VarTy t n) = fmap (VarTy t) $ fvAny' c nfn n + fvAny' c nfn t = fmap to . gfvAny c nfn $ from t aeq' c (VarTy _ n) (VarTy _ m) = aeq' c n m - aeq' c t1 t2 = aeqR1 rep1 c t1 t2 + aeq' c t1 t2 = gaeq c (from t1) (from t2) + acompare' c (VarTy _ n) (VarTy _ m) = acompare' c n m + acompare' c t1 t2 = gacompare c (from t1) (from t2) + instance Alpha ConstTy instance Alpha LitTy @@ -137,8 +139,8 @@ instance NFData (Name Type) where rnf nm = case nm of - (Nm _ s) -> rnf s - (Bn _ l r) -> rnf l `seq` rnf r + (Fn s i) -> rnf s `seq` rnf i + (Bn l r) -> rnf l `seq` rnf r instance NFData ConstTy where rnf cty = case cty of @@ -163,7 +165,7 @@ transparentTy :: Type -> Type transparentTy ty@(AppTy (AppTy (ConstTy (TyCon tc)) _) elTy) = case name2String tc of - "CLaSH.Signal.Internal.CSignal" -> transparentTy elTy + "CLaSH.Signal.Internal.Signal'" -> transparentTy elTy _ -> ty transparentTy (AppTy ty1 ty2) = AppTy (transparentTy ty1) (transparentTy ty2) transparentTy (ForAllTy b) = ForAllTy (uncurry bind $ second transparentTy $ unsafeUnbind b) @@ -176,7 +178,7 @@ let tView = tyView ty in case tView of TyConApp tc args -> case name2String tc of - "CLaSH.Signal.Internal.CSignal" -> coreView tcMap (args !! 1) + "CLaSH.Signal.Internal.Signal'" -> coreView tcMap (args !! 1) _ -> case (tcMap HashMap.! tc) of (AlgTyCon {algTcRhs = (NewTyCon _ nt)}) | length (fst nt) == length args -> coreView tcMap (newTyConInstRhs nt args) diff --git a/src/CLaSH/Core/Type.hs-boot b/src/CLaSH/Core/Type.hs-boot --- a/src/CLaSH/Core/Type.hs-boot +++ b/src/CLaSH/Core/Type.hs-boot @@ -1,9 +1,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + module CLaSH.Core.Type where -import Control.DeepSeq -import Unbound.LocallyNameless +import Control.DeepSeq +import Data.Typeable +import GHC.Generics +import Unbound.Generics.LocallyNameless import {-# SOURCE #-} CLaSH.Core.Term import {-# SOURCE #-} CLaSH.Core.TyCon @@ -14,14 +19,14 @@ type TyName = Name Type type KiName = Name Kind -instance Eq Type -instance Ord Type -instance Rep Type -instance Show Type -instance Alpha Type -instance Subst Type Type -instance Subst Term Type -instance NFData Type -instance NFData (Name Type) +instance Eq Type +instance Generic Type +instance Show Type +instance Alpha Type +instance Subst Type Type +instance Subst Term Type +instance NFData Type +instance NFData (Name Type) +instance Typeable Type mkTyConTy :: TyConName -> Type diff --git a/src/CLaSH/Core/TysPrim.hs b/src/CLaSH/Core/TysPrim.hs --- a/src/CLaSH/Core/TysPrim.hs +++ b/src/CLaSH/Core/TysPrim.hs @@ -9,11 +9,11 @@ ) where -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Unbound.LocallyNameless (string2Name) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Unbound.Generics.LocallyNameless (string2Name) -import CLaSH.Core.TyCon +import CLaSH.Core.TyCon import {-# SOURCE #-} CLaSH.Core.Type -- | Builtin Name diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -1,25 +1,23 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-} - -- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where -import Data.HashMap.Lazy (HashMap) -import Unbound.LocallyNameless (Fresh, bind, embed, unbind, unembed, - unrebind, unrec) -import Unbound.LocallyNameless.Ops (unsafeUnbind) +import Data.HashMap.Lazy (HashMap) +import Unbound.Generics.LocallyNameless (Fresh, bind, embed, unbind, unembed, + unrebind, unrec) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -import CLaSH.Core.DataCon (dcType) -import CLaSH.Core.Literal (literalType) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term (Pat (..), Term (..), TmName) -import CLaSH.Core.Type (Kind, TyName, Type (..), applyTy, - isFunTy, isPolyFunCoreTy, mkFunTy, - splitFunTy) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Core.Var (Id, TyVar, Var (..), varType) -import CLaSH.Util +import CLaSH.Core.DataCon (dcType) +import CLaSH.Core.Literal (literalType) +import CLaSH.Core.Pretty (showDoc) +import CLaSH.Core.Term (Pat (..), Term (..), TmName) +import CLaSH.Core.Type (Kind, TyName, Type (..), applyTy, + isFunTy, isPolyFunCoreTy, mkFunTy, + splitFunTy) +import CLaSH.Core.TyCon (TyCon, TyConName) +import CLaSH.Core.Var (Id, TyVar, Var (..), varType) +import CLaSH.Util -- | Type environment/context type Gamma = HashMap TmName Type diff --git a/src/CLaSH/Core/Var.hs b/src/CLaSH/Core/Var.hs --- a/src/CLaSH/Core/Var.hs +++ b/src/CLaSH/Core/Var.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -6,11 +8,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 -{-# OPTIONS_GHC -fno-warn-duplicate-constraints #-} -#endif - -- | Variables in CoreHW module CLaSH.Core.Var ( Var (..) @@ -20,13 +17,15 @@ ) where -import Control.DeepSeq as DS -import Unbound.LocallyNameless as Unbound hiding (rnf) -import Unbound.LocallyNameless.Name (isFree) +import Control.DeepSeq (NFData (..)) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha,Embed,Name,Subst(..),isFreeName, + unembed) -import {-# SOURCE #-} CLaSH.Core.Term (Term) -import {-# SOURCE #-} CLaSH.Core.Type (Kind, Type) -import CLaSH.Util +import {-# SOURCE #-} CLaSH.Core.Term (Term) +import {-# SOURCE #-} CLaSH.Core.Type (Kind, Type) +import CLaSH.Util -- | Variables in CoreHW data Var a @@ -40,23 +39,21 @@ { varName :: Name a , varType :: Embed Type } - deriving (Eq,Ord,Show) + deriving (Eq,Show,Generic,Typeable) -- | Term variable type Id = Var Term -- | Type variable type TyVar = Var Type -Unbound.derive [''Var] - -instance Alpha a => Alpha (Var a) +instance (Typeable a, Alpha a) => Alpha (Var a) instance Subst Term Id instance Subst Term TyVar instance Subst Type TyVar instance Subst Type Id where - subst tvN u (Id idN ty) | isFree tvN = Id idN (subst tvN u ty) + subst tvN u (Id idN ty) | isFreeName tvN = Id idN (subst tvN u ty) subst m _ _ = error $ $(curLoc) ++ "Cannot substitute for bound variable: " ++ show m instance NFData (Name a) => NFData (Var a) where diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -1,50 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | Module that connects all the parts of the CLaSH compiler library module CLaSH.Driver where -import qualified Control.Concurrent.Supply as Supply +import qualified Control.Concurrent.Supply as Supply import Control.DeepSeq -import Control.Monad.State (evalState) -import Control.Lens (_1, use) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet -import Data.List (isSuffixOf) -import Data.Maybe (listToMaybe) -import qualified Data.Text.Lazy as Text -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath -import qualified System.IO as IO -import Text.PrettyPrint.Leijen.Text (Doc, hPutDoc) -import Unbound.LocallyNameless (name2String) +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.List (isSuffixOf) +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Text.Lazy as Text +import qualified Data.Time.Clock as Clock +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified System.IO as IO +import Text.PrettyPrint.Leijen.Text (Doc, hPutDoc) +import Unbound.Generics.LocallyNameless (name2String) -import CLaSH.Core.Term (Term) -import CLaSH.Core.Type (Type) -import CLaSH.Core.TyCon (TyCon, TyConName) +import CLaSH.Backend +import CLaSH.Core.Term (Term) +import CLaSH.Core.Type (Type) +import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Driver.TestbenchGen import CLaSH.Driver.Types -import CLaSH.Netlist (genNetlist) -import CLaSH.Netlist.Types (Component (..), HWType, - VHDLState) -import CLaSH.Netlist.VHDL (genVHDL, mkTyPackage) -import CLaSH.Normalize (checkNonRecursive, cleanupGraph, - normalize, runNormalization) +import CLaSH.Netlist (genNetlist) +import CLaSH.Netlist.Types (Component (..), HWType) +import CLaSH.Normalize (checkNonRecursive, cleanupGraph, + normalize, runNormalization) import CLaSH.Primitives.Types -import CLaSH.Rewrite.Types (DebugLevel (..)) +import CLaSH.Rewrite.Types (DebugLevel (..)) import CLaSH.Util -import qualified Data.Time.Clock as Clock - --- | Create a set of .VHDL files for a set of functions -generateVHDL :: BindingMap -- ^ Set of functions - -> PrimMap -- ^ Primitive / BlackBox Definitions - -> HashMap TyConName TyCon -- ^ TyCon cache - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator - -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) - -> DebugLevel -- ^ Debug information level for the normalization process - -> IO () -generateVHDL bindingsMap primMap tcm typeTrans eval dbgLevel = do +-- | Create a set of target HDL files for a set of functions +generateHDL :: forall backend . Backend backend + => BindingMap -- ^ Set of functions + -> Maybe backend + -> PrimMap -- ^ Primitive / BlackBox Definitions + -> HashMap TyConName TyCon -- ^ TyCon cache + -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator + -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) + -> DebugLevel -- ^ Debug information level for the normalization process + -> IO () +generateHDL bindingsMap hdlState primMap tcm typeTrans eval dbgLevel = do start <- Clock.getCurrentTime prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime let prepStartDiff = Clock.diffUTCTime prepTime start @@ -79,7 +79,7 @@ let prepNormDiff = Clock.diffUTCTime normTime prepTime putStrLn $ "Normalisation took " ++ show prepNormDiff - (netlist,vhdlState,cmpCnt) <- genNetlist Nothing Nothing + (netlist,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm typeTrans Nothing (fst topEntity) @@ -93,62 +93,63 @@ cName) netlist - (testBench,vhdlState') <- genTestBench dbgLevel supplyTB primMap - typeTrans tcm eval vhdlState cmpCnt bindingsMap - (listToMaybe $ map fst $ HashMap.toList testInputs) - (listToMaybe $ map fst $ HashMap.toList expectedOutputs) - topComponent + testBench <- genTestBench dbgLevel supplyTB primMap + typeTrans tcm eval cmpCnt bindingsMap + (listToMaybe $ map fst $ HashMap.toList testInputs) + (listToMaybe $ map fst $ HashMap.toList expectedOutputs) + topComponent testBenchTime <- testBench `seq` Clock.getCurrentTime let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime putStrLn $ "Testbench generation took " ++ show netTBDiff - let vhdlDocs = createVHDL vhdlState' (netlist ++ testBench) - dir = concat [ "./vhdl/" + let hdlState' = fromMaybe (initBackend :: backend) hdlState + hdlDocs = createHDL hdlState' (netlist ++ testBench) + dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/" , takeWhile (/= '.') (name2String $ fst topEntity) , "/" ] prepareDir dir - mapM_ (writeVHDL dir) vhdlDocs + mapM_ (writeHDL hdlState' dir) hdlDocs - end <- vhdlDocs `seq` Clock.getCurrentTime + end <- hdlDocs `seq` Clock.getCurrentTime let startEndDiff = Clock.diffUTCTime end start putStrLn $ "Total compilation took " ++ show startEndDiff [] -> error $ $(curLoc) ++ "No 'topEntity' found" _ -> error $ $(curLoc) ++ "Multiple 'topEntity's found" --- | Pretty print Components to VHDL Documents -createVHDL :: VHDLState +-- | Pretty print Components to HDL Documents +createHDL :: Backend backend + => backend -> [Component] -> [(String,Doc)] -createVHDL vhdlState components = flip evalState vhdlState $ do - (vhdlNms,vhdlDocs) <- unzip <$> mapM genVHDL components - let vhdlNmDocs = zip vhdlNms vhdlDocs - hwtys <- HashSet.toList <$> use _1 +createHDL backend components = flip evalState backend $ do + (hdlNms,hdlDocs) <- unzip <$> mapM genHDL components + let hdlNmDocs = zip hdlNms hdlDocs + hwtys <- HashSet.toList <$> extractTypes <$> get typesPkg <- mkTyPackage hwtys - return (("types",typesPkg):vhdlNmDocs) + return (("types",typesPkg):hdlNmDocs) --- | Prepares the directory for writing VHDL files. This means creating the --- dir if it does not exist and removing all existing .vhdl files from it. +-- | Prepares the directory for writing HDL files. This means creating the +-- dir if it does not exist and removing all existing .hdl files from it. prepareDir :: String -> IO () prepareDir dir = do -- Create the dir if needed Directory.createDirectoryIfMissing True dir - -- Find all .vhdl files in the directory + -- Find all .hdl files in the directory files <- Directory.getDirectoryContents dir - let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files + let to_remove = filter ((==".hdl") . FilePath.takeExtension) files -- Prepend the dirname to the filenames let abs_to_remove = map (FilePath.combine dir) to_remove -- Remove the files mapM_ Directory.removeFile abs_to_remove --- | Writes a VHDL file to the given directory -writeVHDL :: FilePath -> (String, Doc) -> IO () -writeVHDL dir (cname, vhdl) = do - handle <- IO.openFile (dir ++ cname ++ ".vhdl") IO.WriteMode - IO.hPutStrLn handle "-- Automatically generated VHDL" - hPutDoc handle vhdl +-- | Writes a HDL file to the given directory +writeHDL :: Backend backend => backend -> FilePath -> (String, Doc) -> IO () +writeHDL backend dir (cname, hdl) = do + handle <- IO.openFile (dir ++ cname ++ CLaSH.Backend.extension backend) IO.WriteMode + hPutDoc handle hdl IO.hPutStr handle "\n" IO.hClose handle 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 @@ -1,33 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-} - --- | Generate a VHDL testbench for a component given a set of stimuli and a +-- | Generate a HDL testbench for a component given a set of stimuli and a -- set of matching expected outputs module CLaSH.Driver.TestbenchGen ( genTestBench ) where import Control.Concurrent.Supply (Supply) -import Control.Monad.State (evalState) import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap import Data.List (find,nub) import Data.Maybe (mapMaybe) import Data.Text.Lazy (isPrefixOf,pack,splitOn) -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.RealFloat as Builder -import Text.PrettyPrint.Leijen.Text ((<+>), (<>)) -import qualified Text.PrettyPrint.Leijen.Text as PP -import Unbound.LocallyNameless (name2String) +import Unbound.Generics.LocallyNameless (name2String) import CLaSH.Core.Term import CLaSH.Core.TyCon import CLaSH.Core.Type import CLaSH.Netlist +import CLaSH.Netlist.BlackBox.Types (Element (Err)) +import CLaSH.Netlist.BlackBox.Util (parseFail) import CLaSH.Netlist.Types as N -import CLaSH.Netlist.VHDL (vhdlTypeErrValue) import CLaSH.Normalize (cleanupGraph, normalize, runNormalization) import CLaSH.Primitives.Types @@ -35,8 +30,7 @@ import CLaSH.Util - --- | Generate a VHDL testbench for a component given a set of stimuli and a +-- | Generate a HDL testbench for a component given a set of stimuli and a -- set of matching expected outputs genTestBench :: DebugLevel -> Supply @@ -44,36 +38,33 @@ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> HashMap TyConName TyCon -> (HashMap TyConName TyCon -> Term -> Term) - -> VHDLState -> Int -> HashMap TmName (Type,Term) -- ^ Global binders -> Maybe TmName -- ^ Stimuli -> Maybe TmName -- ^ Expected output -> Component -- ^ Component to generate TB for - -> IO ([Component],VHDLState) -genTestBench dbgLvl supply primMap typeTrans tcm eval vhdlState cmpCnt globals stimuliNmM expectedNmM + -> IO ([Component]) +genTestBench dbgLvl supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM (Component cName hidden [inp] outp _) = do - let ioDecl = [ uncurry NetDecl inp Nothing - , uncurry NetDecl outp Nothing + let ioDecl = [ uncurry NetDecl inp + , uncurry NetDecl outp ] - inpAssg = evalState (vhdlTypeErrValue (snd inp)) vhdlState - inpExpr = Assignment (fst inp) (BlackBoxE (PP.displayT $ PP.renderCompact inpAssg) Nothing) - (inpInst,inpComps,vhdlState',cmpCnt',hidden') <- maybe (return (inpExpr,[],vhdlState,cmpCnt,hidden)) - (genStimuli vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp) + inpExpr = Assignment (fst inp) (BlackBoxE "" [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False) + (inpInst,inpComps,cmpCnt',hidden') <- maybe (return (inpExpr,[],cmpCnt,hidden)) + (genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp) stimuliNmM - let finDecl = [ NetDecl "finished" Bool (Just (N.Literal Nothing (BoolLit False))) - , Assignment "done" (Identifier "finished" Nothing) + let finDecl = [ NetDecl "finished" Bool + , genDone primMap ] - finAssg = "true after 100 ns" - finExpr = Assignment "finished" (BlackBoxE (PP.displayT $ PP.renderCompact finAssg) Nothing) - (expInst,expComps,vhdlState'',hidden'') <- maybe (return (finExpr,[],vhdlState',hidden')) - (genVerifier vhdlState' cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp) + finExpr = genFinish primMap + (expInst,expComps,hidden'') <- maybe (return (finExpr,[],hidden')) + (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp) expectedNmM let clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _) -> Just clkNm ; _ -> Nothing) hidden rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _) -> Just clkNm ; _ -> Nothing) hidden - clks = mapMaybe genClock hidden'' - rsts = mapMaybe genReset hidden'' + clks = mapMaybe (genClock primMap) hidden'' + rsts = mapMaybe (genReset primMap) hidden'' let instDecl = InstDecl cName "totest" (map (\i -> (i,Identifier i Nothing)) @@ -88,7 +79,7 @@ , [instDecl,inpInst,expInst] ]) - return (tbComp:(inpComps++expComps),vhdlState'') + return (tbComp:(inpComps++expComps)) where normalizeSignal :: HashMap TmName (Type,Term) -> TmName @@ -96,62 +87,72 @@ normalizeSignal glbls bndr = runNormalization dbgLvl supply glbls typeTrans tcm eval (normalize [bndr] >>= cleanupGraph bndr) -genTestBench dbgLvl _ _ _ _ _ v _ _ _ _ c = traceIf (dbgLvl > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],v) +genTestBench dbgLvl _ _ _ _ _ _ _ _ _ c = traceIf (dbgLvl > DebugNone) ("Can't make testbench for: " ++ show c) $ return [] -genClock :: (Identifier,HWType) +genClock :: PrimMap + -> (Identifier,HWType) -> Maybe [Declaration] -genClock (clkName,Clock rate) = Just clkDecls +genClock primMap (clkName,Clock rate) = Just clkDecls where - clkGenDecl = PP.vsep - [ "-- pragma translate_off" - , "process is" - , "begin" - , PP.indent 2 - (PP.vsep [ "wait for 2 ns;" - , "while (not finished) loop" - , PP.indent 2 - (PP.vsep [PP.text clkName <+> "<= not" <+> PP.text clkName <> PP.semi - ,"wait for" <+> renderFloat2Dec (fromIntegral rate * 0.5) <+> "ns;" - ,PP.text clkName <+> "<= not" <+> PP.text clkName <> PP.semi - ,"wait for" <+> renderFloat2Dec (fromIntegral rate * 0.5) <+> "ns;" - ]) - , "end loop;" - , "wait;" - ]) - , "end process;" - , "-- pragma translate_on" - ] + clkGenDecl = case HashMap.lookup "CLaSH.Driver.TestbenchGen.clockGen" primMap of + Just (BlackBox _ (Left templ)) -> let (rising,rest) = divMod (toInteger rate) 2 + falling = rising + rest + ctx = emptyBBContext + { bbResult = (Left (Identifier clkName Nothing), Clock rate) + , bbInputs = [ (Left (N.Literal Nothing (NumLit 2)),Integer,True) + , (Left (N.Literal Nothing (NumLit rising)),Integer,True) + , (Left (N.Literal Nothing (NumLit falling)),Integer,True) + ] + } + in BlackBoxD "CLaSH.Driver.TestbenchGen.clockGen" (parseFail templ) ctx + pM -> error $ $(curLoc) ++ ("Can't make clock declaration for: " ++ show pM) - clkDecls = [ NetDecl clkName (Clock rate) (Just (N.Literal Nothing (BitLit L))) - , BlackBoxD (PP.displayT $ PP.renderPretty 0.4 80 clkGenDecl) - ] + clkDecls = [ NetDecl clkName (Clock rate) + , clkGenDecl + ] -genClock _ = Nothing +genClock _ _ = Nothing -genReset :: (Identifier,HWType) +genReset :: PrimMap + -> (Identifier,HWType) -> Maybe [Declaration] -genReset (rstName,Reset clk) = Just rstDecls +genReset primMap (rstName,Reset clk) = Just rstDecls where - rstExpr = PP.vsep - [ "-- pragma translate_off" - , PP.text rstName <+> "<=" <+> PP.align (PP.vsep (PP.punctuate PP.comma - [ "'0' after 0 ns" - , "'1' after 1 ns;" - ])) - , "-- pragma translate_on" - ] + resetGenDecl = case HashMap.lookup "CLaSH.Driver.TestbenchGen.resetGen" primMap of + Just (BlackBox _ (Left templ)) -> let ctx = emptyBBContext + { bbResult = (Left (Identifier rstName Nothing), Reset clk) + , bbInputs = [(Left (N.Literal Nothing (NumLit 1)),Integer,True)] + } + in BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" (parseFail templ) ctx + pM -> error $ $(curLoc) ++ ("Can't make reset declaration for: " ++ show pM) - rstDecls = [ NetDecl rstName (Reset clk) Nothing - , BlackBoxD (PP.displayT $ PP.renderCompact rstExpr) + rstDecls = [ NetDecl rstName (Reset clk) + , resetGenDecl ] -genReset _ = Nothing +genReset _ _ = Nothing -renderFloat2Dec :: Float -> PP.Doc -renderFloat2Dec = PP.text . Builder.toLazyText . Builder.formatRealFloat Builder.Fixed (Just 2) +genFinish :: PrimMap + -> Declaration +genFinish primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.finishedGen" primMap of + Just (BlackBox _ (Left templ)) -> let ctx = emptyBBContext + { bbResult = (Left (Identifier "finished" Nothing), Bool) + , bbInputs = [ (Left (N.Literal Nothing (NumLit 100)),Integer,True) ] + } + in BlackBoxD "CLaSH.Driver.TestbenchGen.finishGen" (parseFail templ) ctx + pM -> error $ $(curLoc) ++ ("Can't make finish declaration for: " ++ show pM) -genStimuli :: VHDLState - -> Int +genDone :: PrimMap + -> Declaration +genDone primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.doneGen" primMap of + Just (BlackBox _ (Left templ)) -> let ctx = emptyBBContext + { bbResult = (Left (Identifier "done" Nothing), Bool) + , bbInputs = [(Left (Identifier "finished" Nothing),Bool,False)] + } + in BlackBoxD "CLaSH.Driver.TestbenchGen.doneGen" (parseFail templ) ctx + pM -> error $ $(curLoc) ++ ("Can't make done declaration for: " ++ show pM) + +genStimuli :: Int -> PrimMap -> HashMap TmName (Type,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) @@ -162,10 +163,10 @@ -> [(Identifier,HWType)] -> (Identifier,HWType) -> TmName - -> IO (Declaration,[Component],VHDLState,Int,[(Identifier,HWType)]) -genStimuli vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp signalNm = do + -> IO (Declaration,[Component],Int,[(Identifier,HWType)]) +genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp signalNm = do let stimNormal = normalizeSignal globals signalNm - (comps,vhdlState',cmpCnt') <- genNetlist (Just vhdlState) (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm + (comps,cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm let sigNm = last (splitOn (pack ".") (pack (name2String signalNm))) sigComp = case find ((isPrefixOf sigNm) . componentName) comps of Just c -> c @@ -182,10 +183,9 @@ (concat [ clkNms, rstNms ]) ++ [(outp,Identifier (fst inp) Nothing)] ) - return (decl,comps,vhdlState',cmpCnt',hidden'') + return (decl,comps,cmpCnt',hidden'') -genVerifier :: VHDLState - -> Int +genVerifier :: Int -> PrimMap -> HashMap TmName (Type,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) @@ -196,10 +196,10 @@ -> [(Identifier,HWType)] -> (Identifier,HWType) -> TmName - -> IO (Declaration,[Component],VHDLState,[(Identifier,HWType)]) -genVerifier vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp signalNm = do + -> IO (Declaration,[Component],[(Identifier,HWType)]) +genVerifier cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp signalNm = do let stimNormal = normalizeSignal globals signalNm - (comps,vhdlState',_) <- genNetlist (Just vhdlState) (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm + (comps,_) <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm let sigNm = last (splitOn (pack ".") (pack (name2String signalNm))) sigComp = case find ((isPrefixOf sigNm) . componentName) comps of Just c -> c @@ -215,4 +215,4 @@ (concat [ clkNms, rstNms ]) ++ [(inp,Identifier (fst outp) Nothing),(fin,Identifier "finished" Nothing)] ) - return (decl,comps,vhdlState',hidden'') + return (decl,comps,hidden'') diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -4,43 +4,40 @@ -- | Create Netlists out of normalized CoreHW Terms module CLaSH.Netlist where -import Control.Lens ((.=), (<<%=)) -import qualified Control.Lens as Lens -import Control.Monad.State (runStateT) -import Control.Monad.Writer (listen, runWriterT) -import Data.Either (lefts,partitionEithers) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.HashSet as HashSet -import Data.List (elemIndex, nub) -import Data.Maybe (fromMaybe) -import qualified Data.Text.Lazy as Text -import Unbound.LocallyNameless (Embed (..), name2String, - runFreshMT, unbind, unembed, - unrebind) +import Control.Lens ((.=), (<<%=)) +import qualified Control.Lens as Lens +import Control.Monad.State (runStateT) +import Control.Monad.Writer (listen, runWriterT) +import Data.Either (lefts,partitionEithers) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Data.List (elemIndex, nub) +import Data.Maybe (fromMaybe) +import qualified Data.Text.Lazy as Text +import Unbound.Generics.LocallyNameless (Embed (..), name2String, + runFreshMT, unbind, unembed, + unrebind) -import CLaSH.Core.DataCon (DataCon (..)) -import CLaSH.Core.Literal (Literal (..)) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term (Pat (..), Term (..), TmName) -import qualified CLaSH.Core.Term as Core -import CLaSH.Core.Type (Type (..)) -import CLaSH.Core.TyCon (TyConName, TyCon) -import CLaSH.Core.Util (collectArgs, isVar, termType) -import CLaSH.Core.Var (Id, Var (..)) +import CLaSH.Core.DataCon (DataCon (..)) +import CLaSH.Core.Literal (Literal (..)) +import CLaSH.Core.Pretty (showDoc) +import CLaSH.Core.Term (Pat (..), Term (..), TmName) +import qualified CLaSH.Core.Term as Core +import CLaSH.Core.Type (Type (..)) +import CLaSH.Core.TyCon (TyConName, TyCon) +import CLaSH.Core.Util (collectArgs, isVar, termType) +import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.BlackBox import CLaSH.Netlist.Id -import CLaSH.Netlist.Types as HW +import CLaSH.Netlist.Types as HW import CLaSH.Netlist.Util import CLaSH.Normalize.Util -import CLaSH.Primitives.Types as P +import CLaSH.Primitives.Types as P import CLaSH.Util -- | Generate a hierarchical netlist out of a set of global binders with -- @topEntity@ at the top. -genNetlist :: Maybe VHDLState - -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad - -> Maybe Int +genNetlist :: Maybe Int -- ^ Starting number of the component counter -> HashMap TmName (Type,Term) -- ^ Global binders @@ -54,15 +51,13 @@ -- ^ Symbol count -> TmName -- ^ Name of the @topEntity@ - -> IO ([Component],VHDLState,Int) -genNetlist vhdlStateM compCntM globals primMap tcm typeTrans mStart topEntity = do - (_,s) <- runNetlistMonad vhdlStateM compCntM globals primMap tcm typeTrans $ genComponent topEntity mStart - return (HashMap.elems $ _components s, _vhdlMState s, _cmpCount s) + -> IO ([Component],Int) +genNetlist compCntM globals primMap tcm typeTrans mStart topEntity = do + (_,s) <- runNetlistMonad compCntM globals primMap tcm typeTrans $ genComponent topEntity mStart + return (HashMap.elems $ _components s, _cmpCount s) -- | Run a NetlistMonad action in a given environment -runNetlistMonad :: Maybe VHDLState - -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad - -> Maybe Int +runNetlistMonad :: Maybe Int -- ^ Starting number of the component counter -> HashMap TmName (Type,Term) -- ^ Global binders @@ -74,14 +69,14 @@ -- ^ Hardcode Type -> HWType translator -> NetlistMonad a -- ^ Action to run - -> IO (a,NetlistState) -runNetlistMonad vhdlStateM compCntM s p tcm typeTrans + -> IO (a, NetlistState) +runNetlistMonad compCntM s p tcm typeTrans = runFreshMT . flip runStateT s' . (fmap fst . runWriterT) . runNetlist where - s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p (fromMaybe (HashSet.empty,0,HashMap.empty) vhdlStateM) typeTrans tcm + s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p typeTrans tcm -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function @@ -91,8 +86,8 @@ compExprM <- fmap (HashMap.lookup compName) $ Lens.use bindings case compExprM of Nothing -> error $ $(curLoc) ++ "No normalized expression found for: " ++ show compName - Just (_,expr) -> makeCached compName components $ - genComponentT compName expr mStart + Just (_,expr_) -> makeCached compName components $ + genComponentT compName expr_ mStart -- | Generate a component for a given function genComponentT :: TmName -- ^ Name of the function @@ -118,7 +113,7 @@ (arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr ; case normalizedM of Right normalized -> mkUniqueNormalized normalized - Left err -> error err + Left err -> error $ $(curLoc) ++ err } let ids = HashMap.fromList @@ -137,7 +132,6 @@ let netDecls = map (\(id_,_) -> NetDecl (mkBasicId . Text.pack . name2String $ varName id_) (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm . unembed $ varType id_) - Nothing ) $ filter ((/= result) . varName . fst) binders (decls,clks) <- listen $ concat <$> mapM (uncurry mkDeclarations . second unembed) binders @@ -164,6 +158,7 @@ tcm <- Lens.use tcCache scrutTy <- termType tcm scrut let sHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy + vHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm varTy (selId,decls) <- case scrut of (Var _ scrutNm) -> return (mkBasicId . Text.pack $ name2String scrutNm,[]) _ -> do @@ -171,16 +166,22 @@ i <- varCount <<%= (+1) let tmpNm = "tmp_" ++ show i tmpNmT = Text.pack tmpNm - tmpDecl = NetDecl tmpNmT sHwTy Nothing + tmpDecl = NetDecl tmpNmT sHwTy tmpAssn = Assignment tmpNmT newExpr return (tmpNmT,newDecls ++ [tmpDecl,tmpAssn]) let dstId = mkBasicId . Text.pack . name2String $ varName bndr altVarId = mkBasicId . Text.pack $ name2String varTm modifier = case pat of - DataPat (Embed dc) ids -> let (_,tms) = unrebind ids + DataPat (Embed dc) ids -> let tms = case unrebind ids of + ([],tms') -> tms' + _ -> error $ $(curLoc) ++ "Not in normal form: Pattern binds existential variables: " ++ showDoc e in case elemIndex (Id varTm (Embed varTy)) tms of Nothing -> Nothing - Just fI -> Just (Indexed (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy,dcTag dc - 1,fI)) + Just fI + | sHwTy /= vHwTy -> Just (Indexed (sHwTy,dcTag dc - 1,fI)) + -- When element and subject have the same HW-type, + -- then the projections is just the identity + | otherwise -> Just (DC (Void,0)) _ -> error $ $(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection: " ++ showDoc e extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier return (decls ++ [Assignment dstId extractExpr]) @@ -190,7 +191,7 @@ tcm <- Lens.use tcCache scrutTy <- termType tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy - (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (last alts'))) <$> mkExpr False scrutTy scrut + (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (last alts'))) <$> mkExpr True scrutTy scrut (exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts' let dstId = mkBasicId . Text.pack . name2String $ varName bndr @@ -210,7 +211,6 @@ DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1)) in case scrutE of Identifier scrutId _ -> Identifier scrutId modifier - BlackBoxE bbE _ -> BlackBoxE bbE modifier _ -> error $ $(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement" _ -> scrutE @@ -272,7 +272,7 @@ Data dc | all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy dc tmArgs | otherwise -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments" - Prim nm _ -> first fst <$> mkPrimitive False bbEasD nm args ty + Prim nm _ -> mkPrimitive False bbEasD nm args ty Var _ f | null tmArgs -> return (Identifier (mkBasicId . Text.pack $ name2String f) Nothing,[]) | otherwise -> error $ $(curLoc) ++ "Not in normal form: top-level binder in argument position: " ++ showDoc app @@ -286,7 +286,9 @@ mkDcApplication dstHType dc args = do tcm <- Lens.use tcCache argTys <- mapM (termType tcm) args - (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr True t e) (zip args argTys) + let isSP (SP _ _) = True + isSP _ = False + (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr (isSP dstHType) t e) (zip args argTys) argHWTys <- mapM coreTypeToHWTypeM argTys fmap (,argDecls) $! case (argHWTys,argExprs) of -- Is the DC just a newtype wrapper? @@ -296,23 +298,23 @@ let dcI = dcTag dc - 1 dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI case compare (length dcArgs) (length argExprs) of - EQ -> return (HW.DataCon dstHType (Just $ DC (dstHType,dcI)) argExprs) + EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprs) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" Product _ dcArgs -> case compare (length dcArgs) (length argExprs) of - EQ -> return (HW.DataCon dstHType (Just $ DC (dstHType,0)) argExprs) + EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprs) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" Sum _ _ -> - return (HW.DataCon dstHType (Just $ DC (dstHType,dcTag dc - 1)) []) + return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) []) Bool -> let dc' = case dcTag dc of 1 -> HW.Literal Nothing (BoolLit False) 2 -> HW.Literal Nothing (BoolLit True) tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" in return dc' - Vector 0 _ -> return (HW.DataCon dstHType Nothing []) + Vector 0 _ -> return (HW.DataCon dstHType VecAppend []) -- Note [Vector Wrapper] -- The Vector type has two versions of the cons constructor: -- * The 'normal' one, which takes a coercion as its first argument, @@ -322,10 +324,10 @@ -- We need to account for both occurrences, that's why we have the two -- case statements below: Vector 1 _ -> case argExprs of - [_,e,_] -> return (HW.DataCon dstHType (Just VecAppend) [e]) - _ -> return (HW.DataCon dstHType (Just VecAppend) [head argExprs]) + [_,e,_] -> return (HW.DataCon dstHType VecAppend [e]) + _ -> return (HW.DataCon dstHType VecAppend [head argExprs]) Vector _ _ -> case argExprs of - [_,e1,e2] -> return (HW.DataCon dstHType (Just VecAppend) [e1,e2]) - _ -> return (HW.DataCon dstHType (Just VecAppend) argExprs) + [_,e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2]) + _ -> return (HW.DataCon dstHType VecAppend argExprs) _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) diff --git a/src/CLaSH/Netlist.hs-boot b/src/CLaSH/Netlist.hs-boot --- a/src/CLaSH/Netlist.hs-boot +++ b/src/CLaSH/Netlist.hs-boot @@ -3,20 +3,19 @@ import CLaSH.Core.DataCon (DataCon) import CLaSH.Core.Term (Term,TmName) import CLaSH.Core.Type (Type) -import CLaSH.Netlist.Types (Expr,HWType,NetlistMonad,Component,Declaration) +import CLaSH.Netlist.Types (Expr, HWType, NetlistMonad, Component, + Declaration) -genComponent :: - TmName - -> Maybe Int - -> NetlistMonad Component +genComponent :: TmName + -> Maybe Int + -> NetlistMonad Component mkExpr :: Bool -> Type -> Term -> NetlistMonad (Expr,[Declaration]) -mkDcApplication :: - HWType - -> DataCon - -> [Term] - -> NetlistMonad (Expr,[Declaration]) +mkDcApplication :: HWType + -> DataCon + -> [Term] + -> NetlistMonad (Expr,[Declaration]) 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 @@ -1,35 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -- | Functions to create BlackBox Contexts and fill in BlackBox templates module CLaSH.Netlist.BlackBox where import Control.Lens ((.=),(<<%=)) import qualified Control.Lens as Lens -import Control.Monad (filterM, mzero) -import Control.Monad.State (state) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Maybe (MaybeT (..)) -import Control.Monad.Writer (tell) -import Data.Either (lefts, partitionEithers) +import Control.Monad (filterM) +import Data.Either (lefts) import qualified Data.HashMap.Lazy as HashMap -import Data.List (partition) -import Data.Maybe (catMaybes, fromJust) +import qualified Data.IntMap as IntMap import Data.Monoid (mconcat) import Data.Text.Lazy (Text, fromStrict, pack) import qualified Data.Text.Lazy as Text import Data.Text (unpack) import qualified Data.Text as TextS -import Unbound.LocallyNameless (embed, name2String, string2Name, +import Unbound.Generics.LocallyNameless (embed, name2String, string2Name, unembed) +-- import CLaSH.Backend as N import CLaSH.Core.DataCon as D (dcTag) import CLaSH.Core.Literal as L (Literal (..)) import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term as C (Term (..), TmName) +import CLaSH.Core.Term as C (Term (..)) import CLaSH.Core.Type as C (Type (..), ConstTy (..), splitFunTys) import CLaSH.Core.TyCon as C (tyConDataCons) @@ -43,7 +37,6 @@ import CLaSH.Netlist.Id as N import CLaSH.Netlist.Types as N import CLaSH.Netlist.Util as N -import CLaSH.Netlist.VHDL as N import CLaSH.Normalize.Util (isConstant) import CLaSH.Primitives.Types as P import CLaSH.Util @@ -54,70 +47,81 @@ -> NetlistMonad (BlackBoxContext,[Declaration]) mkBlackBoxContext resId args = do -- Make context inputs - tcm <- Lens.use tcCache - args' <- fmap (zip args) $ mapM (isFun tcm) args - (varInps,declssV) <- fmap (unzip . catMaybes) $ mapM (runMaybeT . mkInput) args' - let (_,otherArgs) = partitionEithers $ map unVar args' - (litArgs,funArgs) = partition (\(t,b) -> not b && isConstant t) otherArgs - (litInps,declssL) <- fmap (unzip . catMaybes) $ mapM (runMaybeT . mkLitInput . fst) litArgs - (funInps,declssF) <- fmap (unzip . catMaybes) $ mapM (runMaybeT . mkFunInput resId . fst) funArgs + tcm <- Lens.use tcCache + (imps,impDecls) <- unzip <$> mapM mkArgument args + (funs,funDecls) <- mapAccumLM (addFunction tcm) IntMap.empty (zip args [0..]) -- Make context result let res = case synchronizedClk tcm (unembed $ V.varType resId) of - Just clk -> Right . (,clk) . mkBasicId . pack $ name2String (V.varName resId) - Nothing -> Left . mkBasicId . pack $ name2String (V.varName resId) - resTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) + Just clk -> Right . (,clk) . (`N.Identifier` Nothing) . mkBasicId . pack $ name2String (V.varName resId) + Nothing -> Left . (`N.Identifier` Nothing) . mkBasicId . pack $ name2String (V.varName resId) + resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) - return ( Context (res,resTy) varInps (map fst litInps) funInps - , concat declssV ++ concat declssL ++ concat declssF + return ( Context (res,resTy) imps funs + , concat impDecls ++ concat funDecls ) where - unVar :: (Term, Bool) -> Either TmName (Term, Bool) - unVar (Var _ v, False) = Left v - unVar t = Right t - --- | Instantiate a BlackBox template according to the given context -mkBlackBox :: Text -- ^ Template to instantiate - -> BlackBoxContext -- ^ Context to instantiate template with - -> NetlistMonad Text -mkBlackBox templ bbCtx = - let (l,err) = runParse templ - in if null err && verifyBlackBoxContext l bbCtx - then do - l' <- instantiateSym l - (bb,clks) <- liftState vhdlMState $ state $ renderBlackBox l' bbCtx - tell clks - return $! bb - else error $ $(curLoc) ++ "\nCan't match template:\n" ++ show templ ++ "\nwith context:\n" ++ show bbCtx ++ "\ngiven errors:\n" ++ show err - --- | Create an template instantiation text for an argument term -mkInput :: (Term, Bool) - -> MaybeT NetlistMonad ((SyncIdentifier,HWType),[Declaration]) -mkInput (_, True) = return ((Left $ pack "__FUN__", Void),[]) + addFunction tcm im (arg,i) = do + isF <- isFun tcm arg + if isF + then do (f,d) <- mkFunInput resId arg + let im' = IntMap.insert i f im + return (im',d) + else return (im,[]) -mkInput (Var ty v, False) = do - let vT = mkBasicId . pack $ name2String v - tcm <- Lens.use tcCache - hwTy <- lift $ N.unsafeCoreTypeToHWTypeM $(curLoc) ty - case synchronizedClk tcm ty of - Just clk -> return ((Right (vT,clk), hwTy),[]) - Nothing -> return ((Left vT, hwTy),[]) +prepareBlackBox :: TextS.Text + -> Text + -> BlackBoxContext + -> NetlistMonad BlackBoxTemplate +prepareBlackBox pNm t bbCtx = + let (templ,err) = runParse t + in if null err && verifyBlackBoxContext bbCtx templ + then do + templ' <- instantiateSym templ + templ'' <- setClocks bbCtx templ' + return $! templ'' + else + error $ $(curLoc) ++ "\nCan't match template for " ++ show pNm ++ " :\n" ++ show t ++ + "\nwith context:\n" ++ show bbCtx ++ "\ngiven errors:\n" ++ + show err -mkInput (e, False) = case collectArgs e of - (Prim f _, args) -> do - tcm <- Lens.use tcCache - ty <- termType tcm e - ((exprN,hwTy),decls) <- lift $ mkPrimitive True False f args ty - exprV <- fmap (pack . show) $ liftState vhdlMState $ N.expr False exprN - return ((Left exprV,hwTy),decls) - _ -> fmap (first (first Left)) $ mkLitInput e +mkArgument :: Term + -> NetlistMonad ( (SyncExpr,HWType,Bool) + , [Declaration] + ) +mkArgument e = do + tcm <- Lens.use tcCache + ty <- termType tcm e + hwTyM <- N.termHWTypeM e + ((e',t,l),d) <- case hwTyM of + Nothing -> return ((Identifier "__VOID__" Nothing,Void,False),[]) + Just hwTy -> case collectArgs e of + (Var _ v,[]) -> let vT = Identifier (mkBasicId . pack $ name2String v) Nothing + in return ((vT,hwTy,False),[]) + (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal Nothing (N.NumLit i),hwTy,True),[]) + (Prim f _,args) -> do + (e',d) <- mkPrimitive True False f args ty + case e' of + (Identifier _ _) -> return ((e',hwTy,False), d) + _ -> return ((e',hwTy,isConstant e), d) + (Data dc, args) -> do + typeTrans <- Lens.use typeTranslator + args' <- filterM (fmap (representableType typeTrans tcm) . termType tcm) (lefts args) + (exprN,dcDecls) <- mkDcApplication hwTy dc args' + return ((exprN,hwTy,isConstant e),dcDecls) + _ -> return ((Identifier "__VOID__" Nothing,hwTy,False),[]) + return ((addClock tcm ty e',t,l),d) + where + addClock tcm ty e' = case synchronizedClk tcm ty of + Just clk -> Right (e',clk) + _ -> Left e' mkPrimitive :: Bool -- ^ Put BlackBox expression in parenthesis -> Bool -- ^ Treat BlackBox expression as declaration -> TextS.Text -> [Either Term Type] -> Type - -> NetlistMonad ((Expr,HWType),[Declaration]) + -> NetlistMonad (Expr,[Declaration]) mkPrimitive bbEParen bbEasD nm args ty = do bbM <- HashMap.lookup nm <$> Lens.use primitives case bbM of @@ -127,20 +131,21 @@ tmpNmT = pack tmpNm tmpId = Id (string2Name tmpNm) (embed ty) (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId (lefts args) - let hwTy = snd $ result bbCtx + let hwTy = snd $ bbResult bbCtx case template p of (Left tempD) -> do - let tmpDecl = NetDecl tmpNmT hwTy Nothing - bbDecl <- N.BlackBoxD <$> mkBlackBox tempD bbCtx - return ((Identifier tmpNmT Nothing,hwTy),ctxDcls ++ [tmpDecl,bbDecl]) + let tmpDecl = NetDecl tmpNmT hwTy + pNm = name p + bbDecl <- N.BlackBoxD pNm <$> prepareBlackBox pNm tempD bbCtx <*> pure bbCtx + return (Identifier tmpNmT Nothing,ctxDcls ++ [tmpDecl,bbDecl]) (Right tempE) -> do - bbExpr <- mkBlackBox tempE bbCtx - let bbExpr' = if bbEParen then mconcat ["(",bbExpr,")"] else bbExpr + let pNm = name p + bbTempl <- prepareBlackBox pNm tempE bbCtx if bbEasD - then let tmpDecl = NetDecl tmpNmT hwTy Nothing - tmpAssgn = Assignment tmpNmT (BlackBoxE bbExpr' Nothing) - in return ((Identifier tmpNmT Nothing, hwTy), ctxDcls ++ [tmpDecl,tmpAssgn]) - else return ((BlackBoxE bbExpr' Nothing,hwTy),ctxDcls) + then let tmpDecl = NetDecl tmpNmT hwTy + tmpAssgn = Assignment tmpNmT (BlackBoxE pNm bbTempl bbCtx bbEParen) + in return (Identifier tmpNmT Nothing, ctxDcls ++ [tmpDecl,tmpAssgn]) + else return (BlackBoxE pNm bbTempl bbCtx bbEParen,ctxDcls) Just (P.Primitive pNm _) | pNm == "GHC.Prim.tagToEnum#" -> do hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty @@ -150,145 +155,101 @@ let dcs = tyConDataCons (tcm HashMap.! tcN) dc = dcs !! fromInteger i (exprN,dcDecls) <- mkDcApplication hwTy dc [] - return ((exprN,hwTy),dcDecls) + return (exprN,dcDecls) [Right _, Left scrut] -> do i <- varCount <<%= (+1) tcm <- Lens.use tcCache scrutTy <- termType tcm scrut + scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy (scrutExpr,scrutDecls) <- mkExpr False scrutTy scrut - let tmpNm = "tmp_tte_" ++ show i - tmpS = pack tmpNm - netDecl = NetDecl tmpS hwTy Nothing - netAssign = Assignment tmpS (DataTag hwTy (Left scrutExpr)) - return ((Identifier tmpS Nothing,hwTy),netDecl:netAssign:scrutDecls) + let tmpRhs = pack ("tmp_tte_rhs_" ++ show i) + tmpS = pack ("tmp_tte_" ++ show i) + netDeclRhs = NetDecl tmpRhs scrutHTy + netDeclS = NetDecl tmpS hwTy + netAssignRhs = Assignment tmpRhs scrutExpr + netAssignS = Assignment tmpS (DataTag hwTy (Left tmpRhs)) + return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls) _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) | pNm == "GHC.Prim.dataToTag#" -> case args of - [Right _,Left (Data dc)] -> return ((N.Literal Nothing (NumLit $ toInteger $ dcTag dc - 1),Integer),[]) + [Right _,Left (Data dc)] -> return (N.Literal Nothing (NumLit $ toInteger $ dcTag dc - 1),[]) [Right _,Left scrut] -> do i <- varCount <<%= (+1) + j <- varCount <<%= (+1) tcm <- Lens.use tcCache scrutTy <- termType tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy (scrutExpr,scrutDecls) <- mkExpr False scrutTy scrut - let tmpNm = "tmp_dtt_" ++ show i - tmpS = pack tmpNm - netDecl = NetDecl tmpS Integer Nothing - netAssign = Assignment tmpS (DataTag scrutHTy (Right scrutExpr)) - return ((Identifier tmpS Nothing,Integer),netDecl:netAssign:scrutDecls) - _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) - | pNm == "CLaSH.Sized.Internal.BitVector.fromInteger#" -> case lefts args of - largs@[C.Literal (IntegerLiteral i),arg] -> - let sz = fromInteger i - in case arg of - C.Literal (IntegerLiteral j) -> - return ((N.Literal (Just (BitVector sz,sz)) (NumLit $ fromInteger j), BitVector sz),[]) - _ -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs - bb <- mkBlackBox (pack "std_logic_vector(to_unsigned(~ARG[1],~LIT[0]))") bbCtx - return ((BlackBoxE bb Nothing,BitVector sz),ctxDcls) - _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Signed.fromInteger#: " ++ show (map (either showDoc showDoc) args) - | pNm == "CLaSH.Sized.Internal.Signed.fromInteger#" -> case lefts args of - largs@[C.Literal (IntegerLiteral i),arg] -> - let sz = fromInteger i - in case arg of - C.Literal (IntegerLiteral j) - | i > 32 -> return ((N.Literal (Just (Signed sz,sz)) (NumLit $ fromInteger j), Signed sz),[]) - _ -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs - bb <- mkBlackBox (pack "to_signed(~ARG[1],~LIT[0])") bbCtx - return ((BlackBoxE bb Nothing,Signed sz),ctxDcls) - _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Signed.fromInteger#: " ++ show (map (either showDoc showDoc) args) - | pNm == "CLaSH.Sized.Internal.Unsigned.fromInteger#" -> case lefts args of - largs@[C.Literal (IntegerLiteral i),arg] -> - let sz = fromInteger i - in case arg of - C.Literal (IntegerLiteral j) - | i > 31 -> return ((N.Literal (Just (Unsigned sz,sz)) (NumLit $ fromInteger j), Unsigned sz),[]) - _ -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs - bb <- mkBlackBox (pack "to_unsigned(~ARG[1],~LIT[0])") bbCtx - return ((BlackBoxE bb Nothing,Unsigned sz),ctxDcls) - _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Unsigned.fromInteger#: " ++ show (map (either showDoc showDoc) args) - | otherwise -> return ((BlackBoxE (mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]) Nothing,Void),[]) + let tmpRhs = pack ("tmp_dtt_rhs_" ++ show i) + tmpS = pack ("tmp_dtt_" ++ show j) + netDeclRhs = NetDecl tmpRhs scrutHTy + netDeclS = NetDecl tmpS Integer + netAssignRhs = Assignment tmpRhs scrutExpr + netAssignS = Assignment tmpS (DataTag scrutHTy (Right tmpRhs)) + return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls) + _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args) + | otherwise -> return (BlackBoxE "" [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[]) _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm --- | Create an template instantiation text for an argument term, given that --- the term is a literal. Returns 'Nothing' if the term is not a literal. -mkLitInput :: Term -- ^ The literal argument term - -> MaybeT NetlistMonad ((Identifier,HWType),[Declaration]) -mkLitInput (C.Literal (IntegerLiteral i)) = return ((pack $ show i,Integer),[]) -mkLitInput e@(collectArgs -> (Data dc, args)) = lift $ do - typeTrans <- Lens.use typeTranslator - tcm <- Lens.use tcCache - args' <- filterM (fmap (representableType typeTrans tcm) . termType tcm) (lefts args) - hwTy <- N.termHWType $(curLoc) e - (exprN,dcDecls) <- mkDcApplication hwTy dc args' - exprV <- fmap (pack . show) $ liftState vhdlMState $ N.expr False exprN - return ((exprV,hwTy),dcDecls) -mkLitInput _ = mzero - -- | Create an template instantiation text and a partial blackbox content for an -- argument term, given that the term is a function. Errors if the term is not -- a function -mkFunInput :: Id -- ^ Identifier binding the encompassing primitive/blackbox application +mkFunInput :: Id -- ^ Identifier binding the encompassing primitive/blackbox application -> Term -- ^ The function argument term - -> MaybeT NetlistMonad ((BlackBoxTemplate,BlackBoxContext),[Declaration]) + -> NetlistMonad ((Either BlackBoxTemplate Declaration,BlackBoxContext),[Declaration]) mkFunInput resId e = do let (appE,args) = collectArgs e - (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args) + (bbCtx,dcls) <- mkBlackBoxContext resId (lefts args) templ <- case appE of Prim nm _ -> do bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives let templ = case bbM of - Just p@(P.BlackBox {}) -> template p - Just (P.Primitive pNm _) - | pNm == "CLaSH.Sized.Internal.BitVector.fromInteger#" -> Right "std_logic_vector(to_unsigned(~ARG[1],~LIT[0]))" - | pNm == "CLaSH.Sized.Internal.Signed.fromInteger#" -> Right "to_signed(~ARG[1],~LIT[0])" - | pNm == "CLaSH.Sized.Internal.Unsigned.fromInteger#" -> Right "to_unsigned(~ARG[1],~LIT[0])" + Just p@(P.BlackBox {}) -> Left (name p, template p) _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm return templ Data dc -> do tcm <- Lens.use tcCache eTy <- termType tcm e let (_,resTy) = splitFunTys tcm eTy - resHTyM <- lift $ coreTypeToHWTypeM resTy + resHTyM <- coreTypeToHWTypeM resTy case resHTyM of Just resHTy@(SP _ dcArgPairs) -> do let dcI = dcTag dc - 1 dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]] - dcApp = DataCon resHTy (Just $ DC (resHTy,dcI)) dcInps + dcApp = DataCon resHTy (DC (resHTy,dcI)) dcInps dcAss = Assignment (pack "~RESULT") dcApp - templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst dcAss - return (Left templ) + return (Right dcAss) Just resHTy@(Product _ dcArgs) -> do let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]] - dcApp = DataCon resHTy (Just $ DC (resHTy,0)) dcInps + dcApp = DataCon resHTy (DC (resHTy,0)) dcInps dcAss = Assignment (pack "~RESULT") dcApp - templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst dcAss - return (Left templ) + return (Right dcAss) _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e Var _ fun -> do normalized <- Lens.use bindings case HashMap.lookup fun normalized of Just _ -> do - (Component compName hidden compInps compOutp _) <- lift $ preserveVarEnv $ genComponent fun Nothing + (Component compName hidden compInps compOutp _) <- preserveVarEnv $ genComponent fun Nothing let hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden inpAssigns = zip (map fst compInps) [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ] outpAssign = (fst compOutp,Identifier (pack "~RESULT") Nothing) i <- varCount <<%= (+1) let instLabel = Text.concat [compName,pack ("_" ++ show i)] instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns) - templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst instDecl - return (Left templ) - Nothing -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e - _ -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e - let (l,err) = either runParse (first (([O,C " <= "] ++) . (++ [C ";"])) . runParse) templ - if null err - then do - l' <- lift $ instantiateSym l - return ((l',bbCtx),dcls) - else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err + return (Right instDecl) + Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e + _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e + case templ of + Left (_, Left templ') -> let (l,err) = runParse templ' + in if null err + then do + l' <- instantiateSym l + l'' <- setClocks bbCtx l' + return ((Left l'',bbCtx),dcls) + else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err + Left (_, Right templ') -> let ass = Assignment (pack "~RESULT") (Identifier templ' Nothing) + in return ((Right ass, bbCtx),dcls) + Right decl -> return ((Right decl,bbCtx),dcls) -- | Instantiate symbols references with a new symbol and increment symbol counter instantiateSym :: BlackBoxTemplate diff --git a/src/CLaSH/Netlist/BlackBox/Parser.hs b/src/CLaSH/Netlist/BlackBox/Parser.hs --- a/src/CLaSH/Netlist/BlackBox/Parser.hs +++ b/src/CLaSH/Netlist/BlackBox/Parser.hs @@ -3,7 +3,6 @@ (runParse) where -import Data.ListLike.Text.TextLazy () import Data.Text.Lazy (Text, pack) import Text.ParserCombinators.UU import Text.ParserCombinators.UU.BasicInstances hiding (Parser) @@ -29,6 +28,7 @@ pElement :: Parser Element pElement = pTagD <|> C <$> pText + <|> C <$> (pack <$> pToken "~ ") -- | Parse the Text part of a Template pText :: Parser Text @@ -54,21 +54,23 @@ -- | Parse an Expression element pTagE :: Parser Element -pTagE = O <$ pToken "~RESULT" - <|> I <$> (pToken "~ARG" *> pBrackets pNatural) - <|> I <$> (pToken "~LIT" *> pBrackets pNatural) - <|> (Clk . Just) <$> (pToken "~CLK" *> pBrackets pNatural) - <|> Clk Nothing <$ pToken "~CLKO" - <|> (Rst . Just) <$> (pToken "~RST" *> pBrackets pNatural) - <|> Rst Nothing <$ pToken "~RSTO" - <|> Sym <$> (pToken "~SYM" *> pBrackets pNatural) - <|> Typ Nothing <$ pToken "~TYPO" - <|> (Typ . Just) <$> (pToken "~TYP" *> pBrackets pNatural) - <|> TypM Nothing <$ pToken "~TYPMO" - <|> (TypM . Just) <$> (pToken "~TYPM" *> pBrackets pNatural) - <|> Err Nothing <$ pToken "~ERRORO" - <|> (Err . Just) <$> (pToken "~ERROR" *> pBrackets pNatural) - <|> TypElem <$> (pToken "~TYPEL" *> pBrackets pTagE) +pTagE = O <$ pToken "~RESULT" + <|> I <$> (pToken "~ARG" *> pBrackets pNatural) + <|> L <$> (pToken "~LIT" *> pBrackets pNatural) + <|> (Clk . Just) <$> (pToken "~CLK" *> pBrackets pNatural) + <|> Clk Nothing <$ pToken "~CLKO" + <|> (Rst . Just) <$> (pToken "~RST" *> pBrackets pNatural) + <|> Rst Nothing <$ pToken "~RSTO" + <|> Sym <$> (pToken "~SYM" *> pBrackets pNatural) + <|> Typ Nothing <$ pToken "~TYPO" + <|> (Typ . Just) <$> (pToken "~TYP" *> pBrackets pNatural) + <|> TypM Nothing <$ pToken "~TYPMO" + <|> (TypM . Just) <$> (pToken "~TYPM" *> pBrackets pNatural) + <|> Err Nothing <$ pToken "~ERRORO" + <|> (Err . Just) <$> (pToken "~ERROR" *> pBrackets pNatural) + <|> TypElem <$> (pToken "~TYPEL" *> pBrackets pTagE) + <|> SigD <$> (pToken "~SIGD" *> pBrackets pTagE) <*> (Just <$> (pBrackets pNatural)) + <|> (`SigD` Nothing) <$> (pToken "~SIGDO" *> pBrackets pTagE) -- | Parse a bracketed text pBrackets :: Parser a -> Parser a 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 @@ -1,30 +1,7 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | 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) - -import CLaSH.Netlist.Types - --- | Context used to fill in the holes of a BlackBox template -data BlackBoxContext - = Context - { result :: (SyncIdentifier,HWType) -- ^ Result name and type - , inputs :: [(SyncIdentifier,HWType)] -- ^ Argument names and types - , litInputs :: [Identifier] -- ^ Literal arguments (subset of inputs) - , funInputs :: [(BlackBoxTemplate,BlackBoxContext)] - -- ^ Function arguments (subset of inputs): - -- - -- * (Blackbox Template,Partial Blackbox Concext) - } - deriving Show - --- | Either the name of the identifier, or a tuple of the identifier and the --- corresponding clock -type SyncIdentifier = Either Identifier (Identifier,(Identifier,Int)) +import Data.Text.Lazy (Text) -- | A BlackBox Template is a List of Elements type BlackBoxTemplate = [Element] @@ -43,6 +20,7 @@ | TypM (Maybe Int) -- ^ Type root hole | Err (Maybe Int) -- ^ Error value hole | TypElem Element -- ^ Select element type from a vector type + | SigD Element (Maybe Int) deriving Show -- | Component instantiation hole. First argument indicates which function argument @@ -54,8 +32,3 @@ -- is the type of the signal data Decl = Decl Int [(BlackBoxTemplate,BlackBoxTemplate)] deriving Show - --- | 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, Applicative, Monad, MonadWriter [(Identifier,HWType)], MonadState VHDLState) diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs --- a/src/CLaSH/Netlist/BlackBox/Util.hs +++ b/src/CLaSH/Netlist/BlackBox/Util.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} -- | Utilties to verify blackbox contexts against templates and rendering -- filled in templates @@ -6,58 +9,51 @@ import Control.Lens (at, use, (%=), (+=), _1, _2) -import Control.Monad.State (State, lift, runState) -import Control.Monad.Writer (runWriterT, tell) +import Control.Monad.State (State, runState) +import Control.Monad.Writer (MonadWriter, tell) import Data.Foldable (foldrM) import qualified Data.IntMap as IntMap -import qualified Data.List as List import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text -import Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderOneLine) +import Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderCompact, + renderOneLine) +import CLaSH.Backend (Backend (..)) +import CLaSH.Netlist.BlackBox.Parser import CLaSH.Netlist.BlackBox.Types import CLaSH.Netlist.Types (HWType (..), Identifier, - VHDLState) -import CLaSH.Netlist.VHDL (vhdlType, - vhdlTypeErrValue, - vhdlTypeMark) + BlackBoxContext (..), + SyncExpr, Expr(Identifier)) import CLaSH.Util -- | Determine if the number of normal/literal/function inputs of a blackbox -- context at least matches the number of argument that is expected by the -- template. -verifyBlackBoxContext :: BlackBoxTemplate -- ^ Template to check against - -> BlackBoxContext -- ^ Blackbox to verify +verifyBlackBoxContext :: BlackBoxContext -- ^ Blackbox to verify + -> BlackBoxTemplate -- ^ Template to check against -> Bool -verifyBlackBoxContext tmpl bbCtx = - ((length (inputs bbCtx) - 1) >= countArgs tmpl) && - ((length (litInputs bbCtx) - 1) >= countLits tmpl) && - ((length (funInputs bbCtx) - 1) >= countFuns tmpl) - --- | Count the number of argument tags/holes in a blackbox template -countArgs :: BlackBoxTemplate -> Int -countArgs [] = -1 -countArgs l = maximum - $ map (\e -> case e of - I n -> n - D (Decl _ l') -> maximum $ map (countArgs . fst) l' - _ -> -1 - ) l - --- | Counter the number of literal tags/holes in a blackbox template -countLits :: BlackBoxTemplate -> Int -countLits [] = -1 -countLits l = maximum - $ map (\e -> case e of - L n -> n - D (Decl _ l') -> maximum $ map (countLits . fst) l' - _ -> -1 - ) l +verifyBlackBoxContext bbCtx = all verify' + where + verify' (I n) = n < length (bbInputs bbCtx) + verify' (L n) = case indexMaybe (bbInputs bbCtx) n of + Just (_,_,b) -> b + _ -> False + verify' (Clk (Just n)) = n < length (bbInputs bbCtx) + verify' (Rst (Just n)) = n < length (bbInputs bbCtx) + verify' (Typ (Just n)) = n < length (bbInputs bbCtx) + verify' (TypM (Just n)) = n < length (bbInputs bbCtx) + verify' (Err (Just n)) = n < length (bbInputs bbCtx) + verify' (D (Decl n l')) = case IntMap.lookup n (bbFunctions bbCtx) of + Just _ -> all (\(x,y) -> verifyBlackBoxContext bbCtx x && + verifyBlackBoxContext bbCtx y) l' + _ -> False + verify' _ = True --- | Count the number of function instantiations in a blackbox template -countFuns :: BlackBoxTemplate -> Int -countFuns [] = -1 -countFuns l = maximum $ map (\e -> case e of { D (Decl n _) -> n; _ -> -1 }) l +extractLiterals :: BlackBoxContext + -> [Expr] +extractLiterals = map (\case (e,_,_) -> either id fst e) + . filter (\case (_,_,b) -> b) + . bbInputs -- | Update all the symbol references in a template, and increment the symbol -- counter for every newly encountered symbol. @@ -76,91 +72,138 @@ return (Sym k) Just k -> return (Sym k) D (Decl n l') -> D <$> (Decl n <$> mapM (combineM setSym' setSym') l') + SigD e' m -> SigD <$> (head <$> setSym' [e']) <*> pure m _ -> pure e ) +setClocks :: ( MonadWriter [(Identifier,HWType)] m + , Applicative m + ) + => BlackBoxContext + -> BlackBoxTemplate + -> m BlackBoxTemplate +setClocks bc bt = mapM setClocks' bt + where + setClocks' (D (Decl n l)) = D <$> (Decl n <$> mapM (combineM (setClocks bc) (setClocks bc)) l) + setClocks' (SigD e m) = SigD <$> (head <$> setClocks bc [e]) <*> pure m + + setClocks' (Clk Nothing) = let (clk,rate) = clkSyncId $ fst $ bbResult bc + in tell [(clk,Clock rate)] >> return (C clk) + setClocks' (Clk (Just n)) = let (e,_,_) = bbInputs bc !! n + (clk,rate) = clkSyncId e + in tell [(clk,Clock rate)] >> return (C clk) + + setClocks' (Rst Nothing) = let (rst,rate) = (first (`Text.append` "_rst")) . clkSyncId $ fst $ bbResult bc + in tell [(rst,Reset rate)] >> return (C rst) + setClocks' (Rst (Just n)) = let (e,_,_) = bbInputs bc !! n + (rst,rate) = clkSyncId e + rst' = Text.append rst "_rst" + in tell [(rst',Reset rate)] >> return (C rst') + + setClocks' e = return e + -- | Get the name of the clock of an identifier -clkSyncId :: SyncIdentifier -> (Identifier,Int) +clkSyncId :: SyncExpr -> (Identifier,Int) clkSyncId (Right (_,clk)) = clk clkSyncId (Left i) = error $ $(curLoc) ++ "No clock for: " ++ show i -- | Render a blackbox given a certain context. Returns a filled out template -- and a list of 'hidden' inputs that must be added to the encompassing component. -renderBlackBox :: BlackBoxTemplate -- ^ Blackbox template +renderBlackBox :: Backend backend + => BlackBoxTemplate -- ^ Blackbox template -> BlackBoxContext -- ^ Context used to fill in the hole - -> VHDLState - -> ((Text, [(Identifier,HWType)]),VHDLState) -renderBlackBox l bbCtx s - = first (Text.concat *** List.nub) - $ flip runState s - $ runWriterT - $ runBlackBoxM + -> State backend Text +renderBlackBox l bbCtx + = fmap Text.concat $ mapM (renderElem bbCtx) l -- | Render a single template element -renderElem :: BlackBoxContext +renderElem :: Backend backend + => BlackBoxContext -> Element - -> BlackBoxMonad Text + -> State backend Text renderElem b (D (Decl n (l:ls))) = do - o <- combineM (lineToIdentifier b) (lineToType b) l - is <- mapM (combineM (lineToIdentifier b) (lineToType b)) ls - let (templ,pCtx) = indexNote ($(curLoc) ++ "No function argument " ++ show n) (funInputs b) n - let b' = pCtx { result = o, inputs = inputs pCtx ++ is } - if verifyBlackBoxContext templ b' - then Text.concat <$> mapM (renderElem b') templ - else error $ $(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ + (o,oTy,_) <- syncIdToSyncExpr <$> combineM (lineToIdentifier b) (return . lineToType b) l + is <- mapM (fmap syncIdToSyncExpr . combineM (lineToIdentifier b) (return . lineToType b)) ls + let Just (templ,pCtx) = IntMap.lookup n (bbFunctions b) + b' = pCtx { bbResult = (o,oTy), bbInputs = bbInputs pCtx ++ is } + templ' <- case templ of + Left t -> return t + Right d -> do Just inst' <- inst d + return . parseFail . displayT $ renderCompact inst' + if verifyBlackBoxContext b' templ' + then Text.concat <$> mapM (renderElem b') templ' + else error $ $(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ -renderElem b e = either id fst <$> mkSyncIdentifier b e +renderElem b (SigD e m) = do + e' <- renderElem b e + let ty = case m of + Nothing -> snd $ bbResult b + Just n -> let (_,ty',_) = bbInputs b !! n + in ty' + t <- hdlSig e' ty + return (displayT $ renderOneLine t) +renderElem b e = renderTag b e + +parseFail :: Text -> BlackBoxTemplate +parseFail t = case runParse t of + (templ,err) | null err -> templ + | otherwise -> error $ $(curLoc) ++ "\nTemplate:\n" ++ show t ++ "\nHas errors:\n" ++ show err + +syncIdToSyncExpr :: (Text,HWType) + -> (SyncExpr,HWType,Bool) +syncIdToSyncExpr (t,ty) = (Left (Identifier t Nothing),ty,False) + -- | Fill out the template corresponding to an output/input assignment of a -- component instantiation, and turn it into a single identifier so it can -- be used for a new blackbox context. -lineToIdentifier :: BlackBoxContext +lineToIdentifier :: Backend backend + => BlackBoxContext -> BlackBoxTemplate - -> BlackBoxMonad SyncIdentifier + -> State backend Text lineToIdentifier b = foldrM (\e a -> do - e' <- mkSyncIdentifier b e - case (e', a) of - (Left t, Left t') -> return (Left (t `Text.append` t')) - (Left t, Right (t',clk)) -> return (Right (t `Text.append` t',clk)) - (Right (t,clk), Left t') -> return (Right (t `Text.append` t',clk)) - (Right (t,clk), Right (t',_)) -> return (Right (t `Text.append` t',clk)) - ) (Left Text.empty) + e' <- renderTag b e + return (e' `Text.append` a) + ) Text.empty lineToType :: BlackBoxContext -> BlackBoxTemplate - -> BlackBoxMonad HWType -lineToType b [(Typ Nothing)] = return (snd $ result b) -lineToType b [(Typ (Just n))] = return (snd $ inputs b !! n) -lineToType b [(TypElem t)] = do hwty' <- lineToType b [t] - case hwty' of - Vector _ elTy -> return elTy - _ -> error $ $(curLoc) ++ "Element type selection of a non-vector type" + -> HWType +lineToType b [(Typ Nothing)] = snd $ bbResult b +lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n + in ty +lineToType b [(TypElem t)] = case lineToType b [t] of + Vector _ elTy -> elTy + _ -> error $ $(curLoc) ++ "Element type selection of a non-vector type" lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation" -- | Give a context and a tagged hole (of a template), returns part of the -- context that matches the tag of the hole. -mkSyncIdentifier :: BlackBoxContext - -> Element - -> BlackBoxMonad SyncIdentifier -mkSyncIdentifier _ (C t) = return $ Left t -mkSyncIdentifier b O = return $ fst $ result b -mkSyncIdentifier b (I n) = return $ fst $ inputs b !! n -mkSyncIdentifier b (L n) = return $ Left $ litInputs b !! n -mkSyncIdentifier _ (Sym n) = return $ Left $ Text.pack ("n_" ++ show n) -mkSyncIdentifier b (Clk Nothing) = let (clk,rate) = clkSyncId $ fst $ result b - in tell [(clk,Clock rate)] >> return (Left clk) -mkSyncIdentifier b (Clk (Just n)) = let (clk,rate) = clkSyncId $ fst $ inputs b !! n - in tell [(clk,Clock rate)] >> return (Left clk) -mkSyncIdentifier b (Rst Nothing) = let (rst,rate) = (first (`Text.append` Text.pack "_rst")) . clkSyncId $ fst $ result b - in tell [(rst,Reset rate)] >> return (Left rst) -mkSyncIdentifier b (Rst (Just n)) = let (rst,rate) = (first (`Text.append` Text.pack "_rst")) . clkSyncId $ fst $ inputs b !! n - in tell [(rst,Reset rate)] >> return (Left rst) -mkSyncIdentifier b (Typ Nothing) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlType . snd $ result b -mkSyncIdentifier b (Typ (Just n)) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlType . snd $ inputs b !! n -mkSyncIdentifier b (TypM Nothing) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeMark . snd $ result b -mkSyncIdentifier b (TypM (Just n)) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeMark . snd $ inputs b !! n -mkSyncIdentifier b (Err Nothing) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeErrValue . snd $ result b -mkSyncIdentifier b (Err (Just n)) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeErrValue . snd $ inputs b !! n -mkSyncIdentifier _ (D _) = error $ $(curLoc) ++ "Unexpected component declaration" -mkSyncIdentifier _ (TypElem _) = error $ $(curLoc) ++ "Unexpected type element selector" +renderTag :: Backend backend + => BlackBoxContext + -> Element + -> State backend Text +renderTag _ (C t) = return t +renderTag b O = fmap (displayT . renderOneLine) . expr False . either id fst . fst $ bbResult b +renderTag b (I n) = let (s,_,_) = bbInputs b !! n + e = either id fst s + in (displayT . renderOneLine) <$> expr False e +renderTag b (L n) = let (s,_,_) = bbInputs b !! n + e = either id fst s + in (displayT . renderOneLine) <$> expr False e +renderTag _ (Sym n) = return $ Text.pack ("n_" ++ show n) +renderTag b (Typ Nothing) = fmap (displayT . renderOneLine) . hdlType . snd $ bbResult b +renderTag b (Typ (Just n)) = let (_,ty,_) = bbInputs b !! n + in (displayT . renderOneLine) <$> hdlType ty +renderTag b (TypM Nothing) = fmap (displayT . renderOneLine) . hdlTypeMark . snd $ bbResult b +renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n + in (displayT . renderOneLine) <$> hdlTypeMark ty +renderTag b (Err Nothing) = fmap (displayT . renderOneLine) . hdlTypeErrValue . snd $ bbResult b +renderTag b (Err (Just n)) = let (_,ty,_) = bbInputs b !! n + in (displayT . renderOneLine) <$> hdlTypeErrValue ty +renderTag _ (D _) = error $ $(curLoc) ++ "Unexpected component declaration" +renderTag _ (TypElem _) = error $ $(curLoc) ++ "Unexpected type element selector" +renderTag _ (SigD _ _) = error $ $(curLoc) ++ "Unexpected signal declaration" +renderTag _ (Clk _) = error $ $(curLoc) ++ "Unexpected clock" +renderTag _ (Rst _) = error $ $(curLoc) ++ "Unexpected reset" 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 @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} --- | Transform/format a Netlist Identifier so that it is acceptable as a VHDL identifier +-- | Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier module CLaSH.Netlist.Id ( mkBasicId , mkBasicId' @@ -12,7 +12,7 @@ import Data.Text.Lazy as Text import Numeric (showHex) --- | Transform/format a text so that it is acceptable as a VHDL identifier +-- | Transform/format a text so that it is acceptable as a HDL identifier mkBasicId :: Text -> Text mkBasicId = mkBasicId' False 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 @@ -10,33 +10,30 @@ import Control.Monad.Writer (MonadWriter, WriterT) import Data.Hashable import Data.HashMap.Lazy (HashMap) -import Data.HashSet (HashSet) -import Data.Text.Lazy (Text) +import Data.IntMap.Lazy (IntMap, empty) +import qualified Data.Text as S +import Data.Text.Lazy (Text, pack) import GHC.Generics (Generic) -import Text.PrettyPrint.Leijen.Text.Monadic (Doc) -import Unbound.LocallyNameless (Fresh, FreshMT) +import Unbound.Generics.LocallyNameless (Fresh, FreshMT) import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type) import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Core.Util (Gamma) +import CLaSH.Netlist.BlackBox.Types import CLaSH.Primitives.Types (PrimMap) import CLaSH.Util -- | Monad that caches generated components (StateT) and remembers hidden inputs -- of components that are being generated (WriterT) newtype NetlistMonad a = - NetlistMonad { runNetlist :: WriterT [(Identifier,HWType)] (StateT NetlistState (FreshMT IO)) a } - deriving (Functor, Monad, Applicative, MonadState NetlistState, MonadWriter [(Identifier,HWType)], Fresh, MonadIO) - --- | State for the 'CLaSH.Netlist.VHDL.VHDLM' monad: --- --- * Previously encountered HWTypes --- --- * Product type counter --- --- * Cache for previously generated product type names -type VHDLState = (HashSet HWType,Int,HashMap HWType Doc) + NetlistMonad { runNetlist :: WriterT + [(Identifier,HWType)] + (StateT NetlistState (FreshMT IO)) + a + } + deriving (Functor, Monad, Applicative, MonadWriter [(Identifier,HWType)], + MonadState NetlistState, Fresh, MonadIO) -- | State of the NetlistMonad data NetlistState @@ -47,7 +44,6 @@ , _cmpCount :: Int -- ^ Number of create components , _components :: HashMap TmName Component -- ^ Cached components , _primitives :: PrimMap -- ^ Primitive Definitions - , _vhdlMState :: VHDLState -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache } @@ -125,8 +121,8 @@ -- -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative) | InstDecl Identifier Identifier [(Identifier,Expr)] -- ^ Instantiation of another component - | BlackBoxD Text -- ^ Instantiation of blackbox declaration - | NetDecl Identifier HWType (Maybe Expr) -- ^ Signal declaration + | BlackBoxD S.Text BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration + | NetDecl Identifier HWType -- ^ Signal declaration deriving Show instance NFData Declaration where @@ -142,10 +138,10 @@ -- | Expression used in RHS of a declaration data Expr = Literal (Maybe (HWType,Size)) Literal -- ^ Literal expression - | DataCon HWType (Maybe Modifier) [Expr] -- ^ DataCon application + | DataCon HWType Modifier [Expr] -- ^ DataCon application | Identifier Identifier (Maybe Modifier) -- ^ Signal reference - | DataTag HWType (Either Expr Expr) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag# - | BlackBoxE Text (Maybe Modifier) -- ^ Instantiation of a BlackBox expression + | DataTag HWType (Either Identifier Identifier) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag# + | BlackBoxE S.Text BlackBoxTemplate BlackBoxContext Bool -- ^ Instantiation of a BlackBox expression deriving Show -- | Literals used in an expression @@ -163,5 +159,25 @@ | U -- ^ Undefined | Z -- ^ High-impedance deriving Show + +-- | Context used to fill in the holes of a BlackBox template +data BlackBoxContext + = Context + { bbResult :: (SyncExpr,HWType) -- ^ Result name and type + , bbInputs :: [(SyncExpr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal + , bbFunctions :: IntMap (Either BlackBoxTemplate Declaration,BlackBoxContext) + -- ^ Function arguments (subset of inputs): + -- + -- * (Blackbox Template,Partial Blackbox Concext) + } + deriving Show + +emptyBBContext :: BlackBoxContext +emptyBBContext = Context (Left $ Identifier (pack "__EMPTY__") Nothing, Void) [] empty + +-- | Either the name of the identifier, or a tuple of the identifier and the +-- corresponding clock +type SyncIdentifier = Either Identifier (Identifier,(Identifier,Int)) +type SyncExpr = Either Expr (Expr,(Identifier,Int)) makeLenses ''NetlistState 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 @@ -1,9 +1,6 @@ -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-} - -- | Utilities for converting Core Type/Term to Netlist datatypes module CLaSH.Netlist.Util where @@ -16,7 +13,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes,fromMaybe) import Data.Text.Lazy (pack) -import Unbound.LocallyNameless (Embed, Fresh, bind, embed, makeName, +import Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, makeName, name2Integer, name2String, unbind, unembed, unrec) @@ -37,7 +34,7 @@ -- | Split a normalized term into: a list of arguments, a list of let-bindings, -- and a variable reference that is the body of the let-binding. Returns a -- String containing the error is the term was not in a normalized form. -splitNormalized :: (Fresh m,Functor m) +splitNormalized :: (Fresh m, Functor m) => HashMap TyConName TyCon -> Term -> m (Either String ([Id],[LetBinding],Id)) @@ -80,14 +77,14 @@ -> Type -> Maybe (Identifier,Int) synchronizedClk tcm ty - | not . null . typeFreeVars $ ty = Nothing + | not . null . Lens.toListOf typeFreeVars $ ty = Nothing | Just (tyCon,args) <- splitTyConAppM ty = case name2String tyCon of "CLaSH.Sized.Vector.Vec" -> synchronizedClk tcm (args!!1) "CLaSH.Signal.Internal.SClock" -> case splitTyConAppM (head args) of Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack (s ++ show i),i) _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty - "CLaSH.Signal.Internal.CSignal" -> case splitTyConAppM (head args) of + "CLaSH.Signal.Internal.Signal'" -> case splitTyConAppM (head args) of Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack (s ++ show i),i) _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty _ -> case tyConDataCons (tcm HashMap.! tyCon) of @@ -203,12 +200,21 @@ ty <- termType m e unsafeCoreTypeToHWTypeM loc ty +-- | Gives the HWType corresponding to a term. Returns 'Nothing' if the term has +-- a Core type that is not translatable to a HWType. +termHWTypeM :: Term + -> NetlistMonad (Maybe HWType) +termHWTypeM e = do + m <- Lens.use tcCache + ty <- termType m e + coreTypeToHWTypeM ty + -- | Turns a Core variable reference to a Netlist expression. Errors if the term -- is not a variable. varToExpr :: Term -> Expr varToExpr (Var _ var) = Identifier (mkBasicId . pack $ name2String var) Nothing -varToExpr _ = error "not a var" +varToExpr _ = error $ $(curLoc) ++ "not a var" -- | Uniquely rename all the variables and their references in a normalized -- term @@ -220,7 +226,7 @@ let res1 = appendToName (varName res) "_o" let bndrs = map fst binds let exprs = map (unembed . snd) binds - let usesOutput = concatMap (filter (== varName res) . termFreeIds) exprs + let usesOutput = concatMap (filter (== varName res) . Lens.toListOf termFreeIds) exprs let (res2,extraBndr) = case usesOutput of [] -> (res1,[] :: [(Id, Embed Term)]) _ -> let res3 = appendToName (varName res) "_o_sig" @@ -264,7 +270,7 @@ -- | Preserve the Netlist '_varEnv' and '_varCount' when executing a monadic action preserveVarEnv :: NetlistMonad a - -> NetlistMonad a + -> NetlistMonad a preserveVarEnv action = do vCnt <- Lens.use varCount vEnv <- Lens.use varEnv diff --git a/src/CLaSH/Netlist/VHDL.hs b/src/CLaSH/Netlist/VHDL.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/VHDL.hs +++ /dev/null @@ -1,569 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - --- | Generate VHDL for assorted Netlist datatypes -module CLaSH.Netlist.VHDL - ( genVHDL - , mkTyPackage - , vhdlType - , vhdlTypeErrValue - , vhdlTypeMark - , inst - , expr - ) -where - -import qualified Control.Applicative as A -import Control.Lens hiding (Indexed) -import Control.Monad (forM,join,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 (mapAccumL,nubBy) -import Data.Maybe (catMaybes,mapMaybe) -import Data.Text.Lazy (unpack) -import qualified Data.Text.Lazy as T -import Text.PrettyPrint.Leijen.Text.Monadic - -import CLaSH.Netlist.Types -import CLaSH.Netlist.Util -import CLaSH.Util (clog2, curLoc, makeCached, (<:>)) - -type VHDLM a = State VHDLState a - --- | Generate VHDL for a Netlist component -genVHDL :: Component -> VHDLM (String,Doc) -genVHDL c = (unpack cName,) A.<$> vhdl - where - cName = componentName c - vhdl = tyImports <$$> linebreak <> - entity c <$$> linebreak <> - architecture c - --- | Generate a VHDL package containing type definitions for the given HWTypes -mkTyPackage :: [HWType] - -> VHDLM Doc -mkTyPackage hwtys = - "library IEEE;" <$> - "use IEEE.STD_LOGIC_1164.ALL;" <$> - "use IEEE.NUMERIC_STD.ALL;" <$$> linebreak <> - "package" <+> "types" <+> "is" <$> - indent 2 ( packageDec <$> - vcat (sequence funDecs) - ) <> - (case showDecs of - [] -> empty - _ -> linebreak <$> - "-- pragma translate_off" <$> - indent 2 (vcat (sequence showDecs)) <$> - "-- pragma translate_on" - ) <$> - "end" <> semi <> packageBodyDec - where - usedTys = nubBy eqHWTy $ concatMap mkUsedTys hwtys - needsDec = nubBy eqHWTy (hwtys ++ filter needsTyDec usedTys) - hwTysSorted = topSortHWTys needsDec - packageDec = vcat $ mapM tyDec hwTysSorted - (funDecs,funBodies) = unzip . catMaybes $ map funDec (nubBy eqIndexTy usedTys) - (showDecs,showBodies) = unzip $ map mkToStringDecls hwTysSorted - - packageBodyDec :: VHDLM Doc - packageBodyDec = case (funBodies,showBodies) of - ([],[]) -> empty - _ -> linebreak <$> - "package" <+> "body" <+> "types" <+> "is" <$> - indent 2 (vcat (sequence funBodies)) <$> - linebreak <> - "-- pragma translate_off" <$> - indent 2 (vcat (sequence showBodies)) <$> - "-- pragma translate_on" <$> - "end" <> semi - - eqIndexTy :: HWType -> HWType -> Bool - eqIndexTy (Index _) (Index _) = True - eqIndexTy _ _ = False - - eqHWTy :: HWType -> HWType -> Bool - eqHWTy (Vector _ elTy1) (Vector _ elTy2) = case (elTy1,elTy2) of - (Sum _ _,Sum _ _) -> typeSize elTy1 == typeSize elTy2 - (Unsigned n,Sum _ _) -> n == typeSize elTy2 - (Sum _ _,Unsigned n) -> typeSize elTy1 == n - (Index u,Unsigned n) -> clog2 (max 2 u) == n - (Unsigned n,Index u) -> clog2 (max 2 u) == n - _ -> elTy1 == elTy2 - eqHWTy ty1 ty2 = ty1 == ty2 - -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 - where - nodes = zip [0..] hwtys - nodesI = HashMap.fromList (zip hwtys [0..]) - edges = concatMap edge hwtys - graph = mkGraph nodes edges :: Gr HWType () - sorted = reverse $ topsort' graph - - edge t@(Vector _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "Vector") t nodesI,,())) - (HashMap.lookup (mkVecZ elTy) nodesI) - edge t@(Product _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI - in mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ ty) nodesI)) tys - edge t@(SP _ ctys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "SP") t nodesI - in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ ty) nodesI)) tys) ctys - edge _ = [] - -mkVecZ :: HWType -> HWType -mkVecZ (Vector _ elTy) = Vector 0 elTy -mkVecZ t = t - -needsTyDec :: HWType -> Bool -needsTyDec (Vector _ _) = True -needsTyDec (Product _ _) = True -needsTyDec (SP _ _) = True -needsTyDec Bool = True -needsTyDec Integer = True -needsTyDec _ = False - -tyDec :: HWType -> VHDLM Doc -tyDec (Vector _ elTy) = "type" <+> "array_of_" <> tyName elTy <+> "is array (integer range <>) of" <+> vhdlType elTy <> semi - -tyDec ty@(Product _ tys) = prodDec - where - prodDec = "type" <+> tName <+> "is record" <$> - indent 2 (vcat $ zipWithM (\x y -> x <+> colon <+> y <> semi) selNames selTys) <$> - "end record" <> semi - - tName = tyName ty - selNames = map (\i -> tName <> "_sel" <> int i) [0..] - selTys = map vhdlType tys - -tyDec _ = empty - -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_vector") <+> "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_vector") <+> "return" <+> "boolean" <+> "is" <$> - "begin" <$> - indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then" - , indent 2 ("return" <+> "true" <> semi) - ,"else" - , indent 2 ("return" <+> "false" <> semi) - ,"end" <+> "if" <> 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 (Index _) = Just - ( "function" <+> "max" <+> parens ("left, right: in integer") <+> "return integer" <> semi - , "function" <+> "max" <+> parens ("left, right: in integer") <+> "return integer" <+> "is" <$> - "begin" <$> - indent 2 (vcat $ sequence [ "if" <+> "left > right" <+> "then return left" <> semi - , "else return right" <> semi - , "end if" <> semi - ]) <$> - "end" <> semi - ) - -funDec _ = Nothing - -mkToStringDecls :: HWType -> (VHDLM Doc, VHDLM Doc) -mkToStringDecls t@(Product _ elTys) = - ( "function to_string" <+> parens ("value :" <+> vhdlType t) <+> "return STRING" <> semi - , "function to_string" <+> parens ("value :" <+> vhdlType t) <+> "return STRING is" <$> - "begin" <$> - indent 2 ("return" <+> parens (hcat (punctuate " & " elTyPrint)) <> semi) <$> - "end function to_string;" - ) - where - elTyPrint = forM [0..(length elTys - 1)] - (\i -> "to_string" <> - parens ("value." <> vhdlType t <> "_sel" <> int i)) -mkToStringDecls t@(Vector _ elTy) = - ( "function to_string" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return STRING" <> semi - , "function to_string" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return STRING is" <$> - indent 2 - ( "alias ivalue : " <+> vhdlTypeMark t <> "(1 to value'length) is value;" <$> - "variable result : STRING" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi - ) <$> - "begin" <$> - indent 2 - ("for i in ivalue'range loop" <$> - indent 2 - ( "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+> - "to i*" <> int (typeSize elTy)) <+> - ":= to_string" <> parens (if elTy == Bool then "toSLV(ivalue(i))" else "ivalue(i)") <> semi - ) <$> - "end loop;" <$> - "return result;" - ) <$> - "end function to_string;" - ) -mkToStringDecls _ = (empty,empty) - -tyImports :: VHDLM Doc -tyImports = - punctuate' semi $ sequence - [ "library IEEE" - , "use IEEE.STD_LOGIC_1164.ALL" - , "use IEEE.NUMERIC_STD.ALL" - , "use IEEE.MATH_REAL.ALL" - , "use work.all" - , "use work.types.all" - ] - - -entity :: Component -> VHDLM Doc -entity c = do - rec (p,ls) <- fmap unzip (ports (maximum ls)) - "entity" <+> text (componentName c) <+> "is" <$> - (case p of - [] -> empty - _ -> indent 2 ("port" <> - parens (align $ vcat $ punctuate semi (A.pure p)) <> - semi) - ) <$> - "end" <> semi - where - ports l = sequence - $ [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty) - | (i,ty) <- inputs c ] ++ - [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty) - | (i,ty) <- hiddenPorts c ] ++ - [ (,fromIntegral $ T.length (fst $ output c)) A.<$> (fill l (text (fst $ output c)) <+> colon <+> "out" <+> vhdlType (snd $ output c)) - ] - -architecture :: Component -> VHDLM Doc -architecture c = - nest 2 - ("architecture structural of" <+> text (componentName c) <+> "is" <$$> - decls (declarations c)) <$$> - nest 2 - ("begin" <$$> - insts (declarations c)) <$$> - "end" <> semi - --- | Convert a Netlist HWType to a VHDL type -vhdlType :: HWType -> VHDLM Doc -vhdlType hwty = do - when (needsTyDec hwty) (_1 %= HashSet.insert (mkVecZ hwty)) - vhdlType' hwty - -vhdlType' :: HWType -> VHDLM Doc -vhdlType' Bool = "boolean" -vhdlType' (Clock _) = "std_logic" -vhdlType' (Reset _) = "std_logic" -vhdlType' Integer = "integer" -vhdlType' (BitVector n) = case n of - 0 -> "std_logic_vector (0 downto 1)" - _ -> "std_logic_vector" <> parens (int (n-1) <+> "downto 0") -vhdlType' (Index u) = "unsigned" <> parens (int (clog2 (max 2 u) - 1) <+> "downto 0") -vhdlType' (Signed n) = if n == 0 then "signed (0 downto 1)" - else "signed" <> parens (int (n-1) <+> "downto 0") -vhdlType' (Unsigned n) = if n == 0 then "unsigned (0 downto 1)" - else "unsigned" <> parens ( int (n-1) <+> "downto 0") -vhdlType' (Vector n elTy) = "array_of_" <> tyName elTy <> parens ("0 to " <> int (n-1)) -vhdlType' t@(SP _ _) = "std_logic_vector" <> parens (int (typeSize t - 1) <+> "downto 0") -vhdlType' t@(Sum _ _) = case typeSize t of - 0 -> "unsigned (0 downto 1)" - n -> "unsigned" <> parens (int (n -1) <+> "downto 0") -vhdlType' t@(Product _ _) = tyName t -vhdlType' Void = "std_logic_vector" <> parens (int (-1) <+> "downto 0") - --- | Convert a Netlist HWType to the root of a VHDL type -vhdlTypeMark :: HWType -> VHDLM Doc -vhdlTypeMark hwty = do - when (needsTyDec hwty) (_1 %= HashSet.insert (mkVecZ hwty)) - vhdlTypeMark' hwty - where - vhdlTypeMark' Bool = "boolean" - vhdlTypeMark' (Clock _) = "std_logic" - vhdlTypeMark' (Reset _) = "std_logic" - vhdlTypeMark' Integer = "integer" - vhdlTypeMark' (BitVector _) = "std_logic_vector" - vhdlTypeMark' (Index _) = "unsigned" - vhdlTypeMark' (Signed _) = "signed" - vhdlTypeMark' (Unsigned _) = "unsigned" - vhdlTypeMark' (Vector _ elTy) = "array_of_" <> tyName elTy - vhdlTypeMark' (SP _ _) = "std_logic_vector" - vhdlTypeMark' (Sum _ _) = "unsigned" - vhdlTypeMark' t@(Product _ _) = tyName t - vhdlTypeMark' t = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t - -tyName :: HWType -> VHDLM Doc -tyName Integer = "integer" -tyName Bool = "boolean" -tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy -tyName (BitVector n) = "std_logic_vector_" <> int n -tyName t@(Index _) = "unsigned_" <> int (typeSize t) -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 t@(SP _ _) = "std_logic_vector_" <> int (typeSize t) -tyName _ = empty - --- | Convert a Netlist HWType to an error VHDL value for that type -vhdlTypeErrValue :: HWType -> VHDLM Doc -vhdlTypeErrValue Bool = "true" -vhdlTypeErrValue Integer = "integer'high" -vhdlTypeErrValue (BitVector _) = "(others => 'X')" -vhdlTypeErrValue (Index _) = "(others => 'X')" -vhdlTypeErrValue (Signed _) = "(others => 'X')" -vhdlTypeErrValue (Unsigned _) = "(others => 'X')" -vhdlTypeErrValue (Vector _ elTy) = parens ("others" <+> rarrow <+> vhdlTypeErrValue elTy) -vhdlTypeErrValue (SP _ _) = "(others => 'X')" -vhdlTypeErrValue (Sum _ _) = "(others => 'X')" -vhdlTypeErrValue (Product _ elTys) = tupled $ mapM vhdlTypeErrValue elTys -vhdlTypeErrValue (Reset _) = "'X'" -vhdlTypeErrValue (Clock _) = "'X'" -vhdlTypeErrValue Void = "(0 downto 1 => 'X')" - -decls :: [Declaration] -> VHDLM Doc -decls [] = empty -decls ds = do - rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds - case dsDoc of - [] -> empty - _ -> vcat (punctuate semi (A.pure dsDoc)) <> semi - -decl :: Int -> Declaration -> VHDLM (Maybe (Doc,Int)) -decl l (NetDecl id_ ty netInit) = Just A.<$> (,fromIntegral (T.length id_)) A.<$> - "signal" <+> fill l (text id_) <+> colon <+> vhdlType ty <> (maybe empty (\e -> " :=" <+> expr False e) netInit) - -decl _ _ = return Nothing - -insts :: [Declaration] -> VHDLM Doc -insts [] = empty -insts is = vcat . punctuate linebreak . fmap catMaybes $ mapM inst is - --- | Turn a Netlist Declaration to a VHDL concurrent block -inst :: Declaration -> VHDLM (Maybe Doc) -inst (Assignment id_ e) = fmap Just $ - text id_ <+> larrow <+> expr False e <> semi - -inst (CondAssignment id_ scrut es) = fmap Just $ - text id_ <+> larrow <+> align (vcat (conds es)) <> semi - where - 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 <+> colon <+> "entity" - <+> text nm <$$> pms' <> semi - where - pms' = do - rec (p,ls) <- fmap unzip $ sequence [ (,fromIntegral (T.length i)) A.<$> fill (maximum ls) (text i) <+> "=>" <+> expr False e | (i,e) <- pms] - nest 2 $ "port map" <$$> tupled (A.pure p) - -inst (BlackBoxD bs) = fmap Just $ string bs - -inst _ = return Nothing - --- | Turn a Netlist expression into a VHDL expression -expr :: Bool -- ^ Enclose in parenthesis? - -> Expr -- ^ Expr to convert - -> VHDLM Doc -expr _ (Literal sizeM lit) = exprLit sizeM lit -expr _ (Identifier id_ Nothing) = text id_ -expr _ (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = fromSLV argTy id_ start end - where - argTys = snd $ args !! dcI - argTy = argTys !! fI - argSize = typeSize argTy - other = otherSize argTys (fI-1) - start = typeSize ty - 1 - conSize ty - other - end = start - argSize + 1 - -expr _ (Identifier id_ (Just (Indexed (ty@(Product _ _),_,fI)))) = text id_ <> dot <> tyName ty <> "_sel" <> int fI -expr _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = text id_ <> parens (int start <+> "downto" <+> int end) - where - start = typeSize ty - 1 - end = typeSize ty - conSize ty - -expr _ (Identifier id_ (Just _)) = text id_ -expr _ (DataCon ty@(Vector 1 _) _ [e]) = vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> expr False e) -expr _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = vhdlTypeMark ty <> "'" <> case vectorChain e of - Just es -> tupled (mapM (expr False) es) - Nothing -> parens (vhdlTypeMark elTy <> "'" <> parens (expr False e1) <+> "&" <+> expr False e2) -expr _ (DataCon ty@(SP _ args) (Just (DC (_,i))) es) = assignExpr - where - argTys = snd $ args !! i - dcSize = conSize ty + sum (map typeSize argTys) - dcExpr = expr False (dcToExpr ty i) - argExprs = zipWith toSLV argTys es -- (map (expr False) es) - extraArg = case typeSize ty - dcSize of - 0 -> [] - n -> [exprLit (Just (ty,n)) (NumLit 0)] - assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg)) - -expr _ (DataCon ty@(Sum _ _) (Just (DC (_,i))) []) = "to_unsigned" <> tupled (sequence [int i,int (typeSize ty)]) -expr _ (DataCon ty@(Product _ _) _ es) = tupled $ zipWithM (\i e -> tName <> "_sel" <> int i <+> rarrow <+> expr False e) [0..] es - where - tName = tyName ty - -expr b (BlackBoxE bs (Just (DC (ty@(SP _ _),_)))) = parenIf b $ parens (string bs) <> parens (int start <+> "downto" <+> int end) - where - start = typeSize ty - 1 - end = typeSize ty - conSize ty -expr b (BlackBoxE bs _) = parenIf b $ string bs - -expr _ (DataTag Bool (Left e)) = "false when" <+> expr False e <+> "= 0 else true" -expr _ (DataTag Bool (Right e)) = "1 when" <+> expr False e <+> "else 0" -expr _ (DataTag hty@(Sum _ _) (Left e)) = "to_unsigned" <> tupled (sequence [expr False e,int (typeSize hty)]) -expr _ (DataTag (Sum _ _) (Right e)) = "to_integer" <> parens (expr False e) - -expr _ (DataTag (Product _ _) (Right _)) = int 0 -expr _ (DataTag hty@(SP _ _) (Right e)) = "to_integer" <> parens - ("unsigned" <> parens - (expr False e <> parens - (int start <+> "downto" <+> int end))) - where - start = typeSize hty - 1 - end = typeSize hty - conSize hty - -expr _ (DataTag (Vector 0 _) (Right _)) = int 0 -expr _ (DataTag (Vector _ _) (Right _)) = int 1 - -expr _ _ = empty - -otherSize :: [HWType] -> Int -> Int -otherSize _ n | n < 0 = 0 -otherSize [] _ = 0 -otherSize (a:as) n = typeSize a + otherSize as (n-1) - -vectorChain :: Expr -> Maybe [Expr] -vectorChain (DataCon (Vector _ _) Nothing _) = Just [] -vectorChain (DataCon (Vector 1 _) (Just _) [e]) = Just [e] -vectorChain (DataCon (Vector _ _) (Just _) [e1,e2]) = Just e1 <:> vectorChain e2 -vectorChain _ = Nothing - -exprLit :: Maybe (HWType,Size) -> Literal -> VHDLM Doc -exprLit Nothing (NumLit i) = integer i -exprLit (Just (hty,sz)) (NumLit i) = case hty of - Unsigned _ -> "unsigned'" <> parens blit - Signed _ -> "signed'" <> parens blit - BitVector _ -> "std_logic_vector'" <> parens blit - _ -> blit - - where - blit = bits (toBits sz i) -exprLit _ (BoolLit t) = if t then "true" else "false" -exprLit _ (BitLit b) = squotes $ bit_char b -exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l - -toBits :: Integral a => Int -> a -> [Bit] -toBits size val = map (\x -> if odd x then H else L) - $ reverse - $ take size - $ map (`mod` 2) - $ iterate (`div` 2) val - -bits :: [Bit] -> VHDLM Doc -bits = dquotes . hcat . mapM bit_char - -bit_char :: Bit -> VHDLM Doc -bit_char H = char '1' -bit_char L = char '0' -bit_char U = char 'U' -bit_char Z = char 'Z' - -toSLV :: HWType -> Expr -> VHDLM Doc -toSLV Bool e = "toSLV" <> parens (expr False e) -toSLV Integer e = "std_logic_vector" <> parens ("to_signed" <> tupled (sequence [expr False e,int 32])) -toSLV (BitVector _) e = expr False e -toSLV (Signed _) e = "std_logic_vector" <> parens (expr False e) -toSLV (Unsigned _) e = "std_logic_vector" <> parens (expr False e) -toSLV (Sum _ _) e = "std_logic_vector" <> parens (expr False e) -toSLV t@(Product _ tys) (Identifier id_ Nothing) = do - selIds' <- sequence selIds - encloseSep lparen rparen " & " (zipWithM toSLV tys selIds') - where - tName = tyName t - selNames = map (fmap (displayT . renderOneLine) ) [text id_ <> dot <> tName <> "_sel" <> int i | i <- [0..(length tys)-1]] - selIds = map (fmap (\n -> Identifier n Nothing)) selNames -toSLV (Product _ tys) (DataCon _ _ es) = encloseSep lparen rparen " & " (zipWithM toSLV tys es) -toSLV (SP _ _) e = expr False e -toSLV (Vector n elTy) (Identifier id_ Nothing) = do - selIds' <- sequence (reverse selIds) - parens (encloseSep lparen rparen " & " (mapM (toSLV elTy) selIds')) - where - selNames = map (fmap (displayT . renderOneLine) ) $ reverse [text id_ <> parens (int i) | i <- [0 .. (n-1)]] - selIds = map (fmap (`Identifier` Nothing)) selNames -toSLV (Vector n elTy) (DataCon _ _ es) = encloseSep lparen rparen " & " (zipWithM toSLV [elTy,Vector (n-1) elTy] es) -toSLV hty e = error $ $(curLoc) ++ "toSLV: ty:" ++ show hty ++ "\n expr: " ++ show e - -fromSLV :: HWType -> Identifier -> Int -> Int -> VHDLM Doc -fromSLV Bool id_ start _ = "fromSL" <> parens (text id_ <> parens (int start)) -fromSLV Integer id_ start end = "to_integer" <> parens (fromSLV (Signed 32) id_ start end) -fromSLV (BitVector _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end) -fromSLV (Index _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) -fromSLV (Signed _) id_ start end = "signed" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) -fromSLV (Unsigned _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) -fromSLV (Sum _ _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) -fromSLV t@(Product _ tys) id_ start _ = tupled $ zipWithM (\s e -> s <+> rarrow <+> e) selNames args - where - tName = tyName t - selNames = [tName <> "_sel" <> int i | i <- [0..]] - argLengths = map typeSize tys - starts = start : snd (mapAccumL ((join (,) .) . (-)) start argLengths) - ends = map (+1) (tail starts) - args = zipWith3 (`fromSLV` id_) tys starts ends - -fromSLV (SP _ _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end) -fromSLV (Vector n elTy) id_ start _ = tupled (fmap reverse args) - where - argLength = typeSize elTy - starts = take (n + 1) $ iterate (subtract argLength) start - ends = map (+1) (tail starts) - args = zipWithM (fromSLV elTy id_) starts ends -fromSLV hty _ _ _ = error $ $(curLoc) ++ "fromSLV: " ++ show hty - -dcToExpr :: HWType -> Int -> Expr -dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) - -larrow :: VHDLM Doc -larrow = "<=" - -rarrow :: VHDLM Doc -rarrow = "=>" - -parenIf :: Monad m => Bool -> m Doc -> m Doc -parenIf True = parens -parenIf False = id - -punctuate' :: Monad m => m Doc -> m [Doc] -> m Doc -punctuate' s d = vcat (punctuate s d) <> s diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -3,38 +3,40 @@ -- | Turn CoreHW terms into normalized CoreHW Terms module CLaSH.Normalize where -import Control.Concurrent.Supply (Supply) -import Control.Lens ((.=)) -import qualified Control.Lens as Lens -import qualified Control.Monad.State as State -import Data.Either (partitionEithers) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.List (mapAccumL) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import Unbound.LocallyNameless (unembed) +import Control.Concurrent.Supply (Supply) +import Control.Lens ((.=)) +import qualified Control.Lens as Lens +import qualified Control.Monad.State as State +import Data.Either (partitionEithers) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (mapAccumL) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Set.Lens as Lens +import Unbound.Generics.LocallyNameless (unembed) -import CLaSH.Core.FreeVars (termFreeIds) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Subst (substTms) -import CLaSH.Core.Term (Term (..), TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Core.Util (collectArgs, mkApps, termType) -import CLaSH.Core.Var (Id,varName) -import CLaSH.Netlist.Types (HWType) -import CLaSH.Netlist.Util (splitNormalized) +import CLaSH.Core.FreeVars (termFreeIds) +import CLaSH.Core.Pretty (showDoc) +import CLaSH.Core.Subst (substTms) +import CLaSH.Core.Term (Term (..), TmName) +import CLaSH.Core.Type (Type) +import CLaSH.Core.TyCon (TyCon, TyConName) +import CLaSH.Core.Util (collectArgs, mkApps, termType) +import CLaSH.Core.Var (Id,varName) +import CLaSH.Netlist.Types (HWType) +import CLaSH.Netlist.Util (splitNormalized) import CLaSH.Normalize.Strategy -import CLaSH.Normalize.Transformations ( bindConstantVar, caseCon, reduceConst, topLet ) +import CLaSH.Normalize.Transformations (bindConstantVar, caseCon, + reduceConst, topLet ) import CLaSH.Normalize.Types import CLaSH.Normalize.Util -import CLaSH.Rewrite.Combinators ((>->),(!->),repeatR,topdownR) -import CLaSH.Rewrite.Types (DebugLevel (..), RewriteState (..), - bindings, dbgLevel, tcCache) -import CLaSH.Rewrite.Util (liftRS, runRewrite, - runRewriteSession) +import CLaSH.Rewrite.Combinators ((>->),(!->),repeatR,topdownR) +import CLaSH.Rewrite.Types (DebugLevel (..), RewriteState (..), + bindings, dbgLevel, tcCache) +import CLaSH.Rewrite.Util (liftRS, runRewrite, + runRewriteSession) import CLaSH.Util -- | Run a NormalizeSession in a given environment @@ -65,7 +67,7 @@ 100 HashMap.empty 100 - (error "Report as bug: no curFun") + (error $ $(curLoc) ++ "Report as bug: no curFun") normalize :: [TmName] @@ -89,9 +91,9 @@ tcm <- Lens.use tcCache ty' <- termType tcm tm' return (ty',tm') - let usedBndrs = termFreeIds (snd tmNorm) + let usedBndrs = Lens.toListOf termFreeIds (snd tmNorm) if nm `elem` usedBndrs - then error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " remains recursive after normalization." + then error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " (:: " ++ showDoc (fst tmNorm) ++ ") remains recursive after normalization:\n" ++ showDoc (snd tmNorm) else do prevNorm <- fmap HashMap.keys $ liftRS $ Lens.use normalized let toNormalize = filter (`notElem` prevNorm) usedBndrs @@ -124,7 +126,7 @@ let cg = callGraph [] norm topEntity in case recursiveComponents cg of [] -> norm - rcs -> error $ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs + rcs -> error $ $(curLoc) ++ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs -- | Perform general \"clean up\" of the normalized (non-recursive) function -- hierarchy. This includes: @@ -150,8 +152,8 @@ [] -> CLeaf (root,rootTm) _ -> CBranch (root,rootTm) other where - rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap - used = Set.toList $ termFreeIds $ snd rootTm + rootTm = Maybe.fromMaybe (error $ $(curLoc) ++ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap + used = Set.toList $ Lens.setOf termFreeIds $ snd rootTm other = map (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used) stripArgs :: [TmName] diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs --- a/src/CLaSH/Normalize/Strategy.hs +++ b/src/CLaSH/Normalize/Strategy.hs @@ -9,7 +9,7 @@ -- | Normalisation transformation normalization :: NormRewrite -normalization = etaTL >-> constantPropgation >-> anf >-> rmDeadcode >-> bindConst >-> letTL >-> cse >-> recLetRec +normalization = etaTL >-> constantPropgation >-> anf >-> rmDeadcode >-> bindConst >-> letTL >-> evalConst >-> cse >-> recLetRec where etaTL = apply "etaTL" etaExpansionTL anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF @@ -17,6 +17,7 @@ recLetRec = apply "recToLetRec" recToLetRec rmDeadcode = topdownR (apply "deadcode" deadCode) bindConst = topdownR (apply "bindConstantVar" bindConstantVar) + evalConst = topdownR (apply "evalConst" reduceConst) cse = topdownR (apply "CSE" simpleCSE) constantPropgation :: NormRewrite diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs --- a/src/CLaSH/Normalize/Transformations.hs +++ b/src/CLaSH/Normalize/Transformations.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-} - -- | Transformations of the Normalization process module CLaSH.Normalize.Transformations ( appProp @@ -38,15 +35,15 @@ import qualified Data.HashMap.Lazy as HashMap import qualified Data.List as List import qualified Data.Maybe as Maybe -import Unbound.LocallyNameless (Bind, Embed (..), bind, embed, +import Unbound.Generics.LocallyNameless (Bind, Embed (..), bind, embed, rec, unbind, unembed, unrebind, unrec, name2String) -import Unbound.LocallyNameless.Ops (unsafeUnbind) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) import CLaSH.Core.DataCon (DataCon, dcName, dcTag, dcUnivTyVars) import CLaSH.Core.FreeVars (termFreeIds, termFreeTyVars, - termFreeVars, typeFreeVars) + typeFreeVars) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Subst (substTm, substTms, substTyInTm, substTysinTm) @@ -73,7 +70,7 @@ where nonRepTest (Id idName tyE, exprE) = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure (unembed tyE))) - <*> ((notElem idName . snd) <$> localFreeVars (unembed exprE)) + <*> (notElem idName <$> (Lens.toListOf <$> localFreeIds <*> pure (unembed exprE))) nonRepTest _ = return False @@ -83,7 +80,7 @@ where nonRepTest (Id idName tyE, exprE) = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure (unembed tyE))) - <*> ((elem idName . snd) <$> localFreeVars (unembed exprE)) + <*> (elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure (unembed exprE))) nonRepTest _ = return False @@ -91,7 +88,7 @@ typeSpec :: NormRewrite typeSpec ctx e@(TyApp e1 ty) | (Var _ _, args) <- collectArgs e1 - , null $ typeFreeVars ty + , null $ Lens.toListOf typeFreeVars ty , (_, []) <- Either.partitionEithers args = specializeNorm False ctx e @@ -102,7 +99,7 @@ nonRepSpec ctx e@(App e1 e2) | (Var _ _, args) <- collectArgs e1 , (_, []) <- Either.partitionEithers args - , null $ termFreeTyVars e2 + , null $ Lens.toListOf termFreeTyVars e2 = R $ do tcm <- Lens.use tcCache e2Ty <- termType tcm e2 localVar <- isLocalVar e2 @@ -179,7 +176,7 @@ case dcAltM of Just (DataPat _ pxs, e) -> let (tvs,xs) = unrebind pxs - fvs = termFreeIds e + fvs = Lens.toListOf termFreeIds e (binds,_) = List.partition ((`elem` fvs) . varName . fst) $ zip xs (Either.lefts args) e' = case binds of @@ -212,7 +209,8 @@ DefaultPat -> changed altE LitPat _ -> changed altE DataPat _ pxs -> let (tvs,xs) = unrebind pxs - (ftvs,fvs) = termFreeVars altE + ftvs = Lens.toListOf termFreeTyVars altE + fvs = Lens.toListOf termFreeIds altE usedTvs = filter ((`elem` ftvs) . varName) tvs usedXs = filter ((`elem` fvs) . varName) xs in case (usedTvs,usedXs) of @@ -281,7 +279,7 @@ deadCode :: NormRewrite deadCode _ e@(Letrec binds) = R $ do (xes, body) <- fmap (first unrec) $ unbind binds - let bodyFVs = termFreeIds body + let bodyFVs = Lens.toListOf termFreeIds body (xesUsed,xesOther) = List.partition ( (`elem` bodyFVs ) . varName @@ -294,7 +292,7 @@ where findUsedBndrs used [] _ = used findUsedBndrs used explore other = - let fvsUsed = concatMap (termFreeIds . unembed . snd) explore + let fvsUsed = concatMap (Lens.toListOf termFreeIds . unembed . snd) explore (explore',other') = List.partition ( (`elem` fvsUsed) . varName @@ -323,7 +321,7 @@ bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings case bodyMaybe of -- Don't inline recursive expressions - Just (_,body) -> if f `elem` (termFreeIds body) + Just (_,body) -> if f `elem` (Lens.toListOf termFreeIds body) then return e else changed (mkApps body args) _ -> return e @@ -337,7 +335,7 @@ bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings case bodyMaybe of -- Don't inline recursive expressions - Just (_,body) -> if f `elem` (termFreeIds body) + Just (_,body) -> if f `elem` (Lens.toListOf termFreeIds body) then return e else changed body _ -> return e @@ -373,7 +371,7 @@ constantSpec ctx e@(App e1 e2) | (Var _ _, args) <- collectArgs e1 , (_, []) <- Either.partitionEithers args - , null $ termFreeTyVars e2 + , null $ Lens.toListOf termFreeTyVars e2 , isConstant e2 = specializeNorm False ctx e @@ -512,7 +510,7 @@ -- recursive functions involved, hence the need for special-casing code. After -- everything is done properly, we should remove the two lines below. collectANF _ e@(Case _ _ [unsafeUnbind -> (DataPat dc _,_)]) - | name2String (dcName $ unembed dc) == "CLaSH.Signal.Types.:-" = return e + | name2String (dcName $ unembed dc) == "CLaSH.Signal.Internal.:-" = return e collectANF ctx (Case subj ty alts) = do localVar <- liftNormR $ isLocalVar subj @@ -574,7 +572,7 @@ then do argTy <- ( return . fst - . Maybe.fromMaybe (error "etaExpansion splitFunTy") + . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy") . splitFunTy tcm <=< termType tcm ) e diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs --- a/src/CLaSH/Normalize/Util.hs +++ b/src/CLaSH/Normalize/Util.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fcontext-stack=21 #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} -- | Utility functions used by the normalisation transformations module CLaSH.Normalize.Util where @@ -14,7 +12,8 @@ import qualified Data.HashMap.Lazy as HashMap import qualified Data.Maybe as Maybe import qualified Data.Set as Set -import Unbound.LocallyNameless (Fresh, bind, embed, rec) +import qualified Data.Set.Lens as Lens +import Unbound.Generics.LocallyNameless (Fresh, bind, embed, rec) import CLaSH.Core.FreeVars (termFreeIds) import CLaSH.Core.Var (Var (Id)) @@ -24,6 +23,7 @@ import CLaSH.Core.Util (collectArgs, isPolyFun) import CLaSH.Normalize.Types import CLaSH.Rewrite.Util (specialise) +import CLaSH.Util (curLoc) -- | Determine if a function is already inlined in the context of the 'NetlistMonad' alreadyInlined :: TmName @@ -71,7 +71,7 @@ callGraph visited bindingMap root = node:other where rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap - used = Set.toList $ termFreeIds (snd rootTm) + used = Set.toList $ Lens.setOf termFreeIds (snd rootTm) node = (root,used) other = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used) @@ -103,7 +103,7 @@ doms = dominator depGraph cyc block = blockSink bndrs doms (0,root) -lambdaDrop _ _ [] = error "Can't lambdadrop empty cycle" +lambdaDrop _ _ [] = error $ $(curLoc) ++ "Can't lambdadrop empty cycle" dominator :: HashMap TmName [TmName] -- ^ Dependency Graph -> [TmName] -- ^ Recursive block 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 @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + -- | Type and instance definitions for Primitive module CLaSH.Primitives.Types where @@ -25,6 +26,7 @@ { name :: S.Text -- ^ Name of the primitive , primType :: Text -- ^ Additional information } + deriving Show instance FromJSON Primitive where parseJSON (Object v) = case H.toList v of diff --git a/src/CLaSH/Rewrite/Combinators.hs b/src/CLaSH/Rewrite/Combinators.hs --- a/src/CLaSH/Rewrite/Combinators.hs +++ b/src/CLaSH/Rewrite/Combinators.hs @@ -1,13 +1,14 @@ {-# LANGUAGE ScopedTypeVariables #-} + -- | Rewriting combinators and traversals module CLaSH.Rewrite.Combinators where import Control.Monad ((<=<), (>=>)) import qualified Control.Monad.Writer as Writer import qualified Data.Monoid as Monoid -import Unbound.LocallyNameless (Embed, Fresh, bind, embed, rec, +import Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, rec, unbind, unembed, unrec) -import Unbound.LocallyNameless.Ops (unsafeUnbind) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) import CLaSH.Core.Term (Pat, Term (..)) import CLaSH.Core.Util (patIds) 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 @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -- | Type and instance definitions for Rewrite modules module CLaSH.Rewrite.Types where @@ -13,7 +12,7 @@ import Control.Monad.Writer (MonadWriter, WriterT) import Data.HashMap.Strict (HashMap) import Data.Monoid (Any) -import Unbound.LocallyNameless (Fresh, FreshMT) +import Unbound.Generics.LocallyNameless (Fresh, FreshMT) import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type) 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 @@ -1,14 +1,6 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-} - -- | Utilities for rewriting: e.g. inlining, specialisation, etc. module CLaSH.Rewrite.Util where @@ -23,24 +15,25 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HMS +import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Monoid as Monoid import qualified Data.Set as Set -import Unbound.LocallyNameless (Collection (..), Fresh, bind, +import qualified Data.Set.Lens as Lens +import Unbound.Generics.LocallyNameless (Fresh, bind, embed, makeName, name2String, rebind, rec, string2Name, unbind, unembed, unrec) -import qualified Unbound.LocallyNameless as Unbound -import Unbound.Util (filterC) +import qualified Unbound.Generics.LocallyNameless as Unbound import CLaSH.Core.DataCon (dataConInstArgTys) -import CLaSH.Core.FreeVars (termFreeVars, typeFreeVars) +import CLaSH.Core.FreeVars (termFreeIds, termFreeTyVars, typeFreeVars) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Subst (substTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..), TmName) import CLaSH.Core.TyCon (TyCon, TyConName, tyConDataCons) -import CLaSH.Core.Type (KindOrType, TyName, Type (..), +import CLaSH.Core.Type (KindOrType, Type (..), TypeView (..), transparentTy, typeKind, coreView) import CLaSH.Core.Util (Delta, Gamma, collectArgs, @@ -77,9 +70,11 @@ Monad.when (lvl > DebugNone && hasChanged) $ do tcm <- Lens.use tcCache beforeTy <- fmap transparentTy $ termType tcm expr - (beforeFTV,beforeFV) <- localFreeVars expr + let beforeFTV = Lens.setOf termFreeTyVars expr + beforeFV <- Lens.setOf <$> localFreeIds <*> pure expr afterTy <- fmap transparentTy $ termType tcm expr' - (afterFTV,afterFV) <- localFreeVars expr' + let afterFTV = Lens.setOf termFreeTyVars expr + afterFV <- Lens.setOf <$> localFreeIds <*> pure expr' let newFV = Set.size afterFTV > Set.size beforeFTV || Set.size afterFV > Set.size beforeFV Monad.when newFV $ @@ -102,7 +97,7 @@ ) (return ()) Monad.when (lvl >= DebugApplied && not hasChanged && expr /= expr') $ - error $ "Expression changed without notice(" ++ name ++ "): before" ++ before ++ "\nafter:\n" ++ after + error $ $(curLoc) ++ "Expression changed without notice(" ++ name ++ "): before" ++ before ++ "\nafter:\n" ++ after traceIf (lvl >= DebugName && hasChanged) name $ traceIf (lvl >= DebugApplied && hasChanged) ("Changes when applying rewrite to:\n" ++ before ++ "\nResult:\n" ++ after ++ "\n") $ @@ -250,7 +245,7 @@ where val = unembed valE bndrName = varName bndr - selfRef = (bndrName `elem`) . snd $ termFreeVars val + selfRef = bndrName `elem` Lens.toListOf termFreeIds val (res',rest',others') = if selfRef then (res,rest,(bndr,valE):others) else ( substTm (varName bndr) val res @@ -266,19 +261,11 @@ -- | Calculate the /local/ free variable of an expression: the free variables -- that are not bound in the global environment. -localFreeVars :: (Functor m, Monad m, Collection c) - => Term - -> RewriteMonad m (c TyName,c TmName) -localFreeVars term = do +localFreeIds :: (Applicative f, Lens.Contravariant f, Monad m) + => RewriteMonad m ((TmName -> f TmName) -> Term -> f Term) +localFreeIds = do globalBndrs <- Lens.use bindings - let (tyFVs,tmFVs) = termFreeVars term - return ( tyFVs - , filterC - $ cmap (\v -> if v `HML.member` globalBndrs - then Nothing - else Just v - ) tmFVs - ) + return ((termFreeIds . Lens.filtered (not . (`HML.member` globalBndrs)))) -- | Lift the binders in a let-binding to a global function that have a certain -- property @@ -313,7 +300,8 @@ let ty = unembed tyE e = unembed eE -- Get all local FVs, excluding the 'idName' from the let-binding - (localFTVs,localFVs) <- fmap (Set.toList *** Set.toList) $ localFreeVars e + let localFTVs = List.nub $ Lens.toListOf termFreeTyVars e + localFVs <- List.nub <$> (Lens.toListOf <$> localFreeIds <*> pure e) let localFTVkinds = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k delta) localFTVs localFVs' = filter (/= idName) localFVs localFVtys' = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k gamma) localFVs' @@ -517,8 +505,8 @@ -> Either Term Type -> RewriteMonad m ([Either Id TyVar],[Either Term Type]) specArgBndrsAndVars ctx specArg = do - (specFTVs,specFVs) <- fmap (Set.toList *** Set.toList) $ - either localFreeVars (pure . (,emptyC) . typeFreeVars) specArg + let specFTVs = List.nub $ either (Lens.toListOf termFreeTyVars) (Lens.toListOf typeFreeVars) specArg + specFVs <- List.nub <$> either ((Lens.toListOf <$> localFreeIds <*>) . pure) (const (pure [])) specArg (gamma,delta) <- mkEnv ctx let (specTyBndrs,specTyVars) = unzip $ map (\tv -> let ki = HML.lookupDefault (error $ $(curLoc) ++ show tv ++ " not found") tv delta diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -32,8 +30,8 @@ import Control.Lens import Debug.Trace (trace) import qualified Language.Haskell.TH as TH -import Unbound.LocallyNameless (Embed(..)) -import Unbound.LocallyNameless.Name (Name(..)) +import Unbound.Generics.LocallyNameless (Embed(..)) +import Unbound.Generics.LocallyNameless.Name (Name(..)) #ifdef CABAL import qualified Paths_clash_lib (version) @@ -51,8 +49,8 @@ return supply instance Hashable (Name a) where - hashWithSalt salt (Nm _ (str,int)) = hashWithSalt salt (hashWithSalt (hash int) str) - hashWithSalt salt (Bn _ i0 i1) = hashWithSalt salt (hash i0 `hashWithSalt` i1) + hashWithSalt salt (Fn str int) = hashWithSalt salt (hashWithSalt (hash int) str) + hashWithSalt salt (Bn i0 i1) = hashWithSalt salt (hash i0 `hashWithSalt` i1) instance (Ord a) => Ord (Embed a) where compare (Embed a) (Embed b) = compare a b