Almost finished support for 'map'

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

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index c36d85f2006f54aa84632c54afb4a9f40ce45efb..14e3faca07543f497da404cd8e5cb317c7e6d099 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -7,6 +7,7 @@ module NormalizeTools where
 import Debug.Trace
 import qualified List
 import qualified Data.Monoid as Monoid
 import Debug.Trace
 import qualified List
 import qualified Data.Monoid as Monoid

+import qualified Control.Arrow as Arrow

 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
 import qualified Control.Monad.Trans.Writer as Writer
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
 import qualified Control.Monad.Trans.Writer as Writer


@@ -74,6 +75,17 @@ cloneVar v = do
   -- contains, but vannillaIdInfo is always correct, since it means "no info").
   return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
 
   -- contains, but vannillaIdInfo is always correct, since it means "no info").
   return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
 

+-- Creates a new function with the same name as the given binder (but with a
+-- new unique) and with the given function body. Returns the new binder for
+-- this function.
+mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr
+mkFunction bndr body = do
+  let ty = CoreUtils.exprType body
+  id <- cloneVar bndr
+  let newid = Var.setVarType id ty
+  Trans.lift $ addGlobalBind newid body
+  return newid
+

 -- Apply the given transformation to all expressions in the given expression,
 -- including the expression itself.
 everywhere :: (String, Transform) -> Transform
 -- Apply the given transformation to all expressions in the given expression,
 -- including the expression itself.
 everywhere :: (String, Transform) -> Transform


@@ -191,8 +203,21 @@ mkUnique = Trans.lift $ do
 -- Replace each of the binders given with the coresponding expressions in the
 -- given expression.
 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
 -- 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.extendSubst s b e) CoreSubst.emptySubst replace
+substitute [] expr = expr
+-- Apply one substitution on the expression, but also on any remaining
+-- substitutions. This seems to be the only way to handle substitutions like
+-- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
+-- according to CoreSubst documentation (but it doesn't seem to be a problem).
+-- TODO: Find out how this works, exactly.
+substitute ((b, e):subss) expr = substitute subss' expr'
+  where 
+    -- Create the Subst
+    subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
+    -- Apply this substitution to the main expression
+    expr' = CoreSubst.substExpr subs expr
+    -- Apply this substitution on all the expressions in the remaining
+    -- substitutions
+    subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss

 
 -- Run a given TransformSession. Used mostly to setup the right calls and
 -- an initial state.
 
 -- Run a given TransformSession. Used mostly to setup the right calls and
 -- an initial state.