diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.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 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 @@ -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 diff --git a/src/CLaSH/Normalize/PrimitiveReductions.hs b/src/CLaSH/Normalize/PrimitiveReductions.hs --- a/src/CLaSH/Normalize/PrimitiveReductions.hs +++ b/src/CLaSH/Normalize/PrimitiveReductions.hs @@ -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 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 @@ -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) ] 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 @@ -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 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 @@ -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