Add variant of isRepr that operates in the TranslatorSession.
[matthijs/master-project/cλash.git] / cλash / CLasH / Normalize / NormalizeTools.hs
1 {-# LANGUAGE PackageImports #-}
2 -- 
3 -- This module provides functions for program transformations.
4 --
5 module CLasH.Normalize.NormalizeTools where
6
7 -- Standard modules
8 import qualified Data.Monoid as Monoid
9 import qualified Control.Monad as Monad
10 import qualified Control.Monad.Trans.Writer as Writer
11 import qualified "transformers" Control.Monad.Trans as Trans
12 import qualified Data.Accessor.Monad.Trans.State as MonadState
13 -- import Debug.Trace
14
15 -- GHC API
16 import CoreSyn
17 import qualified Name
18 import qualified Id
19 import qualified CoreSubst
20 import qualified Type
21 -- import qualified CoreUtils
22 -- import Outputable ( showSDoc, ppr, nest )
23
24 -- Local imports
25 import CLasH.Normalize.NormalizeTypes
26 import CLasH.Translator.TranslatorTypes
27 import CLasH.Utils
28 import qualified CLasH.Utils.Core.CoreTools as CoreTools
29 import qualified CLasH.VHDL.VHDLTools as VHDLTools
30
31 -- Apply the given transformation to all expressions in the given expression,
32 -- including the expression itself.
33 everywhere :: (String, Transform) -> Transform
34 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
35
36 -- Apply the first transformation, followed by the second transformation, and
37 -- keep applying both for as long as expression still changes.
38 applyboth :: Transform -> (String, Transform) -> Transform
39 applyboth first (name, second) expr = do
40   -- Apply the first
41   expr' <- first expr
42   -- Apply the second
43   (expr'', changed) <- Writer.listen $ second expr'
44   if Monoid.getAny $
45         -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n")
46         changed 
47     then 
48      -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
49      -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
50       applyboth first (name, second)
51         expr'' 
52     else 
53       -- trace ("No changes") $
54       return expr''
55
56 -- Apply the given transformation to all direct subexpressions (only), not the
57 -- expression itself.
58 subeverywhere :: Transform -> Transform
59 subeverywhere trans (App a b) = do
60   a' <- trans a
61   b' <- trans b
62   return $ App a' b'
63
64 subeverywhere trans (Let (NonRec b bexpr) expr) = do
65   bexpr' <- trans bexpr
66   expr' <- trans expr
67   return $ Let (NonRec b bexpr') expr'
68
69 subeverywhere trans (Let (Rec binds) expr) = do
70   expr' <- trans expr
71   binds' <- mapM transbind binds
72   return $ Let (Rec binds') expr'
73   where
74     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
75     transbind (b, e) = do
76       e' <- trans e
77       return (b, e')
78
79 subeverywhere trans (Lam x expr) = do
80   expr' <- trans expr
81   return $ Lam x expr'
82
83 subeverywhere trans (Case scrut b t alts) = do
84   scrut' <- trans scrut
85   alts' <- mapM transalt alts
86   return $ Case scrut' b t alts'
87   where
88     transalt :: CoreAlt -> TransformMonad CoreAlt
89     transalt (con, binders, expr) = do
90       expr' <- trans expr
91       return (con, binders, expr')
92
93 subeverywhere trans (Var x) = return $ Var x
94 subeverywhere trans (Lit x) = return $ Lit x
95 subeverywhere trans (Type x) = return $ Type x
96
97 subeverywhere trans (Cast expr ty) = do
98   expr' <- trans expr
99   return $ Cast expr' ty
100
101 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
102
103 -- Apply the given transformation to all expressions, except for direct
104 -- arguments of an application
105 notappargs :: (String, Transform) -> Transform
106 notappargs trans = applyboth (subnotappargs trans) trans
107
108 -- Apply the given transformation to all (direct and indirect) subexpressions
109 -- (but not the expression itself), except for direct arguments of an
110 -- application
111 subnotappargs :: (String, Transform) -> Transform
112 subnotappargs trans (App a b) = do
113   a' <- subnotappargs trans a
114   b' <- subnotappargs trans b
115   return $ App a' b'
116
117 -- Let subeverywhere handle all other expressions
118 subnotappargs trans expr = subeverywhere (notappargs trans) expr
119
120 -- Runs each of the transforms repeatedly inside the State monad.
121 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
122 dotransforms transs expr = do
123   (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
124   if Monoid.getAny changed then dotransforms transs expr' else return expr'
125
126 -- Inline all let bindings that satisfy the given condition
127 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
128 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
129     applies <- condition (bndr, expr')
130     if applies
131       then do
132         -- Substitute the binding in res and return that
133         res' <- substitute_clone bndr expr' res
134         change res'
135       else
136         -- Don't change this let
137         return expr
138 -- Leave all other expressions unchanged
139 inlinebind _ expr = return expr
140
141 -- Sets the changed flag in the TransformMonad, to signify that some
142 -- transform has changed the result
143 setChanged :: TransformMonad ()
144 setChanged = Writer.tell (Monoid.Any True)
145
146 -- Sets the changed flag and returns the given value.
147 change :: a -> TransformMonad a
148 change val = do
149   setChanged
150   return val
151
152 -- Returns the given value and sets the changed flag if the bool given is
153 -- True. Note that this will not unset the changed flag if the bool is False.
154 changeif :: Bool -> a -> TransformMonad a
155 changeif True val = change val
156 changeif False val = return val
157
158 -- | Creates a transformation that substitutes the given binder with the given
159 -- expression (This can be a type variable, replace by a Type expression).
160 -- Does not set the changed flag.
161 substitute :: CoreBndr -> CoreExpr -> Transform
162 -- Use CoreSubst to subst a type var in an expression
163 substitute find repl expr = do
164   let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
165   return $ CoreSubst.substExpr subst expr 
166
167 -- | Creates a transformation that substitutes the given binder with the given
168 -- expression. This does only work for value expressions! All binders in the
169 -- expression are cloned before the replacement, to guarantee uniqueness.
170 substitute_clone :: CoreBndr -> CoreExpr -> Transform
171 -- If we see the var to find, replace it by a uniqued version of repl
172 substitute_clone find repl (Var var) | find == var = do
173   repl' <- Trans.lift $ CoreTools.genUniques repl
174   change repl'
175
176 -- For all other expressions, just look in subexpressions
177 substitute_clone find repl expr = subeverywhere (substitute_clone find repl) expr
178
179 -- Is the given expression representable at runtime, based on the type?
180 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
181 isRepr tything = Trans.lift (isRepr' tything)
182
183 isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
184 isRepr' tything = case CoreTools.getType tything of
185   Nothing -> return False
186   Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty 
187
188 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
189 is_local_var (CoreSyn.Var v) = do
190   bndrs <- getGlobalBinders
191   return $ v `notElem` bndrs
192 is_local_var _ = return False
193
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 `notElem` compiler_names
200   where
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", "head", "tail", "init", "last", "+", "*", "-", "!"]
206
207 -- Is the given binder normalizable? This means that its type signature can be
208 -- represented in hardware, which should (?) guarantee that it can be made
209 -- into hardware. Note that if a binder is not normalizable, it might become
210 -- so using argument propagation.
211 isNormalizeable :: CoreBndr -> TransformMonad Bool 
212 isNormalizeable bndr = do
213   let ty = Id.idType bndr
214   let (arg_tys, res_ty) = Type.splitFunTys ty
215   -- This function is normalizable if all its arguments and return value are
216   -- representable.
217   andM $ mapM isRepr (res_ty:arg_tys)