X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=cf33b7bb3d9aab751eb071db017975c35e7bb04d;hb=9a75989431be8c2188283c9dff0c105dabb84420;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..cf33b7b 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 @@ -320,44 +327,46 @@ inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . is -------------------------------- -- 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 +-- This transformation inlines simple top level bindings. Simple +-- currently means that the body is only a single application (though +-- the complexity of the arguments is not currently checked) or that the +-- normalized form only contains a single binding. This should catch 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. +-- These useless wrappers are created by GHC automatically. If we don't +-- inline them, we get loads of useless components cluttering the +-- generated VHDL. +-- +-- Note that the inlining could also inline simple functions defined by +-- the user, not just GHC generated functions. It turns out to be near +-- impossible to reliably determine what functions are generated and +-- what functions are user-defined. Instead of guessing (which will +-- inline less than we want) we will just inline all simple functions. +-- +-- 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. 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 | not (is_fun expr) = + case collectArgs expr of + (Var f, args) -> 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 @@ -391,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