clash-lib 0.3.0.4 → 0.3.1
raw patch · 23 files changed
+385/−304 lines, 23 files
Files
- CHANGELOG.md +20/−0
- README.md +3/−0
- clash-lib.cabal +4/−2
- src/CLaSH/Core/Pretty.hs +2/−2
- src/CLaSH/Core/Term.hs +22/−21
- src/CLaSH/Core/TyCon.hs +14/−21
- src/CLaSH/Core/Type.hs +9/−0
- src/CLaSH/Core/TysPrim.hs +4/−6
- src/CLaSH/Core/Util.hs +4/−6
- src/CLaSH/Driver/TestbenchGen.hs +2/−2
- src/CLaSH/Netlist.hs +33/−70
- src/CLaSH/Netlist.hs-boot +6/−1
- src/CLaSH/Netlist/BlackBox.hs +151/−76
- src/CLaSH/Netlist/BlackBox/Parser.hs +2/−2
- src/CLaSH/Netlist/BlackBox/Types.hs +1/−1
- src/CLaSH/Netlist/BlackBox/Util.hs +3/−3
- src/CLaSH/Netlist/Util.hs +8/−4
- src/CLaSH/Netlist/VHDL.hs +47/−29
- src/CLaSH/Normalize.hs +4/−2
- src/CLaSH/Normalize/Transformations.hs +32/−37
- src/CLaSH/Rewrite/Combinators.hs +2/−2
- src/CLaSH/Rewrite/Util.hs +5/−17
- src/CLaSH/Util.hs +7/−0
+ CHANGELOG.md view
@@ -0,0 +1,20 @@+# Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package++## 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)+ * Replace VHDL default hole by error hole [#13](https://github.com/christiaanb/clash2/issues/13)++* Fixes bugs:+ * 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)+ * 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)+
README.md view
@@ -1,3 +1,6 @@+# Support+For updates and questions join the mailing list clash-language@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-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.3.0.4+Version: 0.3.1 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -39,7 +39,8 @@ Category: Hardware Build-type: Simple -Extra-source-files: README.md+Extra-source-files: README.md,+ CHANGELOG.md Cabal-version: >=1.10 @@ -52,6 +53,7 @@ default-language: Haskell2010 ghc-options: -O2 -Wall -fwarn-tabs+ CPP-Options: -DCABAL Build-depends: aeson >= 0.6.2.0, attoparsec >= 0.10.4.0,
src/CLaSH/Core/Pretty.hs view
@@ -102,7 +102,7 @@ App fun arg -> pprPrecApp prec fun arg TyApp e' ty -> pprPrecTyApp prec e' ty Letrec b -> lunbind b $ \(xes,e') -> pprPrecLetrec prec (unrec xes) e'- Case e' alts -> pprPrecCase prec e' =<< mapM (`lunbind` return) alts+ Case e' _ alts -> pprPrecCase prec e' =<< mapM (`lunbind` return) alts data BindingSite = LambdaBind@@ -225,7 +225,7 @@ pprFunTail otherTy = ppr_type TopPrec otherTy <:> pure [] ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1 <*> ppr_type TyConPrec ty2)-ppr_type _ ty = error $ $(curLoc) ++ "Can't pretty print type: " ++ show ty+ppr_type _ (ConstTy Arrow) = return (parens rarrow) pprForAllType :: (Applicative m, LFresh m) => TypePrec -> Type -> m Doc pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty
src/CLaSH/Core/Term.hs view
@@ -32,17 +32,17 @@ -- | Term representation in the CoreHW language: System F + LetRec + Case data Term- = Var Type TmName -- ^ Variable reference- | Data DataCon -- ^ Datatype constructor- | Literal Literal -- ^ Literal- | Prim Text Type -- ^ Primitive- | Lam (Bind Id Term) -- ^ Term-abstraction- | TyLam (Bind TyVar Term) -- ^ Type-abstraction- | App Term Term -- ^ Application- | TyApp Term Type -- ^ Type-application+ = Var Type TmName -- ^ Variable reference+ | Data DataCon -- ^ Datatype constructor+ | Literal Literal -- ^ Literal+ | Prim Text Type -- ^ Primitive+ | Lam (Bind Id Term) -- ^ Term-abstraction+ | TyLam (Bind TyVar Term) -- ^ Type-abstraction+ | App Term Term -- ^ Application+ | TyApp Term Type -- ^ Type-application | Letrec (Bind (Rec [LetBinding]) Term) -- ^ Recursive let-binding- | Case Term [Bind Pat Term] -- ^ Case-expression: subject, type of- -- alternatives, list of alternatives+ | Case Term Type [Bind Pat Term] -- ^ Case-expression: subject, type of+ -- alternatives, list of alternatives deriving Show -- | Term reference@@ -94,16 +94,17 @@ instance Subst Type Pat instance Subst Type Term where subst tvN u x | isFree 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)- TyApp e ty -> TyApp (subst tvN u e ) (subst tvN u ty )- Letrec b -> Letrec (subst tvN u b )- Case e alts -> Case (subst tvN u e )- (subst tvN u alts )- Var ty nm -> Var (subst tvN u ty ) nm- Prim nm ty -> Prim nm (subst tvN u ty)- e -> e+ 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)+ TyApp e ty -> TyApp (subst tvN u e ) (subst tvN u ty )+ Letrec b -> Letrec (subst tvN u b )+ Case e ty alts -> Case (subst tvN u e )+ (subst tvN u ty )+ (subst tvN u alts )+ Var ty nm -> Var (subst tvN u ty ) nm+ Prim nm ty -> Prim nm (subst tvN u ty)+ e -> e subst m _ _ = error $ $(curLoc) ++ "Cannot substitute for bound variable: " ++ show m instance Subst Term Text@@ -123,7 +124,7 @@ 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 alts -> rnf sc `seq` rnf (map unsafeUnbind alts)+ Case sc ty alts -> rnf sc `seq` rnf ty `seq` rnf (map unsafeUnbind alts) instance NFData Pat where rnf p = case p of
src/CLaSH/Core/TyCon.hs view
@@ -12,7 +12,6 @@ ( TyCon (..) , TyConName , AlgTyConRhs (..)- , PrimRep (..) , mkKindTyCon , isTupleTyConLike , tyConDataCons@@ -39,12 +38,18 @@ , tyConArity :: Int -- ^ Number of type arguments , algTcRhs :: AlgTyConRhs -- ^ DataCon definitions }+ -- | Function TyCons (e.g. type families)+ | FunTyCon+ { tyConName :: TyConName -- ^ Name of the TyCon+ , tyConKind :: Kind -- ^ Kind of the TyCon+ , tyConArity :: Int -- ^ Number of type arguments+ , tyConSubst :: [([Type],Type)] -- ^ List of: ([LHS match types], RHS type)+ } -- | Primitive TyCons | PrimTyCon { tyConName :: TyConName -- ^ Name of the TyCon , tyConKind :: Kind -- ^ Kind of the TyCon , tyConArity :: Int -- ^ Number of type arguments- , primTyConRep :: PrimRep -- ^ Representation } -- | To close the loop on the type hierarchy | SuperKindTyCon@@ -53,6 +58,7 @@ instance Show TyCon where show (AlgTyCon {tyConName = n}) = "AlgTyCon: " ++ show n+ show (FunTyCon {tyConName = n}) = "FunTyCon: " ++ show n show (PrimTyCon {tyConName = n}) = "PrimTyCon: " ++ show n show (SuperKindTyCon {tyConName = n}) = "SuperKindTyCon: " ++ show n @@ -80,15 +86,8 @@ } deriving Show --- | Representations for primitive types-data PrimRep- = IntRep- | VoidRep- deriving Show--Unbound.derive [''TyCon,''AlgTyConRhs,''PrimRep]+Unbound.derive [''TyCon,''AlgTyConRhs] -instance Alpha PrimRep instance Alpha TyCon where swaps' _ _ d = d fv' _ _ = emptyC@@ -108,17 +107,16 @@ instance Subst Type TyCon instance Subst Type AlgTyConRhs-instance Subst Type PrimRep instance Subst Term TyCon instance Subst Term AlgTyConRhs-instance Subst Term PrimRep 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- PrimTyCon nm ki ar rep -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rep- SuperKindTyCon nm -> rnf nm+ 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 instance NFData (Name TyCon) where rnf nm = case nm of@@ -130,17 +128,12 @@ DataTyCon dcs -> rnf dcs NewTyCon dc eta -> rnf dc `seq` rnf eta -instance NFData PrimRep where- rnf pm = case pm of- IntRep -> ()- VoidRep -> ()- -- | Create a Kind out of a TyConName mkKindTyCon :: TyConName -> Kind -> TyCon mkKindTyCon name kind- = PrimTyCon name kind 0 VoidRep+ = PrimTyCon name kind 0 -- | Does the TyCon look like a tuple TyCon isTupleTyConLike :: TyConName -> Bool
src/CLaSH/Core/Type.hs view
@@ -29,6 +29,7 @@ , mkFunTy , mkTyConApp , splitFunTy+ , splitFunTys , splitFunForallTy , splitTyConAppM , isPolyFunTy@@ -261,6 +262,14 @@ -> Maybe (Type, Type) splitFunTy m (coreView m -> FunTy arg res) = Just (arg,res) splitFunTy _ _ = Nothing++splitFunTys :: HashMap TyConName TyCon+ -> Type+ -> ([Type],Type)+splitFunTys m (coreView m -> FunTy arg res) = (arg:args,res')+ where+ (args,res') = splitFunTys m res+splitFunTys _ ty = ([],ty) -- | Split a poly-function type in a: list of type-binders and argument types, -- and the result type
src/CLaSH/Core/TysPrim.hs view
@@ -41,16 +41,14 @@ intPrimTyConName = string2Name "Int" voidPrimTyConName = string2Name "VOID" -liftedPrimTC ::- TyConName- -> PrimRep- -> TyCon+liftedPrimTC :: TyConName+ -> TyCon liftedPrimTC name = PrimTyCon name liftedTypeKind 0 -- | Builtin Type intPrimTc, voidPrimTc :: TyCon-intPrimTc = (liftedPrimTC intPrimTyConName IntRep )-voidPrimTc = (liftedPrimTC voidPrimTyConName VoidRep)+intPrimTc = (liftedPrimTC intPrimTyConName )+voidPrimTc = (liftedPrimTC voidPrimTyConName) intPrimTy, voidPrimTy :: Type intPrimTy = mkTyConTy intPrimTyConName
src/CLaSH/Core/Util.hs view
@@ -46,9 +46,7 @@ TyApp e' ty -> termType m e' >>= (\f -> applyTy m f ty) Letrec b -> do (_,e') <- unbind b termType m e'- Case _ (alt:_) -> do (_,e') <- unbind alt- termType m e'- Case _ [] -> error $ $(curLoc) ++ "Empty case"+ Case _ ty _ -> return ty -- | Split a (Type)Application in the applied term and it arguments collectArgs :: Term@@ -220,6 +218,6 @@ bndrSzs = map (termSize . unembed . snd) (unrec bndrsR) bodySz = termSize body in sum (bodySz:bndrSzs)-termSize (Case subj alts) = let subjSz = termSize subj- altSzs = map (termSize . snd . unsafeUnbind) alts- in sum (subjSz:altSzs)+termSize (Case subj _ alts) = let subjSz = termSize subj+ altSzs = map (termSize . snd . unsafeUnbind) alts+ in sum (subjSz:altSzs)
src/CLaSH/Driver/TestbenchGen.hs view
@@ -27,7 +27,7 @@ import CLaSH.Netlist import CLaSH.Netlist.Types as N-import CLaSH.Netlist.VHDL (vhdlTypeDefault)+import CLaSH.Netlist.VHDL (vhdlTypeErrValue) import CLaSH.Normalize (cleanupGraph, normalize, runNormalization) import CLaSH.Primitives.Types@@ -56,7 +56,7 @@ let ioDecl = [ uncurry NetDecl inp Nothing , uncurry NetDecl outp Nothing ]- inpAssg = evalState (vhdlTypeDefault (snd inp)) vhdlState+ 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)
src/CLaSH/Netlist.hs view
@@ -6,20 +6,18 @@ import Control.Lens ((.=), (<<%=)) import qualified Control.Lens as Lens-import qualified Control.Monad as Monad import Control.Monad.State (runStateT) import Control.Monad.Writer (listen, runWriterT)-import Data.Either (partitionEithers)+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 as TextS import qualified Data.Text.Lazy as Text import Unbound.LocallyNameless (Embed (..), name2String,- runFreshMT, string2Name, unbind,- unembed, unrebind)+ runFreshMT, unbind, unembed,+ unrebind) import CLaSH.Core.DataCon (DataCon (..)) import CLaSH.Core.Literal (Literal (..))@@ -115,7 +113,8 @@ . Text.pack $ name2String compName - (arguments,binders,result) <- do { normalizedM <- splitNormalized componentExpr+ tcm <- Lens.use tcCache+ (arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr ; case normalizedM of Right normalized -> mkUniqueNormalized normalized Left err -> error err@@ -131,7 +130,6 @@ varEnv .= gamma typeTrans <- Lens.use typeTranslator- tcm <- Lens.use tcCache let resType = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm $ HashMap.lookupDefault (error $ $(curLoc) ++ "resType" ++ show (result,HashMap.keys ids)) result ids argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType $(curLoc) typeTrans tcm t) arguments @@ -153,10 +151,10 @@ -> NetlistMonad [Declaration] mkDeclarations bndr (Var _ v) = mkFunApp bndr v [] -mkDeclarations _ e@(Case _ []) =+mkDeclarations _ e@(Case _ _ []) = error $ $(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported: " ++ showDoc e -mkDeclarations bndr e@(Case (Var scrutTy scrutNm) [alt]) = do+mkDeclarations bndr e@(Case (Var scrutTy scrutNm) _ [alt]) = do (pat,v) <- unbind alt (varTy,varTm) <- case v of (Var t n) -> return (t,n)@@ -175,7 +173,7 @@ extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier return [Assignment dstId extractExpr] -mkDeclarations bndr (Case scrut alts) = do+mkDeclarations bndr (Case scrut altTy alts) = do alts' <- mapM unbind alts tcm <- Lens.use tcCache scrutTy <- termType tcm scrut@@ -188,8 +186,6 @@ where mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe Expr,Expr),[Declaration]) mkCondExpr scrutHTy (pat,alt) = do- tcm <- Lens.use tcCache- altTy <- termType tcm alt (altExpr,altDecls) <- mkExpr altTy alt (,altDecls) <$> case pat of DefaultPat -> return (Nothing,altExpr)@@ -206,13 +202,11 @@ _ -> error $ $(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement" _ -> scrutE -mkDeclarations bndr app = do+mkDeclarations bndr app = let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app- tcm <- Lens.use tcCache- args' <- Monad.filterM (Monad.liftM3 representableType (Lens.use typeTranslator) (pure tcm) . termType tcm) args- case appF of+ in case appF of Var _ f- | null tyArgs -> mkFunApp bndr f args'+ | null tyArgs -> mkFunApp bndr f args | otherwise -> error $ $(curLoc) ++ "Not in normal form: Var-application with Type arguments" _ -> do (exprApp,declsApp) <- mkExpr (unembed $ varType bndr) app@@ -257,59 +251,16 @@ _ -> error $ $(curLoc) ++ "not an integer literal" mkExpr ty app = do- let (appF,(args,_)) = second partitionEithers $ collectArgs app- hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty- tcm <- Lens.use tcCache- args' <- Monad.filterM (Monad.liftM3 representableType (Lens.use typeTranslator) (pure tcm) . termType tcm) args+ let (appF,args) = collectArgs app+ tmArgs = lefts args+ hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty case appF of Data dc- | all (\e -> isConstant e || isVar e) args' -> mkDcApplication hwTy dc args'- | otherwise -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments"- Prim nm _- -- TODO: Optimize the tagToEnum and dataToTag translations so that in- -- general:- -- - tagToEnum is translated to 'to_unsigned'- -- - dataToTag is translated to 'to_integer'- | nm == TextS.pack "GHC.Prim.tagToEnum#" -> do- i <- varCount <<%= (+1)- scrutTy <- termType tcm (head args)- (scrutExpr,scrutDecls) <- mkExpr scrutTy (head args)- let tmpNm = "tmp_tte_" ++ show i- tmpS = Text.pack tmpNm- netDecl = NetDecl tmpS hwTy Nothing- netAssign = Assignment tmpS (DataTag hwTy (Left scrutExpr))- return (Identifier tmpS Nothing,netDecl:netAssign:scrutDecls)- | nm == TextS.pack "GHC.Prim.dataToTag#" -> do- i <- varCount <<%= (+1)- scrutTy <- termType tcm (head args)- scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy- (scrutExpr,scrutDecls) <- mkExpr scrutTy (head args)- let tmpNm = "tmp_dtt_" ++ show i- tmpS = Text.pack tmpNm- netDecl = NetDecl tmpS hwTy Nothing- netAssign = Assignment tmpS (DataTag scrutHTy (Right scrutExpr))- return (Identifier tmpS Nothing,netDecl:netAssign:scrutDecls)- | otherwise -> do- bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives- case bbM of- Just p@(P.BlackBox {}) ->- case template p of- Left templD -> do- i <- varCount <<%= (+1)- let tmpNm = "tmp_" ++ show i- tmpId = Id (string2Name tmpNm) (Embed ty)- tmpS = Text.pack tmpNm- netDecl = NetDecl tmpS hwTy Nothing- (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId args- bb <- fmap BlackBoxD $! mkBlackBox templD bbCtx- return (Identifier tmpS Nothing, ctxDcls ++ [netDecl,bb])- Right templE -> do- (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (Embed ty)) args- bb <- fmap (`BlackBoxE` Nothing) $! mkBlackBox templE bbCtx- return (bb,ctxDcls)- _ -> error $ $(curLoc) ++ "No blackbox found: " ++ TextS.unpack nm+ | 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 nm args ty Var _ f- | null args -> return (Identifier (mkBasicId . Text.pack $ name2String f) Nothing,[])+ | 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 _ -> error $ $(curLoc) ++ "Not in normal form: application of a Let/Lam/Case: " ++ showDoc app @@ -353,8 +304,20 @@ 2 -> HW.Literal Nothing (BitLit H) tg -> error $ $(curLoc) ++ "unknown bit literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" in return dc'- Vector 0 _ -> return (HW.DataCon dstHType Nothing [])- Vector 1 _ -> return (HW.DataCon dstHType (Just VecAppend) [head argExprs])- Vector _ _ -> return (HW.DataCon dstHType (Just VecAppend) argExprs)+ Vector 0 _ -> return (HW.DataCon dstHType Nothing [])+ -- Note [Vector Wrapper]+ -- The Vector type has two versions of the cons constructor:+ -- * The 'normal' one, which takes a coercion as its first argument,+ -- followed by the element and the vector+ -- * The wrapper one, which just takes the element and vector argument+ --+ -- 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])+ Vector _ _ -> case argExprs of+ [_,e1,e2] -> return (HW.DataCon dstHType (Just VecAppend) [e1,e2])+ _ -> return (HW.DataCon dstHType (Just VecAppend) argExprs) _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)
src/CLaSH/Netlist.hs-boot view
@@ -1,13 +1,18 @@-module CLaSH.Netlist (genComponent,mkDcApplication) where+module CLaSH.Netlist (genComponent,mkExpr,mkDcApplication) where 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) genComponent :: TmName -> Maybe Int -> NetlistMonad Component++mkExpr :: Type+ -> Term+ -> NetlistMonad (Expr,[Declaration]) mkDcApplication :: HWType
src/CLaSH/Netlist/BlackBox.hs view
@@ -19,8 +19,9 @@ import Data.List (partition) import Data.Maybe (catMaybes, fromJust) import Data.Monoid (mconcat)-import Data.Text.Lazy (Text, pack)+import Data.Text.Lazy (Text, fromStrict, pack) import Data.Text (unpack)+import qualified Data.Text as TextS import Unbound.LocallyNameless (embed, name2String, string2Name, unembed) @@ -28,11 +29,13 @@ import CLaSH.Core.Literal as L (Literal (..)) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Term as C (Term (..), TmName)-import CLaSH.Core.Type as C (Type (..), ConstTy (..))+import CLaSH.Core.Type as C (Type (..), ConstTy (..),+ splitFunTys) import CLaSH.Core.TyCon as C (tyConDataCons) import CLaSH.Core.Util (collectArgs, isFun, termType) import CLaSH.Core.Var as V (Id, Var (..))-import {-# SOURCE #-} CLaSH.Netlist (genComponent, mkDcApplication)+import {-# SOURCE #-} CLaSH.Netlist (genComponent, mkDcApplication,+ mkExpr) import CLaSH.Netlist.BlackBox.Parser as B import CLaSH.Netlist.BlackBox.Types as B import CLaSH.Netlist.BlackBox.Util as B@@ -100,49 +103,98 @@ Nothing -> return ((Left vT, hwTy),[]) mkInput (e, False) = case collectArgs e of- (Prim f _, args) -> mkInput' f args- _ -> fmap (first (first Left)) $ mkLitInput e- where- mkInput' nm args = do- bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives- case bbM of- Just p@(P.BlackBox {}) -> do- i <- lift $ varCount <<%= (+1)- tcm <- Lens.use tcCache- ty <- termType tcm e- let dstNm = "bb_sig_" ++ show i- dstId = pack dstNm- resId = Id (string2Name dstNm) (embed ty)- (bbCtx,ctxDecls) <- lift $ mkBlackBoxContext resId (lefts args)- let hwTy = snd $ result bbCtx- case template p of- (Left tempD) -> do- let netDecl = N.NetDecl dstId hwTy Nothing- bbCtx' = bbCtx { result = first (either (Left . const dstId)- (Right . first (const dstId)))- (result bbCtx) }- bbDecl <- fmap N.BlackBoxD $ lift $ mkBlackBox tempD bbCtx'- return ((Left dstId, hwTy),ctxDecls ++ [netDecl,bbDecl])- (Right tempE) -> do- bb <- lift $ mkBlackBox tempE bbCtx- let bb' = mconcat [pack "(",bb,pack ")"]- return ((Left bb', hwTy),ctxDecls)- Just (P.Primitive pNm _)- | pNm == "GHC.Prim.tagToEnum#" -> case collectArgs (head $ fst $ partitionEithers args) of- (C.Literal (IntegerLiteral i), _) -> do- tcm <- Lens.use tcCache- let ConstTy (TyCon tcN) = head . snd $ partitionEithers args- dcs = tyConDataCons (tcm HashMap.! tcN)- dc = dcs !! (fromInteger $ i - 1)- ((id_,hwTy),decs) <- mkLitInput (Data dc)- return ((Left id_,hwTy),decs)- _ -> error $ $(curLoc) ++ "tagToEnum: " ++ showDoc e- | pNm == "GHC.Prim.dataToTag#" -> case collectArgs (head $ fst $ partitionEithers args) of- (Data dc, _) -> return ((Left . pack . show . subtract 1 $ dcTag dc,Integer),[])- _ -> error $ $(curLoc) ++ "dataToTag: " ++ showDoc e- | otherwise -> mzero- Nothing -> error $ $(curLoc) ++ "No blackbox found: " ++ unpack nm+ (Prim f _, args) -> do+ tcm <- Lens.use tcCache+ ty <- termType tcm e+ ((exprN,hwTy),decls) <- lift $ mkPrimitive True f args ty+ exprV <- fmap (pack . show) $ liftState vhdlMState $ N.expr False exprN+ return ((Left exprV,hwTy),decls)+ _ -> fmap (first (first Left)) $ mkLitInput e +mkPrimitive :: Bool+ -> TextS.Text+ -> [Either Term Type]+ -> Type+ -> NetlistMonad ((Expr,HWType),[Declaration])+mkPrimitive bbEParen nm args ty = do+ bbM <- HashMap.lookup nm <$> Lens.use primitives+ case bbM of+ Just p@(P.BlackBox {}) -> do+ i <- varCount <<%= (+1)+ let tmpNm = "tmp_" ++ show i+ tmpNmT = pack tmpNm+ tmpId = Id (string2Name tmpNm) (embed ty)+ (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId (lefts args)+ let hwTy = snd $ result 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])+ (Right tempE) -> do+ bbExpr <- mkBlackBox tempE bbCtx+ let bbExpr' = if bbEParen then mconcat ["(",bbExpr,")"] else bbExpr+ return ((BlackBoxE bbExpr' Nothing,hwTy),ctxDcls)+ Just (P.Primitive pNm _)+ | pNm == "GHC.Prim.tagToEnum#" -> do+ hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty+ case args of+ [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntegerLiteral i))] -> do+ tcm <- Lens.use tcCache+ let dcs = tyConDataCons (tcm HashMap.! tcN)+ dc = dcs !! fromInteger i+ (exprN,dcDecls) <- mkDcApplication hwTy dc []+ return ((exprN,hwTy),dcDecls)+ [Right _, Left scrut] -> do+ i <- varCount <<%= (+1)+ tcm <- Lens.use tcCache+ scrutTy <- termType tcm scrut+ (scrutExpr,scrutDecls) <- mkExpr 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)+ _ -> 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 $ dcTag dc - 1),Integer),[])+ [Right _,Left scrut] -> do+ i <- varCount <<%= (+1)+ tcm <- Lens.use tcCache+ scrutTy <- termType tcm scrut+ scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy+ (scrutExpr,scrutDecls) <- mkExpr 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.Signed.fromIntegerS" -> case lefts args of+ [C.Literal (IntegerLiteral i),arg] ->+ let sz = fromInteger i+ in case arg of+ C.Literal (IntegerLiteral j)+ | i > 32 -> return ((N.Literal (Just sz) (NumLit $ fromInteger j), Signed sz),[])+ _ -> do+ (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) (lefts args)+ bb <- mkBlackBox (pack "to_signed(~ARG[1],~LIT[0])") bbCtx+ return ((BlackBoxE bb Nothing,Signed sz),ctxDcls)+ _ -> error $ $(curLoc) ++ "CLaSH.Sized.Signed.fromIntegerS: " ++ show (map (either showDoc showDoc) args)+ | pNm == "CLaSH.Sized.Unsigned.fromIntegerU" -> case lefts args of+ [C.Literal (IntegerLiteral i),arg] ->+ let sz = fromInteger i+ in case arg of+ C.Literal (IntegerLiteral j)+ | i > 31 -> return ((N.Literal (Just sz) (NumLit $ fromInteger j), Unsigned sz),[])+ _ -> do+ (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) (lefts args)+ bb <- mkBlackBox (pack "to_unsigned(~ARG[1],~LIT[0])") bbCtx+ return ((BlackBoxE bb Nothing,Unsigned sz),ctxDcls)+ _ -> error $ $(curLoc) ++ "CLaSH.Sized.Unsigned.fromIntegerU: " ++ show (map (either showDoc showDoc) args)+ | otherwise -> return ((BlackBoxE (mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]) Nothing,Void),[])+ _ -> 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@@ -164,37 +216,60 @@ mkFunInput :: Id -- ^ Identifier binding the encompassing primitive/blackbox application -> Term -- ^ The function argument term -> MaybeT NetlistMonad ((BlackBoxTemplate,BlackBoxContext),[Declaration])-mkFunInput resId e = case collectArgs e of- (Prim nm _, args) -> do- bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives- case bbM of- Just p@(P.BlackBox {}) -> do- (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args)- let (l,err) = either runParse (first (([O,C " <= "] ++) . (++ [C ";"])) . runParse) (template p)- if null err- then do- l' <- lift $ instantiateSym l- return ((l',bbCtx),dcls)- else error $ $(curLoc) ++ "\nTemplate:\n" ++ show (template p) ++ "\nHas errors:\n" ++ show err- _ -> error $ "No blackbox found: " ++ unpack nm- (Var _ fun, args) -> do- normalized <- Lens.use bindings- case HashMap.lookup fun normalized of- Just _ -> do- (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args)- (Component compName hidden compInps compOutp _) <- lift $ 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 instDecl = InstDecl compName (pack ("comp_inst_" ++ show i)) (outpAssign:hiddenAssigns ++ inpAssigns)- templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst instDecl- let (line,err) = runParse templ- if null err- then return ((line,bbCtx),dcls)- else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err- Nothing -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e- _ -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e+mkFunInput resId e = do+ let (appE,args) = collectArgs e+ (bbCtx,dcls) <- lift $ 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.Signed.fromIntegerS" -> Right "to_signed(~ARG[1],~LIT[0])"+ | pNm == "CLaSH.Sized.Unsigned.fromIntegerU" -> Right "to_unsigned(~ARG[1],~LIT[0])"+ _ -> 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+ 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+ dcAss = Assignment (pack "~RESULT") dcApp+ templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst dcAss+ return (Left templ)+ 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+ dcAss = Assignment (pack "~RESULT") dcApp+ templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst dcAss+ return (Left templ)+ _ -> 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+ 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 instDecl = InstDecl compName (pack ("comp_inst_" ++ show i)) (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 -- | Instantiate symbols references with a new symbol and increment symbol counter instantiateSym :: BlackBoxTemplate
src/CLaSH/Netlist/BlackBox/Parser.hs view
@@ -66,8 +66,8 @@ <|> (Typ . Just) <$> (pToken "~TYP" *> pBrackets pNatural) <|> TypM Nothing <$ pToken "~TYPMO" <|> (TypM . Just) <$> (pToken "~TYPM" *> pBrackets pNatural)- <|> Def Nothing <$ pToken "~DEFAULTO"- <|> (Def . Just) <$> (pToken "~DEFAULT" *> pBrackets pNatural)+ <|> Err Nothing <$ pToken "~ERRORO"+ <|> (Err . Just) <$> (pToken "~ERROR" *> pBrackets pNatural) <|> TypElem <$> (pToken "~TYPEL" *> pBrackets pTagE) -- | Parse a bracketed text
src/CLaSH/Netlist/BlackBox/Types.hs view
@@ -41,7 +41,7 @@ | Rst (Maybe Int) -- ^ Reset hole | Typ (Maybe Int) -- ^ Type declaration hole | TypM (Maybe Int) -- ^ Type root hole- | Def (Maybe Int) -- ^ Default value hole+ | Err (Maybe Int) -- ^ Error value hole | TypElem Element -- ^ Select element type from a vector type deriving Show
src/CLaSH/Netlist/BlackBox/Util.hs view
@@ -19,7 +19,7 @@ import CLaSH.Netlist.Types (HWType (..), Identifier, VHDLState) import CLaSH.Netlist.VHDL (vhdlType,- vhdlTypeDefault,+ vhdlTypeErrValue, vhdlTypeMark) import CLaSH.Util @@ -160,7 +160,7 @@ 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 (Def Nothing) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeDefault . snd $ result b-mkSyncIdentifier b (Def (Just n)) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeDefault . 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"
src/CLaSH/Netlist/Util.hs view
@@ -38,9 +38,10 @@ -- 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)- => Term+ => HashMap TyConName TyCon+ -> Term -> m (Either String ([Id],[LetBinding],Id))-splitNormalized expr = do+splitNormalized tcm expr = do (args,letExpr) <- fmap (first partitionEithers) $ collectBndrs expr case letExpr of Letrec b@@ -50,7 +51,9 @@ Var t v -> return $! Right (tmArgs,unrec xes,Id v (embed t)) _ -> return $! Left ($(curLoc) ++ "Not in normal form: res not simple var") | otherwise -> return $! Left ($(curLoc) ++ "Not in normal form: tyArgs")- _ -> return $! Left ($(curLoc) ++ "Not in normal from: no Letrec: " ++ showDoc expr)+ _ -> do+ ty <- termType tcm expr+ return $! Left ($(curLoc) ++ "Not in normal from: no Letrec:\n" ++ showDoc expr ++ "\nWhich has type:\n" ++ showDoc ty) -- | Converts a Core type to a HWType given a function that translates certain -- builtin types. Errors if the Core type is not translatable.@@ -245,7 +248,8 @@ Var t v | v == varName f -> return . Var t $ varName r App e1 e2 -> App <$> subsBndr f r e1 <*> subsBndr f r e2- Case scrut alts -> Case <$> subsBndr f r scrut+ Case scrut ty alts -> Case <$> subsBndr f r scrut+ <*> pure ty <*> mapM ( return . uncurry bind <=< secondM (subsBndr f r)
src/CLaSH/Netlist/VHDL.hs view
@@ -9,7 +9,7 @@ ( genVHDL , mkTyPackage , vhdlType- , vhdlTypeDefault+ , vhdlTypeErrValue , vhdlTypeMark , inst , expr@@ -23,7 +23,7 @@ import Data.Graph.Inductive (Gr, mkGraph, topsort') import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashSet as HashSet-import Data.List (mapAccumL,nub)+import Data.List (mapAccumL,nubBy) import Data.Maybe (catMaybes,mapMaybe) import Data.Text.Lazy (unpack) import qualified Data.Text.Lazy as T@@ -64,8 +64,9 @@ ) <$> "end" <> semi <> packageBodyDec where- hwTysSorted = topSortHWTys hwtys- usedTys = nub $ concatMap mkUsedTys hwtys+ 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 usedTys (showDecs,showBodies) = unzip $ map mkToStringDecls hwTysSorted@@ -82,6 +83,14 @@ "-- pragma translate_on" <$> "end" <> semi + 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+ _ -> elTy1 == elTy2+ eqHWTy ty1 ty2 = ty1 == ty2+ mkUsedTys :: HWType -> [HWType] mkUsedTys v@(Vector _ elTy) = v : mkUsedTys elTy@@ -228,16 +237,13 @@ "end" <> semi where ports l = sequence- $ [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty <> optionalDefault ty) -- <+> ":=" <+> vhdlTypeDefault ty)+ $ [ (,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 <> optionalDefault ty) -- <+> ":=" <+> vhdlTypeDefault ty)+ [ (,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) <> optionalDefault (snd $ output c)) -- <+> ":=" <+> vhdlTypeDefault (snd $ output c))+ [ (,fromIntegral $ T.length (fst $ output c)) A.<$> (fill l (text (fst $ output c)) <+> colon <+> "out" <+> vhdlType (snd $ output c)) ] - optionalDefault ty@Integer = " :=" <+> vhdlTypeDefault ty- optionalDefault _ = empty- architecture :: Component -> VHDLM Doc architecture c = nest 2@@ -305,20 +311,20 @@ tyName t@(SP _ _) = "std_logic_vector_" <> int (typeSize t) tyName _ = empty --- | Convert a Netlist HWType to a default VHDL value for that type-vhdlTypeDefault :: HWType -> VHDLM Doc-vhdlTypeDefault Bit = "'0'"-vhdlTypeDefault Bool = "false"-vhdlTypeDefault Integer = "0"-vhdlTypeDefault (Signed _) = "(others => '0')"-vhdlTypeDefault (Unsigned _) = "(others => '0')"-vhdlTypeDefault (Vector _ elTy) = parens ("others" <+> rarrow <+> vhdlTypeDefault elTy)-vhdlTypeDefault (SP _ _) = "(others => '0')"-vhdlTypeDefault (Sum _ _) = "(others => '0')"-vhdlTypeDefault (Product _ elTys) = tupled $ mapM vhdlTypeDefault elTys-vhdlTypeDefault (Reset _) = "'0'"-vhdlTypeDefault (Clock _) = "'0'"-vhdlTypeDefault Void = "((-1) downto 0 => '0')"+-- | Convert a Netlist HWType to an error VHDL value for that type+vhdlTypeErrValue :: HWType -> VHDLM Doc+vhdlTypeErrValue Bit = "'1'"+vhdlTypeErrValue Bool = "true"+vhdlTypeErrValue Integer = "integer'high"+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@@ -329,9 +335,6 @@ _ -> vcat (punctuate semi (A.pure dsDoc)) <> semi decl :: Int -> Declaration -> VHDLM (Maybe (Doc,Int))-decl l (NetDecl id_ ty@Integer netInit) = Just A.<$> (,fromIntegral (T.length id_)) A.<$>- "signal" <+> fill l (text id_) <+> colon <+> vhdlType ty <+> ":=" <+> maybe (vhdlTypeDefault ty) (expr False) netInit- 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) @@ -478,13 +481,21 @@ toSLV (Sum _ _) e = "std_logic_vector" <> parens (expr False e) toSLV t@(Product _ tys) (Identifier id_ Nothing) = do selIds' <- sequence selIds- parens (hcat $ punctuate " & " (zipWithM toSLV tys 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) = parens (hcat $ punctuate " & " (zipWithM toSLV tys es))+toSLV (Product _ tys) (DataCon _ _ es) = encloseSep lparen rparen " & " (zipWithM toSLV tys es) toSLV (SP _ _) e = expr False e+toSLV (Vector _ Bit) e = expr False e+toSLV (Vector n elTy) (Identifier id_ Nothing) = do+ selIds' <- sequence 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@@ -504,6 +515,13 @@ args = zipWith3 (`fromSLV` id_) tys starts ends fromSLV (SP _ _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end)+fromSLV (Vector _ Bit) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end)+fromSLV (Vector n elTy) id_ start _ = tupled 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
src/CLaSH/Normalize.hs view
@@ -175,7 +175,8 @@ flattenNode :: CallTree -> NormalizeSession (Either CallTree ((TmName,Term),[CallTree])) flattenNode c@(CLeaf (nm,(_,e))) = do- norm <- splitNormalized e+ tcm <- Lens.use tcCache+ norm <- splitNormalized tcm e case norm of Right (ids,[(_,bExpr)],_) -> do let (fun,args) = collectArgs (unembed bExpr)@@ -184,7 +185,8 @@ Nothing -> return (Left c) _ -> return (Left c) flattenNode b@(CBranch (nm,(_,e)) us) = do- norm <- splitNormalized e+ tcm <- Lens.use tcCache+ norm <- splitNormalized tcm e case norm of Right (ids,[(_,bExpr)],_) -> do let (fun,args) = collectArgs (unembed bExpr)
src/CLaSH/Normalize/Transformations.hs view
@@ -49,7 +49,8 @@ import CLaSH.Core.Subst (substTm, substTms, substTyInTm, substTysinTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..))-import CLaSH.Core.Type (TypeView (..), splitFunTy, tyView)+import CLaSH.Core.Type (TypeView (..), applyFunTy,+ applyTy, splitFunTy, tyView) import CLaSH.Core.Util (collectArgs, idToVar, isCon, isFun, isLet, isPolyFun, isPrim, isVar, mkApps, mkLams, mkTmApps,@@ -112,27 +113,24 @@ -- | Lift the let-bindings out of the subject of a Case-decomposition caseLet :: NormRewrite-caseLet _ (Case (Letrec b) alts) = R $ do+caseLet _ (Case (Letrec b) ty alts) = R $ do (xes,e) <- unbind b- changed . Letrec $ bind xes (Case e alts)+ changed . Letrec $ bind xes (Case e ty alts) caseLet _ e = return e -- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives caseCase :: NormRewrite-caseCase _ e@(Case (Case scrut alts1) alts2)+caseCase _ e@(Case (Case scrut alts1Ty alts1) alts2Ty alts2) = R $ do- alt1E <- snd <$> unbind (head alts1)- tcm <- Lens.use tcCache- alts1Ty <- termType tcm alt1E ty1Rep <- representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure alts1Ty if not ty1Rep then do newAlts <- mapM ( return . uncurry bind- . second (\altE -> Case altE alts2)+ . second (\altE -> Case altE alts2Ty alts2) <=< unbind ) alts1- changed $ Case scrut newAlts+ changed $ Case scrut alts2Ty newAlts else return e caseCase _ e = return e@@ -140,7 +138,7 @@ -- | Inline function with a non-representable result if it's the subject -- of a Case-decomposition inlineNonRep :: NormRewrite-inlineNonRep _ e@(Case scrut alts)+inlineNonRep _ e@(Case scrut altsTy alts) | (Var _ f, args) <- collectArgs scrut = R $ do isInlined <- liftR $ alreadyInlined f@@ -159,7 +157,7 @@ case (nonRepScrut, bodyMaybe) of (True,Just (_, scrutBody)) -> do Monad.when noException (liftR $ addNewInline f)- changed $ Case (mkApps scrutBody args) alts+ changed $ Case (mkApps scrutBody args) altsTy alts _ -> return e where exception (tyView -> TyConApp (name2String -> "GHC.Num.Num") [arg]) = numDictArg arg@@ -184,7 +182,7 @@ -- the subject is (an application of) a DataCon; or if there is only a single -- alternative that doesn't reference variables bound by the pattern. caseCon :: NormRewrite-caseCon _ c@(Case scrut alts)+caseCon _ c@(Case scrut _ alts) | (Data dc, args) <- collectArgs scrut = R $ do alts' <- mapM unbind alts@@ -207,7 +205,7 @@ equalCon dc (DataPat dc' _) = dcTag dc == dcTag (unembed dc') equalCon _ _ = False -caseCon _ c@(Case (Literal l) alts) = R $ do+caseCon _ c@(Case (Literal l) _ alts) = R $ do alts' <- mapM unbind alts let ltAltsM = List.find (equalLit . fst) alts' case ltAltsM of@@ -219,7 +217,7 @@ equalLit (LitPat l') = l == (unembed l') equalLit _ = False -caseCon _ e@(Case _ [alt]) = R $ do+caseCon _ e@(Case _ _ [alt]) = R $ do (pat,altE) <- unbind alt case pat of DefaultPat -> changed altE@@ -232,14 +230,14 @@ ([],[]) -> changed altE _ -> return e -caseCon ctx e@(Case subj alts)+caseCon ctx e@(Case subj ty alts) | isConstant subj = do tcm <- Lens.use tcCache lvl <- Lens.view dbgLevel reduceConstant <- Lens.use evaluator case reduceConstant tcm subj of- Data dc -> caseCon ctx (Case (Data dc) alts)- Literal l -> caseCon ctx (Case (Literal l) alts)+ Data dc -> caseCon ctx (Case (Data dc) ty alts)+ Literal l -> caseCon ctx (Case (Literal l) ty alts) subj' -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (return e) caseCon _ e = return e@@ -402,7 +400,10 @@ (v,e) <- unbind b changed . Letrec $ bind v (App e arg) -appProp _ (App (Case scrut alts) arg) = R $ do+appProp _ (App (Case scrut ty alts) arg) = R $ do+ tcm <- Lens.use tcCache+ argTy <- termType tcm arg+ let ty' = applyFunTy tcm ty argTy if isConstant arg || isVar arg then do alts' <- mapM ( return@@ -410,16 +411,15 @@ . second (`App` arg) <=< unbind ) alts- changed $ Case scrut alts'+ changed $ Case scrut ty' alts' else do- tcm <- Lens.use tcCache (boundArg,argVar) <- mkTmBinderFor tcm "caseApp" arg alts' <- mapM ( return . uncurry bind . second (`App` argVar) <=< unbind ) alts- changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut alts')+ changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut ty' alts') appProp _ (TyApp (TyLam b) t) = R $ do (tv,e) <- unbind b@@ -429,13 +429,15 @@ (v,e) <- unbind b changed . Letrec $ bind v (TyApp e t) -appProp _ (TyApp (Case scrut alts) ty) = R $ do+appProp _ (TyApp (Case scrut altsTy alts) ty) = R $ do alts' <- mapM ( return . uncurry bind . second (`TyApp` ty) <=< unbind ) alts- changed $ Case scrut alts'+ tcm <- Lens.use tcCache+ ty' <- applyTy tcm altsTy ty+ changed $ Case scrut ty' alts' appProp _ e = return e @@ -460,11 +462,7 @@ makeANF ctx e = R $ do- (e',bndrs) <- runR $ runWriterT $- bottomupWhenR (\ctx' tm -> fmap not $- liftNormR $- untranslatableFVs (ctx' ++ ctx) tm- ) collectANF ctx e+ (e',bndrs) <- runR $ runWriterT $ bottomupR collectANF ctx e case bndrs of [] -> return e _ -> changed . Letrec $ bind (rec bndrs) e'@@ -500,22 +498,18 @@ tell [(argId,embed body)] return argVar -collectANF ctx e@(Case subj alts) = do- untranslatableSubj <- liftNormR $ isUntranslatable subj+collectANF ctx (Case subj ty alts) = do localVar <- liftNormR $ isLocalVar subj- (bndr,subj') <- if localVar || untranslatableSubj || isConstant subj+ (bndr,subj') <- if localVar || isConstant subj then return ([],subj) else do tcm <- Lens.use tcCache (argId,argVar) <- liftNormR $ mkTmBinderFor tcm "subjLet" subj return ([(argId,embed subj)],argVar) - untranslatableE <- liftNormR $ isUntranslatable e- (binds,alts') <- if untranslatableE- then return ([],alts)- else fmap (first concat . unzip) $ liftNormR $ mapM (doAlt subj') alts+ (binds,alts') <- fmap (first concat . unzip) $ liftNormR $ mapM (doAlt subj') alts tell (bndr ++ binds)- return (Case subj' alts')+ return (Case subj' ty alts') where doAlt :: Term -> Bind Pat Term -> RewriteMonad NormalizeMonad ([LetBinding],Bind Pat Term) -- See NOTE [unsafeUnbind]@@ -581,7 +575,8 @@ recToLetRec [] e = R $ do fn <- liftR $ Lens.use curFun bodyM <- fmap (HashMap.lookup fn) $ Lens.use bindings- normalizedE <- splitNormalized e+ tcm <- Lens.use tcCache+ normalizedE <- splitNormalized tcm e case (normalizedE,bodyM) of (Right (args,bndrs,res), Just (bodyTy,_)) -> do let appF = mkTmApps (Var bodyTy fn) (map idToVar args)
src/CLaSH/Rewrite/Combinators.hs view
@@ -56,11 +56,11 @@ e' <- trans (LetBinding bndrs:c) (unembed e) return (b',embed e') -allR rf trans c (Case scrut alts) = do+allR rf trans c (Case scrut ty alts) = do scrut' <- trans (CaseScrut:c) scrut alts' <- if rf then mapM (fmap (uncurry bind) . rewriteAlt <=< unbind) alts else mapM (fmap (uncurry bind) . rewriteAlt . unsafeUnbind) alts- return $ Case scrut' alts'+ return $ Case scrut' ty alts' where rewriteAlt :: (Pat, Term) -> m (Pat, Term) rewriteAlt (p,e) = do
src/CLaSH/Rewrite/Util.hs view
@@ -24,7 +24,6 @@ import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HMS import qualified Data.Map as Map-import Data.Maybe (mapMaybe) import qualified Data.Monoid as Monoid import qualified Data.Set as Set import Unbound.LocallyNameless (Collection (..), Fresh, bind,@@ -35,7 +34,7 @@ import Unbound.Util (filterC) import CLaSH.Core.DataCon (dataConInstArgTys)-import CLaSH.Core.FreeVars (termFreeVars, typeFreeVars, termFreeIds)+import CLaSH.Core.FreeVars (termFreeVars, typeFreeVars) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Subst (substTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..),@@ -422,10 +421,11 @@ then cantCreate $(curLoc) "Field index exceed max" else do wildBndrs <- mapM mkWildValBinder fieldTys- selBndr <- mkInternalVar "sel" (indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI)+ let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI+ selBndr <- mkInternalVar "sel" ty let bndrs = take fieldI wildBndrs ++ [fst selBndr] ++ drop (fieldI+1) wildBndrs- let pat = DataPat (embed dc) (rebind [] bndrs)- let retVal = Case scrut [ bind pat (snd selBndr) ]+ pat = DataPat (embed dc) (rebind [] bndrs)+ retVal = Case scrut ty [ bind pat (snd selBndr) ] return retVal _ -> cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc scrutTy) @@ -527,15 +527,3 @@ $ map (\tm -> let ty = HML.lookupDefault (error $ $(curLoc) ++ show tm ++ " not found") tm gamma in (Left $ Id tm (embed ty), Left $ Var ty tm)) specFVs return (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars)--untranslatableFVs :: (Functor m, Monad m)- => [CoreContext]- -> Term- -> RewriteMonad m Bool-untranslatableFVs ctx tm = do- let (gamma,_) = contextEnv ctx- fvs = termFreeIds tm- vars = mapMaybe (\n -> do fvTy <- HML.lookup n gamma- return (Var fvTy n)- ) fvs- or <$> mapM isUntranslatable vars
src/CLaSH/Util.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TupleSections #-}@@ -34,7 +35,9 @@ import Unbound.LocallyNameless (Embed(..)) import Unbound.LocallyNameless.Name (Name(..)) +#ifdef CABAL import qualified Paths_clash_lib (version)+#endif -- | A class that can generate unique numbers class MonadUnique m where@@ -217,4 +220,8 @@ (ys', ys'') = splitAtList xs ys clashLibVersion :: Version+#ifdef CABAL clashLibVersion = Paths_clash_lib.version+#else+clashLibVersion = error "development version"+#endif