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
27 import Outputable ( showSDoc, ppr, nest )
30 import CLasH.Normalize.NormalizeTypes
31 import CLasH.Translator.TranslatorTypes
32 import CLasH.Utils.Pretty
33 import qualified CLasH.Utils.Core.CoreTools as CoreTools
34 import CLasH.VHDL.VHDLTypes
35 import qualified CLasH.VHDL.VHDLTools as VHDLTools
37 -- Apply the given transformation to all expressions in the given expression,
38 -- including the expression itself.
39 everywhere :: (String, Transform) -> Transform
40 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
42 -- Apply the first transformation, followed by the second transformation, and
43 -- keep applying both for as long as expression still changes.
44 applyboth :: Transform -> (String, Transform) -> Transform
45 applyboth first (name, second) expr = do
49 (expr'', changed) <- Writer.listen $ second expr'
51 -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
54 -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
55 -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
56 applyboth first (name, second) $
59 -- trace ("No changes") $
62 -- Apply the given transformation to all direct subexpressions (only), not the
64 subeverywhere :: Transform -> Transform
65 subeverywhere trans (App a b) = do
70 subeverywhere trans (Let (NonRec b bexpr) expr) = do
73 return $ Let (NonRec b bexpr') expr'
75 subeverywhere trans (Let (Rec binds) expr) = do
77 binds' <- mapM transbind binds
78 return $ Let (Rec binds') expr'
80 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
85 subeverywhere trans (Lam x expr) = do
89 subeverywhere trans (Case scrut b t alts) = do
91 alts' <- mapM transalt alts
92 return $ Case scrut' b t alts'
94 transalt :: CoreAlt -> TransformMonad CoreAlt
95 transalt (con, binders, expr) = do
97 return (con, binders, expr')
99 subeverywhere trans (Var x) = return $ Var x
100 subeverywhere trans (Lit x) = return $ Lit x
101 subeverywhere trans (Type x) = return $ Type x
103 subeverywhere trans (Cast expr ty) = do
105 return $ Cast expr' ty
107 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
109 -- Apply the given transformation to all expressions, except for direct
110 -- arguments of an application
111 notappargs :: (String, Transform) -> Transform
112 notappargs trans = applyboth (subnotappargs trans) trans
114 -- Apply the given transformation to all (direct and indirect) subexpressions
115 -- (but not the expression itself), except for direct arguments of an
117 subnotappargs :: (String, Transform) -> Transform
118 subnotappargs trans (App a b) = do
119 a' <- subnotappargs trans a
120 b' <- subnotappargs trans b
123 -- Let subeverywhere handle all other expressions
124 subnotappargs trans expr = subeverywhere (notappargs trans) expr
126 -- Runs each of the transforms repeatedly inside the State monad.
127 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
128 dotransforms transs expr = do
129 (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
130 if Monoid.getAny changed then dotransforms transs expr' else return expr'
132 -- Inline all let bindings that satisfy the given condition
133 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
134 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
135 applies <- condition (bndr, expr')
138 -- Substitute the binding in res and return that
139 change $ substitute [(bndr, expr')] res
141 -- Don't change this let
143 -- Leave all other expressions unchanged
144 inlinebind _ expr = return expr
146 -- Sets the changed flag in the TransformMonad, to signify that some
147 -- transform has changed the result
148 setChanged :: TransformMonad ()
149 setChanged = Writer.tell (Monoid.Any True)
151 -- Sets the changed flag and returns the given value.
152 change :: a -> TransformMonad a
157 -- Returns the given value and sets the changed flag if the bool given is
158 -- True. Note that this will not unset the changed flag if the bool is False.
159 changeif :: Bool -> a -> TransformMonad a
160 changeif True val = change val
161 changeif False val = return val
163 -- Replace each of the binders given with the coresponding expressions in the
165 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
166 substitute [] expr = expr
167 -- Apply one substitution on the expression, but also on any remaining
168 -- substitutions. This seems to be the only way to handle substitutions like
169 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
170 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
171 -- TODO: Find out how this works, exactly.
172 substitute ((b, e):subss) expr = substitute subss' expr'
175 subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
176 -- Apply this substitution to the main expression
177 expr' = CoreSubst.substExpr subs expr
178 -- Apply this substitution on all the expressions in the remaining
180 subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
182 -- Is the given expression representable at runtime, based on the type?
183 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
184 isRepr tything = case CoreTools.getType tything of
185 Nothing -> return False
186 Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
188 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
189 is_local_var (CoreSyn.Var v) = do
190 bndrs <- getGlobalBinders
191 return $ not $ v `elem` bndrs
192 is_local_var _ = return False
194 -- Is the given binder defined by the user?
195 isUserDefined :: CoreSyn.CoreBndr -> Bool
196 -- System names are certain to not be user defined
197 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
198 -- Check a list of typical compiler-defined names
199 isUserDefined bndr = str `elem` compiler_names
201 str = Name.getOccString bndr
202 -- These are names of bindings usually generated by the compiler. For some
203 -- reason these are not marked as system, probably because the name itself
204 -- is not made up by the compiler, just this particular binding is.
205 compiler_names = ["fromInteger"]