diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) 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.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 diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -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 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 @@ -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) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -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 diff --git a/src/CLaSH/Normalize/DEC.hs b/src/CLaSH/Normalize/DEC.hs --- a/src/CLaSH/Normalize/DEC.hs +++ b/src/CLaSH/Normalize/DEC.hs @@ -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 diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs --- a/src/CLaSH/Normalize/Strategy.hs +++ b/src/CLaSH/Normalize/Strategy.hs @@ -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: 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 @@ -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 diff --git a/src/CLaSH/Normalize/Types.hs b/src/CLaSH/Normalize/Types.hs --- a/src/CLaSH/Normalize/Types.hs +++ b/src/CLaSH/Normalize/Types.hs @@ -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 diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs --- a/src/CLaSH/Normalize/Util.hs +++ b/src/CLaSH/Normalize/Util.hs @@ -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