Let scrutinee binder removal mark the expression as changed.

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

diff --git a/cλash/CLasH/Normalize.hs b/cλash/CLasH/Normalize.hs
index f3a9d2e4662ca2e204d761fa1c80fc4272628a73..f0f2de2fccba3187092c4958bc1e3382cc0c0682 100644 (file)
--- a/cλash/CLasH/Normalize.hs
+++ b/cλash/CLasH/Normalize.hs
@@ -4,39 +4,32 @@
 -- top level function "normalize", and defines the actual transformation passes that
 -- are performed.
 --
 -- top level function "normalize", and defines the actual transformation passes that
 -- are performed.
 --

-module CLasH.Normalize (getNormalized, normalizeExpr) where
+module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized) where

 
 -- Standard modules
 import Debug.Trace
 import qualified Maybe
 
 -- Standard modules
 import Debug.Trace
 import qualified Maybe

+import qualified List

 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.Writer as Writer
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.Writer as Writer

-import qualified Data.Map as Map

 import qualified Data.Monoid as Monoid
 import qualified Data.Monoid as Monoid

-import Data.Accessor

 
 -- GHC API
 import CoreSyn
 
 -- GHC API
 import CoreSyn

-import qualified UniqSupply

 import qualified CoreUtils
 import qualified Type
 import qualified CoreUtils
 import qualified Type

-import qualified TcType

 import qualified Id
 import qualified Var
 import qualified VarSet
 import qualified Id
 import qualified Var
 import qualified VarSet

-import qualified NameSet

 import qualified CoreFVs
 import qualified CoreFVs

-import qualified CoreUtils

 import qualified MkCore
 import qualified MkCore

-import qualified HscTypes

 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Normalize.NormalizeTools
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Normalize.NormalizeTools

-import CLasH.VHDL.VHDLTypes

 import qualified CLasH.Utils as Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Core.BinderTools
 import qualified CLasH.Utils as Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Core.BinderTools


@@ -62,8 +55,10 @@ etatop = notappargs ("eta", eta)
 -- β-reduction
 --------------------------------
 beta, betatop :: Transform
 -- β-reduction
 --------------------------------
 beta, betatop :: Transform

