clash-lib 0.5.12 → 0.5.13

raw patch · 7 files changed

+77/−32 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• clash-lib.cabal +1/−1
• src/CLaSH/Core/DataCon.hs +4/−4
• src/CLaSH/Core/Util.hs +42/−9
• src/CLaSH/Driver/TestbenchGen.hs +2/−2
• src/CLaSH/Normalize/Transformations.hs +23/−15
• src/CLaSH/Rewrite/Util.hs +1/−1

@@ -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:

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)))]))

@@ -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