X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=c761433551412714f8c8e58e0451005aa31db5cb;hb=b29ff3c525d3d81e73ed153549d5347941f78f8b;hp=fa6ae8c25f9f387fdcdea2b8708329463e2e6cd3;hpb=3deb1d21f696f8495cd99345c9677210e2a2fc79;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index fa6ae8c..c761433 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/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