X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=999704f38d79b05b5c2936bde593236ccc5af137;hb=5ff98f8da99e22a0e49f87a9b3121a6b618ef0b4;hp=a5b2a9474d290dbb7fb6d0804c7f3c6622fb41b7;hpb=d54117f6de8d00fe0ce7552c905cf197678d7ed7;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 a5b2a94..999704f 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -341,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
@@ -398,13 +400,25 @@ needsInline f = do
 --------------------------------
 -- Dictionary inlining
 --------------------------------
--- Inline all top level dictionaries, so we can use them to resolve
--- class methods based on the dictionary passed. 
-inlinedict c expr@(Var f) | Id.isDictId f = do
-  body_maybe <- Trans.lift $ getGlobalBind f
+-- Inline all top level dictionaries, that are in a position where
+-- classopresolution can actually resolve them. This makes this
+-- transformation look similar to classoperesolution below, but we'll
+-- keep them separated for clarity. By not inlining other dictionaries,
+-- we prevent expression sizes exploding when huge type level integer
+-- dictionaries are inlined which can never be expanded (in casts, for
+-- example).
+inlinedict c expr@(App (App (Var sel) ty) (Var dict)) | not is_builtin && is_classop = do
+  body_maybe <- Trans.lift $ getGlobalBind dict
   case body_maybe of
+    -- No body available (no source available, or a local variable /
+    -- argument)
     Nothing -> return expr
-    Just body -> change body
+    Just body -> change (App (App (Var sel) ty) body)
+  where
+    -- Is this a builtin function / method?
+    is_builtin = elem (Name.getOccString sel) builtinIds
+    -- Are we dealing with a class operation selector?
+    is_classop = Maybe.isJust (Id.isClassOpId_maybe sel)
 
 -- Leave all other expressions unchanged
 inlinedict c expr = return expr