diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.5.12 *September 14th 2015* +* New features: + * Completely unroll "definitions" of some higher-order primitives with non-representable argument or result vectors: + It is now possible to translate e.g. `f xs ys = zipWith ($) (map (+) xs) ys :: Vec 4 Int -> Vec 4 Int -> Vec 4 Int` + +* Fixes bugs: + * `topLet` transformation erroneously not performed in a top-down traversal + * Specialisation limit unchecked on types and constants + * Vector of functions cannot be translated [#25](https://github.com/clash-lang/clash-compiler/issues/25 ) + * CLaSH fails to generate VHDL when map is applied [#78](https://github.com/clash-lang/clash-compiler/issues/78) + ## 0.5.11 *September 7th 2015* * Fixes bugs: * Clash running out of memory on Simple-ish project [#70](https://github.com/clash-lang/clash-compiler/issues/70) 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.5.11 +Version: 0.5.12 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/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -1,21 +1,26 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where import Data.HashMap.Lazy (HashMap) -import Unbound.Generics.LocallyNameless (Fresh, bind, embed, unbind, unembed, +import Unbound.Generics.LocallyNameless (Fresh, bind, embed, rebind, + string2Name, unbind, unembed, unrebind, unrec) import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -import CLaSH.Core.DataCon (dcType) +import CLaSH.Core.DataCon (DataCon, dcType, dataConInstArgTys) import CLaSH.Core.Literal (literalType) import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term (Pat (..), Term (..), TmName) -import CLaSH.Core.Type (Kind, TyName, Type (..), applyTy, +import CLaSH.Core.Term (LetBinding, Pat (..), Term (..), + TmName) +import CLaSH.Core.Type (Kind, LitTy (..), TyName, + Type (..), applyTy, isFunTy, isPolyFunCoreTy, mkFunTy, splitFunTy) import CLaSH.Core.TyCon (TyCon, TyConName) +import CLaSH.Core.TysPrim (typeNatKind) import CLaSH.Core.Var (Id, TyVar, Var (..), varType) import CLaSH.Util @@ -219,3 +224,67 @@ termSize (Case subj _ alts) = let subjSz = termSize subj altSzs = map (termSize . snd . unsafeUnbind) alts in sum (subjSz:altSzs) + +-- | Create a vector of supplied elements +mkVec :: DataCon -- ^ The Nil constructor + -> DataCon -- ^ The Cons (:>) constructor + -> Type -- ^ Element type + -> Int -- ^ Length of the vector + -> [Term] -- ^ Elements to put in the vector + -> Term +mkVec nilCon consCon resTy = go + where + go _ [] = mkApps (Data nilCon) [Right (LitTy (NumTy 0)) + ,Right resTy + ,Left (Prim "_CO_" nilCoTy) + ] + + go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n)) + ,Right resTy + ,Right (LitTy (NumTy (n-1))) + ,Left (Prim "_CO_" (consCoTy n)) + ,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)))]) + +-- | Create let-bindings with case-statements that select elements out of a +-- vector. Returns both the variables to which element-selections are bound +-- and the let-bindings +extractElems :: DataCon -- ^ The Cons (:>) constructor + -> Type -- ^ The element type + -> Char -- ^ Char to append to the bound variable names + -> Int -- ^ Length of the vector + -> Term -- ^ The vector + -> [(Term,[LetBinding])] +extractElems consCon resTy s maxN = go maxN + where + go :: Int -> Term -> [(Term,[LetBinding])] + go 0 _ = [] + go n e = (elVar + ,[(Id elBNm (embed resTy) ,embed lhs) + ,(Id restBNm (embed restTy),embed rhs) + ] + ) : + go (n-1) (Var restTy restBNm) + + where + elBNm = string2Name ("el" ++ s:show (maxN-n)) + restBNm = string2Name ("rest" ++ s:show (maxN-n)) + elVar = Var resTy elBNm + pat = DataPat (embed consCon) (rebind [mTV] [co,el,rest]) + elPatNm = string2Name "el" + restPatNm = string2Name "rest" + lhs = Case e resTy [bind pat (Var resTy elPatNm)] + rhs = Case e restTy [bind pat (Var restTy restPatNm)] + + mName = string2Name "m" + mTV = TyVar mName (embed typeNatKind) + tys = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))] + idTys = dataConInstArgTys consCon tys + [co,el,rest] = zipWith Id [string2Name "_co_",elPatNm, restPatNm] + (map embed idTys) + restTy = last $ dataConInstArgTys consCon tys diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -42,7 +42,7 @@ -> PrimMap -- ^ Primitive / BlackBox Definitions -> HashMap TyConName TyCon -- ^ TyCon cache -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator - -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) + -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) -> Maybe TopEntity -> CLaSHOpts -- ^ Debug information level for the normalization process -> IO () 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 @@ -40,7 +40,7 @@ -> PrimMap -- ^ Primitives -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> HashMap TyConName TyCon - -> (HashMap TyConName TyCon -> Term -> Term) + -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -> Int -> HashMap TmName (Type,Term) -- ^ Global binders -> Maybe TmName -- ^ Stimuli diff --git a/src/CLaSH/Driver/TopWrapper.hs b/src/CLaSH/Driver/TopWrapper.hs --- a/src/CLaSH/Driver/TopWrapper.hs +++ b/src/CLaSH/Driver/TopWrapper.hs @@ -177,7 +177,7 @@ netdecl = NetDecl iName hwty assigns = zipWith (\id_ n -> Assignment id_ - (Identifier iName (Just (Indexed (hwty,1,n))))) + (Identifier iName (Just (Indexed (hwty,10,n))))) ids [0..] in (nms',(ports',(netdecl:assigns ++ decls',iName))) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -20,6 +20,7 @@ unrebind) import CLaSH.Core.DataCon (DataCon (..)) +import CLaSH.Core.FreeVars (typeFreeVars) import CLaSH.Core.Literal (Literal (..)) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Term (Pat (..), Term (..), TmName) @@ -184,10 +185,14 @@ let dstId = mkBasicId . Text.pack . name2String $ varName bndr altVarId = mkBasicId . Text.pack $ name2String varTm modifier = case pat of - DataPat (Embed dc) ids -> let tms = case unrebind ids of - ([],tms') -> tms' - _ -> error $ $(curLoc) ++ "Not in normal form: Pattern binds existential variables: " ++ showDoc e - in case elemIndex (Id varTm (Embed varTy)) tms of + DataPat (Embed dc) ids -> let (exts,tms) = unrebind ids + tmsTys = map (unembed . varType) tms + tmsFVs = concatMap (Lens.toListOf typeFreeVars) tmsTys + extNms = map varName exts + tms' = if any (`elem` tmsFVs) extNms + then error $ $(curLoc) ++ "Not in normal form: Pattern binds existential variables: " ++ showDoc e + else tms + in case elemIndex (Id varTm (Embed varTy)) tms' of Nothing -> Nothing Just fI | sHwTy /= vHwTy -> Just (Indexed (sHwTy,dcTag dc - 1,fI)) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -51,7 +51,7 @@ -- ^ Hardcoded Type -> HWType translator -> HashMap TyConName TyCon -- ^ TyCon cache - -> (HashMap TyConName TyCon -> Term -> Term) + -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) -> NormalizeSession a -- ^ NormalizeSession to run @@ -219,7 +219,7 @@ let (toInline,il_used) = unzip il_ct newExpr <- case toInline of [] -> return tm - _ -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topLet) (showDoc nm, substTms toInline tm) + _ -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topdownSucR topLet) (showDoc nm, substTms toInline tm) return (CBranch (nm,(ty,newExpr)) (newUsed ++ (concat il_used))) callTreeToList :: [TmName] 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 @@ -38,10 +38,11 @@ ] transBUP :: [(String,NormRewrite)] - transBUP = [ ("inlineClosed", inlineClosed) - , ("inlineSmall" , inlineSmall) - , ("inlineNonRep", inlineNonRep) - , ("bindNonRep" , bindNonRep) -- See: [Note] bindNonRep before liftNonRep + transBUP = [ ("inlineClosed" , inlineClosed) + , ("inlineSmall" , inlineSmall) + , ("inlineNonRep" , inlineNonRep) + , ("bindNonRep" , bindNonRep) -- See: [Note] bindNonRep before liftNonRep + , ("reduceNonRepPrim", reduceNonRepPrim) ] specRws :: [(String,NormRewrite)] 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 @@ -1,5 +1,6 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} -- | Transformations of the Normalization process module CLaSH.Normalize.Transformations @@ -25,6 +26,7 @@ , inlineSmall , simpleCSE , reduceConst + , reduceNonRepPrim ) where @@ -37,23 +39,27 @@ import qualified Data.Maybe as Maybe import Unbound.Generics.LocallyNameless (Bind, Embed (..), bind, embed, rec, unbind, unembed, unrebind, - unrec, name2String) + unrec, name2String, string2Name, + rebind) import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -import CLaSH.Core.DataCon (DataCon, dcName, dcTag, - dcUnivTyVars) +import CLaSH.Core.DataCon (DataCon (..), dataConInstArgTys) import CLaSH.Core.FreeVars (termFreeIds, termFreeTyVars, typeFreeVars) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Subst (substTm, substTms, substTyInTm, substTysinTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..)) -import CLaSH.Core.Type (TypeView (..), applyFunTy, - applyTy, splitFunTy, typeKind, tyView) -import CLaSH.Core.Util (collectArgs, idToVar, isCon, +import CLaSH.Core.Type (TypeView (..), Type (..), + LitTy (..), applyFunTy, + applyTy, 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, - termSize,termType) + mkVec, termSize,termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.Util (representableType, splitNormalized) @@ -98,7 +104,7 @@ | (Var _ _, args) <- collectArgs e1 , null $ Lens.toListOf typeFreeVars ty , (_, []) <- Either.partitionEithers args - = specializeNorm False ctx e + = specializeNorm ctx e typeSpec _ e = return e @@ -113,7 +119,7 @@ localVar <- isLocalVar e2 nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure e2Ty) if nonRepE2 && not localVar - then specializeNorm True ctx e + then specializeNorm ctx e else return e nonRepSpec _ e = return e @@ -226,7 +232,7 @@ tcm <- Lens.view tcCache lvl <- Lens.view dbgLevel reduceConstant <- Lens.view evaluator - case reduceConstant tcm subj of + case reduceConstant tcm True subj of Literal l -> caseCon ctx (Case (Literal l) ty alts) subj'@(collectArgs -> (Data _,_)) -> caseCon ctx (Case subj' ty alts) subj' -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (caseOneAlt e) @@ -261,8 +267,8 @@ case (untranslatable,arg) of (True,Letrec b) -> do (binds,body) <- unbind b changed (Letrec (bind binds (App appConPrim body))) - (True,Case {}) -> specializeNorm True ctx e - (True,Lam _) -> specializeNorm True ctx e + (True,Case {}) -> specializeNorm ctx e + (True,Lam _) -> specializeNorm ctx e _ -> return e nonRepANF _ e = return e @@ -395,7 +401,7 @@ , (_, []) <- Either.partitionEithers args , null $ Lens.toListOf termFreeTyVars e2 , isConstant e2 - = specializeNorm False ctx e + = specializeNorm ctx e constantSpec _ e = return e @@ -693,9 +699,229 @@ = do tcm <- Lens.view tcCache reduceConstant <- Lens.view evaluator - case reduceConstant tcm e of + case reduceConstant tcm False e of e'@(Data _) -> changed e' e'@(Literal _) -> changed e' _ -> return e reduceConst _ e = return e + +-- | Replace primitives by their "definition" if they would lead to let-bindings +-- with a non-representable type when a function is in ANF. This happens for +-- example when CLaSH.Size.Vector.map consumes or produces a vector of +-- non-representable elements. +-- +-- Basically what this transformation does is replace a primitive the completely +-- unrolled recursive definition that it represents. e.g. +-- +-- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int) +-- +-- is replaced by: +-- +-- > let (x0 :: (Int -> Int)) = case xs of (:>) _ x xr -> x +-- > (xr0 :: Vec 1 (Int -> Int)) = case xs of (:>) _ x xr -> xr +-- > (x1 :: (Int -> Int)( = case xr0 of (:>) _ x xr -> x +-- > (y0 :: Int) = case ys of (:>) _ y yr -> y +-- > (yr0 :: Vec 1 Int) = case ys of (:>) _ y yr -> xr +-- > (y1 :: Int = case yr0 of (:>) _ y yr -> y +-- > in (($) x0 y0 :> ($) x1 y1 :> Nil) +-- +-- Currently, it only handles the following functions: +-- +-- * CLaSH.Sized.Vector.map +-- * CLaSH.Sized.Vector.zipWith +-- * CLaSH.Sized.Vector.traverse# +reduceNonRepPrim :: NormRewrite +reduceNonRepPrim _ e@(App _ _) + | (Prim f _, args) <- collectArgs e + = case f of + "CLaSH.Sized.Vector.zipWith" | length args == 7 -> do + let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args + case nTy of + (LitTy (NumTy n)) -> do + untranslatableTys <- mapM isUntranslatableType [lhsElTy,rhsElty,resElTy] + if or untranslatableTys + then let [fun,lhsArg,rhsArg] = Either.lefts args + in reduceZipWith n lhsElTy rhsElty resElTy fun lhsArg rhsArg + else return e + _ -> return e + "CLaSH.Sized.Vector.map" | length args == 5 -> do + let [argElTy,resElTy,nTy] = Either.rights args + case nTy of + (LitTy (NumTy n)) -> do + untranslatableTys <- mapM isUntranslatableType [argElTy,resElTy] + if or untranslatableTys + then let [fun,arg] = Either.lefts args + in reduceMap n argElTy resElTy fun arg + else return e + _ -> return e + "CLaSH.Sized.Vector.traverse#" | length args == 7 -> + let [aTy,fTy,bTy,nTy] = Either.rights args + in case nTy of + (LitTy (NumTy n)) -> + let [dict,fun,arg] = Either.lefts args + in reduceTraverse n aTy fTy bTy dict fun arg + _ -> return e + _ -> return e + +reduceNonRepPrim _ e = return e + +-- | Replace an application of @CLaSH.Sized.Vector.zipWith@ primitive on vectors +-- of a known length @n@, by the fully unrolled recursive "definition" of of +-- @CLaSH.Sized.Vector.zipWith@ +reduceZipWith :: Int -- ^ Length of the vector(s) + -> Type -- ^ Type of the lhs of the function + -> Type -- ^ Type of the rhs of the function + -> Type -- ^ Type of the result of the function + -> Term -- ^ The zipWith'd functions + -> Term -- ^ The 1st vector argument + -> Term -- ^ The 2nd vector argument + -> NormalizeSession Term +reduceZipWith n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do + tcm <- Lens.view tcCache + (TyConApp vecTcNm _) <- tyView <$> termType tcm lhsArg + let (Just vecTc) = HashMap.lookup vecTcNm tcm + [nilCon,consCon] = tyConDataCons vecTc + (varsL,elemsL) = second concat . unzip $ extractElems consCon lhsElTy 'L' n lhsArg + (varsR,elemsR) = second concat . unzip $ extractElems consCon rhsElTy 'R' n rhsArg + funApps = zipWith (\l r -> mkApps fun [Left l,Left r]) varsL varsR + lbody = mkVec nilCon consCon resElTy n funApps + lb = Letrec (bind (rec (init elemsL ++ init elemsR)) lbody) + changed lb + +-- | Replace an application of @CLaSH.Sized.Vector.map@ primitive on vectors +-- of a known length @n@, by the fully unrolled recursive "definition" of of +-- @CLaSH.Sized.Vector.map@ +reduceMap :: Int -- ^ Length of the vector + -> Type -- ^ Argument type of the function + -> Type -- ^ Result type of the function + -> Term -- ^ The map'd function + -> Term -- ^ The map'd over vector + -> NormalizeSession Term +reduceMap n argElTy resElTy fun arg = do + tcm <- Lens.view tcCache + (TyConApp vecTcNm _) <- tyView <$> termType tcm arg + let (Just vecTc) = HashMap.lookup vecTcNm tcm + [nilCon,consCon] = tyConDataCons vecTc + (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 @CLaSH.Sized.Vector.traverse#@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @CLaSH.Sized.Vector.map@ +reduceTraverse :: Int -- ^ Length of the vector + -> Type -- ^ Element type of the argument vector + -> Type -- ^ The type of the applicative + -> Type -- ^ Element type of the result vector + -> Term -- ^ The @Applicative@ dictionary + -> Term -- ^ The function to traverse with + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceTraverse n aTy fTy bTy dict fun arg = do + tcm <- Lens.view tcCache + (TyConApp vecTcNm _) <- tyView <$> termType tcm arg + (TyConApp apDictTcNm _) <- tyView <$> termType tcm dict + let (Just apDictTc) = HashMap.lookup apDictTcNm tcm + [apDictCon] = tyConDataCons apDictTc + apDictIdTys = dataConInstArgTys apDictCon [fTy] + apDictIds = zipWith Id (map string2Name ["functorDict" + ,"pure" + ,"ap" + ,"apConstL" + ,"apConstR"]) + (map embed apDictIdTys) + + (TyConApp funcDictTcNm _) = tyView (head apDictIdTys) + (Just funcDictTc) = HashMap.lookup funcDictTcNm tcm + [funcDictCon] = tyConDataCons funcDictTc + funcDictIdTys = dataConInstArgTys funcDictCon [fTy] + funcDicIds = zipWith Id (map string2Name ["fmap","fmapConst"]) + (map embed funcDictIdTys) + + apPat = DataPat (embed apDictCon) (rebind [] apDictIds) + fnPat = DataPat (embed funcDictCon) (rebind [] funcDicIds) + + -- Extract the 'pure' function from the Applicative dictionary + pureTy = apDictIdTys!!1 + pureTm = Case dict pureTy [bind apPat (Var pureTy (string2Name "pure"))] + + -- Extract the '<*>' function from the Applicative dictionary + apTy = apDictIdTys!!2 + apTm = Case dict apTy [bind apPat (Var apTy (string2Name "ap"))] + + -- Extract the Functor dictionary from the Applicative dictionary + funcTy = (head apDictIdTys) + funcTm = Case dict funcTy + [bind apPat (Var funcTy (string2Name "functorDict"))] + + -- Extract the 'fmap' function from the Functor dictionary + fmapTy = (head funcDictIdTys) + fmapTm = Case (Var funcTy (string2Name "functorDict")) fmapTy + [bind fnPat (Var fmapTy (string2Name "fmap"))] + + (Just vecTc) = HashMap.lookup vecTcNm tcm + [nilCon,consCon] = tyConDataCons vecTc + (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'T' n arg + + funApps = map (fun `App`) vars + + lbody = mkTravVec vecTcNm nilCon consCon (idToVar (apDictIds!!1)) + (idToVar (apDictIds!!2)) + (idToVar (funcDicIds!!0)) + bTy n funApps + + lb = Letrec (bind (rec ([((apDictIds!!0),embed funcTm) + ,((apDictIds!!1),embed pureTm) + ,((apDictIds!!2),embed apTm) + ,((funcDicIds!!0),embed fmapTm) + ] ++ init elems)) lbody) + changed lb + +-- | Create the traversable vector +-- +-- e.g. for a length '2' input vector, we get +-- +-- > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil) +mkTravVec :: TyConName -- ^ Vec tcon + -> DataCon -- ^ Nil con + -> DataCon -- ^ Cons con + -> Term -- ^ 'pure' term + -> Term -- ^ '<*>' term + -> Term -- ^ 'fmap' term + -> Type -- ^ 'b' ty + -> Int -- ^ Length of the vector + -> [Term] -- ^ Elements of the vector + -> Term +mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go + where + go :: Int -> [Term] -> Term + go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy]) + ,Left (mkApps (Data nilCon) + [Right (LitTy (NumTy 0)) + ,Right bTy + ,Left (Prim "_CO_" nilCoTy)])] + + go n (x:xs) = mkApps apTm + [Right (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) + ,Right (mkTyConApp vecTc [LitTy (NumTy n),bTy]) + ,Left (mkApps fmapTm [Right bTy + ,Right (mkFunTy (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) + (mkTyConApp vecTc [LitTy (NumTy n),bTy])) + ,Left (mkApps (Data consCon) + [Right (LitTy (NumTy n)) + ,Right bTy + ,Right (LitTy (NumTy (n-1))) + ,Left (Prim "_CO_" (consCoTy n)) + ]) + ,Left x]) + ,Left (go (n-1) xs)] + + nilCoTy = head (dataConInstArgTys nilCon [(LitTy (NumTy 0)),bTy]) + + consCoTy n = head (dataConInstArgTys consCon [(LitTy (NumTy n)) + ,bTy + ,(LitTy (NumTy (n-1)))]) 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 @@ -47,7 +47,7 @@ (HashMap.singleton f 1) -- | Specialize under the Normalization Monad -specializeNorm :: Bool -> NormRewrite +specializeNorm :: NormRewrite specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit -- | Determine if a term is closed diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs --- a/src/CLaSH/Rewrite/Types.hs +++ b/src/CLaSH/Rewrite/Types.hs @@ -77,7 +77,7 @@ -- ^ Hardcode Type -> HWType translator , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache - , _evaluator :: HashMap TyConName TyCon -> Term -> Term + , _evaluator :: HashMap TyConName TyCon -> Bool -> Term -> Term -- ^ Hardcoded evaluator (delta-reduction)} } 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 @@ -405,13 +405,25 @@ $ Lens.use bindings isLocalVar _ = return False +{-# INLINE isUntranslatable #-} -- | Determine if a term cannot be represented in hardware isUntranslatable :: Term -> RewriteMonad extra Bool isUntranslatable tm = do tcm <- Lens.view tcCache - not <$> (representableType <$> Lens.view typeTranslator <*> pure tcm <*> termType tcm tm) + not <$> (representableType <$> Lens.view typeTranslator + <*> pure tcm + <*> termType tcm tm) +{-# INLINE isUntranslatableType #-} +-- | Determine if a type cannot be represented in hardware +isUntranslatableType :: Type + -> RewriteMonad extra Bool +isUntranslatableType ty = + not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view tcCache + <*> pure ty) + -- | Is the Context a Lambda/Term-abstraction context? isLambdaBodyCtx :: CoreContext -> Bool @@ -460,24 +472,22 @@ specialise :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations -> Lens' extra (HashMap TmName Int) -- ^ Lens into the specialisation history -> Lens' extra Int -- ^ Lens into the specialisation limit - -> Bool -> Rewrite extra -specialise specMapLbl specHistLbl specLimitLbl doCheck ctx e = case e of - (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl False ctx e (collectArgs e1) (Right ty) - (App e1 e2) -> specialise' specMapLbl specHistLbl specLimitLbl doCheck ctx e (collectArgs e1) (Left e2) +specialise specMapLbl specHistLbl specLimitLbl ctx e = case e of + (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Right ty) + (App e1 e2) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Left e2) _ -> return e -- | Specialise an application on its argument specialise' :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations -> Lens' extra (HashMap TmName Int) -- ^ Lens into specialisation history -> Lens' extra Int -- ^ Lens into the specialisation limit - -> Bool -- ^ Perform specialisation limit check -> [CoreContext] -- Transformation context -> Term -- ^ Original term -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments -> Either Term Type -- ^ Argument to specialize on -> RewriteMonad extra Term -specialise' specMapLbl specHistLbl specLimitLbl doCheck ctx e (Var _ f, args) specArg = do +specialise' specMapLbl specHistLbl specLimitLbl ctx e (Var _ f, args) specArg = do lvl <- Lens.view dbgLevel -- Create binders and variable references for free variables in 'specArg' (specBndrs,specVars) <- specArgBndrsAndVars ctx specArg @@ -499,7 +509,7 @@ -- Determine if we see a sequence of specialisations on a growing argument specHistM <- HML.lookup f <$> Lens.use (extra.specHistLbl) specLim <- Lens.use (extra . specLimitLbl) - if doCheck && maybe False (> specLim) specHistM + if maybe False (> specLim) specHistM then fail $ unlines [ "Hit specialisation limit " ++ show specLim ++ " on function `" ++ showDoc f ++ "'.\n" , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n" , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n" @@ -522,19 +532,20 @@ newf `deepseq` changed newExpr Nothing -> return e -specialise' _ _ _ _ ctx _ (appE,args) (Left specArg) = do +specialise' _ _ _ ctx _ (appE,args) (Left specArg) = do -- Create binders and variable references for free variables in 'specArg' (specBndrs,specVars) <- specArgBndrsAndVars ctx (Left specArg) -- Create specialized function let newBody = mkAbstraction specArg specBndrs - newf <- mkFunction (string2Name "specF") newBody + cf <- Lens.use curFun + newf <- mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) newBody -- Create specialized argument let newArg = Left $ mkApps ((uncurry . flip) Var newf) specVars -- Use specialized argument let newExpr = mkApps appE (args ++ [newArg]) changed newExpr -specialise' _ _ _ _ _ e _ _ = return e +specialise' _ _ _ _ e _ _ = return e -- | Create binders and variable references for free variables in 'specArg' specArgBndrsAndVars :: [CoreContext]