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 Data.Either as Either
11 import qualified Control.Arrow as Arrow
12 import qualified Control.Monad as Monad
13 import qualified Control.Monad.Trans.State as State
14 import qualified Control.Monad.Trans.Writer as Writer
15 import qualified "transformers" Control.Monad.Trans as Trans
16 import qualified Data.Map as Map
18 import Data.Accessor.MonadState as MonadState
22 import qualified UniqSupply
23 import qualified Unique
24 import qualified OccName
27 import qualified SrcLoc
29 import qualified IdInfo
30 import qualified CoreUtils
31 import qualified CoreSubst
32 import qualified VarSet
33 import Outputable ( showSDoc, ppr, nest )
38 import qualified VHDLTools
40 -- Create a new internal var with the given name and type. A Unique is
41 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
42 -- since the Unique is also stored in the name, but this ensures variable
43 -- names are unique in the output).
44 mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
45 mkInternalVar str ty = do
47 let occname = OccName.mkVarOcc (str ++ show uniq)
48 let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
49 return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
51 -- Create a new type variable with the given name and kind. A Unique is
52 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
53 -- since the Unique is also stored in the name, but this ensures variable
54 -- names are unique in the output).
55 mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var
56 mkTypeVar str kind = do
58 let occname = OccName.mkVarOcc (str ++ show uniq)
59 let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
60 return $ Var.mkTyVar name kind
62 -- Creates a binder for the given expression with the given name. This
63 -- works for both value and type level expressions, so it can return a Var or
64 -- TyVar (which is just an alias for Var).
65 mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var
66 mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty)
67 mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
69 -- Creates a reference to the given variable. This works for both a normal
70 -- variable as well as a type variable
71 mkReferenceTo :: Var.Var -> CoreExpr
72 mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
73 | otherwise = (Var var)
75 cloneVar :: Var.Var -> TransformMonad Var.Var
78 -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
79 -- contains, but vannillaIdInfo is always correct, since it means "no info").
80 return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
82 -- Creates a new function with the same name as the given binder (but with a
83 -- new unique) and with the given function body. Returns the new binder for
85 mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr
86 mkFunction bndr body = do
87 let ty = CoreUtils.exprType body
89 let newid = Var.setVarType id ty
90 Trans.lift $ addGlobalBind newid body
93 -- Apply the given transformation to all expressions in the given expression,
94 -- including the expression itself.
95 everywhere :: (String, Transform) -> Transform
96 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
98 -- Apply the first transformation, followed by the second transformation, and
99 -- keep applying both for as long as expression still changes.
100 applyboth :: Transform -> (String, Transform) -> Transform
101 applyboth first (name, second) expr = do
105 (expr'', changed) <- Writer.listen $ second expr'
107 -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
110 -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
111 -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
112 applyboth first (name, second) $
115 -- trace ("No changes") $
118 -- Apply the given transformation to all direct subexpressions (only), not the
119 -- expression itself.
120 subeverywhere :: Transform -> Transform
121 subeverywhere trans (App a b) = do
126 subeverywhere trans (Let (NonRec b bexpr) expr) = do
127 bexpr' <- trans bexpr
129 return $ Let (NonRec b bexpr') expr'
131 subeverywhere trans (Let (Rec binds) expr) = do
133 binds' <- mapM transbind binds
134 return $ Let (Rec binds') expr'
136 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
137 transbind (b, e) = do
141 subeverywhere trans (Lam x expr) = do
145 subeverywhere trans (Case scrut b t alts) = do
146 scrut' <- trans scrut
147 alts' <- mapM transalt alts
148 return $ Case scrut' b t alts'
150 transalt :: CoreAlt -> TransformMonad CoreAlt
151 transalt (con, binders, expr) = do
153 return (con, binders, expr')
155 subeverywhere trans (Var x) = return $ Var x
156 subeverywhere trans (Lit x) = return $ Lit x
157 subeverywhere trans (Type x) = return $ Type x
159 subeverywhere trans (Cast expr ty) = do
161 return $ Cast expr' ty
163 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
165 -- Apply the given transformation to all expressions, except for direct
166 -- arguments of an application
167 notappargs :: (String, Transform) -> Transform
168 notappargs trans = applyboth (subnotappargs trans) trans
170 -- Apply the given transformation to all (direct and indirect) subexpressions
171 -- (but not the expression itself), except for direct arguments of an
173 subnotappargs :: (String, Transform) -> Transform
174 subnotappargs trans (App a b) = do
175 a' <- subnotappargs trans a
176 b' <- subnotappargs trans b
179 -- Let subeverywhere handle all other expressions
180 subnotappargs trans expr = subeverywhere (notappargs trans) expr
182 -- Runs each of the transforms repeatedly inside the State monad.
183 dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
184 dotransforms transs expr = do
185 (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
186 if Monoid.getAny changed then dotransforms transs expr' else return expr'
188 -- Inline all let bindings that satisfy the given condition
189 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
190 inlinebind condition expr@(Let (Rec binds) res) = do
191 -- Find all bindings that adhere to the condition
192 res_eithers <- mapM docond binds
193 case Either.partitionEithers res_eithers of
194 -- No replaces? No change
195 ([], _) -> return expr
196 (replace, others) -> do
197 -- Substitute the to be replaced binders with their expression
198 let newexpr = substitute replace (Let (Rec others) res)
201 docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
204 return $ case res of True -> Left b; False -> Right b
206 -- Leave all other expressions unchanged
207 inlinebind _ expr = return expr
209 -- Sets the changed flag in the TransformMonad, to signify that some
210 -- transform has changed the result
211 setChanged :: TransformMonad ()
212 setChanged = Writer.tell (Monoid.Any True)
214 -- Sets the changed flag and returns the given value.
215 change :: a -> TransformMonad a
220 -- Create a new Unique
221 mkUnique :: TransformMonad Unique.Unique
222 mkUnique = Trans.lift $ do
223 us <- getA tsUniqSupply
224 let (us', us'') = UniqSupply.splitUniqSupply us
225 putA tsUniqSupply us'
226 return $ UniqSupply.uniqFromSupply us''
228 -- Replace each of the binders given with the coresponding expressions in the
230 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
231 substitute [] expr = expr
232 -- Apply one substitution on the expression, but also on any remaining
233 -- substitutions. This seems to be the only way to handle substitutions like
234 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
235 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
236 -- TODO: Find out how this works, exactly.
237 substitute ((b, e):subss) expr = substitute subss' expr'
240 subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
241 -- Apply this substitution to the main expression
242 expr' = CoreSubst.substExpr subs expr
243 -- Apply this substitution on all the expressions in the remaining
245 subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
247 -- Run a given TransformSession. Used mostly to setup the right calls and
249 runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a
250 runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply)
252 -- Is the given expression representable at runtime, based on the type?
253 isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
254 isRepr (Type ty) = return False
255 isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)