diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.5.13 *September 21st 2015* +* Fixes bugs: + * Performance bug: top-level definitions of type "Signal" erroneously inlined. + ## 0.5.12 *September 14th 2015* * New features: * Completely unroll "definitions" of some higher-order primitives with non-representable argument or result vectors: 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.5.12 +Version: 0.5.13 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that diff --git a/src/CLaSH/Core/DataCon.hs b/src/CLaSH/Core/DataCon.hs --- a/src/CLaSH/Core/DataCon.hs +++ b/src/CLaSH/Core/DataCon.hs @@ -78,18 +78,18 @@ -- type are substituted for the list of types. The argument types are returned. -- -- The list of types should be equal to the number of type variables, otherwise --- an error is reported. -dataConInstArgTys :: DataCon -> [Type] -> [Type] +-- @Nothing@ is returned. +dataConInstArgTys :: DataCon -> [Type] -> Maybe [Type] dataConInstArgTys (MkData { dcArgTys = arg_tys , dcUnivTyVars = univ_tvs , dcExtTyVars = ex_tvs }) inst_tys | length tyvars == length inst_tys - = map (substs (zip tyvars inst_tys)) arg_tys + = Just (map (substs (zip tyvars inst_tys)) arg_tys) | otherwise - = error $ $(curLoc) ++ "dataConInstArgTys: number of tyVars and Types differ" + = Nothing where tyvars = univ_tvs ++ ex_tvs diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -1,13 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} -- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where +import qualified Data.HashMap.Lazy as HashMap import Data.HashMap.Lazy (HashMap) +import qualified Data.HashSet as HashSet +import Data.Maybe (fromJust, mapMaybe) import Unbound.Generics.LocallyNameless (Fresh, bind, embed, rebind, string2Name, unbind, unembed, unrebind, unrec) +import Unbound.Generics.LocallyNameless.Name (name2String) import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) import CLaSH.Core.DataCon (DataCon, dcType, dataConInstArgTys) @@ -16,10 +21,10 @@ import CLaSH.Core.Term (LetBinding, Pat (..), Term (..), TmName) import CLaSH.Core.Type (Kind, LitTy (..), TyName, - Type (..), applyTy, + Type (..), TypeView (..), applyTy, isFunTy, isPolyFunCoreTy, mkFunTy, - splitFunTy) -import CLaSH.Core.TyCon (TyCon, TyConName) + splitFunTy, tyView) +import CLaSH.Core.TyCon (TyCon, TyConName, tyConDataCons) import CLaSH.Core.TysPrim (typeNatKind) import CLaSH.Core.Var (Id, TyVar, Var (..), varType) import CLaSH.Util @@ -246,10 +251,12 @@ ,Left x ,Left (go (n-1) xs)] - nilCoTy = head (dataConInstArgTys nilCon [(LitTy (NumTy 0)),resTy]) - consCoTy n = head (dataConInstArgTys consCon [(LitTy (NumTy n)) - ,resTy - ,(LitTy (NumTy (n-1)))]) + nilCoTy = head (fromJust $! dataConInstArgTys nilCon [(LitTy (NumTy 0)) + ,resTy]) + consCoTy n = head (fromJust $! dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))]) -- | Create let-bindings with case-statements that select elements out of a -- vector. Returns both the variables to which element-selections are bound @@ -284,7 +291,33 @@ mName = string2Name "m" mTV = TyVar mName (embed typeNatKind) tys = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))] - idTys = dataConInstArgTys consCon tys + (Just idTys) = dataConInstArgTys consCon tys [co,el,rest] = zipWith Id [string2Name "_co_",elPatNm, restPatNm] (map embed idTys) - restTy = last $ dataConInstArgTys consCon tys + restTy = last (fromJust (dataConInstArgTys consCon tys)) + +-- | Determine whether a type is isomorphic to "CLaSH.Signal.Internal.Signal'" +-- +-- It is i.e.: +-- +-- * Signal' clk a +-- * (Signal' clk a, Signal' clk b) +-- * Vec n (Signal' clk a) +-- * data Wrap = W (Signal clk' Int) +-- * etc. +isSignalType :: HashMap TyConName TyCon -> Type -> Bool +isSignalType tcm ty = go HashSet.empty ty + where + go tcSeen (tyView -> TyConApp tcNm args) = case name2String tcNm of + "CLaSH.Signal.Internal.Signal'" -> True + _ | tcNm `HashSet.member` tcSeen -> False -- Do not follow rec types + | otherwise -> case HashMap.lookup tcNm tcm of + Just tc -> let dcs = tyConDataCons tc + dcInsArgTys = concat + $ mapMaybe (`dataConInstArgTys` args) dcs + tcSeen' = HashSet.insert tcNm tcSeen + in any (go tcSeen') dcInsArgTys + Nothing -> traceIf True ($(curLoc) ++ "isSignalType: " ++ show tcNm + ++ " not found.") False + + go _ _ = False 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 @@ -113,7 +113,7 @@ falling = rising + rest ctx = emptyBBContext { bbResult = (Left (Identifier clkName Nothing), Clock clkSym rate) - , bbInputs = [ (Left (N.Literal Nothing (NumLit 2)),Integer,True) + , bbInputs = [ (Left (N.Literal Nothing (NumLit 3)),Integer,True) , (Left (N.Literal Nothing (NumLit rising)),Integer,True) , (Left (N.Literal Nothing (NumLit falling)),Integer,True) ] @@ -136,7 +136,7 @@ Just (BlackBox _ (Left templ)) -> do let ctx = emptyBBContext { bbResult = (Left (Identifier rstName Nothing), Reset clkSym rate) - , bbInputs = [(Left (N.Literal Nothing (NumLit 1)),Integer,True)] + , bbInputs = [(Left (N.Literal Nothing (NumLit 2)),Integer,True)] } templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.resetGen" templ ctx let resetGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" templ' ctx 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 @@ -52,14 +52,16 @@ import CLaSH.Core.Term (LetBinding, Pat (..), Term (..)) import CLaSH.Core.Type (TypeView (..), Type (..), LitTy (..), applyFunTy, - applyTy, splitFunTy, typeKind, + applyTy, isPolyFunCoreTy, + splitFunTy, typeKind, tyView, mkTyConApp, mkFunTy) import CLaSH.Core.TyCon (TyConName, tyConDataCons) import CLaSH.Core.Util (collectArgs, extractElems, idToVar, isCon, isFun, isLet, isPolyFun, isPrim, - isVar, mkApps, mkLams, mkTmApps, - mkVec, termSize,termType) + isSignalType, isVar, mkApps, + mkLams, mkTmApps, mkVec, + termSize, termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.Util (representableType, splitNormalized) @@ -343,8 +345,11 @@ inlineClosed _ e@(collectArgs -> (Var _ f,args)) | all (either isConstant (const True)) args = do - untranslatable <- isUntranslatable e - if untranslatable + tcm <- Lens.view tcCache + eTy <- termType tcm e + untranslatable <- isUntranslatableType eTy + let isSignal = isSignalType tcm eTy + if untranslatable || isSignal then return e else do bndrs <- Lens.use bindings @@ -356,11 +361,12 @@ else return e _ -> return e -inlineClosed _ e@(Var _ f) = do +inlineClosed _ e@(Var fTy f) = do tcm <- Lens.view tcCache - closed <- isClosed tcm e - untranslatable <- isUntranslatable e - if closed && not untranslatable + let closed = not (isPolyFunCoreTy tcm fTy) + isSignal = isSignalType tcm fTy + untranslatable <- isUntranslatableType fTy + if closed && not untranslatable && not isSignal then do bndrs <- Lens.use bindings case HashMap.lookup f bndrs of @@ -826,7 +832,7 @@ (TyConApp apDictTcNm _) <- tyView <$> termType tcm dict let (Just apDictTc) = HashMap.lookup apDictTcNm tcm [apDictCon] = tyConDataCons apDictTc - apDictIdTys = dataConInstArgTys apDictCon [fTy] + (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy] apDictIds = zipWith Id (map string2Name ["functorDict" ,"pure" ,"ap" @@ -837,7 +843,7 @@ (TyConApp funcDictTcNm _) = tyView (head apDictIdTys) (Just funcDictTc) = HashMap.lookup funcDictTcNm tcm [funcDictCon] = tyConDataCons funcDictTc - funcDictIdTys = dataConInstArgTys funcDictCon [fTy] + (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy] funcDicIds = zipWith Id (map string2Name ["fmap","fmapConst"]) (map embed funcDictIdTys) @@ -920,8 +926,10 @@ ,Left x]) ,Left (go (n-1) xs)] - nilCoTy = head (dataConInstArgTys nilCon [(LitTy (NumTy 0)),bTy]) + nilCoTy = head (Maybe.fromJust (dataConInstArgTys nilCon [(LitTy (NumTy 0)) + ,bTy])) - consCoTy n = head (dataConInstArgTys consCon [(LitTy (NumTy n)) - ,bTy - ,(LitTy (NumTy (n-1)))]) + consCoTy n = head (Maybe.fromJust (dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,bTy + ,(LitTy (NumTy (n-1)))])) 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 @@ -455,7 +455,7 @@ dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" | otherwise -> do let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1) - let fieldTys = dataConInstArgTys dc args + let (Just fieldTys) = dataConInstArgTys dc args if fieldI >= length fieldTys then cantCreate $(curLoc) "Field index exceed max" else do