X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;fp=c%CE%BBash%2FCLasH%2FNormalize.hs;h=0000000000000000000000000000000000000000;hb=04f836932ad17dd557af0ba388a12d2b74c1e7d7;hp=c27e93eb7803c0c4604492308cbccd9fadbc2864;hpb=75978cf28a619d14ae27ea2bb4a53246b6a0bcd8;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" deleted file mode 100644 index c27e93e..0000000 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ /dev/null @@ -1,1043 +0,0 @@ --- --- Functions to bring a Core expression in normal form. This module provides a --- top level function "normalize", and defines the actual transformation passes that --- are performed. --- -module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized) where - --- Standard modules -import Debug.Trace -import qualified Maybe -import qualified List -import qualified Control.Monad.Trans.Class as Trans -import qualified Control.Monad as Monad -import qualified Control.Monad.Trans.Writer as Writer -import qualified Data.Accessor.Monad.Trans.State as MonadState -import qualified Data.Monoid as Monoid -import qualified Data.Map as Map - --- GHC API -import CoreSyn -import qualified CoreUtils -import qualified BasicTypes -import qualified Type -import qualified TysWiredIn -import qualified Id -import qualified Var -import qualified Name -import qualified DataCon -import qualified VarSet -import qualified CoreFVs -import qualified Class -import qualified MkCore -import Outputable ( showSDoc, ppr, nest ) - --- Local imports -import CLasH.Normalize.NormalizeTypes -import CLasH.Translator.TranslatorTypes -import CLasH.Normalize.NormalizeTools -import CLasH.VHDL.Constants (builtinIds) -import qualified CLasH.Utils as Utils -import CLasH.Utils.Core.CoreTools -import CLasH.Utils.Core.BinderTools -import CLasH.Utils.Pretty - ----------------------------------------------------------------- --- Cleanup transformations ----------------------------------------------------------------- - --------------------------------- --- β-reduction --------------------------------- -beta :: Transform --- Substitute arg for x in expr. For value lambda's, also clone before --- substitution. -beta c (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg c expr - | otherwise = setChanged >> substitute_clone x arg c expr --- Leave all other expressions unchanged -beta c expr = return expr - --------------------------------- --- Unused let binding removal --------------------------------- -letremoveunused :: Transform -letremoveunused c expr@(Let (NonRec b bound) res) = do - let used = expr_uses_binders [b] res - if used - then return expr - else change res -letremoveunused c expr@(Let (Rec binds) res) = do - -- Filter out all unused binds. - let binds' = filter dobind binds - -- Only set the changed flag if binds got removed - changeif (length binds' /= length binds) (Let (Rec binds') res) - where - bound_exprs = map snd binds - -- For each bind check if the bind is used by res or any of the bound - -- expressions - dobind (bndr, _) = any (expr_uses_binders [bndr]) (res:bound_exprs) --- Leave all other expressions unchanged -letremoveunused c expr = return expr - --------------------------------- --- empty let removal --------------------------------- --- Remove empty (recursive) lets -letremove :: Transform -letremove c (Let (Rec []) res) = change res --- Leave all other expressions unchanged -letremove c expr = return expr - --------------------------------- --- Simple let binding removal --------------------------------- --- Remove a = b bindings from let expressions everywhere -letremovesimple :: Transform -letremovesimple = inlinebind (\(b, e) -> Trans.lift $ is_local_var e) - --------------------------------- --- Cast propagation --------------------------------- --- Try to move casts as much downward as possible. -castprop :: Transform -castprop c (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty) -castprop c expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts') - where - alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts --- Leave all other expressions unchanged -castprop c expr = return expr - --------------------------------- --- Cast simplification. Mostly useful for state packing and unpacking, but --- perhaps for others as well. --------------------------------- -castsimpl :: Transform -castsimpl c expr@(Cast val ty) = do - -- Don't extract values that are already simpl - local_var <- Trans.lift $ is_local_var val - -- Don't extract values that are not representable, to prevent loops with - -- inlinenonrep - repr <- isRepr val - if (not local_var) && repr - then do - -- Generate a binder for the expression - id <- Trans.lift $ mkBinderFor val "castval" - -- Extract the expression - change $ Let (NonRec id val) (Cast (Var id) ty) - else - return expr --- Leave all other expressions unchanged -castsimpl c expr = return expr - --------------------------------- --- Top level function inlining --------------------------------- --- 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) --- --- 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 :: Transform -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 - --- | Does the given binder need to be inlined? If so, return the body to --- be used for inlining. -needsInline :: CoreBndr -> TransformMonad (Maybe CoreExpr) -needsInline f = do - body_maybe <- Trans.lift $ getGlobalBind f - case body_maybe of - -- No body available? - Nothing -> return Nothing - Just body -> case CoreSyn.collectArgs body of - -- The body is some (top level) binder applied to 0 or more - -- arguments. That should be simple enough to inline. - (Var f, args) -> return $ Just body - -- Body is more complicated, try normalizing it - _ -> do - norm_maybe <- Trans.lift $ getNormalized_maybe False f - case norm_maybe of - -- Noth normalizeable - Nothing -> return Nothing - Just norm -> case splitNormalizedNonRep norm of - -- The function has just a single binding, so that's simple - -- enough to inline. - (args, [bind], Var res) -> return $ Just norm - -- More complicated function, don't inline - _ -> return Nothing - - ----------------------------------------------------------------- --- Program structure transformations ----------------------------------------------------------------- - --------------------------------- --- η 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 :: Transform -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))) --- Leave all other expressions unchanged -eta c e = return e - --------------------------------- --- Application propagation --------------------------------- --- Move applications into let and case expressions. -appprop :: Transform --- Propagate the application into the let -appprop c (App (Let binds expr) arg) = change $ Let binds (App expr arg) --- Propagate the application into each of the alternatives -appprop c (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts' - where - alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts - ty' = CoreUtils.applyTypeToArg ty arg --- Leave all other expressions unchanged -appprop c expr = return expr - --------------------------------- --- Let recursification --------------------------------- --- Make all lets recursive, so other transformations don't need to --- handle non-recursive lets -letrec :: Transform -letrec c expr@(Let (NonRec bndr val) res) = - change $ Let (Rec [(bndr, val)]) res - --- Leave all other expressions unchanged -letrec c expr = return expr - --------------------------------- --- let flattening --------------------------------- --- Takes a let that binds another let, and turns that into two nested lets. --- e.g., from: --- let b = (let b' = expr' in res') in res --- to: --- let b' = expr' in (let b = res' in res) -letflat :: Transform --- Turn a nonrec let that binds a let into two nested lets. -letflat c (Let (NonRec b (Let binds res')) res) = - change $ Let binds (Let (NonRec b res') res) -letflat c (Let (Rec binds) expr) = do - -- Flatten each binding. - binds' <- Utils.concatM $ Monad.mapM flatbind binds - -- Return the new let. We don't use change here, since possibly nothing has - -- changed. If anything has changed, flatbind has already flagged that - -- change. - return $ Let (Rec binds') expr - where - -- Turns a binding of a let into a multiple bindings, or any other binding - -- into a list with just that binding - flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)] - flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds) - flatbind (b, Let (NonRec b' expr') expr) = change [(b, expr), (b', expr')] - flatbind (b, expr) = return [(b, expr)] --- Leave all other expressions unchanged -letflat c expr = return expr - --------------------------------- --- Return value simplification --------------------------------- --- Ensure the return value of a function follows proper normal form. eta --- expansion ensures the body starts with lambda abstractions, this --- transformation ensures that the lambda abstractions always contain a --- recursive let and that, when the return value is representable, the --- let contains a local variable reference in its body. - --- Extract the return value from the body of the top level lambdas (of --- which ther could be zero), unless it is a let expression (in which --- case the next clause applies). -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 - return expr --- Extract the return value from the body of a let expression, which is --- itself the body of the top level lambdas (of which there could be --- zero). -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 body "res" - change $ Let (Rec ((id, body):binds)) (Var id) - else - return expr --- Leave all other expressions unchanged -retvalsimpl c expr = return expr - --------------------------------- --- Representable arguments simplification --------------------------------- --- Make sure that all arguments of a representable type are simple variables. -appsimpl :: Transform --- Simplify all representable arguments. Do this by introducing a new Let --- that binds the argument and passing the new binder in the application. -appsimpl c expr@(App f arg) = do - -- Check runtime representability - repr <- isRepr arg - local_var <- Trans.lift $ is_local_var arg - if repr && not local_var - then do -- Extract representable arguments - id <- Trans.lift $ mkBinderFor arg "arg" - change $ Let (NonRec id arg) (App f (Var id)) - else -- Leave non-representable arguments unchanged - return expr --- Leave all other expressions unchanged -appsimpl c expr = return expr - ----------------------------------------------------------------- --- Built-in function transformations ----------------------------------------------------------------- - --------------------------------- --- Function-typed argument extraction --------------------------------- --- This transform takes any function-typed argument that cannot be propagated --- (because the function that is applied to it is a builtin function), and --- puts it in a brand new top level binder. This allows us to for example --- apply map to a lambda expression This will not conflict with inlinenonrep, --- since that only inlines local let bindings, not top level bindings. -funextract :: Transform -funextract c expr@(App _ _) | is_var fexpr = do - body_maybe <- Trans.lift $ getGlobalBind f - case body_maybe of - -- We don't have a function body for f, so we can perform this transform. - Nothing -> do - -- Find the new arguments - args' <- mapM doarg args - -- And update the arguments. We use return instead of changed, so the - -- changed flag doesn't get set if none of the args got changed. - return $ MkCore.mkCoreApps fexpr args' - -- We have a function body for f, leave this application to funprop - Just _ -> return expr - where - -- Find the function called and the arguments - (fexpr, args) = collectArgs expr - Var f = fexpr - -- Change any arguments that have a function type, but are not simple yet - -- (ie, a variable or application). This means to create a new function - -- for map (\f -> ...) b, but not for map (foo a) b. - -- - -- We could use is_applicable here instead of is_fun, but I think - -- arguments to functions could only have forall typing when existential - -- typing is enabled. Not sure, though. - doarg arg | not (is_simple arg) && is_fun arg = do - -- Create a new top level binding that binds the argument. Its body will - -- be extended with lambda expressions, to take any free variables used - -- by the argument expression. - let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg - let body = MkCore.mkCoreLams free_vars arg - id <- Trans.lift $ mkBinderFor body "fun" - Trans.lift $ addGlobalBind id body - -- Replace the argument with a reference to the new function, applied to - -- all vars it uses. - change $ MkCore.mkCoreApps (Var id) (map Var free_vars) - -- Leave all other arguments untouched - doarg arg = return arg - --- Leave all other expressions unchanged -funextract c expr = return expr - - - - ----------------------------------------------------------------- --- Case normalization transformations ----------------------------------------------------------------- - --------------------------------- --- Scrutinee simplification --------------------------------- --- Make sure the scrutinee of a case expression is a local variable --- reference. -scrutsimpl :: Transform --- Don't touch scrutinees that are already simple -scrutsimpl c expr@(Case (Var _) _ _ _) = return expr --- Replace all other cases with a let that binds the scrutinee and a new --- simple scrutinee, but only when the scrutinee is representable (to prevent --- loops with inlinenonrep, though I don't think a non-representable scrutinee --- will be supported anyway...) -scrutsimpl c expr@(Case scrut b ty alts) = do - repr <- isRepr scrut - if repr - then do - id <- Trans.lift $ mkBinderFor scrut "scrut" - change $ Let (NonRec id scrut) (Case (Var id) b ty alts) - else - return expr --- Leave all other expressions unchanged -scrutsimpl c expr = return expr - --------------------------------- --- Scrutinee binder removal --------------------------------- --- A case expression can have an extra binder, to which the scrutinee is bound --- after bringing it to WHNF. This is used for forcing evaluation of strict --- arguments. Since strictness does not matter for us (rather, everything is --- sort of strict), this binder is ignored when generating VHDL, and must thus --- be wild in the normal form. -scrutbndrremove :: Transform --- If the scrutinee is already simple, and the bndr is not wild yet, replace --- all occurences of the binder with the scrutinee variable. -scrutbndrremove c (Case (Var scrut) bndr ty alts) | bndr_used = do - alts' <- mapM subs_bndr alts - change $ Case (Var scrut) wild ty alts' - where - is_used (_, _, expr) = expr_uses_binders [bndr] expr - bndr_used = or $ map is_used alts - subs_bndr (con, bndrs, expr) = do - expr' <- substitute bndr (Var scrut) c expr - return (con, bndrs, expr') - wild = MkCore.mkWildBinder (Id.idType bndr) --- Leave all other expressions unchanged -scrutbndrremove c expr = return expr - --------------------------------- --- Case normalization --------------------------------- --- Turn a case expression with any number of alternatives with any --- number of non-wild binders into as set of case and let expressions, --- all of which are in normal form (e.g., a bunch of extractor case --- expressions to extract all fields from the scrutinee, a number of let --- bindings to bind each alternative and a single selector case to --- select the right value. -casesimpl :: Transform --- This is already a selector case (or, if x does not appear in bndrs, a very --- simple case statement that will be removed by caseremove below). Just leave --- it be. -casesimpl c expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr --- Make sure that all case alternatives have only wild binders and simple --- expressions. --- This is done by creating a new let binding for each non-wild binder, which --- is bound to a new simple selector case statement and for each complex --- expression. We do this only for representable types, to prevent loops with --- inlinenonrep. -casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do - (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts - let bindings = concat bindingss - -- Replace the case with a let with bindings and a case - let newlet = mkNonRecLets bindings (Case scrut bndr ty alts') - -- If there are no non-wild binders, or this case is already a simple - -- selector (i.e., a single alt with exactly one binding), already a simple - -- selector altan no bindings (i.e., no wild binders in the original case), - -- don't change anything, otherwise, replace the case. - if null bindings then return expr else change newlet - where - -- Check if the scrutinee binder is used - is_used (_, _, expr) = expr_uses_binders [bndr] expr - bndr_used = or $ map is_used alts - -- Generate a single wild binder, since they are all the same - wild = MkCore.mkWildBinder - -- Wilden the binders of one alt, producing a list of bindings as a - -- sideeffect. - doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt) - doalt (con, bndrs, expr) = do - -- Make each binder wild, if possible - bndrs_res <- Monad.zipWithM dobndr bndrs [0..] - let (newbndrs, bindings_maybe) = unzip bndrs_res - -- Extract a complex expression, if possible. For this we check if any of - -- the new list of bndrs are used by expr. We can't use free_vars here, - -- since that looks at the old bndrs. - let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr - (exprbinding_maybe, expr') <- doexpr expr uses_bndrs - -- Create a new alternative - let newalt = (con, newbndrs, expr') - let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe]) - return (bindings, newalt) - where - -- Make wild alternatives for each binder - wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs - -- A set of all the binders that are used by the expression - free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr - -- Look at the ith binder in the case alternative. Return a new binder - -- for it (either the same one, or a wild one) and optionally a let - -- binding containing a case expression. - dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr)) - dobndr b i = do - repr <- isRepr b - -- Is b wild (e.g., not a free var of expr. Since b is only in scope - -- in expr, this means that b is unused if expr does not use it.) - let wild = not (VarSet.elemVarSet b free_vars) - -- Create a new binding for any representable binder that is not - -- already wild and is representable (to prevent loops with - -- inlinenonrep). - if (not wild) && repr - then do - caseexpr <- Trans.lift $ mkSelCase scrut i - -- Create a new binder that will actually capture a value in this - -- case statement, and return it. - return (wildbndrs!!i, Just (b, caseexpr)) - else - -- Just leave the original binder in place, and don't generate an - -- extra selector case. - return (b, Nothing) - -- Process the expression of a case alternative. Accepts an expression - -- and whether this expression uses any of the binders in the - -- alternative. Returns an optional new binding and a new expression. - doexpr :: CoreExpr -> Bool -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreExpr) - doexpr expr uses_bndrs = do - local_var <- Trans.lift $ is_local_var expr - repr <- isRepr expr - -- Extract any expressions that do not use any binders from this - -- alternative, is not a local var already and is representable (to - -- prevent loops with inlinenonrep). - if (not uses_bndrs) && (not local_var) && repr - then do - id <- Trans.lift $ mkBinderFor expr "caseval" - -- We don't flag a change here, since casevalsimpl will do that above - -- based on Just we return here. - return (Just (id, expr), Var id) - else - -- Don't simplify anything else - return (Nothing, expr) --- Leave all other expressions unchanged -casesimpl c expr = return expr - --------------------------------- --- Case removal --------------------------------- --- Remove case statements that have only a single alternative and only wild --- binders. -caseremove :: Transform --- Replace a useless case by the value of its single alternative -caseremove c (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr - -- Find if any of the binders are used by expr - where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` b:bndrs))) expr --- Leave all other expressions unchanged -caseremove c expr = return expr - --------------------------------- --- Case of known constructor simplification --------------------------------- --- If a case expressions scrutinizes a datacon application, we can --- determine which alternative to use and remove the case alltogether. --- We replace it with a let expression the binds every binder in the --- alternative bound to the corresponding argument of the datacon. We do --- this instead of substituting the binders, to prevent duplication of --- work and preserve sharing wherever appropriate. -knowncase :: Transform -knowncase context expr@(Case scrut@(App _ _) bndr ty alts) | not bndr_used = do - case collectArgs scrut of - (Var f, args) -> case Id.isDataConId_maybe f of - -- Not a dataconstructor? Don't change anything (probably a - -- function, then) - Nothing -> return expr - Just dc -> do - let (altcon, bndrs, res) = case List.find (\(altcon, bndrs, res) -> altcon == (DataAlt dc)) alts of - Just alt -> alt -- Return the alternative found - Nothing -> head alts -- If the datacon is not present, the first must be the default alternative - -- Double check if we have either the correct alternative, or - -- the default. - if altcon /= (DataAlt dc) && altcon /= DEFAULT then error ("Normalize.knowncase: Invalid core, datacon not found in alternatives and DEFAULT alternative is not first? " ++ pprString expr) else return () - -- Find out how many arguments to drop (type variables and - -- predicates like dictionaries). - let (tvs, preds, _, _) = DataCon.dataConSig dc - let count = length tvs + length preds - -- Create a let expression that binds each of the binders in - -- this alternative to the corresponding argument of the data - -- constructor. - let binds = zip bndrs (drop count args) - change $ Let (Rec binds) res - _ -> return expr -- Scrutinee is not an application of a var - where - is_used (_, _, expr) = expr_uses_binders [bndr] expr - bndr_used = or $ map is_used alts - --- Leave all other expressions unchanged -knowncase c expr = return expr - - - - ----------------------------------------------------------------- --- Unrepresentable value removal transformations ----------------------------------------------------------------- - --------------------------------- --- Non-representable binding inlining --------------------------------- --- Remove a = B bindings, with B of a non-representable type, from let --- expressions everywhere. This means that any value that we can't generate a --- signal for, will be inlined and hopefully turned into something we can --- represent. --- --- This is a tricky function, which is prone to create loops in the --- transformations. To fix this, we make sure that no transformation will --- create a new let binding with a non-representable type. These other --- transformations will just not work on those function-typed values at first, --- but the other transformations (in particular β-reduction) should make sure --- that the type of those values eventually becomes representable. -inlinenonrep :: Transform -inlinenonrep = inlinebind ((Monad.liftM not) . isRepr . snd) - --------------------------------- --- Function specialization --------------------------------- --- Remove all applications to non-representable arguments, by duplicating the --- function called with the non-representable parameter replaced by the free --- variables of the argument passed in. -argprop :: Transform --- Transform any application of a named function (i.e., skip applications of --- lambda's). Also skip applications that have arguments with free type --- variables, since we can't inline those. -argprop c expr@(App _ _) | is_var fexpr = do - -- Find the body of the function called - body_maybe <- Trans.lift $ getGlobalBind f - case body_maybe of - Just body -> do - -- Process each of the arguments in turn - (args', changed) <- Writer.listen $ mapM doarg args - -- See if any of the arguments changed - case Monoid.getAny changed of - True -> do - let (newargs', newparams', oldargs) = unzip3 args' - let newargs = concat newargs' - let newparams = concat newparams' - -- Create a new body that consists of a lambda for all new arguments and - -- the old body applied to some arguments. - let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) - -- Create a new function with the same name but a new body - newf <- Trans.lift $ mkFunction f newbody - - Trans.lift $ MonadState.modify tsInitStates (\ismap -> - let init_state_maybe = Map.lookup f ismap in - case init_state_maybe of - Nothing -> ismap - Just init_state -> Map.insert newf init_state ismap) - -- Replace the original application with one of the new function to the - -- new arguments. - change $ MkCore.mkCoreApps (Var newf) newargs - False -> - -- Don't change the expression if none of the arguments changed - return expr - - -- If we don't have a body for the function called, leave it unchanged (it - -- should be a primitive function then). - Nothing -> return expr - where - -- Find the function called and the arguments - (fexpr, args) = collectArgs expr - Var f = fexpr - - -- Process a single argument and return (args, bndrs, arg), where args are - -- the arguments to replace the given argument in the original - -- application, bndrs are the binders to include in the top-level lambda - -- in the new function body, and arg is the argument to apply to the old - -- function body. - doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr) - doarg arg = do - repr <- isRepr arg - bndrs <- Trans.lift getGlobalBinders - let interesting var = Var.isLocalVar var && (var `notElem` bndrs) - if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) - then do - -- Propagate all complex arguments that are not representable, but not - -- arguments with free type variables (since those would require types - -- not known yet, which will always be known eventually). - -- Find interesting free variables, each of which should be passed to - -- the new function instead of the original function argument. - -- - -- Interesting vars are those that are local, but not available from the - -- top level scope (functions from this module are defined as local, but - -- they're not local to this function, so we can freely move references - -- to them into another function). - let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg - -- Mark the current expression as changed - setChanged - -- TODO: Clone the free_vars (and update references in arg), since - -- this might cause conflicts if two arguments that are propagated - -- share a free variable. Also, we are now introducing new variables - -- into a function that are not fresh, which violates the binder - -- uniqueness invariant. - return (map Var free_vars, free_vars, arg) - else do - -- Representable types will not be propagated, and arguments with free - -- type variables will be propagated later. - -- Note that we implicitly remove any type variables in the type of - -- the original argument by using the type of the actual argument - -- for the new formal parameter. - -- TODO: preserve original naming? - id <- Trans.lift $ mkBinderFor arg "param" - -- Just pass the original argument to the new function, which binds it - -- to a new id and just pass that new id to the old function body. - return ([arg], [id], mkReferenceTo id) --- Leave all other expressions unchanged -argprop c expr = return expr - --------------------------------- --- Non-representable result inlining --------------------------------- --- This transformation takes a function (top level binding) that has a --- non-representable result (e.g., a tuple containing a function, or an --- Integer. The latter can occur in some cases as the result of the --- fromIntegerT function) and inlines enough of the function to make the --- result representable again. --- --- This is done by first normalizing the function and then "inlining" --- the result. Since no unrepresentable let bindings are allowed in --- normal form, we can be sure that all free variables of the result --- expression will be representable (Note that we probably can't --- guarantee that all representable parts of the expression will be free --- variables, so we might inline more than strictly needed). --- --- The new function result will be a tuple containing all free variables --- of the old result, so the old result can be rebuild at the caller. --- --- We take care not to inline dictionary id's, which are top level --- bindings with a non-representable result type as well, since those --- will never become VHDL signals directly. There is a separate --- transformation (inlinedict) that specifically inlines dictionaries --- only when it is useful. -inlinenonrepresult :: Transform - --- Apply to any (application of) a reference to a top level function --- that is fully applied (i.e., dos not have a function type) but is not --- representable. We apply in any context, since non-representable --- expressions are generally left alone and can occur anywhere. -inlinenonrepresult context expr | not (is_fun expr) = - case collectArgs expr of - (Var f, args) | not (Id.isDictId f) -> do - repr <- isRepr expr - if not repr - then do - body_maybe <- Trans.lift $ getNormalized_maybe True f - case body_maybe of - Just body -> do - let (bndrs, binds, res) = splitNormalizedNonRep body - if has_free_tyvars res - then - -- Don't touch anything with free type variables, since - -- we can't return those. We'll wait until argprop - -- removed those variables. - return expr - else do - -- Get the free local variables of res - global_bndrs <- Trans.lift getGlobalBinders - let interesting var = Var.isLocalVar var && (var `notElem` global_bndrs) - let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting res - let free_var_types = map Id.idType free_vars - let n_free_vars = length free_vars - -- Get a tuple datacon to wrap around the free variables - let fvs_datacon = TysWiredIn.tupleCon BasicTypes.Boxed n_free_vars - let fvs_datacon_id = DataCon.dataConWorkId fvs_datacon - -- Let the function now return a tuple with references to - -- all free variables of the old return value. First pass - -- all the types of the variables, since tuple - -- constructors are polymorphic. - let newres = mkApps (Var fvs_datacon_id) (map Type free_var_types ++ map Var free_vars) - -- Recreate the function body with the changed return value - let newbody = mkLams bndrs (Let (Rec binds) newres) - -- Create the new function - f' <- Trans.lift $ mkFunction f newbody - - -- Call the new function - let newapp = mkApps (Var f') args - res_bndr <- Trans.lift $ mkBinderFor newapp "res" - -- Create extractor case expressions to extract each of the - -- free variables from the tuple. - sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1] - - -- Bind the res_bndr to the result of the new application - -- and each of the free variables to the corresponding - -- selector case. Replace the let body with the original - -- body of the called function (which can still access all - -- of its free variables, from the let). - let binds = (res_bndr, newapp):(zip free_vars sel_cases) - let letexpr = Let (Rec binds) res - - -- Finally, regenarate all uniques in the new expression, - -- since the free variables could otherwise become - -- duplicated. It is not strictly necessary to regenerate - -- res, since we're moving that expression, but it won't - -- hurt. - letexpr_uniqued <- Trans.lift $ genUniques letexpr - change letexpr_uniqued - Nothing -> return expr - else - -- Don't touch representable expressions or (applications of) - -- dictionary ids. - return expr - -- Not a reference to or application of a top level function - _ -> return expr --- Leave all other expressions unchanged -inlinenonrepresult c expr = return expr - --------------------------------- --- ClassOp resolution --------------------------------- --- Resolves any class operation to the actual operation whenever --- possible. Class methods (as well as parent dictionary selectors) are --- special "functions" that take a type and a dictionary and evaluate to --- the corresponding method. A dictionary is nothing more than a --- special dataconstructor applied to the type the dictionary is for, --- each of the superclasses and all of the class method definitions for --- that particular type. Since dictionaries all always inlined (top --- levels dictionaries are inlined by inlinedict, local dictionaries are --- inlined by inlinenonrep), we will eventually have something like: --- --- baz --- @ CLasH.HardwareTypes.Bit --- (D:Baz @ CLasH.HardwareTypes.Bit bitbaz) --- --- Here, baz is the method selector for the baz method, while --- D:Baz is the dictionary constructor for the Baz and bitbaz is the baz --- method defined in the Baz Bit instance declaration. --- --- To resolve this, we can look at the ClassOp IdInfo from the baz Id, --- which contains the Class it is defined for. From the Class, we can --- get a list of all selectors (both parent class selectors as well as --- method selectors). Since the arguments to D:Baz (after the type --- argument) correspond exactly to this list, we then look up baz in --- that list and replace the entire expression by the corresponding --- argument to D:Baz. --- --- We don't resolve methods that have a builtin translation (such as --- ==), since the actual implementation is not always (easily) --- translateable. For example, when deriving ==, GHC generates code --- using $con2tag functions to translate a datacon to an int and compare --- that with GHC.Prim.==# . Better to avoid that for now. -classopresolution :: Transform -classopresolution c expr@(App (App (Var sel) ty) dict) | not is_builtin = - case Id.isClassOpId_maybe sel of - -- Not a class op selector - Nothing -> return expr - Just cls -> case collectArgs dict of - (_, []) -> return expr -- Dict is not an application (e.g., not inlined yet) - (Var dictdc, (ty':selectors)) | not (Maybe.isJust (Id.isDataConId_maybe dictdc)) -> return expr -- Dictionary is not a datacon yet (but e.g., a top level binder) - | tyargs_neq ty ty' -> error $ "Normalize.classopresolution: Applying class selector to dictionary without matching type?\n" ++ pprString expr - | otherwise -> - let selector_ids = Class.classSelIds cls in - -- Find the selector used in the class' list of selectors - case List.elemIndex sel selector_ids of - Nothing -> error $ "Normalize.classopresolution: Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids - -- Get the corresponding argument from the dictionary - Just n -> change (selectors!!n) - (_, _) -> return expr -- Not applying a variable? Don't touch - where - -- Compare two type arguments, returning True if they are _not_ - -- equal - tyargs_neq (Type ty1) (Type ty2) = not $ Type.coreEqType ty1 ty2 - tyargs_neq _ _ = True - -- Is this a builtin function / method? - is_builtin = elem (Name.getOccString sel) builtinIds - --- Leave all other expressions unchanged -classopresolution c expr = return expr - --------------------------------- --- Dictionary inlining --------------------------------- --- 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 (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 - - -{- --------------------------------- --- Identical let binding merging --------------------------------- --- Merge two bindings in a let if they are identical --- TODO: We would very much like to use GHC's CSE module for this, but that --- doesn't track if something changed or not, so we can't use it properly. -letmerge :: Transform -letmerge c expr@(Let _ _) = do - let (binds, res) = flattenLets expr - binds' <- domerge binds - return $ mkNonRecLets binds' res - where - domerge :: [(CoreBndr, CoreExpr)] -> TransformMonad [(CoreBndr, CoreExpr)] - domerge [] = return [] - domerge (e:es) = do - es' <- mapM (mergebinds e) es - es'' <- domerge es' - return (e:es'') - - -- Uses the second bind to simplify the second bind, if applicable. - mergebinds :: (CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr) - mergebinds (b1, e1) (b2, e2) - -- Identical expressions? Replace the second binding with a reference to - -- the first binder. - | CoreUtils.cheapEqExpr e1 e2 = change $ (b2, Var b1) - -- Different expressions? Don't change - | otherwise = return (b2, e2) --- Leave all other expressions unchanged -letmerge c expr = return expr --} - --------------------------------- --- End of transformations --------------------------------- - - - - --- What transforms to run? -transforms = [ ("inlinedict", inlinedict) - , ("inlinetoplevel", inlinetoplevel) - , ("inlinenonrepresult", inlinenonrepresult) - , ("knowncase", knowncase) - , ("classopresolution", classopresolution) - , ("argprop", argprop) - , ("funextract", funextract) - , ("eta", eta) - , ("beta", beta) - , ("appprop", appprop) - , ("castprop", castprop) - , ("letremovesimple", letremovesimple) - , ("letrec", letrec) - , ("letremove", letremove) - , ("retvalsimpl", retvalsimpl) - , ("letflat", letflat) - , ("scrutsimpl", scrutsimpl) - , ("scrutbndrremove", scrutbndrremove) - , ("casesimpl", casesimpl) - , ("caseremove", caseremove) - , ("inlinenonrep", inlinenonrep) - , ("appsimpl", appsimpl) - , ("letremoveunused", letremoveunused) - , ("castsimpl", castsimpl) - ] - --- | Returns the normalized version of the given function, or an error --- if it is not a known global binder. -getNormalized :: - Bool -- ^ Allow the result to be unrepresentable? - -> CoreBndr -- ^ The function to get - -> TranslatorSession CoreExpr -- The normalized function body -getNormalized result_nonrep bndr = do - norm <- getNormalized_maybe result_nonrep bndr - return $ Maybe.fromMaybe - (error $ "Normalize.getNormalized: Unknown or non-representable function requested: " ++ show bndr) - norm - --- | Returns the normalized version of the given function, or Nothing --- when the binder is not a known global binder or is not normalizeable. -getNormalized_maybe :: - Bool -- ^ Allow the result to be unrepresentable? - -> CoreBndr -- ^ The function to get - -> TranslatorSession (Maybe CoreExpr) -- The normalized function body - -getNormalized_maybe result_nonrep bndr = do - expr_maybe <- getGlobalBind bndr - normalizeable <- isNormalizeable result_nonrep bndr - if not normalizeable || Maybe.isNothing expr_maybe - then - -- Binder not normalizeable or not found - return Nothing - else do - -- Binder found and is monomorphic. Normalize the expression - -- and cache the result. - normalized <- Utils.makeCached bndr tsNormalized $ - normalizeExpr (show bndr) (Maybe.fromJust expr_maybe) - return (Just normalized) - --- | Normalize an expression -normalizeExpr :: - String -- ^ What are we normalizing? For debug output only. - -> CoreSyn.CoreExpr -- ^ The expression to normalize - -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression - -normalizeExpr what expr = do - startcount <- MonadState.get tsTransformCounter - expr_uniqued <- genUniques expr - -- Do a debug print, if requested - let expr_uniqued' = Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") expr_uniqued - -- Normalize this expression - expr' <- dotransforms transforms expr_uniqued' - endcount <- MonadState.get tsTransformCounter - -- Do a debug print, if requested - Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr') ++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $ - return expr' - --- | Split a normalized expression into the argument binders, top level --- bindings and the result binder. This function returns an error if --- the type of the expression is not representable. -splitNormalized :: - CoreExpr -- ^ The normalized expression - -> ([CoreBndr], [Binding], CoreBndr) -splitNormalized expr = - case splitNormalizedNonRep expr of - (args, binds, Var res) -> (args, binds, res) - _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n" - --- Split a normalized expression, whose type can be unrepresentable. -splitNormalizedNonRep:: - CoreExpr -- ^ The normalized expression - -> ([CoreBndr], [Binding], CoreExpr) -splitNormalizedNonRep expr = (args, binds, resexpr) - where - (args, letexpr) = CoreSyn.collectBinders expr - (binds, resexpr) = flattenLets letexpr