--- Substitute arg for x in expr
-beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
+-- Substitute arg for x in expr. For value lambda's, also clone before
+-- substitution.
+beta (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg expr
+                            | otherwise      = setChanged >> substitute_clone x arg expr

 -- Propagate the application into the let
 beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
 -- Propagate the application into each of the alternatives
 -- Propagate the application into the let
 beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
 -- Propagate the application into each of the alternatives


@@ -106,7 +101,7 @@ castsimpl expr@(Cast val ty) = do
       -- Generate a binder for the expression
       id <- Trans.lift $ mkBinderFor val "castval"
       -- Extract the expression
       -- Generate a binder for the expression
       id <- Trans.lift $ mkBinderFor val "castval"
       -- Extract the expression

-      change $ Let (Rec [(id, val)]) (Cast (Var id) ty)
+      change $ Let (NonRec id val) (Cast (Var id) ty)

     else
       return expr
 -- Leave all other expressions unchanged
     else
       return expr
 -- Leave all other expressions unchanged


@@ -114,23 +109,70 @@ castsimpl expr = return expr
 -- Perform this transform everywhere
 castsimpltop = everywhere ("castsimpl", castsimpl)
 
 -- Perform this transform everywhere
 castsimpltop = everywhere ("castsimpl", castsimpl)
 

+

 --------------------------------
 --------------------------------

--- let recursification
+-- Lambda simplication

 --------------------------------
 --------------------------------

-letrec, letrectop :: Transform
-letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res
+-- Ensure that a lambda always evaluates to a let expressions or a simple
+-- variable reference.
+lambdasimpl, lambdasimpltop :: Transform
+-- Don't simplify a lambda that evaluates to let, since this is already
+-- normal form (and would cause infinite loops).
+lambdasimpl expr@(Lam _ (Let _ _)) = return expr
+-- Put the of a lambda in its own binding, but not when the expression is
+-- already a local variable, or not representable (to prevent loops with
+-- inlinenonrep).
+lambdasimpl expr@(Lam bndr res) = do
+  repr <- isRepr res
+  local_var <- Trans.lift $ is_local_var res
+  if not local_var && repr
+    then do
+      id <- Trans.lift $ mkBinderFor res "res"
+      change $ Lam bndr (Let (NonRec id res) (Var id))
+    else
+      -- If the result is already a local var or not representable, don't
+      -- extract it.
+      return expr
+

 -- Leave all other expressions unchanged
 -- Leave all other expressions unchanged

-letrec expr = return expr
+lambdasimpl expr = return expr

 -- Perform this transform everywhere
 -- Perform this transform everywhere

-letrectop = everywhere ("letrec", letrec)
+lambdasimpltop = everywhere ("lambdasimpl", lambdasimpl)
+
+--------------------------------
+-- let derecursification
+--------------------------------
+letderec, letderectop :: Transform
+letderec expr@(Let (Rec binds) res) = case liftable of
+  -- Nothing is liftable, just return
+  [] -> return expr
+  -- Something can be lifted, generate a new let expression
+  _ -> change $ mkNonRecLets liftable (Let (Rec nonliftable) res)
+  where
+    -- Make a list of all the binders bound in this recursive let
+    bndrs = map fst binds
+    -- See which bindings are liftable
+    (liftable, nonliftable) = List.partition canlift binds
+    -- Any expression that does not use any of the binders in this recursive let
+    -- can be lifted into a nonrec let. It can't use its own binder either,
+    -- since that would mean the binding is self-recursive and should be in a
+    -- single bind recursive let.
+    canlift (bndr, e) = not $ expr_uses_binders bndrs e
+-- Leave all other expressions unchanged
+letderec expr = return expr
+-- Perform this transform everywhere
+letderectop = everywhere ("letderec", letderec)

 
 --------------------------------
 -- let simplification
 --------------------------------
 letsimpl, letsimpltop :: Transform
 
 --------------------------------
 -- let simplification
 --------------------------------
 letsimpl, letsimpltop :: Transform

+-- Don't simplify a let that evaluates to another let, since this is already
+-- normal form (and would cause infinite loops with letflat below).
+letsimpl expr@(Let _ (Let _ _)) = return expr

 -- Put the "in ..." value of a let in its own binding, but not when the
 -- expression is already a local variable, or not representable (to prevent loops with inlinenonrep).
 -- Put the "in ..." value of a let in its own binding, but not when the
 -- expression is already a local variable, or not representable (to prevent loops with inlinenonrep).

-letsimpl expr@(Let (Rec binds) res) = do
+letsimpl expr@(Let binds res) = do

   repr <- isRepr res
   local_var <- Trans.lift $ is_local_var res
   if not local_var && repr
   repr <- isRepr res
   local_var <- Trans.lift $ is_local_var res
   if not local_var && repr


@@ -138,8 +180,7 @@ letsimpl expr@(Let (Rec binds) res) = do
       -- If the result is not a local var already (to prevent loops with
       -- ourselves), extract it.
       id <- Trans.lift $ mkBinderFor res "foo"
       -- If the result is not a local var already (to prevent loops with
       -- ourselves), extract it.
       id <- Trans.lift $ mkBinderFor res "foo"

-      let bind = (id, res)
-      change $ Let (Rec (bind:binds)) (Var id)
+      change $ Let binds (Let (NonRec id  res) (Var id))

     else
       -- If the result is already a local var, don't extract it.
       return expr
     else
       -- If the result is already a local var, don't extract it.
       return expr


@@ -152,13 +193,18 @@ letsimpltop = everywhere ("letsimpl", letsimpl)
 --------------------------------
 -- let flattening
 --------------------------------
 --------------------------------
 -- let flattening
 --------------------------------

+-- Takes a let that binds another let, and turns that into two nested lets.
+-- e.g., from:
+-- let b = (let b' = expr' in res') in res
+-- to:
+-- let b' = expr' in (let b = res' in res)

 letflat, letflattop :: Transform
 letflat, letflattop :: Transform

+-- Turn a nonrec let that binds a let into two nested lets.
+letflat (Let (NonRec b (Let binds  res')) res) = 
+  change $ Let binds (Let (NonRec b res') res)

 letflat (Let (Rec binds) expr) = do
 letflat (Let (Rec binds) expr) = do

-  -- Turn each binding into a list of bindings (possibly containing just one
-  -- element, of course)
-  bindss <- Monad.mapM flatbind binds
-  -- Concat all the bindings
-  let binds' = concat bindss
+  -- Flatten each binding.
+  binds' <- Utils.concatM $ Monad.mapM flatbind binds

   -- Return the new let. We don't use change here, since possibly nothing has
   -- changed. If anything has changed, flatbind has already flagged that
   -- change.
   -- Return the new let. We don't use change here, since possibly nothing has
   -- changed. If anything has changed, flatbind has already flagged that
   -- change.


@@ -168,23 +214,40 @@ letflat (Let (Rec binds) expr) = do
     -- into a list with just that binding
     flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
     flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
     -- into a list with just that binding
     flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
     flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)

+    flatbind (b, Let (NonRec b' expr') expr) = change [(b, expr), (b', expr')]

     flatbind (b, expr) = return [(b, expr)]
 -- Leave all other expressions unchanged
 letflat expr = return expr
 -- Perform this transform everywhere
 letflattop = everywhere ("letflat", letflat)
 
     flatbind (b, expr) = return [(b, expr)]
 -- Leave all other expressions unchanged
 letflat expr = return expr
 -- Perform this transform everywhere
 letflattop = everywhere ("letflat", letflat)
 

+--------------------------------
+-- empty let removal
+--------------------------------
+-- Remove empty (recursive) lets
+letremove, letremovetop :: Transform
+letremove (Let (Rec []) res) = change res
+-- Leave all other expressions unchanged
+letremove expr = return expr
+-- Perform this transform everywhere
+letremovetop = everywhere ("letremove", letremove)
+

 --------------------------------
 -- Simple let binding removal
 --------------------------------
 -- Remove a = b bindings from let expressions everywhere
 --------------------------------
 -- Simple let binding removal
 --------------------------------
 -- Remove a = b bindings from let expressions everywhere

-letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
+letremovesimpletop :: Transform
+letremovesimpletop = everywhere ("letremovesimple", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))

 
 --------------------------------
 -- Unused let binding removal
 --------------------------------
 letremoveunused, letremoveunusedtop :: Transform
 
 --------------------------------
 -- Unused let binding removal
 --------------------------------
 letremoveunused, letremoveunusedtop :: Transform

+letremoveunused expr@(Let (NonRec b bound) res) = do
+  let used = expr_uses_binders [b] res
+  if used
+    then return expr
+    else change res

 letremoveunused expr@(Let (Rec binds) res) = do
   -- Filter out all unused binds.
   let binds' = filter dobind binds
 letremoveunused expr@(Let (Rec binds) res) = do
   -- Filter out all unused binds.
   let binds' = filter dobind binds


@@ -199,6 +262,7 @@ letremoveunused expr@(Let (Rec binds) res) = do
 letremoveunused expr = return expr
 letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
 
 letremoveunused expr = return expr
 letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
 

+{-

 --------------------------------
 -- Identical let binding merging
 --------------------------------
 --------------------------------
 -- Identical let binding merging
 --------------------------------


@@ -206,9 +270,10 @@ letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
 -- TODO: We would very much like to use GHC's CSE module for this, but that
 -- doesn't track if something changed or not, so we can't use it properly.
 letmerge, letmergetop :: Transform
 -- TODO: We would very much like to use GHC's CSE module for this, but that
 -- doesn't track if something changed or not, so we can't use it properly.
 letmerge, letmergetop :: Transform

-letmerge expr@(Let (Rec binds) res) = do
+letmerge expr@(Let _ _) = do
+  let (binds, res) = flattenLets expr

   binds' <- domerge binds
   binds' <- domerge binds

-  return (Let (Rec binds') res)
+  return $ mkNonRecLets binds' res

   where
     domerge :: [(CoreBndr, CoreExpr)] -> TransformMonad [(CoreBndr, CoreExpr)]
     domerge [] = return []
   where
     domerge :: [(CoreBndr, CoreExpr)] -> TransformMonad [(CoreBndr, CoreExpr)]
     domerge [] = return []


@@ -228,25 +293,79 @@ letmerge expr@(Let (Rec binds) res) = do
 -- Leave all other expressions unchanged
 letmerge expr = return expr
 letmergetop = everywhere ("letmerge", letmerge)
 -- Leave all other expressions unchanged
 letmerge expr = return expr
 letmergetop = everywhere ("letmerge", letmerge)

-    
+-}
+

 --------------------------------
 --------------------------------

--- Function inlining
+-- Non-representable binding inlining

 --------------------------------
 --------------------------------

--- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
--- expressions everywhere. This means that any value that still needs to be
--- applied to something else (polymorphic values need to be applied to a
--- Type) will be inlined, and will eventually be applied to all their
--- arguments.
+-- Remove a = B bindings, with B of a non-representable type, from let
+-- expressions everywhere. This means that any value that we can't generate a
+-- signal for, will be inlined and hopefully turned into something we can
+-- represent.

 --
 -- This is a tricky function, which is prone to create loops in the
 -- transformations. To fix this, we make sure that no transformation will
 --
 -- This is a tricky function, which is prone to create loops in the
 -- transformations. To fix this, we make sure that no transformation will

--- create a new let binding with a function type. These other transformations
--- will just not work on those function-typed values at first, but the other
--- transformations (in particular β-reduction) should make sure that the type
--- of those values eventually becomes primitive.
+-- create a new let binding with a non-representable type. These other
+-- transformations will just not work on those function-typed values at first,
+-- but the other transformations (in particular β-reduction) should make sure
+-- that the type of those values eventually becomes representable.

 inlinenonreptop :: Transform
 inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
 
 inlinenonreptop :: Transform
 inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
 

+--------------------------------
+-- Top level function inlining
+--------------------------------
+-- This transformation inlines top level bindings that have been generated by
+-- the compiler and are really simple. Really simple currently means that the
+-- normalized form only contains a single binding, which catches most of the
+-- cases where a top level function is created that simply calls a type class
+-- method with a type and dictionary argument, e.g.
+--   fromInteger = GHC.Num.fromInteger (SizedWord D8) $dNum
+-- which is later called using simply
+--   fromInteger (smallInteger 10)
+-- By inlining such calls to simple, compiler generated functions, we prevent
+-- huge amounts of trivial components in the VHDL output, which the user never
+-- wanted. We never inline user-defined functions, since we want to preserve
+-- all structure defined by the user. Currently this includes all functions
+-- that were created by funextract, since we would get loops otherwise.
+--
+-- Note that "defined by the compiler" isn't completely watertight, since GHC
+-- doesn't seem to set all those names as "system names", we apply some
+-- guessing here.
+inlinetoplevel, inlinetopleveltop :: Transform
+-- Any system name is candidate for inlining. Never inline user-defined
+-- functions, to preserve structure.
+inlinetoplevel expr@(Var f) | not $ isUserDefined f = do
+  norm <- isNormalizeable f
+  -- See if this is a top level binding for which we have a body
+  body_maybe <- Trans.lift $ getGlobalBind f
+  if norm && Maybe.isJust body_maybe
+    then do
+      -- Get the normalized version
+      norm <- Trans.lift $ getNormalized f
+      if needsInline norm 
+        then do
+          -- Regenerate all uniques in the to-be-inlined expression
+          norm_uniqued <- Trans.lift $ genUniques norm
+          change norm_uniqued
+        else
+          return expr
+    else
+      -- No body or not normalizeable.
+      return expr
+-- Leave all other expressions unchanged
+inlinetoplevel expr = return expr
+inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel)
+
+needsInline :: CoreExpr -> Bool
+needsInline expr = case splitNormalized expr of
+  -- Inline any function that only has a single definition, it is probably
+  -- simple enough. This might inline some stuff that it shouldn't though it
+  -- will never inline user-defined functions (inlinetoplevel only tries
+  -- system names) and inlining should never break things.
+  (args, [bind], res) -> True
+  _ -> False
+

 --------------------------------
 -- Scrutinee simplification
 --------------------------------
 --------------------------------
 -- Scrutinee simplification
 --------------------------------


@@ -262,7 +381,7 @@ scrutsimpl expr@(Case scrut b ty alts) = do
   if repr
     then do
       id <- Trans.lift $ mkBinderFor scrut "scrut"
   if repr
     then do
       id <- Trans.lift $ mkBinderFor scrut "scrut"

-      change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+      change $ Let (NonRec id scrut) (Case (Var id) b ty alts)

     else
       return expr
 -- Leave all other expressions unchanged
     else
       return expr
 -- Leave all other expressions unchanged


@@ -270,6 +389,31 @@ scrutsimpl expr = return expr
 -- Perform this transform everywhere
 scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
 
 -- Perform this transform everywhere
 scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
 

+--------------------------------
+-- Scrutinee binder removal
+--------------------------------
+-- A case expression can have an extra binder, to which the scrutinee is bound
+-- after bringing it to WHNF. This is used for forcing evaluation of strict
+-- arguments. Since strictness does not matter for us (rather, everything is
+-- sort of strict), this binder is ignored when generating VHDL, and must thus
+-- be wild in the normal form.
+scrutbndrremove, scrutbndrremovetop :: Transform
+-- If the scrutinee is already simple, and the bndr is not wild yet, replace
+-- all occurences of the binder with the scrutinee variable.
+scrutbndrremove (Case (Var scrut) bndr ty alts) | bndr_used = do
+    alts' <- mapM subs_bndr alts
+    change $ Case (Var scrut) wild ty alts'
+  where
+    is_used (_, _, expr) = expr_uses_binders [bndr] expr
+    bndr_used = or $ map is_used alts
+    subs_bndr (con, bndrs, expr) = do
+      expr' <- substitute bndr (Var scrut) expr
+      return (con, bndrs, expr')
+    wild = MkCore.mkWildBinder (Id.idType bndr)
+-- Leave all other expressions unchanged
+scrutbndrremove expr = return expr
+scrutbndrremovetop = everywhere ("scrutbndrremove", scrutbndrremove)
+

 --------------------------------
 -- Case binder wildening
 --------------------------------
 --------------------------------
 -- Case binder wildening
 --------------------------------


@@ -288,7 +432,7 @@ casesimpl expr@(Case scrut b ty alts) = do
   (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
   let bindings = concat bindingss
   -- Replace the case with a let with bindings and a case
   (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
   let bindings = concat bindingss
   -- Replace the case with a let with bindings and a case

-  let newlet = (Let (Rec bindings) (Case scrut b ty alts'))
+  let newlet = mkNonRecLets bindings (Case scrut b ty alts')

   -- If there are no non-wild binders, or this case is already a simple
   -- selector (i.e., a single alt with exactly one binding), already a simple
   -- selector altan no bindings (i.e., no wild binders in the original case),
   -- If there are no non-wild binders, or this case is already a simple
   -- selector (i.e., a single alt with exactly one binding), already a simple
   -- selector altan no bindings (i.e., no wild binders in the original case),


@@ -307,11 +451,11 @@ casesimpl expr@(Case scrut b ty alts) = do
     -- Extract a complex expression, if possible. For this we check if any of
     -- the new list of bndrs are used by expr. We can't use free_vars here,
     -- since that looks at the old bndrs.
     -- Extract a complex expression, if possible. For this we check if any of
     -- the new list of bndrs are used by expr. We can't use free_vars here,
     -- since that looks at the old bndrs.

-    let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) $ expr
+    let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr

     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
     -- Create a new alternative
     let newalt = (con, newbndrs, expr')
     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
     -- Create a new alternative
     let newalt = (con, newbndrs, expr')

-    let bindings = Maybe.catMaybes (exprbinding_maybe : bindings_maybe)
+    let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])

     return (bindings, newalt)
     where
       -- Make wild alternatives for each binder
     return (bindings, newalt)
     where
       -- Make wild alternatives for each binder


@@ -323,7 +467,7 @@ casesimpl expr@(Case scrut b ty alts) = do
       -- binding containing a case expression.
       dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
       dobndr b i = do
       -- binding containing a case expression.
       dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
       dobndr b i = do

-        repr <- isRepr (Var b)
+        repr <- isRepr b

         -- Is b wild (e.g., not a free var of expr. Since b is only in scope
         -- in expr, this means that b is unused if expr does not use it.)
         let wild = not (VarSet.elemVarSet b free_vars)
         -- Is b wild (e.g., not a free var of expr. Since b is only in scope
         -- in expr, this means that b is unused if expr does not use it.)
         let wild = not (VarSet.elemVarSet b free_vars)


@@ -358,7 +502,7 @@ casesimpl expr@(Case scrut b ty alts) = do
             id <- Trans.lift $ mkBinderFor expr "caseval"
             -- We don't flag a change here, since casevalsimpl will do that above
             -- based on Just we return here.
             id <- Trans.lift $ mkBinderFor expr "caseval"
             -- We don't flag a change here, since casevalsimpl will do that above
             -- based on Just we return here.

-            return $ (Just (id, expr), Var id)
+            return (Just (id, expr), Var id)

           else
             -- Don't simplify anything else
             return (Nothing, expr)
           else
             -- Don't simplify anything else
             return (Nothing, expr)


@@ -396,7 +540,7 @@ appsimpl expr@(App f arg) = do
   if repr && not local_var
     then do -- Extract representable arguments
       id <- Trans.lift $ mkBinderFor arg "arg"
   if repr && not local_var
     then do -- Extract representable arguments
       id <- Trans.lift $ mkBinderFor arg "arg"

-      change $ Let (Rec [(id, arg)]) (App f (Var id))
+      change $ Let (NonRec id arg) (App f (Var id))

     else -- Leave non-representable arguments unchanged
       return expr
 -- Leave all other expressions unchanged
     else -- Leave non-representable arguments unchanged
       return expr
 -- Leave all other expressions unchanged


@@ -456,7 +600,7 @@ argprop expr@(App _ _) | is_var fexpr = do
     doarg arg = do
       repr <- isRepr arg
       bndrs <- Trans.lift getGlobalBinders
     doarg arg = do
       repr <- isRepr arg
       bndrs <- Trans.lift getGlobalBinders

-      let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
+      let interesting var = Var.isLocalVar var && (var `notElem` bndrs)

       if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) 
         then do
           -- Propagate all complex arguments that are not representable, but not
       if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) 
         then do
           -- Propagate all complex arguments that are not representable, but not


@@ -472,10 +616,18 @@ argprop expr@(App _ _) | is_var fexpr = do
           let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
           -- Mark the current expression as changed
           setChanged
           let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
           -- Mark the current expression as changed
           setChanged

+          -- TODO: Clone the free_vars (and update references in arg), since
+          -- this might cause conflicts if two arguments that are propagated
+          -- share a free variable. Also, we are now introducing new variables
+          -- into a function that are not fresh, which violates the binder
+          -- uniqueness invariant.

           return (map Var free_vars, free_vars, arg)
         else do
           -- Representable types will not be propagated, and arguments with free
           -- type variables will be propagated later.
           return (map Var free_vars, free_vars, arg)
         else do
           -- Representable types will not be propagated, and arguments with free
           -- type variables will be propagated later.

+          -- Note that we implicitly remove any type variables in the type of
+          -- the original argument by using the type of the actual argument
+          -- for the new formal parameter.

           -- TODO: preserve original naming?
           id <- Trans.lift $ mkBinderFor arg "param"
           -- Just pass the original argument to the new function, which binds it
           -- TODO: preserve original naming?
           id <- Trans.lift $ mkBinderFor arg "param"
           -- Just pass the original argument to the new function, which binds it


@@ -537,6 +689,25 @@ funextract expr = return expr
 -- Perform this transform everywhere
 funextracttop = everywhere ("funextract", funextract)
 
 -- Perform this transform everywhere
 funextracttop = everywhere ("funextract", funextract)
 

+--------------------------------
+-- Ensure that a function that just returns another function (or rather,
+-- another top-level binder) is still properly normalized. This is a temporary
+-- solution, we should probably integrate this pass with lambdasimpl and
+-- letsimpl instead.
+--------------------------------
+simplrestop expr@(Lam _ _) = return expr
+simplrestop expr@(Let _ _) = return expr
+simplrestop expr = do
+  local_var <- Trans.lift $ is_local_var expr
+  -- Don't extract values that are not representable, to prevent loops with
+  -- inlinenonrep
+  repr <- isRepr expr
+  if local_var || not repr
+    then
+      return expr
+    else do
+      id <- Trans.lift $ mkBinderFor expr "res" 
+      change $ Let (NonRec id expr) (Var id)

 --------------------------------
 -- End of transformations
 --------------------------------
 --------------------------------
 -- End of transformations
 --------------------------------


@@ -545,14 +716,14 @@ funextracttop = everywhere ("funextract", funextract)
 
 
 -- What transforms to run?
 
 
 -- What transforms to run?

-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop]
+transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]

 
 -- | Returns the normalized version of the given function.
 getNormalized ::
   CoreBndr -- ^ The function to get
   -> TranslatorSession CoreExpr -- The normalized function body
 
 
 -- | Returns the normalized version of the given function.
 getNormalized ::
   CoreBndr -- ^ The function to get
   -> TranslatorSession CoreExpr -- The normalized function body
 

-getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
+getNormalized bndr = Utils.makeCached bndr tsNormalized $

   if is_poly (Var bndr)
     then
       -- This should really only happen at the top level... TODO: Give
   if is_poly (Var bndr)
     then
       -- This should really only happen at the top level... TODO: Give


@@ -569,15 +740,12 @@ normalizeExpr ::
   -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
 
 normalizeExpr what expr = do
   -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
 
 normalizeExpr what expr = do

-      -- Introduce an empty Let at the top level, so there will always be
-      -- a let in the expression (none of the transformations will remove
-      -- the last let).
-      let expr' = Let (Rec []) expr
+      expr_uniqued <- genUniques expr

       -- Normalize this expression
       -- Normalize this expression

-      trace ("Transforming " ++ what ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
-      expr'' <- dotransforms transforms expr'
-      trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr'')) $ return ()
-      return expr''
+      trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return ()
+      expr' <- dotransforms transforms expr_uniqued
+      trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+      return expr'

 
 -- | Get the value that is bound to the given binder at top level. Fails when
 --   there is no such binding.
 
 -- | Get the value that is bound to the given binder at top level. Fails when
 --   there is no such binding.


@@ -585,7 +753,20 @@ getBinding ::
   CoreBndr -- ^ The binder to get the expression for
   -> TranslatorSession CoreExpr -- ^ The value bound to the binder
 
   CoreBndr -- ^ The binder to get the expression for
   -> TranslatorSession CoreExpr -- ^ The value bound to the binder
 

-getBinding bndr = Utils.makeCached bndr tsBindings $ do
+getBinding bndr = Utils.makeCached bndr tsBindings $

   -- If the binding isn't in the "cache" (bindings map), then we can't create
   -- it out of thin air, so return an error.
   error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr
   -- If the binding isn't in the "cache" (bindings map), then we can't create
   -- it out of thin air, so return an error.
   error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr

+
+-- | Split a normalized expression into the argument binders, top level
+--   bindings and the result binder.
+splitNormalized ::
+  CoreExpr -- ^ The normalized expression
+  -> ([CoreBndr], [Binding], CoreBndr)
+splitNormalized expr = (args, binds, res)
+  where
+    (args, letexpr) = CoreSyn.collectBinders expr
+    (binds, resexpr) = flattenLets letexpr
+    res = case resexpr of 
+      (Var x) -> x
+      _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"