clash-lib 0.6.15 → 0.6.16
raw patch · 7 files changed
+177/−84 lines, 7 filesdep ~aesondep ~attoparsecdep ~bytestring
Dependency ranges changed: aeson, attoparsec, bytestring, clash-prelude, concurrent-supply, containers, deepseq, directory, errors, fgl, filepath, hashable, lens, mtl, pretty, process, template-haskell, text, time, transformers, unordered-containers, uu-parsinglib, wl-pprint-text
Files
- CHANGELOG.md +7/−0
- clash-lib.cabal +26/−26
- src/CLaSH/Normalize/DEC.hs +21/−6
- src/CLaSH/Normalize/PrimitiveReductions.hs +39/−2
- src/CLaSH/Normalize/Strategy.hs +3/−3
- src/CLaSH/Normalize/Transformations.hs +54/−32
- src/CLaSH/Rewrite/Util.hs +27/−15
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.16 *June 7th 2016*+* New features:+ * DEC transformation also lifts HO-primitives applied to "interesting" primitives (i.e. `zipWith (*)`)+* Fixes bugs:+ * replicate unfolded incorrectly [#150](https://github.com/clash-lang/clash-compiler/issues/150)+ * `imap` is not unrolled [#151](https://github.com/clash-lang/clash-compiler/issues/151)+ ## 0.6.15 *April 7th 2016* * New features: * Up to 2x reduced compilation times when working with large `Vec` literals
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.6.15+Version: 0.6.16 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -87,31 +87,31 @@ TupleSections ViewPatterns - Build-depends: aeson >= 0.6.2.0,- attoparsec >= 0.10.4.0,- base >= 4.8 && < 5,- bytestring >= 0.10.0.2,- clash-prelude >= 0.10.4,- concurrent-supply >= 0.1.7,- containers >= 0.5.0.0,- deepseq >= 1.3.0.2,- directory >= 1.2.0.1,- errors >= 1.4.2,- fgl >= 5.4.2.4,- filepath >= 1.3.0.1,- hashable >= 1.2.1.0,- lens >= 3.9.2,- mtl >= 2.1.2,- pretty >= 1.1.1.0,- process >= 1.1.0.2,- template-haskell >= 2.8.0.0,- text >= 0.11.3.1,- time >= 1.4.0.1,- transformers >= 0.3.0.0,- unbound-generics >= 0.1 && < 0.4,- unordered-containers >= 0.2.3.3,- uu-parsinglib >= 2.8.1,- wl-pprint-text >= 1.1.0.0+ Build-depends: aeson >= 0.6.2.0 && < 0.12,+ attoparsec >= 0.10.4.0 && < 0.14,+ base >= 4.8 && < 5,+ bytestring >= 0.10.0.2 && < 0.11,+ clash-prelude >= 0.10.4 && < 0.11,+ concurrent-supply >= 0.1.7 && < 0.2,+ containers >= 0.5.0.0 && < 0.6,+ deepseq >= 1.3.0.2 && < 1.5,+ directory >= 1.2.0.1 && < 1.3,+ errors >= 1.4.2 && < 2.2,+ fgl >= 5.4.2.4 && < 5.6,+ filepath >= 1.3.0.1 && < 1.5,+ hashable >= 1.2.1.0 && < 1.3,+ lens >= 3.9.2 && < 4.15,+ mtl >= 2.1.2 && < 2.3,+ pretty >= 1.1.1.0 && < 1.2,+ process >= 1.1.0.2 && < 1.3,+ template-haskell >= 2.8.0.0 && < 2.11,+ text >= 0.11.3.1 && < 1.3,+ time >= 1.4.0.1 && < 1.6,+ transformers >= 0.3.0.0 && < 0.5,+ unbound-generics >= 0.1 && < 0.4,+ unordered-containers >= 0.2.3.3 && < 0.3,+ uu-parsinglib >= 2.8.1 && < 2.10,+ wl-pprint-text >= 1.1.0.0 && < 1.2 Exposed-modules: CLaSH.Backend
src/CLaSH/Normalize/DEC.hs view
@@ -65,7 +65,7 @@ import CLaSH.Core.Literal (Literal (..)) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..), TmName) import CLaSH.Core.TyCon (tyConDataCons)-import CLaSH.Core.Type (Type, mkTyConApp, splitFunForallTy)+import CLaSH.Core.Type (Type, isPolyFunTy, mkTyConApp, splitFunForallTy) import CLaSH.Core.Util (collectArgs, mkApps, termType) import CLaSH.Normalize.Types (NormalizeState) import CLaSH.Normalize.Util (isConstant)@@ -386,10 +386,18 @@ if nm `Set.member` inScope then Just e else Nothing-interestingToLift _ eval e@(Prim nm _) args =+interestingToLift inScope eval e@(Prim nm pty) args = case List.lookup nm interestingPrims of Just t | t || not (all isConstant lArgs) -> Just e- _ -> Nothing+ _ -> if isHOTy pty+ then if not . null . Maybe.catMaybes $+ map (uncurry (interestingToLift inScope eval) .+ collectArgs+ ) lArgs+ then Just e+ else Nothing+ else Nothing+ where interestingPrims = [("CLaSH.Sized.Internal.BitVector.*#",tailNonPow2)@@ -425,11 +433,15 @@ ,("GHC.Prim.remInt#",lastNotPow2) ] - lArgs = Either.lefts args+ lArgs = Either.lefts args allNonPow2 = all (not . termIsPow2) lArgs- tailNonPow2 = all (not . termIsPow2) (tail lArgs)- lastNotPow2 = not (termIsPow2 (last lArgs))+ tailNonPow2 = case lArgs of+ [] -> True+ _ -> all (not . termIsPow2) (tail lArgs)+ lastNotPow2 = case lArgs of+ [] -> True+ _ -> not (termIsPow2 (last lArgs)) termIsPow2 e' = case eval e' of Literal (IntegerLiteral n) -> isPow2 n@@ -445,5 +457,8 @@ ,"CLaSH.Sized.Internal.Signed.fromInteger#" ,"CLaSH.Sized.Internal.Unsigned.fromInteger#" ]++ isHOTy t = case splitFunForallTy t of+ (args',_) -> any isPolyFunTy (Either.rights args') interestingToLift _ _ _ _ = Nothing
src/CLaSH/Normalize/PrimitiveReductions.hs view
@@ -18,6 +18,7 @@ * CLaSH.Sized.Vector.tail * CLaSH.Sized.Vector.unconcatBitVector# * CLaSH.Sized.Vector.replicate+ * CLaSH.Sized.Vector.imap Partially handles: @@ -44,9 +45,9 @@ import CLaSH.Core.Type (LitTy (..), Type (..), TypeView (..), coreView, mkFunTy, mkTyConApp,- splitFunForallTy)+ splitFunForallTy, tyView) import CLaSH.Core.TyCon (TyConName, tyConDataCons)-import CLaSH.Core.TysPrim (typeNatKind)+import CLaSH.Core.TysPrim (integerPrimTy, typeNatKind) import CLaSH.Core.Util (appendToVec, extractElems, idToVar, mkApps, mkVec, termType)@@ -99,6 +100,42 @@ (vars,elems) = second concat . unzip $ extractElems consCon argElTy 'A' n arg funApps = map (fun `App`) vars+ lbody = mkVec nilCon consCon resElTy n funApps+ lb = Letrec (bind (rec (init elems)) lbody)+ changed lb++-- | Replace an application of the @CLaSH.Sized.Vector.imap@ primitive on vectors+-- of a known length @n@, by the fully unrolled recursive "definition" of+-- @CLaSH.Sized.Vector.imap@+reduceImap :: Int -- ^ Length of the vector+ -> Type -- ^ Argument type of the function+ -> Type -- ^ Result type of the function+ -> Term -- ^ The imap'd function+ -> Term -- ^ The imap'd over vector+ -> NormalizeSession Term+reduceImap n argElTy resElTy fun arg = do+ tcm <- Lens.view tcCache+ (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg+ let (Just vecTc) = HashMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ (vars,elems) = second concat . unzip+ $ extractElems consCon argElTy 'I' n arg+ (Right idxTy:_,_) <- splitFunForallTy <$> termType tcm fun+ let (TyConApp idxTcNm _) = tyView idxTy+ nTv = string2Name "n"+ -- fromInteger# :: KnownNat n => Integer -> Index n+ idxFromIntegerTy = ForAllTy (bind (TyVar nTv (embed typeNatKind))+ (foldr mkFunTy+ (mkTyConApp idxTcNm+ [VarTy typeNatKind nTv])+ [integerPrimTy,integerPrimTy]))+ idxFromInteger = Prim "CLaSH.Sized.Internal.Index.fromInteger#"+ idxFromIntegerTy+ idxs = map (App (App (TyApp idxFromInteger (LitTy (NumTy n)))+ (Literal (IntegerLiteral (toInteger n))))+ . Literal . IntegerLiteral . toInteger) [0..(n-1)]++ funApps = zipWith (\i v -> App (App fun i) v) idxs vars lbody = mkVec nilCon consCon resElTy n funApps lb = Letrec (bind (rec (init elems)) lbody) changed lb
src/CLaSH/Normalize/Strategy.hs view
@@ -32,13 +32,12 @@ constantPropgation :: NormRewrite constantPropgation = propagate >-> repeatR inlineAndPropagate >->- caseFlattening >-> dec >-> lifting >-> spec >-> dec >->+ caseFlattening >-> dec >-> spec >-> dec >-> conSpec where 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))@@ -59,7 +58,8 @@ transInlineSafe = [ ("inlineClosed" , inlineClosed) , ("inlineSmall" , inlineSmall)- , ("bindNonRep" , bindNonRep) -- See: [Note] bindNonRep before liftNonRep+ , ("bindOrLiftNonRep", inlineOrLiftNonRep) -- See: [Note] bindNonRep before liftNonRep+ -- See: [Note] bottom-up traversal for liftNonRep , ("reduceNonRepPrim", reduceNonRepPrim) ]
src/CLaSH/Normalize/Transformations.hs view
@@ -12,12 +12,11 @@ module CLaSH.Normalize.Transformations ( appProp- , bindNonRep- , liftNonRep , caseLet , caseCon , caseCase , inlineNonRep+ , inlineOrLiftNonRep , typeSpec , nonRepSpec , etaExpansionTL@@ -88,34 +87,23 @@ import CLaSH.Rewrite.Util import CLaSH.Util --- | Inline non-recursive, non-representable, non-join-point, let-bindings-bindNonRep :: NormRewrite-bindNonRep = inlineBinders nonRepTest- where- nonRepTest :: Term -> (Var Term, Embed Term) -> RewriteMonad extra Bool- nonRepTest e (id_@(Id idName tyE), exprE)- = (&&) <$> (not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure (unembed tyE)))- <*> ((&&) <$> (notElem idName <$> (Lens.toListOf <$> localFreeIds <*> pure (unembed exprE)))- <*> (pure (not $ isJoinPointIn id_ e)))-- nonRepTest _ _ = return False---- | Lift non-representable let-bindings-liftNonRep :: NormRewrite-liftNonRep = liftBinders nonRepTest+inlineOrLiftNonRep :: NormRewrite+inlineOrLiftNonRep = inlineOrLiftBinders nonRepTest inlineTest where- nonRepTest :: Term -> (Var Term, Embed Term) -> RewriteMonad extra Bool- nonRepTest _ ((Id _ tyE), _)- -- We used to also check whether the binder we are lifting is either- -- recursive or a join-point. This is no longer needed because we apply- -- bindNonRep exhaustively before we apply liftNonRep. See also:- -- [Note] bindNonRep before liftNonRep+ nonRepTest :: (Var Term, Embed Term) -> RewriteMonad extra Bool+ nonRepTest ((Id _ tyE), _) = not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure (unembed tyE))+ nonRepTest _ = return False - nonRepTest _ _ = return False+ inlineTest :: Term -> (Var Term, Embed Term) -> RewriteMonad extra Bool+ inlineTest e (id_@(Id idName _), exprE)+ = not <$> ((||) <$> (elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure (unembed exprE)))+ <*> pure (isJoinPointIn id_ e)) + inlineTest _ _ = return True+ -- | Specialize functions on their type typeSpec :: NormRewrite typeSpec ctx e@(TyApp e1 ty)@@ -402,6 +390,24 @@ else return e _ -> return e +-- Replace any expression that creates a Vector of size 0 within the application+-- of the Cons constructor, by the Nil constructor.+removeUnusedExpr _ e@(collectArgs -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil]))+ | name2String (dcName dc) == "CLaSH.Sized.Vector.Cons"+ = do+ tcm <- Lens.view tcCache+ case runExcept (tyNatSize tcm nTy) of+ Right 0+ | (con, _) <- collectArgs nil+ , not (isCon con)+ -> do eTy <- termType tcm e+ let (TyConApp vecTcNm _) = tyView eTy+ (Just vecTc) = HashMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ v = mkVec nilCon consCon aTy 1 [a]+ changed v+ _ -> return e+ removeUnusedExpr _ e = return e -- | Inline let-bindings when the RHS is either a local variable reference or@@ -953,7 +959,7 @@ let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args case runExcept (tyNatSize tcm nTy) of Right n -> do- untranslatableTys <- mapM isUntranslatableType [lhsElTy,rhsElty,resElTy]+ untranslatableTys <- mapM isUntranslatableType_not_poly [lhsElTy,rhsElty,resElTy] if or untranslatableTys then let [fun,lhsArg,rhsArg] = Either.lefts args in reduceZipWith n lhsElTy rhsElty resElTy fun lhsArg rhsArg@@ -963,7 +969,7 @@ let [argElTy,resElTy,nTy] = Either.rights args case runExcept (tyNatSize tcm nTy) of Right n -> do- untranslatableTys <- mapM isUntranslatableType [argElTy,resElTy]+ untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy] if or untranslatableTys then let [fun,arg] = Either.lefts args in reduceMap n argElTy resElTy fun arg@@ -979,7 +985,7 @@ "CLaSH.Sized.Vector.fold" | length args == 4 -> do let [aTy,nTy] = Either.rights args isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x- untranslatableTy <- isUntranslatableType aTy+ untranslatableTy <- isUntranslatableType_not_poly aTy case runExcept (tyNatSize tcm nTy) of Right n | not (isPow2 (n + 1)) || untranslatableTy -> let [fun,arg] = Either.lefts args@@ -989,7 +995,7 @@ let [aTy,bTy,nTy] = Either.rights args in case runExcept (tyNatSize tcm nTy) of Right n -> do- untranslatableTys <- mapM isUntranslatableType [aTy,bTy]+ untranslatableTys <- mapM isUntranslatableType_not_poly [aTy,bTy] if or untranslatableTys then let [fun,start,arg] = Either.lefts args in reduceFoldr n aTy bTy fun start arg@@ -1008,7 +1014,7 @@ | n == 0 -> changed rArg | m == 0 -> changed lArg | otherwise -> do- untranslatableTy <- isUntranslatableType aTy+ untranslatableTy <- isUntranslatableType_not_poly aTy if untranslatableTy then reduceAppend n m aTy lArg rArg else return e@@ -1018,7 +1024,7 @@ [vArg] = Either.lefts args case runExcept (tyNatSize tcm nTy) of Right n -> do- untranslatableTy <- isUntranslatableType aTy+ untranslatableTy <- isUntranslatableType_not_poly aTy if untranslatableTy then reduceHead n aTy vArg else return e@@ -1028,7 +1034,7 @@ [vArg] = Either.lefts args case runExcept (tyNatSize tcm nTy) of Right n -> do- untranslatableTy <- isUntranslatableType aTy+ untranslatableTy <- isUntranslatableType_not_poly aTy if untranslatableTy then reduceTail n aTy vArg else return e@@ -1047,13 +1053,29 @@ let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args case runExcept (tyNatSize tcm nTy) of Right n -> do- untranslatableTy <- isUntranslatableType aTy+ untranslatableTy <- isUntranslatableType_not_poly aTy if untranslatableTy then reduceReplicate n aTy eTy vArg else return e _ -> return e+ "CLaSH.Sized.Vector.imap" | length args == 6 -> do+ let [nTy,argElTy,resElTy] = Either.rights args+ case runExcept (tyNatSize tcm nTy) of+ Right n -> do+ untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy]+ if or untranslatableTys+ then let [_,fun,arg] = Either.lefts args+ in reduceImap n argElTy resElTy fun arg+ else return e+ _ -> return e _ -> return e+ where+ isUntranslatableType_not_poly t = do+ u <- isUntranslatableType t+ if u+ then return (null $ Lens.toListOf typeFreeVars t)+ else return False reduceNonRepPrim _ e = return e
src/CLaSH/Rewrite/Util.hs view
@@ -328,26 +328,38 @@ globalBndrs <- Lens.use bindings return ((termFreeIds . Lens.filtered (not . (`HML.member` globalBndrs)))) --- | Lift the binders in a let-binding to a global function that have a certain--- property-liftBinders :: (Term -> LetBinding -> RewriteMonad extra Bool) -- ^ Property test- -> Rewrite extra-liftBinders condition ctx expr@(Letrec b) = do- (xes,res) <- unbind b- let expr' = Letrec (bind xes res)- (replace,others) <- partitionM (condition expr') (unrec xes)+inlineOrLiftBinders :: (LetBinding -> RewriteMonad extra Bool) -- ^ Property test+ -> (Term -> LetBinding -> RewriteMonad extra Bool)+ -- ^ Test whether to lift or inline+ --+ -- * True: inline+ -- * False: lift+ -> Rewrite extra+inlineOrLiftBinders condition inlineOrLift ctx expr@(Letrec b) = do+ (xesR,res) <- unbind b+ let xes = unrec xesR+ (replace,others) <- partitionM condition xes case replace of [] -> return expr _ -> do- (gamma,delta) <- mkEnv (LetBinding undefined (map fst $ unrec xes) : ctx)- replace' <- mapM (liftBinding gamma delta) replace- let (others',res') = substituteBinders replace' others res- newExpr = case others' of- [] -> res'- _ -> Letrec (bind (rec others') res')+ -- Because 'unbind b' refreshes binders in xes, we must recreate+ -- the let expression, and _not_ reuse 'expr'+ let expr' = Letrec (bind xesR res)+ (doInline,doLift) <- partitionM (inlineOrLift expr') replace+ -- We first substitute the binders that we can inline both the binders+ -- that we intend to lift, the other binders, and the body+ let (others',res') = substituteBinders doInline (doLift ++ others) res+ (doLift',others'') = splitAt (length doLift) others'+ (gamma,delta) <- mkEnv (LetBinding undefined (map fst xes) : ctx)+ doLift'' <- mapM (liftBinding gamma delta) doLift'+ -- We then substitute the lifted binders in the other binders and the body+ let (others3,res'') = substituteBinders doLift'' others'' res'+ newExpr = case others3 of+ [] -> res''+ _ -> Letrec (bind (rec others3) res'') changed newExpr -liftBinders _ _ e = return e+inlineOrLiftBinders _ _ _ e = return e -- | Create a global function for a Let-binding and return a Let-binding where -- the RHS is a reference to the new global function applied to the free