1 {-# LANGUAGE PackageImports #-}
3 -- This module provides functions for program transformations.
5 module NormalizeTools where
8 import qualified Data.Monoid as Monoid
9 import qualified Control.Monad as Monad
10 import qualified Control.Monad.Trans.State as State
11 import qualified Control.Monad.Trans.Writer as Writer
12 import qualified "transformers" Control.Monad.Trans as Trans
17 import qualified UniqSupply
18 import qualified Unique
19 import qualified OccName
22 import qualified SrcLoc
24 import qualified IdInfo
25 import Outputable ( showSDoc, ppr, nest )
30 -- Create a new internal var with the given name and type. A Unique is
31 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
32 -- since the Unique is also stored in the name, but this ensures variable
33 -- names are unique in the output).
34 mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
35 mkInternalVar str ty = do
37 let occname = OccName.mkVarOcc (str ++ show uniq)
38 let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
39 return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
41 -- Apply the given transformation to all expressions in the given expression,
42 -- including the expression itself.
43 everywhere :: (String, Transform) -> Transform
44 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
46 -- Apply the first transformation, followed by the second transformation, and
47 -- keep applying both for as long as expression still changes.
48 applyboth :: Transform -> (String, Transform) -> Transform
49 applyboth first (name, second) expr = do
53 (expr'', changed) <- Writer.listen $ second expr'
54 if Monoid.getAny changed
56 trace ("Transform " ++ name ++ " changed from:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nTo:\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n") $
57 applyboth first (name, second) expr''
61 -- Apply the given transformation to all direct subexpressions (only), not the
63 subeverywhere :: Transform -> Transform
64 subeverywhere trans (App a b) = do
69 subeverywhere trans (Let (Rec binds) expr) = do
71 binds' <- mapM transbind binds
72 return $ Let (Rec binds') expr'
74 transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
79 subeverywhere trans (Lam x expr) = do
83 subeverywhere trans (Case scrut b t alts) = do
85 alts' <- mapM transalt alts
86 return $ Case scrut' b t alts'
88 transalt :: CoreAlt -> TransformMonad CoreAlt
89 transalt (con, binders, expr) = do
91 return (con, binders, expr')
94 subeverywhere trans expr = return expr
96 -- Apply the given transformation to all expressions, except for every first
97 -- argument of an application.
98 notapplied :: (String, Transform) -> Transform
99 notapplied trans = applyboth (subnotapplied trans) trans
101 -- Apply the given transformation to all (direct and indirect) subexpressions
102 -- (but not the expression itself), except for the first argument of an
103 -- applicfirst argument of an application
104 subnotapplied :: (String, Transform) -> Transform
105 subnotapplied trans (App a b) = do
106 a' <- subnotapplied trans a
107 b' <- notapplied trans b
110 -- Let subeverywhere handle all other expressions
111 subnotapplied trans expr = subeverywhere (notapplied trans) expr
113 -- Run the given transforms over the given expression
114 dotransforms :: [Transform] -> UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
115 dotransforms transs uniqSupply = (flip State.evalState initState) . (dotransforms' transs)
116 where initState = TransformState uniqSupply
118 -- Runs each of the transforms repeatedly inside the State monad.
119 dotransforms' :: [Transform] -> CoreExpr -> State.State TransformState CoreExpr
120 dotransforms' transs expr = do
121 (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
122 if Monoid.getAny changed then dotransforms' transs expr' else return expr'
124 -- Sets the changed flag in the TransformMonad, to signify that some
125 -- transform has changed the result
126 setChanged :: TransformMonad ()
127 setChanged = Writer.tell (Monoid.Any True)
129 -- Sets the changed flag and returns the given value.
130 change :: a -> TransformMonad a
135 -- Create a new Unique
136 mkUnique :: TransformMonad Unique.Unique
137 mkUnique = Trans.lift $ do
138 us <- getA tsUniqSupply
139 let (us', us'') = UniqSupply.splitUniqSupply us
140 putA tsUniqSupply us'
141 return $ UniqSupply.uniqFromSupply us''