clash-lib 0.6.14 → 0.6.15

raw patch · 10 files changed

+110/−63 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• clash-lib.cabal +1/−1
• src/CLaSH/Driver.hs +12/−11
• src/CLaSH/Driver/TestbenchGen.hs +7/−2
• src/CLaSH/Normalize.hs +5/−2
• src/CLaSH/Normalize/DEC.hs +1/−1
• src/CLaSH/Normalize/Strategy.hs +38/−26
• src/CLaSH/Normalize/Transformations.hs +15/−13
• src/CLaSH/Normalize/Types.hs +2/−0
• src/CLaSH/Normalize/Util.hs +23/−7

@@ -1,5 +1,11 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.15 *April 7th 2016*+* New features:+  * Up to 2x reduced compilation times when working with large `Vec` literals+* Fixes bugs:+  * Bug in DEC transformation throws CLaSH into an endless loop [#140](https://github.com/clash-lang/clash-compiler/issues/140)+ ## 0.6.14 *March 21st 2016* * New features:   * Also generate testbench for circuits without input ports [#135](https://github.com/clash-lang/clash-compiler/issues/135)

@@ -1,5 +1,5 @@ Name:                 clash-lib-Version:              0.6.14+Version:              0.6.15 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that

@@ -15,6 +15,7 @@ import           Control.DeepSeq import           Control.Monad                    (when) import           Control.Monad.State              (evalState, get)+import qualified Data.HashMap.Lazy                as HML import           Data.HashMap.Strict              (HashMap) import qualified Data.HashMap.Strict              as HM import qualified Data.HashSet                     as HashSet@@ -44,6 +45,7 @@ import           CLaSH.Netlist.Types              (Component (..), HWType) import           CLaSH.Normalize                  (checkNonRecursive, cleanupGraph,                                                    normalize, runNormalization)+import           CLaSH.Normalize.Util             (callGraph, mkRecursiveComponents) import           CLaSH.Primitives.Types import           CLaSH.Util                       (first) @@ -60,15 +62,10 @@             -> Maybe TmName -- ^ testInput bndr             -> Maybe TmName -- ^ expectedOutput bndr             -> CLaSHOpts -- ^ Debug information level for the normalization process+            -> (Clock.UTCTime,Clock.UTCTime)             -> IO ()-generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval (topEntity,annM) testInpM expOutM opts = do-  start <- Clock.getCurrentTime-  prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime-  let prepStartDiff = Clock.diffUTCTime prepTime start--      primMap' = (HM.map parsePrimitive :: PrimMap Text.Text -> PrimMap BlackBoxTemplate) primMap--  putStrLn $ "Loading dependencies took " ++ show prepStartDiff+generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval (topEntity,annM) testInpM expOutM opts (startTime,prepTime) = do+  let primMap' = (HM.map parsePrimitive :: PrimMap Text.Text -> PrimMap BlackBoxTemplate) primMap    (supplyN,supplyTB) <- Supply.splitSupply                       . snd@@ -78,7 +75,11 @@   let doNorm     = do norm <- normalize [topEntity]                       let normChecked = checkNonRecursive topEntity norm                       cleanupGraph topEntity normChecked-      transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval primMap' doNorm+      cg         = callGraph [] bindingsMap topEntity+      rcs        = concat $ mkRecursiveComponents cg+      rcsMap     = HML.fromList+                 $ map (\(t,_) -> (t,t `elem` rcs)) cg+      transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval primMap' rcsMap doNorm    normTime <- transformedBindings `deepseq` Clock.getCurrentTime   let prepNormDiff = Clock.diffUTCTime normTime prepTime@@ -129,8 +130,8 @@   mapM_ (writeHDL hdlState' dir) hdlDocs   copyDataFiles dir dfiles' -  end <- hdlDocs `seq` Clock.getCurrentTime-  let startEndDiff = Clock.diffUTCTime end start+  endTime <- hdlDocs `seq` Clock.getCurrentTime+  let startEndDiff = Clock.diffUTCTime endTime startTime   putStrLn $ "Total compilation took " ++ show startEndDiff  parsePrimitive :: Primitive Text -> Primitive BlackBoxTemplate

@@ -37,6 +37,7 @@ import           CLaSH.Netlist.Types              as N import           CLaSH.Normalize                  (cleanupGraph, normalize,                                                    runNormalization)+import           CLaSH.Normalize.Util             (callGraph, mkRecursiveComponents) import           CLaSH.Primitives.Types import           CLaSH.Rewrite.Types @@ -118,8 +119,12 @@     normalizeSignal :: HashMap TmName (Type,Term)                     -> TmName                     -> HashMap TmName (Type,Term)-    normalizeSignal glbls bndr =-      runNormalization opts supply glbls typeTrans tcm tupTcm eval primMap (normalize [bndr] >>= cleanupGraph bndr)+    normalizeSignal glbls bndr = do+      let cg  = callGraph [] glbls bndr+          rcs = concat $ mkRecursiveComponents cg+          rcsMap = HashMap.fromList+                 $ map (\(t,_) -> (t,t `elem` rcs)) cg+      runNormalization opts supply glbls typeTrans tcm tupTcm eval primMap rcsMap (normalize [bndr] >>= cleanupGraph bndr)  genTestBench opts _ _ _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles) 

@@ -68,10 +68,12 @@                  -- ^ Hardcoded evaluator (delta-reduction)                  -> PrimMap BlackBoxTemplate                  -- ^ Primitive Definitions+                 -> HashMap TmName Bool+                 -- ^ Map telling whether a components is part of a recursive group                  -> NormalizeSession a                  -- ^ NormalizeSession to run                  -> a-runNormalization opts supply globals typeTrans tcm tupTcm eval primMap+runNormalization opts supply globals typeTrans tcm tupTcm eval primMap rcsMap   = runRewriteSession rwEnv rwState   where     rwEnv     = RewriteEnv@@ -98,6 +100,7 @@                   (opt_inlineLimit opts)                   (opt_inlineBelow opts)                   primMap+                  rcsMap   normalize :: [TmName]@@ -172,7 +175,7 @@                   -> HashMap TmName (Type,Term) checkNonRecursive topEntity norm =   let cg = callGraph [] norm topEntity-  in  case recursiveComponents cg of+  in  case mkRecursiveComponents cg of        []  -> norm        rcs -> error $ $(curLoc) ++ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs 

@@ -139,7 +139,7 @@         Just fun' | fun' `notElem` seen -> do           (args',collected) <- collectGlobalsArgs inScope substitution                                                   (fun':seen) args-          let e' = Maybe.fromMaybe e (List.lookup fun' substitution)+          let e' = Maybe.fromMaybe (mkApps fun' args') (List.lookup fun' substitution)           return (e',(fun',Leaf args'):collected)         _ -> do (args',collected) <- collectGlobalsArgs inScope substitution                                                         seen args

