Only inline top level functions that are applied in a let binding.

[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 fa6ae8c25f9f387fdcdea2b8708329463e2e6cd3..c761433551412714f8c8e58e0451005aa31db5cb 100644 (file)
--- a/cλash/CLasH/Normalize.hs
+++ b/cλash/CLasH/Normalize.hs
@@ -48,13 +48,20 @@ import CLasH.Utils.Pretty
 -- η abstraction
 --------------------------------
 eta, etatop :: Transform
+-- Don't apply to expressions that are applied, since that would cause
+-- us to apply to our own result indefinitely.
+eta (AppFirst:_) expr = return expr
+-- Also don't apply to arguments, since this can cause loops with
+-- funextract. This isn't the proper solution, but due to an
+-- implementation bug in notappargs, this is how it used to work so far.
+eta (AppSecond:_) expr = return expr
 eta c expr | is_fun expr && not (is_lam expr) = do
   let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
   id <- Trans.lift $ mkInternalVar "param" arg_ty
   change (Lam id (App expr (Var id)))
 -- Leave all other expressions unchanged
 eta c e = return e
-etatop = notappargs ("eta", eta)
+etatop = everywhere ("eta", eta)
 
 --------------------------------
 -- β-reduction
@@ -334,30 +341,32 @@ inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . is
 -- all structure defined by the user. Currently this includes all functions
 -- that were created by funextract, since we would get loops otherwise.
 --
+-- Only functions that are actually completely applied and bound by a
+-- variable in a let expression are inlined. These are the expressions
+-- that will eventually generate instantiations of trivial components.
+-- By not inlining any other reference, we also prevent looping problems
+-- with funextract and inlinedict.
+--
 -- 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
--- HACK: Don't inline == and /=. The default (derived) implementation
--- for /= uses the polymorphic version of ==, which gets a dictionary
--- for Eq passed in, which contains a reference to itself, resulting in
--- an infinite loop in transformation. Not inlining == is really a hack,
--- but for now it keeps things working with the most common symptom of
--- this problem.
-inlinetoplevel c expr@(Var f) | Name.getOccString f `elem` ["==", "/="] = return expr
--- Any system name is candidate for inlining. Never inline user-defined
--- functions, to preserve structure.
-inlinetoplevel c expr@(Var f) | not $ isUserDefined f = do
-  body_maybe <- needsInline f
-  case body_maybe of
-    Just body -> do
-        -- Regenerate all uniques in the to-be-inlined expression
-        body_uniqued <- Trans.lift $ genUniques body
-        -- And replace the variable reference with the unique'd body.
-        change body_uniqued
-        -- No need to inline
-    Nothing -> return expr
-
+inlinetoplevel (LetBinding:_) expr =
+  case collectArgs expr of
+       -- Any system name is candidate for inlining. Never inline
+       -- user-defined functions, to preserve structure.
+       (Var f, args) | not $ isUserDefined f -> do
+         body_maybe <- needsInline f
+         case body_maybe of
+               Just body -> do
+                       -- Regenerate all uniques in the to-be-inlined expression
+                       body_uniqued <- Trans.lift $ genUniques body
+                       -- And replace the variable reference with the unique'd body.
+                       change (mkApps body_uniqued args)
+                       -- No need to inline
+               Nothing -> return expr
+       -- This is not an application of a binder, leave it unchanged.
+       _ -> return expr
 
 -- Leave all other expressions unchanged
 inlinetoplevel c expr = return expr