1 {-# LANGUAGE PackageImports #-}
3 -- This module provides functions for program transformations.
5 module CLasH.Normalize.NormalizeTools where
8 import qualified Data.Monoid as Monoid
9 import qualified Control.Monad as Monad
10 import qualified Control.Monad.Trans.Writer as Writer
11 import qualified "transformers" Control.Monad.Trans as Trans
12 import qualified Data.Accessor.Monad.Trans.State as MonadState
19 import qualified CoreSubst
21 -- import qualified CoreUtils
22 -- import Outputable ( showSDoc, ppr, nest )
25 import CLasH.Normalize.NormalizeTypes
26 import CLasH.Translator.TranslatorTypes
28 import qualified CLasH.Utils.Core.CoreTools as CoreTools
29 import qualified CLasH.VHDL.VHDLTools as VHDLTools
31 -- Apply the given transformation to all expressions in the given expression,
32 -- including the expression itself.
33 everywhere :: (String, Transform) -> Transform
34 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
36 -- Apply the first transformation, followed by the second transformation, and
37 -- keep applying both for as long as expression still changes.
38 applyboth :: Transform -> (String, Transform) -> Transform
39 applyboth first (name, second) expr = do
43 (expr'', changed) <- Writer.listen $ second expr'
45 -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n")
48 -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
49 -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
50 applyboth first (name, second)
53 -- trace ("No changes") $
56 -- Apply the given transformation to all direct subexpressions (only), not the
58 subeverywhere :: Transform -> Transform
59 subeverywhere trans (App a b) = do
64 subeverywhere trans (Let (NonRec b bexpr) expr) = do
67 return $ Let (NonRec b bexpr') expr'
69 subeverywhere trans (Let (Rec binds) expr) = do
71 binds' <- mapM transbind binds
72 return $ Let (Rec binds') expr'
74 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
79 subeverywhere trans (Lam x expr) = do
83 subeverywhere trans (Case scrut b t alts) = do
85 alts' <- mapM transalt alts
86 return $ Case scrut' b t alts'
88 transalt :: CoreAlt -> TransformMonad CoreAlt
89 transalt (con, binders, expr) = do
91 return (con, binders, expr')
93 subeverywhere trans (Var x) = return $ Var x
94 subeverywhere trans (Lit x) = return $ Lit x
95 subeverywhere trans (Type x) = return $ Type x
97 subeverywhere trans (Cast expr ty) = do
99 return $ Cast expr' ty
101 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
103 -- Apply the given transformation to all expressions, except for direct
104 -- arguments of an application
105 notappargs :: (String, Transform) -> Transform
106 notappargs trans = applyboth (subnotappargs trans) trans
108 -- Apply the given transformation to all (direct and indirect) subexpressions
109 -- (but not the expression itself), except for direct arguments of an
111 subnotappargs :: (String, Transform) -> Transform
112 subnotappargs trans (App a b) = do
113 a' <- subnotappargs trans a
114 b' <- subnotappargs trans b
117 -- Let subeverywhere handle all other expressions
118 subnotappargs trans expr = subeverywhere (notappargs trans) expr
120 -- Runs each of the transforms repeatedly inside the State monad.
121 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
122 dotransforms transs expr = do
123 (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
124 if Monoid.getAny changed then dotransforms transs expr' else return expr'
126 -- Inline all let bindings that satisfy the given condition
127 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
128 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
129 applies <- condition (bndr, expr')
132 -- Substitute the binding in res and return that
133 res' <- substitute_clone bndr expr' res
136 -- Don't change this let
138 -- Leave all other expressions unchanged
139 inlinebind _ expr = return expr
141 -- Sets the changed flag in the TransformMonad, to signify that some
142 -- transform has changed the result
143 setChanged :: TransformMonad ()
144 setChanged = Writer.tell (Monoid.Any True)
146 -- Sets the changed flag and returns the given value.
147 change :: a -> TransformMonad a
152 -- Returns the given value and sets the changed flag if the bool given is
153 -- True. Note that this will not unset the changed flag if the bool is False.
154 changeif :: Bool -> a -> TransformMonad a
155 changeif True val = change val
156 changeif False val = return val
158 -- | Creates a transformation that substitutes the given binder with the given
159 -- expression (This can be a type variable, replace by a Type expression).
160 -- Does not set the changed flag.
161 substitute :: CoreBndr -> CoreExpr -> Transform
162 -- Use CoreSubst to subst a type var in an expression
163 substitute find repl expr = do
164 let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
165 return $ CoreSubst.substExpr subst expr
167 -- | Creates a transformation that substitutes the given binder with the given
168 -- expression. This does only work for value expressions! All binders in the
169 -- expression are cloned before the replacement, to guarantee uniqueness.
170 substitute_clone :: CoreBndr -> CoreExpr -> Transform
171 -- If we see the var to find, replace it by a uniqued version of repl
172 substitute_clone find repl (Var var) | find == var = do
173 repl' <- Trans.lift $ CoreTools.genUniques repl
176 -- For all other expressions, just look in subexpressions
177 substitute_clone find repl expr = subeverywhere (substitute_clone find repl) expr
179 -- Is the given expression representable at runtime, based on the type?
180 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
181 isRepr tything = case CoreTools.getType tything of
182 Nothing -> return False
183 Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
185 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
186 is_local_var (CoreSyn.Var v) = do
187 bndrs <- getGlobalBinders
188 return $ v `notElem` bndrs
189 is_local_var _ = return False
191 -- Is the given binder defined by the user?
192 isUserDefined :: CoreSyn.CoreBndr -> Bool
193 -- System names are certain to not be user defined
194 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
195 -- Check a list of typical compiler-defined names
196 isUserDefined bndr = str `notElem` compiler_names
198 str = Name.getOccString bndr
199 -- These are names of bindings usually generated by the compiler. For some
200 -- reason these are not marked as system, probably because the name itself
201 -- is not made up by the compiler, just this particular binding is.
202 compiler_names = ["fromInteger", "head", "tail", "init", "last", "+", "*", "-", "!"]
204 -- Is the given binder normalizable? This means that its type signature can be
205 -- represented in hardware, which should (?) guarantee that it can be made
206 -- into hardware. Note that if a binder is not normalizable, it might become
207 -- so using argument propagation.
208 isNormalizeable :: CoreBndr -> TransformMonad Bool
209 isNormalizeable bndr = do
210 let ty = Id.idType bndr
211 let (arg_tys, res_ty) = Type.splitFunTys ty
212 -- This function is normalizable if all its arguments and return value are
214 andM $ mapM isRepr (res_ty:arg_tys)