X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize%2FNormalizeTools.hs;h=e32bd341470489020363478fe5198972fcb23559;hb=5eb86d4e07de5c2a31e0862314d100f72bfaa46e;hp=76fc749bd11435816f3632ede8ce530e5fa14966;hpb=ee495d5974e55eacc04986df09b732a258f63e6b;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 76fc749..e32bd34 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -20,14 +20,19 @@ import Data.Accessor.MonadState as MonadState -- GHC API import CoreSyn +import qualified Name +import qualified Id import qualified CoreSubst import qualified CoreUtils +import qualified Type import Outputable ( showSDoc, ppr, nest ) -- Local imports import CLasH.Normalize.NormalizeTypes import CLasH.Translator.TranslatorTypes +import CLasH.Utils import CLasH.Utils.Pretty +import qualified CLasH.Utils.Core.CoreTools as CoreTools import CLasH.VHDL.VHDLTypes import qualified CLasH.VHDL.VHDLTools as VHDLTools @@ -128,22 +133,15 @@ dotransforms transs expr = do -- Inline all let bindings that satisfy the given condition inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform -inlinebind condition expr@(Let (Rec binds) res) = do - -- Find all bindings that adhere to the condition - res_eithers <- mapM docond binds - case Either.partitionEithers res_eithers of - -- No replaces? No change - ([], _) -> return expr - (replace, others) -> do - -- Substitute the to be replaced binders with their expression - let newexpr = substitute replace (Let (Rec others) res) - change newexpr - where - docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr)) - docond b = do - res <- condition b - return $ case res of True -> Left b; False -> Right b - +inlinebind condition expr@(Let (NonRec bndr expr') res) = do + applies <- condition (bndr, expr') + if applies + then + -- Substitute the binding in res and return that + setChanged >> substitute bndr expr' res + else + -- Don't change this let + return expr -- Leave all other expressions unchanged inlinebind _ expr = return expr @@ -164,32 +162,62 @@ changeif :: Bool -> a -> TransformMonad a changeif True val = change val changeif False val = return val --- Replace each of the binders given with the coresponding expressions in the --- given expression. -substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr -substitute [] expr = expr --- Apply one substitution on the expression, but also on any remaining --- substitutions. This seems to be the only way to handle substitutions like --- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed --- according to CoreSubst documentation (but it doesn't seem to be a problem). --- TODO: Find out how this works, exactly. -substitute ((b, e):subss) expr = substitute subss' expr' - where - -- Create the Subst - subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e) - -- Apply this substitution to the main expression - expr' = CoreSubst.substExpr subs expr - -- Apply this substitution on all the expressions in the remaining - -- substitutions - subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss +-- Creates a transformation that substitutes the given binder with the given +-- expression (This can be a type variable, replace by a Type expression). All +-- value binders in the expression are cloned before the replacement, to +-- guarantee uniqueness. +substitute :: CoreBndr -> CoreExpr -> Transform +-- Use CoreSubst to subst a type var in a type +substitute find (Type repl_ty) (Type ty) = do + let subst = CoreSubst.extendTvSubst CoreSubst.emptySubst find repl_ty + let ty' = CoreSubst.substTy subst ty + return (Type ty') +-- Use CoreSubst to subst a type var in the type annotation of a case +substitute find repl@(Type repl_ty) (Case scrut bndr ty alts) = do + let subst = CoreSubst.extendTvSubst CoreSubst.emptySubst find repl_ty + let ty' = CoreSubst.substTy subst ty + -- And continue with substituting on all subexpressions of the case + subeverywhere (substitute find repl) (Case scrut bndr ty' alts) +-- If we see the var to find, replace it by a uniqued version of repl +substitute find repl (Var var) | find == var = do + setChanged >> (Trans.lift $ CoreTools.genUniques repl) + +-- For all other expressions, just look in subexpressions +substitute find repl expr = subeverywhere (substitute find repl) expr -- Is the given expression representable at runtime, based on the type? -isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool -isRepr (Type ty) = return False -isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr) +isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool +isRepr tything = case CoreTools.getType tything of + Nothing -> return False + Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool is_local_var (CoreSyn.Var v) = do bndrs <- getGlobalBinders return $ not $ v `elem` bndrs is_local_var _ = return False + +-- Is the given binder defined by the user? +isUserDefined :: CoreSyn.CoreBndr -> Bool +-- System names are certain to not be user defined +isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False +-- Check a list of typical compiler-defined names +isUserDefined bndr = str `elem` compiler_names + where + str = Name.getOccString bndr + -- These are names of bindings usually generated by the compiler. For some + -- reason these are not marked as system, probably because the name itself + -- is not made up by the compiler, just this particular binding is. + compiler_names = ["fromInteger"] + +-- Is the given binder normalizable? This means that its type signature can be +-- represented in hardware, which should (?) guarantee that it can be made +-- into hardware. Note that if a binder is not normalizable, it might become +-- so using argument propagation. +isNormalizeable :: CoreBndr -> TransformMonad Bool +isNormalizeable bndr = do + let ty = Id.idType bndr + let (arg_tys, res_ty) = Type.splitFunTys ty + -- This function is normalizable if all its arguments and return value are + -- representable. + andM $ mapM isRepr (res_ty:arg_tys)