@@ -19,7 +19,7 @@ normalization = constantPropgation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >->                 bindConst >-> letTL >-> evalConst >-!-> cse >-!-> recLetRec   where-    etaTL      = apply "etaTL" etaExpansionTL !-> repeatR (innerMost (apply "applicationPropagation" appProp))+    etaTL      = apply "etaTL" etaExpansionTL !-> innerMost (apply "applicationPropagation" appProp)     anf        = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF     letTL      = topdownSucR (apply "topLet" topLet)     recLetRec  = apply "recToLetRec" recToLetRec@@ -35,34 +35,46 @@                      caseFlattening >-> dec >-> lifting >-> spec >-> dec >->                      conSpec   where-    propagate = innerMost (applyMany transInner)-    inlineAndPropagate = bottomupR (applyMany transBUP) !-> propagate-    lifting   = bottomupR (apply "liftNonRep" liftNonRep) -- See: [Note] bottom-up traversal for liftNonRep-    spec      = bottomupR (applyMany specRws)-    caseFlattening = repeatR (topdownR (apply "caseFlat" caseFlat))-    dec = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation))-    conSpec = bottomupR (apply "constantSpec" constantSpec)+    propagate          = innerMost (applyMany transPropagate)+    inlineAndPropagate = (topdownR (applyMany transInlineSafe) >-> inlineNR)+                         !-> propagate+    lifting            = bottomupR (apply "liftNonRep" liftNonRep) -- See: [Note] bottom-up traversal for liftNonRep+    spec               = bottomupR (applyMany specTransformations)+    caseFlattening     = repeatR (topdownR (apply "caseFlat" caseFlat))+    dec                = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation))+    conSpec            = bottomupR (apply "constantSpec" constantSpec) -    transInner :: [(String,NormRewrite)]-    transInner = [ ("applicationPropagation", appProp        )-                 , ("bindConstantVar"       , bindConstantVar)-                 , ("caseLet"               , caseLet        )-                 , ("caseCase"              , caseCase       )-                 , ("caseCon"               , caseCon        )-                 ]+    transPropagate :: [(String,NormRewrite)]+    transPropagate =+      [ ("applicationPropagation", appProp        )+      , ("bindConstantVar"       , bindConstantVar)+      , ("caseLet"               , caseLet        )+      , ("caseCase"              , caseCase       )+      , ("caseCon"               , caseCon        )+      ] -    transBUP :: [(String,NormRewrite)]-    transBUP = [ ("inlineClosed"    , inlineClosed)-               , ("inlineSmall"     , inlineSmall)-               , ("inlineNonRep"    , inlineNonRep)-               , ("bindNonRep"      , bindNonRep) -- See: [Note] bindNonRep before liftNonRep-               , ("reduceNonRepPrim", reduceNonRepPrim)-               ]+    -- These transformations can safely be applied in a top-down traversal as+    -- they themselves check whether the to-be-inlined binder is recursive or not.+    transInlineSafe :: [(String,NormRewrite)]+    transInlineSafe =+       [ ("inlineClosed"    , inlineClosed)+       , ("inlineSmall"     , inlineSmall)+       , ("bindNonRep"      , bindNonRep) -- See: [Note] bindNonRep before liftNonRep+       , ("reduceNonRepPrim", reduceNonRepPrim)+       ] -    specRws :: [(String,NormRewrite)]-    specRws = [ ("typeSpec"    , typeSpec)-              , ("nonRepSpec"  , nonRepSpec)-              ]+    -- InlineNonRep cannot be applied in a top-down traversal, as the non-representable+    -- binder might be recursive. The idea is, is that if the recursive+    -- non-representable binder is inlined once, we can get rid of the recursive+    -- aspect using the case-of-known-constructor+    inlineNR :: NormRewrite+    inlineNR = bottomupR (apply "inlineNonRep" inlineNonRep)++    specTransformations :: [(String,NormRewrite)]+    specTransformations =+      [ ("typeSpec"    , typeSpec)+      , ("nonRepSpec"  , nonRepSpec)+      ]  {- [Note] bottom-up traversal for liftNonRep We used to say:

@@ -426,10 +426,11 @@         bndrs <- Lens.use bindings         case HashMap.lookup f bndrs of           -- Don't inline recursive expressions-          Just (_,body) -> let cg = callGraph [] bndrs f-                           in if null (recursiveComponents cg)-                              then changed (mkApps body args)-                              else return e+          Just (_,body) -> do+            isRecBndr <- isRecursiveBndr f+            if isRecBndr+               then return e+               else changed (mkApps body args)           _ -> return e  inlineClosed _ e@(Var fTy f) = do@@ -442,10 +443,11 @@       bndrs <- Lens.use bindings       case HashMap.lookup f bndrs of         -- Don't inline recursive expressions-        Just (_,body) -> let cg = callGraph [] bndrs f-                         in if null (recursiveComponents cg)-                            then changed body-                            else return e+        Just (_,body) -> do+          isRecBndr <- isRecursiveBndr f+          if isRecBndr+             then return e+             else changed body         _ -> return e     else return e @@ -462,11 +464,11 @@       sizeLimit <- Lens.use (extra.inlineBelow)       case HashMap.lookup f bndrs of         -- Don't inline recursive expressions-        Just (_,body) -> let cg = callGraph [] bndrs f-                         in if null (recursiveComponents cg) &&-                               termSize body < sizeLimit-                            then changed (mkApps body args)-                            else return e+        Just (_,body) -> do+          isRecBndr <- isRecursiveBndr f+          if not isRecBndr && termSize body < sizeLimit+             then changed (mkApps body args)+             else return e         _ -> return e  inlineSmall _ e = return e

@@ -48,6 +48,8 @@   -- ^ Size of a function below which it is always inlined if it is not   -- recursive   , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions+  , _recursiveComponents :: HashMap TmName Bool+  -- ^ Map telling whether a components is part of a recursive group   }  makeLenses ''NormalizeState

