Add and use a mkFunction utility function.

This function creates a new function with a given body and adds it to the
TransformMonad state. The function is named after an existing binder, but
with a new Unique.

diff --git a/Normalize.hs b/Normalize.hs
index a01199119929f1b00fbab01ada4bdf519df9fa10..93e89b615a0b493ef8a64ebdb99d9029f7ec5f15 100644 (file)
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -302,14 +302,13 @@ typeprop, typeproptop :: Transform
 -- arguments without any free tyvars, since tyvars those wouldn't be in scope
 -- in the new function.
 typeprop expr@(App (Var f) arg@(Type ty)) | not $ has_free_tyvars arg = do
-  id <- cloneVar f
-  let newty = Type.applyTy (Id.idType f) ty
-  let newf = Var.setVarType id newty
   body_maybe <- Trans.lift $ getGlobalBind f
   case body_maybe of
     Just body -> do
       let newbody = App body (Type ty)
-      Trans.lift $ addGlobalBind newf newbody
+      -- Create a new function with the same name but a new body
+      newf <- mkFunction f newbody
+      -- Replace the application with this new function
       change (Var newf)
     -- If we don't have a body for the function called, leave it unchanged (it
     -- should be a primitive function then).
@@ -346,11 +345,8 @@ funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do
           -- Create a new body that consists of a lambda for all new arguments and
           -- the old body applied to some arguments.
           let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
-          -- Create a new function name
-          id <- cloneVar f
-          let newf = Var.setVarType id (CoreUtils.exprType newbody)
-          -- Add the new function
-          Trans.lift $ addGlobalBind newf newbody
+          -- Create a new function with the same name but a new body
+          newf <- mkFunction f newbody
           -- Replace the original application with one of the new function to the
           -- new arguments.
           change $ MkCore.mkCoreApps (Var newf) newargs

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index c36d85f2006f54aa84632c54afb4a9f40ce45efb..25c9273d8fb38ef4810f6207925aa8e109251e73 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -74,6 +74,17 @@ cloneVar v = do
   -- 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