2 -- This module provides functions for program transformations.
4 module CLasH.Normalize.NormalizeTools where
7 import qualified Data.Monoid as Monoid
8 import qualified Data.Either as Either
9 import qualified Control.Monad as Monad
10 import qualified Control.Monad.Trans.Writer as Writer
11 import qualified Control.Monad.Trans.Class as Trans
12 import qualified Data.Accessor.Monad.Trans.State as MonadState
18 import qualified CoreSubst
20 import qualified CoreUtils
21 import Outputable ( showSDoc, ppr, nest )
24 import CLasH.Normalize.NormalizeTypes
25 import CLasH.Translator.TranslatorTypes
26 import CLasH.VHDL.Constants (builtinIds)
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 :: Transform -> Transform
34 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
37 NormDbgNone -- ^ No debugging
38 | NormDbgFinal -- ^ Print functions before / after normalization
39 | NormDbgApplied -- ^ Print expressions before / after applying transformations
40 | NormDbgAll -- ^ Print expressions when a transformation does not apply
42 normalize_debug = NormDbgFinal
44 -- Applies a transform, optionally showing some debug output.
45 apply :: (String, Transform) -> Transform
46 apply (name, trans) ctx expr = do
47 -- Apply the transformation and find out if it changed anything
48 (expr', any_changed) <- Writer.listen $ trans ctx expr
49 let changed = Monoid.getAny any_changed
50 -- If it changed, increase the transformation counter
51 Monad.when changed $ Trans.lift (MonadState.modify tsTransformCounter (+1))
52 -- Prepare some debug strings
53 let before = showSDoc (nest 4 $ ppr expr) ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr) ++ "\n"
54 let context = "Context: " ++ show ctx ++ "\n"
55 let after = showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
56 traceIf (normalize_debug >= NormDbgApplied && changed) ("Changes when applying transform " ++ name ++ " to:\n" ++ before ++ context ++ "Result:\n" ++ after) $
57 traceIf (normalize_debug >= NormDbgAll && not changed) ("No changes when applying transform " ++ name ++ " to:\n" ++ before ++ context) $
60 -- Apply the first transformation, followed by the second transformation, and
61 -- keep applying both for as long as expression still changes.
62 applyboth :: Transform -> Transform -> Transform
63 applyboth first second context expr = do
65 expr' <- first context expr
67 (expr'', changed) <- Writer.listen $ second context expr'
68 if Monoid.getAny $ changed
70 applyboth first second context expr''
74 -- Apply the given transformation to all direct subexpressions (only), not the
76 subeverywhere :: Transform -> Transform
77 subeverywhere trans c (App a b) = do
78 a' <- trans (AppFirst:c) a
79 b' <- trans (AppSecond:c) b
82 subeverywhere trans c (Let (NonRec b bexpr) expr) = do
83 bexpr' <- trans (LetBinding:c) bexpr
84 expr' <- trans (LetBody:c) expr
85 return $ Let (NonRec b bexpr') expr'
87 subeverywhere trans c (Let (Rec binds) expr) = do
88 expr' <- trans (LetBody:c) expr
89 binds' <- mapM transbind binds
90 return $ Let (Rec binds') expr'
92 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
94 e' <- trans (LetBinding:c) e
97 subeverywhere trans c (Lam x expr) = do
98 expr' <- trans (LambdaBody:c) expr
101 subeverywhere trans c (Case scrut b t alts) = do
102 scrut' <- trans (Other:c) scrut
103 alts' <- mapM transalt alts
104 return $ Case scrut' b t alts'
106 transalt :: CoreAlt -> TransformMonad CoreAlt
107 transalt (con, binders, expr) = do
108 expr' <- trans (Other:c) expr
109 return (con, binders, expr')
111 subeverywhere trans c (Var x) = return $ Var x
112 subeverywhere trans c (Lit x) = return $ Lit x
113 subeverywhere trans c (Type x) = return $ Type x
115 subeverywhere trans c (Cast expr ty) = do
116 expr' <- trans (Other:c) expr
117 return $ Cast expr' ty
119 subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
121 -- Runs each of the transforms repeatedly inside the State monad.
122 dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr
123 dotransforms transs expr = do
124 (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere (apply trans) [] e) expr transs
125 if Monoid.getAny changed then dotransforms transs expr' else return expr'
127 -- Inline all let bindings that satisfy the given condition
128 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
129 inlinebind condition context expr@(Let (Rec binds) res) = do
130 -- Find all bindings that adhere to the condition
131 res_eithers <- mapM docond binds
132 case Either.partitionEithers res_eithers of
133 -- No replaces? No change
134 ([], _) -> return expr
135 (replace, others) -> do
136 -- Substitute the to be replaced binders with their expression
137 newexpr <- do_substitute replace (Let (Rec others) res)
140 -- Apply the condition to a let binding and return an Either
141 -- depending on whether it needs to be inlined or not.
142 docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
145 return $ case res of True -> Left b; False -> Right b
147 -- Apply the given list of substitutions to the the given expression
148 do_substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> TransformMonad CoreExpr
149 do_substitute [] expr = return expr
150 do_substitute ((bndr, val):reps) expr = do
151 -- Perform this substitution in the expression
152 expr' <- substitute_clone bndr val context expr
153 -- And in the substitution values we will be using next
154 reps' <- mapM (subs_bind bndr val) reps
155 -- And then perform the remaining substitutions
156 do_substitute reps' expr'
158 -- Replace the given binder with the given expression in the
159 -- expression oft the given let binding
160 subs_bind :: CoreBndr -> CoreExpr -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
161 subs_bind bndr expr (b, v) = do
162 v' <- substitute_clone bndr expr (LetBinding:context) v
166 -- Leave all other expressions unchanged
167 inlinebind _ context expr = return expr
169 -- Sets the changed flag in the TransformMonad, to signify that some
170 -- transform has changed the result
171 setChanged :: TransformMonad ()
172 setChanged = Writer.tell (Monoid.Any True)
174 -- Sets the changed flag and returns the given value.
175 change :: a -> TransformMonad a
180 -- Returns the given value and sets the changed flag if the bool given is
181 -- True. Note that this will not unset the changed flag if the bool is False.
182 changeif :: Bool -> a -> TransformMonad a
183 changeif True val = change val
184 changeif False val = return val
186 -- | Creates a transformation that substitutes the given binder with the given
187 -- expression (This can be a type variable, replace by a Type expression).
188 -- Does not set the changed flag.
189 substitute :: CoreBndr -> CoreExpr -> Transform
190 -- Use CoreSubst to subst a type var in an expression
191 substitute find repl context expr = do
192 let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
193 return $ CoreSubst.substExpr subst expr
195 -- | Creates a transformation that substitutes the given binder with the given
196 -- expression. This does only work for value expressions! All binders in the
197 -- expression are cloned before the replacement, to guarantee uniqueness.
198 substitute_clone :: CoreBndr -> CoreExpr -> Transform
199 -- If we see the var to find, replace it by a uniqued version of repl
200 substitute_clone find repl context (Var var) | find == var = do
201 repl' <- Trans.lift $ CoreTools.genUniques repl
204 -- For all other expressions, just look in subexpressions
205 substitute_clone find repl context expr = subeverywhere (substitute_clone find repl) context expr
207 -- Is the given expression representable at runtime, based on the type?
208 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
209 isRepr tything = Trans.lift (isRepr' tything)
211 isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
212 isRepr' tything = case CoreTools.getType tything of
213 Nothing -> return False
214 Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty
216 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
217 is_local_var (CoreSyn.Var v) = do
218 bndrs <- getGlobalBinders
219 return $ v `notElem` bndrs
220 is_local_var _ = return False
222 -- Is the given binder defined by the user?
223 isUserDefined :: CoreSyn.CoreBndr -> Bool
224 -- System names are certain to not be user defined
225 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
226 -- Builtin functions are usually not user-defined either (and would
227 -- break currently if they are...)
228 isUserDefined bndr = str `notElem` builtinIds
230 str = Name.getOccString bndr
232 -- | Is the given binder normalizable? This means that its type signature can be
233 -- represented in hardware, which should (?) guarantee that it can be made
234 -- into hardware. This checks whether all the arguments and (optionally)
235 -- the return value are
238 Bool -- ^ Allow the result to be unrepresentable?
239 -> CoreBndr -- ^ The binder to check
240 -> TranslatorSession Bool -- ^ Is it normalizeable?
241 isNormalizeable result_nonrep bndr = do
242 let ty = Id.idType bndr
243 let (arg_tys, res_ty) = Type.splitFunTys ty
244 let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys)
245 andM $ mapM isRepr' check_tys