@@ -31,6 +31,7 @@ import           CLaSH.Core.TyCon        (TyCon, TyConName) import           CLaSH.Core.Util         (collectArgs, isPolyFun) import           CLaSH.Normalize.Types+import           CLaSH.Rewrite.Types     (bindings,extra) import           CLaSH.Rewrite.Util      (specialise) import           CLaSH.Util              (curLoc) @@ -72,6 +73,21 @@   (Literal _,_)    -> True   _                -> False +isRecursiveBndr :: TmName -> NormalizeSession Bool+isRecursiveBndr f = do+  cg <- Lens.use (extra.recursiveComponents)+  case HashMap.lookup f cg of+    Just isR -> return isR+    Nothing -> do+      bndrs <- Lens.use bindings+      let cg'  = callGraph [] bndrs f+          rcs  = concat $ mkRecursiveComponents cg'+          isR  = f `elem` rcs+          cg'' = HashMap.fromList+               $ map (\(t,_) -> (t,t `elem` rcs)) cg'+      (extra.recursiveComponents) %= HashMap.union cg''+      return isR+ -- | Create a call graph for a set of global binders, given a root callGraph :: [TmName] -- ^ List of functions that should not be inspected           -> HashMap TmName (Type,Term) -- ^ Global binders@@ -85,13 +101,13 @@     other  = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used)  -- | Determine the sets of recursive components given the edges of a callgraph-recursiveComponents :: [(TmName,[TmName])] -- ^ [(calling function,[called function])]+mkRecursiveComponents :: [(TmName,[TmName])] -- ^ [(calling function,[called function])]                     -> [[TmName]]-recursiveComponents cg = map (List.sortBy (compare `on` (`List.elemIndex` fs)))-                       . Maybe.catMaybes-                       . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing})-                       . Graph.stronglyConnComp-                       $ map (\(n,es) -> (n,n,es)) cg+mkRecursiveComponents cg = map (List.sortBy (compare `on` (`List.elemIndex` fs)))+                         . Maybe.catMaybes+                         . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing})+                         . Graph.stronglyConnComp+                         $ map (\(n,es) -> (n,n,es)) cg   where     fs = map fst cg @@ -102,7 +118,7 @@   where     depGraph = callGraph [] bndrs topEntity     used     = HashMap.fromList depGraph-    rcs      = recursiveComponents depGraph+    rcs      = mkRecursiveComponents depGraph     dropped  = map (lambdaDrop bndrs used) rcs     bndrs'   = foldr (\(k,v) b -> HashMap.insert k v b) bndrs dropped