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 CLasH.VHDL.VHDLTypes
34 import qualified CLasH.VHDL.VHDLTools as VHDLTools
36 -- Apply the given transformation to all expressions in the given expression,
37 -- including the expression itself.
38 everywhere :: (String, Transform) -> Transform
39 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
41 -- Apply the first transformation, followed by the second transformation, and
42 -- keep applying both for as long as expression still changes.
43 applyboth :: Transform -> (String, Transform) -> Transform
44 applyboth first (name, second) expr = do
48 (expr'', changed) <- Writer.listen $ second expr'
50 -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
53 -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
54 -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
55 applyboth first (name, second) $
58 -- trace ("No changes") $
61 -- Apply the given transformation to all direct subexpressions (only), not the
63 subeverywhere :: Transform -> Transform
64 subeverywhere trans (App a b) = do
69 subeverywhere trans (Let (NonRec b bexpr) expr) = do
72 return $ Let (NonRec b bexpr') expr'
74 subeverywhere trans (Let (Rec binds) expr) = do
76 binds' <- mapM transbind binds
77 return $ Let (Rec binds') expr'
79 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
84 subeverywhere trans (Lam x expr) = do
88 subeverywhere trans (Case scrut b t alts) = do
90 alts' <- mapM transalt alts
91 return $ Case scrut' b t alts'
93 transalt :: CoreAlt -> TransformMonad CoreAlt
94 transalt (con, binders, expr) = do
96 return (con, binders, expr')
98 subeverywhere trans (Var x) = return $ Var x
99 subeverywhere trans (Lit x) = return $ Lit x
100 subeverywhere trans (Type x) = return $ Type x
102 subeverywhere trans (Cast expr ty) = do
104 return $ Cast expr' ty
106 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
108 -- Apply the given transformation to all expressions, except for direct
109 -- arguments of an application
110 notappargs :: (String, Transform) -> Transform
111 notappargs trans = applyboth (subnotappargs trans) trans
113 -- Apply the given transformation to all (direct and indirect) subexpressions
114 -- (but not the expression itself), except for direct arguments of an
116 subnotappargs :: (String, Transform) -> Transform
117 subnotappargs trans (App a b) = do
118 a' <- subnotappargs trans a
119 b' <- subnotappargs trans b
122 -- Let subeverywhere handle all other expressions
123 subnotappargs trans expr = subeverywhere (notappargs trans) expr
125 -- Runs each of the transforms repeatedly inside the State monad.
126 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
127 dotransforms transs expr = do
128 (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
129 if Monoid.getAny changed then dotransforms transs expr' else return expr'
131 -- Inline all let bindings that satisfy the given condition
132 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
133 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
134 applies <- condition (bndr, expr')
137 -- Substitute the binding in res and return that
138 change $ substitute [(bndr, expr')] res
140 -- Don't change this let
142 -- Leave all other expressions unchanged
143 inlinebind _ expr = return expr
145 -- Sets the changed flag in the TransformMonad, to signify that some
146 -- transform has changed the result
147 setChanged :: TransformMonad ()
148 setChanged = Writer.tell (Monoid.Any True)
150 -- Sets the changed flag and returns the given value.
151 change :: a -> TransformMonad a
156 -- Returns the given value and sets the changed flag if the bool given is
157 -- True. Note that this will not unset the changed flag if the bool is False.
158 changeif :: Bool -> a -> TransformMonad a
159 changeif True val = change val
160 changeif False val = return val
162 -- Replace each of the binders given with the coresponding expressions in the
164 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
165 substitute [] expr = expr
166 -- Apply one substitution on the expression, but also on any remaining
167 -- substitutions. This seems to be the only way to handle substitutions like
168 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
169 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
170 -- TODO: Find out how this works, exactly.
171 substitute ((b, e):subss) expr = substitute subss' expr'
174 subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
175 -- Apply this substitution to the main expression
176 expr' = CoreSubst.substExpr subs expr
177 -- Apply this substitution on all the expressions in the remaining
179 subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
181 -- Is the given expression representable at runtime, based on the type?
182 isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
183 isRepr (Type ty) = return False
184 isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)
186 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
187 is_local_var (CoreSyn.Var v) = do
188 bndrs <- getGlobalBinders
189 return $ not $ v `elem` bndrs
190 is_local_var _ = return False
192 -- Is the given binder defined by the user?
193 isUserDefined :: CoreSyn.CoreBndr -> Bool
194 -- System names are certain to not be user defined
195 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
196 -- Assume everything else is user defined
197 isUserDefined bdnr = True