Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project

[matthijs/master-project/cλash.git] / NormalizeTools.hs

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index 90daf4819e0d609d559a998ae9527422731f1eb0..6699101d33bc18a3a90a8870ce18d095cd72b129 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -5,6 +5,7 @@
 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
@@ -22,6 +23,8 @@ import qualified Var
 import qualified SrcLoc
 import qualified Type
 import qualified IdInfo
+import qualified CoreUtils
+import qualified CoreSubst
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
@@ -53,7 +56,7 @@ applyboth first (name, second) expr  = do
   (expr'', changed) <- Writer.listen $ second expr'
   if Monoid.getAny changed 
     then 
-      trace ("Transform " ++ name ++ " changed from:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nTo:\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n") $
+      trace ("Transform " ++ name ++ " changed from:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n" ++ "\nTo:\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
       applyboth first (name, second) expr'' 
     else 
       return expr''
@@ -121,6 +124,18 @@ dotransforms' transs expr = do
   (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
   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
 setChanged :: TransformMonad ()
@@ -139,3 +154,9 @@ mkUnique = Trans.lift $ do
     let (us', us'') = UniqSupply.splitUniqSupply us
     putA tsUniqSupply us'
     return $ UniqSupply.uniqFromSupply us''
+
+-- Replace each of the binders given with the coresponding expressions in the
+-- given expression.
+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