module NormalizeTools where
-- Standard modules
import Debug.Trace
+import qualified List
import qualified Data.Monoid as Monoid
import qualified Control.Monad as Monad
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer as Writer
import qualified "transformers" Control.Monad.Trans as Trans
+import qualified Data.Map as Map
import Data.Accessor
-- GHC API
import qualified IdInfo
import qualified CoreUtils
import qualified CoreSubst
+import qualified VarSet
import Outputable ( showSDoc, ppr, nest )
-- Local imports
let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
+cloneVar :: Var.Var -> TransformMonad Var.Var
+cloneVar v = do
+ uniq <- mkUnique
+ -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
+ -- contains, but vannillaIdInfo is always correct, since it means "no info").
+ return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
+
-- Apply the given transformation to all expressions in the given expression,
-- including the expression itself.
everywhere :: (String, Transform) -> Transform
-- Let subeverywhere handle all other expressions
subnotapplied trans expr = subeverywhere (notapplied trans) expr
--- Run the given transforms over the given expression
-dotransforms :: [Transform] -> UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
-dotransforms transs uniqSupply = (flip State.evalState initState) . (dotransforms' transs)
- where initState = TransformState uniqSupply
-
-- Runs each of the transforms repeatedly inside the State monad.
-dotransforms' :: [Transform] -> CoreExpr -> State.State TransformState CoreExpr
-dotransforms' transs expr = do
+dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
+dotransforms transs expr = do
(expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
- if Monoid.getAny changed then dotransforms' transs expr' else return expr'
+ if Monoid.getAny changed then dotransforms transs expr' else return expr'
+
+-- Inline all let bindings that satisfy the given condition
+inlinebind :: ((CoreBndr, CoreExpr) -> Bool) -> Transform
+inlinebind condition (Let (Rec binds) expr) | not $ null replace =
+ change newexpr
+ where
+ -- Find all simple bindings
+ (replace, others) = List.partition condition binds
+ -- Substitute the to be replaced binders with their expression
+ newexpr = substitute replace (Let (Rec others) expr)
+-- Leave all other expressions unchanged
+inlinebind _ expr = return expr
-- Sets the changed flag in the TransformMonad, to signify that some
-- transform has changed the result
substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
substitute replace expr = CoreSubst.substExpr subs expr
where subs = foldl (\s (b, e) -> CoreSubst.extendIdSubst s b e) CoreSubst.emptySubst replace
+
+-- Run a given TransformSession. Used mostly to setup the right calls and
+-- an initial state.
+runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a
+runTransformSession uniqSupply session = State.evalState session initState
+ where initState = TransformState uniqSupply Map.empty VarSet.emptyVarSet