X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize%2FNormalizeTools.hs;h=6acaa86a5286ed347c6c2dccd3ab57c0e768fbf1;hb=13d79fc21cd9ed00802647602401814d746c47cb;hp=5f0c3fd6e75164a0f74737355089205947d30715;hpb=bf9f8e9e9cfce93ae1e35cf524b371beb34f5010;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 5f0c3fd..6acaa86 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -3,105 +3,31 @@ -- This module provides functions for program transformations. -- module CLasH.Normalize.NormalizeTools where + -- Standard modules -import Debug.Trace -import qualified List import qualified Data.Monoid as Monoid -import qualified Data.Either as Either -import qualified Control.Arrow as Arrow import qualified Control.Monad as Monad -import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Writer as Writer import qualified "transformers" Control.Monad.Trans as Trans -import qualified Data.Map as Map -import Data.Accessor -import Data.Accessor.MonadState as MonadState +import qualified Data.Accessor.Monad.Trans.State as MonadState +-- import Debug.Trace -- GHC API import CoreSyn -import qualified UniqSupply -import qualified Unique -import qualified OccName import qualified Name -import qualified Var -import qualified SrcLoc -import qualified Type -import qualified IdInfo -import qualified CoreUtils +import qualified Id import qualified CoreSubst -import qualified VarSet -import qualified HscTypes -import Outputable ( showSDoc, ppr, nest ) +import qualified Type +-- import qualified CoreUtils +-- import Outputable ( showSDoc, ppr, nest ) -- Local imports import CLasH.Normalize.NormalizeTypes import CLasH.Translator.TranslatorTypes -import CLasH.Utils.Pretty -import CLasH.VHDL.VHDLTypes +import CLasH.Utils +import qualified CLasH.Utils.Core.CoreTools as CoreTools import qualified CLasH.VHDL.VHDLTools as VHDLTools --- Create a new internal var with the given name and type. A Unique is --- appended to the given name, to ensure uniqueness (not strictly neccesary, --- since the Unique is also stored in the name, but this ensures variable --- names are unique in the output). -mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var -mkInternalVar str ty = Trans.lift (mkInternalVar' str ty) - -mkInternalVar' :: String -> Type.Type -> TranslatorSession Var.Var -mkInternalVar' str ty = do - uniq <- mkUnique' - let occname = OccName.mkVarOcc (str ++ show uniq) - let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan - return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo - --- Create a new type variable with the given name and kind. A Unique is --- appended to the given name, to ensure uniqueness (not strictly neccesary, --- since the Unique is also stored in the name, but this ensures variable --- names are unique in the output). -mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var -mkTypeVar str kind = Trans.lift (mkTypeVar' str kind) - -mkTypeVar' :: String -> Type.Kind -> TranslatorSession Var.Var -mkTypeVar' str kind = do - uniq <- mkUnique' - let occname = OccName.mkVarOcc (str ++ show uniq) - let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan - return $ Var.mkTyVar name kind - --- Creates a binder for the given expression with the given name. This --- works for both value and type level expressions, so it can return a Var or --- TyVar (which is just an alias for Var). -mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var -mkBinderFor expr string = Trans.lift (mkBinderFor' expr string) - -mkBinderFor' :: CoreExpr -> String -> TranslatorSession Var.Var -mkBinderFor' (Type ty) string = mkTypeVar' string (Type.typeKind ty) -mkBinderFor' expr string = mkInternalVar' string (CoreUtils.exprType expr) - --- Creates a reference to the given variable. This works for both a normal --- variable as well as a type variable -mkReferenceTo :: Var.Var -> CoreExpr -mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var) - | otherwise = (Var var) - -cloneVar :: Var.Var -> TransformMonad Var.Var -cloneVar v = do - uniq <- mkUnique - -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it - -- contains, but vannillaIdInfo is always correct, since it means "no info"). - return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo - --- Creates a new function with the same name as the given binder (but with a --- new unique) and with the given function body. Returns the new binder for --- this function. -mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr -mkFunction bndr body = do - let ty = CoreUtils.exprType body - id <- cloneVar bndr - let newid = Var.setVarType id ty - Trans.lift $ addGlobalBind newid body - return newid - -- Apply the given transformation to all expressions in the given expression, -- including the expression itself. everywhere :: (String, Transform) -> Transform @@ -110,21 +36,21 @@ everywhere trans = applyboth (subeverywhere (everywhere trans)) trans -- Apply the first transformation, followed by the second transformation, and -- keep applying both for as long as expression still changes. applyboth :: Transform -> (String, Transform) -> Transform -applyboth first (name, second) expr = do +applyboth first (name, second) expr = do -- Apply the first expr' <- first expr -- Apply the second (expr'', changed) <- Writer.listen $ second expr' if Monoid.getAny $ --- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ + -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") changed then --- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ --- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ - applyboth first (name, second) $ + -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ + -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ + applyboth first (name, second) expr'' else --- trace ("No changes") $ + -- trace ("No changes") $ return expr'' -- Apply the given transformation to all direct subexpressions (only), not the @@ -199,22 +125,16 @@ 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 do + -- Substitute the binding in res and return that + res' <- substitute_clone bndr expr' res + change res' + else + -- Don't change this let + return expr -- Leave all other expressions unchanged inlinebind _ expr = return expr @@ -229,43 +149,66 @@ change val = do setChanged return val --- Create a new Unique -mkUnique :: TransformMonad Unique.Unique -mkUnique = Trans.lift $ mkUnique' - -mkUnique' :: TranslatorSession Unique.Unique -mkUnique' = do - us <- getA tsUniqSupply - let (us', us'') = UniqSupply.splitUniqSupply us - putA tsUniqSupply us' - return $ UniqSupply.uniqFromSupply us'' - --- 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 +-- Returns the given value and sets the changed flag if the bool given is +-- True. Note that this will not unset the changed flag if the bool is False. +changeif :: Bool -> a -> TransformMonad a +changeif True val = change val +changeif False val = return val + +-- | Creates a transformation that substitutes the given binder with the given +-- expression (This can be a type variable, replace by a Type expression). +-- Does not set the changed flag. +substitute :: CoreBndr -> CoreExpr -> Transform +-- Use CoreSubst to subst a type var in an expression +substitute find repl expr = do + let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl + return $ CoreSubst.substExpr subst expr + +-- | Creates a transformation that substitutes the given binder with the given +-- expression. This does only work for value expressions! All binders in the +-- expression are cloned before the replacement, to guarantee uniqueness. +substitute_clone :: CoreBndr -> CoreExpr -> Transform +-- If we see the var to find, replace it by a uniqued version of repl +substitute_clone find repl (Var var) | find == var = do + repl' <- Trans.lift $ CoreTools.genUniques repl + change repl' + +-- For all other expressions, just look in subexpressions +substitute_clone find repl expr = subeverywhere (substitute_clone 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 + return $ v `notElem` 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 `notElem` 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)