1 {-# LANGUAGE PackageImports #-}
3 -- This module provides functions for program transformations.
5 module NormalizeTools where
9 import qualified Data.Monoid as Monoid
10 import qualified Control.Arrow as Arrow
11 import qualified Control.Monad as Monad
12 import qualified Control.Monad.Trans.State as State
13 import qualified Control.Monad.Trans.Writer as Writer
14 import qualified "transformers" Control.Monad.Trans as Trans
15 import qualified Data.Map as Map
17 import Data.Accessor.MonadState as MonadState
21 import qualified UniqSupply
22 import qualified Unique
23 import qualified OccName
26 import qualified SrcLoc
28 import qualified IdInfo
29 import qualified CoreUtils
30 import qualified CoreSubst
31 import qualified VarSet
32 import Outputable ( showSDoc, ppr, nest )
37 import qualified VHDLTools
39 -- Create a new internal var with the given name and type. A Unique is
40 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
41 -- since the Unique is also stored in the name, but this ensures variable
42 -- names are unique in the output).
43 mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
44 mkInternalVar str ty = do
46 let occname = OccName.mkVarOcc (str ++ show uniq)
47 let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
48 return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
50 -- Create a new type variable with the given name and kind. A Unique is
51 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
52 -- since the Unique is also stored in the name, but this ensures variable
53 -- names are unique in the output).
54 mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var
55 mkTypeVar str kind = do
57 let occname = OccName.mkVarOcc (str ++ show uniq)
58 let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
59 return $ Var.mkTyVar name kind
61 -- Creates a binder for the given expression with the given name. This
62 -- works for both value and type level expressions, so it can return a Var or
63 -- TyVar (which is just an alias for Var).
64 mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var
65 mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty)
66 mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
68 -- Creates a reference to the given variable. This works for both a normal
69 -- variable as well as a type variable
70 mkReferenceTo :: Var.Var -> CoreExpr
71 mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
72 | otherwise = (Var var)
74 cloneVar :: Var.Var -> TransformMonad Var.Var
77 -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
78 -- contains, but vannillaIdInfo is always correct, since it means "no info").
79 return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
81 -- Creates a new function with the same name as the given binder (but with a
82 -- new unique) and with the given function body. Returns the new binder for
84 mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr
85 mkFunction bndr body = do
86 let ty = CoreUtils.exprType body
88 let newid = Var.setVarType id ty
89 Trans.lift $ addGlobalBind newid body
92 -- Apply the given transformation to all expressions in the given expression,
93 -- including the expression itself.
94 everywhere :: (String, Transform) -> Transform
95 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
97 -- Apply the first transformation, followed by the second transformation, and
98 -- keep applying both for as long as expression still changes.
99 applyboth :: Transform -> (String, Transform) -> Transform
100 applyboth first (name, second) expr = do
104 (expr'', changed) <- Writer.listen $ second expr'
106 -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
109 -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
110 -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
111 applyboth first (name, second) $
114 -- trace ("No changes") $
117 -- Apply the given transformation to all direct subexpressions (only), not the
118 -- expression itself.
119 subeverywhere :: Transform -> Transform
120 subeverywhere trans (App a b) = do
125 subeverywhere trans (Let (NonRec b bexpr) expr) = do
126 bexpr' <- trans bexpr
128 return $ Let (NonRec b bexpr') expr'
130 subeverywhere trans (Let (Rec binds) expr) = do
132 binds' <- mapM transbind binds
133 return $ Let (Rec binds') expr'
135 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
136 transbind (b, e) = do
140 subeverywhere trans (Lam x expr) = do
144 subeverywhere trans (Case scrut b t alts) = do
145 scrut' <- trans scrut
146 alts' <- mapM transalt alts
147 return $ Case scrut' b t alts'
149 transalt :: CoreAlt -> TransformMonad CoreAlt
150 transalt (con, binders, expr) = do
152 return (con, binders, expr')
154 subeverywhere trans (Var x) = return $ Var x
155 subeverywhere trans (Lit x) = return $ Lit x
156 subeverywhere trans (Type x) = return $ Type x
158 subeverywhere trans (Cast expr ty) = do
160 return $ Cast expr' ty
162 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
164 -- Apply the given transformation to all expressions, except for direct
165 -- arguments of an application
166 notappargs :: (String, Transform) -> Transform
167 notappargs trans = applyboth (subnotappargs trans) trans
169 -- Apply the given transformation to all (direct and indirect) subexpressions
170 -- (but not the expression itself), except for direct arguments of an
172 subnotappargs :: (String, Transform) -> Transform
173 subnotappargs trans (App a b) = do
174 a' <- subnotappargs trans a
175 b' <- subnotappargs trans b
178 -- Let subeverywhere handle all other expressions
179 subnotappargs trans expr = subeverywhere (notappargs trans) expr
181 -- Runs each of the transforms repeatedly inside the State monad.
182 dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
183 dotransforms transs expr = do
184 (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
185 if Monoid.getAny changed then dotransforms transs expr' else return expr'
187 -- Inline all let bindings that satisfy the given condition
188 inlinebind :: ((CoreBndr, CoreExpr) -> Bool) -> Transform
189 inlinebind condition (Let (Rec binds) expr) | not $ null replace =
192 -- Find all simple bindings
193 (replace, others) = List.partition condition binds
194 -- Substitute the to be replaced binders with their expression
195 newexpr = substitute replace (Let (Rec others) expr)
196 -- Leave all other expressions unchanged
197 inlinebind _ expr = return expr
199 -- Sets the changed flag in the TransformMonad, to signify that some
200 -- transform has changed the result
201 setChanged :: TransformMonad ()
202 setChanged = Writer.tell (Monoid.Any True)
204 -- Sets the changed flag and returns the given value.
205 change :: a -> TransformMonad a
210 -- Create a new Unique
211 mkUnique :: TransformMonad Unique.Unique
212 mkUnique = Trans.lift $ do
213 us <- getA tsUniqSupply
214 let (us', us'') = UniqSupply.splitUniqSupply us
215 putA tsUniqSupply us'
216 return $ UniqSupply.uniqFromSupply us''
218 -- Replace each of the binders given with the coresponding expressions in the
220 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
221 substitute [] expr = expr
222 -- Apply one substitution on the expression, but also on any remaining
223 -- substitutions. This seems to be the only way to handle substitutions like
224 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
225 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
226 -- TODO: Find out how this works, exactly.
227 substitute ((b, e):subss) expr = substitute subss' expr'
230 subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
231 -- Apply this substitution to the main expression
232 expr' = CoreSubst.substExpr subs expr
233 -- Apply this substitution on all the expressions in the remaining
235 subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
237 -- Run a given TransformSession. Used mostly to setup the right calls and
239 runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a
240 runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply)
242 -- Is the given expression representable at runtime, based on the type?
243 isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
244 isRepr (Type ty) = return False
245 isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)