X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=2b5c8999147c03662ff5bf806cab27af9e992ff3;hb=74c1f82bd035a57c9df445d803644fb338b32120;hp=c761433551412714f8c8e58e0451005aa31db5cb;hpb=b29ff3c525d3d81e73ed153549d5347941f78f8b;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 c761433..2b5c899 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -45,17 +45,16 @@ import CLasH.Utils.Pretty -------------------------------- -------------------------------- --- η abstraction --------------------------------- +-- η expansion +-------------------------------- +-- Make sure all parameters to the normalized functions are named by top +-- level lambda expressions. For this we apply η expansion to the +-- function body (possibly enclosed in some lambda abstractions) while +-- it has a function type. Eventually this will result in a function +-- body consisting of a bunch of nested lambdas containing a +-- non-function value (e.g., a complete application). 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 +eta c expr | is_fun expr && not (is_lam expr) && all (== LambdaBody) c = do let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr id <- Trans.lift $ mkInternalVar "param" arg_ty change (Lam id (App expr (Var id))) @@ -121,35 +120,40 @@ castsimpl c expr = return expr -- Perform this transform everywhere castsimpltop = everywhere ("castsimpl", castsimpl) - -------------------------------- --- Lambda simplication +-- 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. -------------------------------- --- 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 c 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 c expr@(Lam bndr res) = do - repr <- isRepr res - local_var <- Trans.lift $ is_local_var res +retvalsimpl c expr@(Let (Rec binds) body) | all (== LambdaBody) c = do + -- Don't extract values that are already a local variable, to prevent + -- loops with ourselves. + local_var <- Trans.lift $ is_local_var body + -- Don't extract values that are not representable, to prevent loops with + -- inlinenonrep + repr <- isRepr body if not local_var && repr then do - id <- Trans.lift $ mkBinderFor res "res" - change $ Lam bndr (Let (NonRec id res) (Var id)) + id <- Trans.lift $ mkBinderFor body "res" + change $ Let (Rec ((id, body):binds)) (Var id) + else + return expr + +retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do + local_var <- Trans.lift $ is_local_var expr + repr <- isRepr expr + if not local_var && repr + then do + id <- Trans.lift $ mkBinderFor expr "res" + change $ Let (Rec [(id, expr)]) (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 -lambdasimpl c expr = return expr +retvalsimpl c expr = return expr -- Perform this transform everywhere -lambdasimpltop = everywhere ("lambdasimpl", lambdasimpl) +retvalsimpltop = everywhere ("retvalsimpl", retvalsimpl) -------------------------------- -- let derecursification @@ -175,33 +179,6 @@ letderec c expr = return expr -- Perform this transform everywhere letderectop = everywhere ("letderec", letderec) --------------------------------- --- 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 c 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). -letsimpl c expr@(Let binds res) = do - repr <- isRepr res - local_var <- Trans.lift $ is_local_var res - if not local_var && repr - then do - -- If the result is not a local var already (to prevent loops with - -- ourselves), extract it. - id <- Trans.lift $ mkBinderFor res "foo" - change $ Let binds (Let (NonRec id res) (Var id)) - else - -- If the result is already a local var, don't extract it. - return expr - --- Leave all other expressions unchanged -letsimpl c expr = return expr --- Perform this transform everywhere -letsimpltop = everywhere ("letsimpl", letsimpl) - -------------------------------- -- let flattening -------------------------------- @@ -327,35 +304,35 @@ 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. +-- +-- 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. --- --- 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 -inlinetoplevel (LetBinding:_) expr = +inlinetoplevel (LetBinding:_) expr | not (is_fun 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 + (Var f, args) -> do body_maybe <- needsInline f case body_maybe of Just body -> do @@ -400,13 +377,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 @@ -808,25 +797,6 @@ funextract c expr = return expr -- 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 c expr@(Lam _ _) = return expr -simplrestop c expr@(Let _ _) = return expr -simplrestop c 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 -------------------------------- @@ -835,7 +805,7 @@ simplrestop c expr = do -- What transforms to run? -transforms = [inlinedicttop, inlinetopleveltop, classopresolutiontop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop] +transforms = [inlinedicttop, inlinetopleveltop, classopresolutiontop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, retvalsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop] -- | Returns the normalized version of the given function, or an error -- if it is not a known global binder. @@ -880,11 +850,14 @@ normalizeExpr :: -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression normalizeExpr what expr = do + startcount <- MonadState.get tsTransformCounter expr_uniqued <- genUniques expr -- Normalize this expression trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return () expr' <- dotransforms transforms expr_uniqued + endcount <- MonadState.get tsTransformCounter trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return () + trace ("\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $ return () return expr' -- | Split a normalized expression into the argument binders, top level