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.MonadState 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 change $ substitute [(bndr, expr')] res
143 -- Don't change this let
145 -- Leave all other expressions unchanged
146 inlinebind _ expr = return expr
148 -- Sets the changed flag in the TransformMonad, to signify that some
149 -- transform has changed the result
150 setChanged :: TransformMonad ()
151 setChanged = Writer.tell (Monoid.Any True)
153 -- Sets the changed flag and returns the given value.
154 change :: a -> TransformMonad a
159 -- Returns the given value and sets the changed flag if the bool given is
160 -- True. Note that this will not unset the changed flag if the bool is False.
161 changeif :: Bool -> a -> TransformMonad a
162 changeif True val = change val
163 changeif False val = return val
165 -- Replace each of the binders given with the coresponding expressions in the
167 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
168 substitute [] expr = expr
169 -- Apply one substitution on the expression, but also on any remaining
170 -- substitutions. This seems to be the only way to handle substitutions like
171 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
172 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
173 -- TODO: Find out how this works, exactly.
174 substitute ((b, e):subss) expr = substitute subss' expr'
177 subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
178 -- Apply this substitution to the main expression
179 expr' = CoreSubst.substExpr subs expr
180 -- Apply this substitution on all the expressions in the remaining
182 subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
184 -- Is the given expression representable at runtime, based on the type?
185 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
186 isRepr tything = case CoreTools.getType tything of
187 Nothing -> return False
188 Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
190 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
191 is_local_var (CoreSyn.Var v) = do
192 bndrs <- getGlobalBinders
193 return $ not $ v `elem` bndrs
194 is_local_var _ = return False
196 -- Is the given binder defined by the user?
197 isUserDefined :: CoreSyn.CoreBndr -> Bool
198 -- System names are certain to not be user defined
199 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
200 -- Check a list of typical compiler-defined names
201 isUserDefined bndr = str `elem` compiler_names
203 str = Name.getOccString bndr
204 -- These are names of bindings usually generated by the compiler. For some
205 -- reason these are not marked as system, probably because the name itself
206 -- is not made up by the compiler, just this particular binding is.
207 compiler_names = ["fromInteger"]
209 -- Is the given binder normalizable? This means that its type signature can be
210 -- represented in hardware, which should (?) guarantee that it can be made
211 -- into hardware. Note that if a binder is not normalizable, it might become
212 -- so using argument propagation.
213 isNormalizeable :: CoreBndr -> TransformMonad Bool
214 isNormalizeable bndr = do
215 let ty = Id.idType bndr
216 let (arg_tys, res_ty) = Type.splitFunTys ty
217 -- This function is normalizable if all its arguments and return value are
219 andM $ mapM isRepr (res_ty:arg_tys)