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