1 {-# LANGUAGE PackageImports #-}
3 -- This module provides functions for program transformations.
5 module CLasH.Normalize.NormalizeTools where
10 import qualified Data.Monoid as Monoid
11 import qualified Data.Either as Either
12 import qualified Control.Arrow as Arrow
13 import qualified Control.Monad as Monad
14 import qualified Control.Monad.Trans.State as State
15 import qualified Control.Monad.Trans.Writer as Writer
16 import qualified "transformers" Control.Monad.Trans as Trans
17 import qualified Data.Map as Map
19 import Data.Accessor.Monad.Trans.State as MonadState
25 import qualified CoreSubst
26 import qualified CoreUtils
28 import Outputable ( showSDoc, ppr, nest )
31 import CLasH.Normalize.NormalizeTypes
32 import CLasH.Translator.TranslatorTypes
34 import CLasH.Utils.Pretty
35 import qualified CLasH.Utils.Core.CoreTools as CoreTools
36 import CLasH.VHDL.VHDLTypes
37 import qualified CLasH.VHDL.VHDLTools as VHDLTools
39 -- Apply the given transformation to all expressions in the given expression,
40 -- including the expression itself.
41 everywhere :: (String, Transform) -> Transform
42 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
44 -- Apply the first transformation, followed by the second transformation, and
45 -- keep applying both for as long as expression still changes.
46 applyboth :: Transform -> (String, Transform) -> Transform
47 applyboth first (name, second) expr = do
51 (expr'', changed) <- Writer.listen $ second expr'
53 -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
56 -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
57 -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
58 applyboth first (name, second) $
61 -- trace ("No changes") $
64 -- Apply the given transformation to all direct subexpressions (only), not the
66 subeverywhere :: Transform -> Transform
67 subeverywhere trans (App a b) = do
72 subeverywhere trans (Let (NonRec b bexpr) expr) = do
75 return $ Let (NonRec b bexpr') expr'
77 subeverywhere trans (Let (Rec binds) expr) = do
79 binds' <- mapM transbind binds
80 return $ Let (Rec binds') expr'
82 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
87 subeverywhere trans (Lam x expr) = do
91 subeverywhere trans (Case scrut b t alts) = do
93 alts' <- mapM transalt alts
94 return $ Case scrut' b t alts'
96 transalt :: CoreAlt -> TransformMonad CoreAlt
97 transalt (con, binders, expr) = do
99 return (con, binders, expr')
101 subeverywhere trans (Var x) = return $ Var x
102 subeverywhere trans (Lit x) = return $ Lit x
103 subeverywhere trans (Type x) = return $ Type x
105 subeverywhere trans (Cast expr ty) = do
107 return $ Cast expr' ty
109 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
111 -- Apply the given transformation to all expressions, except for direct
112 -- arguments of an application
113 notappargs :: (String, Transform) -> Transform
114 notappargs trans = applyboth (subnotappargs trans) trans
116 -- Apply the given transformation to all (direct and indirect) subexpressions
117 -- (but not the expression itself), except for direct arguments of an
119 subnotappargs :: (String, Transform) -> Transform
120 subnotappargs trans (App a b) = do
121 a' <- subnotappargs trans a
122 b' <- subnotappargs trans b
125 -- Let subeverywhere handle all other expressions
126 subnotappargs trans expr = subeverywhere (notappargs trans) expr
128 -- Runs each of the transforms repeatedly inside the State monad.
129 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
130 dotransforms transs expr = do
131 (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
132 if Monoid.getAny changed then dotransforms transs expr' else return expr'
134 -- Inline all let bindings that satisfy the given condition
135 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
136 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
137 applies <- condition (bndr, expr')
140 -- Substitute the binding in res and return that
141 res' <- substitute_clone bndr expr' res
144 -- Don't change this let
146 -- Leave all other expressions unchanged
147 inlinebind _ expr = return expr
149 -- Sets the changed flag in the TransformMonad, to signify that some
150 -- transform has changed the result
151 setChanged :: TransformMonad ()
152 setChanged = Writer.tell (Monoid.Any True)
154 -- Sets the changed flag and returns the given value.
155 change :: a -> TransformMonad a
160 -- Returns the given value and sets the changed flag if the bool given is
161 -- True. Note that this will not unset the changed flag if the bool is False.
162 changeif :: Bool -> a -> TransformMonad a
163 changeif True val = change val
164 changeif False val = return val
166 -- | Creates a transformation that substitutes the given binder with the given
167 -- expression (This can be a type variable, replace by a Type expression).
168 -- Does not set the changed flag.
169 substitute :: CoreBndr -> CoreExpr -> Transform
170 -- Use CoreSubst to subst a type var in an expression
171 substitute find repl expr = do
172 let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
173 return $ CoreSubst.substExpr subst expr
175 -- | Creates a transformation that substitutes the given binder with the given
176 -- expression. This does only work for value expressions! All binders in the
177 -- expression are cloned before the replacement, to guarantee uniqueness.
178 substitute_clone :: CoreBndr -> CoreExpr -> Transform
179 -- If we see the var to find, replace it by a uniqued version of repl
180 substitute_clone find repl (Var var) | find == var = do
181 repl' <- Trans.lift $ CoreTools.genUniques repl
184 -- For all other expressions, just look in subexpressions
185 substitute_clone find repl expr = subeverywhere (substitute_clone find repl) expr
187 -- Is the given expression representable at runtime, based on the type?
188 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
189 isRepr tything = case CoreTools.getType tything of
190 Nothing -> return False
191 Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
193 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
194 is_local_var (CoreSyn.Var v) = do
195 bndrs <- getGlobalBinders
196 return $ not $ v `elem` bndrs
197 is_local_var _ = return False
199 -- Is the given binder defined by the user?
200 isUserDefined :: CoreSyn.CoreBndr -> Bool
201 -- System names are certain to not be user defined
202 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
203 -- Check a list of typical compiler-defined names
204 isUserDefined bndr = not $ str `elem` compiler_names
206 str = Name.getOccString bndr
207 -- These are names of bindings usually generated by the compiler. For some
208 -- reason these are not marked as system, probably because the name itself
209 -- is not made up by the compiler, just this particular binding is.
210 compiler_names = ["fromInteger"]
212 -- Is the given binder normalizable? This means that its type signature can be
213 -- represented in hardware, which should (?) guarantee that it can be made
214 -- into hardware. Note that if a binder is not normalizable, it might become
215 -- so using argument propagation.
216 isNormalizeable :: CoreBndr -> TransformMonad Bool
217 isNormalizeable bndr = do
218 let ty = Id.idType bndr
219 let (arg_tys, res_ty) = Type.splitFunTys ty
220 -- This function is normalizable if all its arguments and return value are
222 andM $ mapM isRepr (res_ty:arg_tys)