diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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) + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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.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, 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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) 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 @@ -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) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -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) 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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" 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 @@ -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) diff --git a/src/CLaSH/Netlist/VHDL.hs b/src/CLaSH/Netlist/VHDL.hs --- a/src/CLaSH/Netlist/VHDL.hs +++ b/src/CLaSH/Netlist/VHDL.hs @@ -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 diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -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) 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 @@ -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) 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 @@ -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 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 @@ -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 diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -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