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..817dd51fcda0a7239b27ddb9013599b87ce941ba 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -5,11 +5,13 @@
 module NormalizeTools where
 -- Standard modules
 import Debug.Trace
 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.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 Data.Accessor
 
 -- GHC API


@@ -22,6 +24,9 @@ import qualified Var
 import qualified SrcLoc
 import qualified Type
 import qualified IdInfo
 import qualified SrcLoc
 import qualified Type
 import qualified IdInfo

+import qualified CoreUtils
+import qualified CoreSubst
+import qualified VarSet

 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports


@@ -53,7 +58,7 @@ applyboth first (name, second) expr  = do
   (expr'', changed) <- Writer.listen $ second expr'
   if Monoid.getAny changed 
     then 
   (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''
       applyboth first (name, second) expr'' 
     else 
       return expr''


@@ -110,16 +115,23 @@ subnotapplied trans (App a b) = do
 -- Let subeverywhere handle all other expressions
 subnotapplied trans expr = subeverywhere (notapplied trans) expr
 
 -- 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.
 -- 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
   (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
 
 -- Sets the changed flag in the TransformMonad, to signify that some
 -- transform has changed the result


@@ -139,3 +151,15 @@ mkUnique = Trans.lift $ do
     let (us', us'') = UniqSupply.splitUniqSupply us
     putA tsUniqSupply us'
     return $ UniqSupply.uniqFromSupply us''
     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
+
+-- 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