From 2b625f3b78898f203ba5c542d6421f1f73d28e4f Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Thu, 18 Jun 2009 15:26:38 +0200 Subject: [PATCH] Add a (fairly complete) set of transforms. These transforms should normalize most core programs, though this was not confirmed yet. Also, they do not use any cross-function transforming. --- Normalize.hs | 262 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 259 insertions(+), 3 deletions(-) diff --git a/Normalize.hs b/Normalize.hs index 5aacd7a..2b37e09 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -7,7 +7,6 @@ module Normalize (normalize) where -- Standard modules import Debug.Trace -import qualified List import qualified Maybe import qualified Control.Monad as Monad @@ -17,7 +16,8 @@ import qualified UniqSupply import qualified CoreUtils import qualified Type import qualified Id -import qualified CoreSubst +import qualified UniqSet +import qualified CoreFVs import Outputable ( showSDoc, ppr, nest ) -- Local imports @@ -25,8 +25,264 @@ import NormalizeTypes import NormalizeTools import CoreTools +-------------------------------- +-- Start of transformations +-------------------------------- + +-------------------------------- +-- η abstraction +-------------------------------- +eta, etatop :: Transform +eta expr | is_fun expr && not (is_lam expr) = do + let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr + id <- mkInternalVar "param" arg_ty + change (Lam id (App expr (Var id))) +-- Leave all other expressions unchanged +eta e = return e +etatop = notapplied ("eta", eta) + +-------------------------------- +-- β-reduction +-------------------------------- +beta, betatop :: Transform +-- Substitute arg for x in expr +beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr +-- Propagate the application into the let +beta (App (Let binds expr) arg) = change $ Let binds (App expr arg) +-- Propagate the application into each of the alternatives +beta (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') = Type.splitFunTy ty +-- Leave all other expressions unchanged +beta expr = return expr +-- Perform this transform everywhere +betatop = everywhere ("beta", beta) + +-------------------------------- +-- let recursification +-------------------------------- +letrec, letrectop :: Transform +letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res +-- Leave all other expressions unchanged +letrec expr = return expr +-- Perform this transform everywhere +letrectop = everywhere ("letrec", letrec) + +-------------------------------- +-- let simplification +-------------------------------- +letsimpl, letsimpltop :: Transform +-- Don't simplifiy lets that are already simple +letsimpl expr@(Let _ (Var _)) = return expr +-- Put the "in ..." value of a let in its own binding, but not when the +-- expression has a function type (to prevent loops with inlinefun). +letsimpl (Let (Rec binds) expr) | not $ is_fun expr = do + id <- mkInternalVar "foo" (CoreUtils.exprType expr) + let bind = (id, expr) + change $ Let (Rec (bind:binds)) (Var id) +-- Leave all other expressions unchanged +letsimpl expr = return expr +-- Perform this transform everywhere +letsimpltop = everywhere ("letsimpl", letsimpl) + +-------------------------------- +-- let flattening +-------------------------------- +letflat, letflattop :: Transform +letflat (Let (Rec binds) expr) = do + -- Turn each binding into a list of bindings (possibly containing just one + -- element, of course) + bindss <- Monad.mapM flatbind binds + -- Concat all the bindings + let binds' = concat bindss + -- 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, expr) = return [(b, expr)] +-- Leave all other expressions unchanged +letflat expr = return expr +-- Perform this transform everywhere +letflattop = everywhere ("letflat", letflat) + +-------------------------------- +-- Simple let binding removal +-------------------------------- +-- Remove a = b bindings from let expressions everywhere +letremovetop :: Transform +letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) -> True; otherwise -> False)) + +-------------------------------- +-- Function inlining +-------------------------------- +-- Remove a = B bindings, with B :: a -> b, from let expressions everywhere. +-- 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 function 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 primitive. +inlinefuntop :: Transform +inlinefuntop = everywhere ("inlinefun", inlinebind (Type.isFunTy . CoreUtils.exprType . snd)) + +-------------------------------- +-- Scrutinee simplification +-------------------------------- +scrutsimpl,scrutsimpltop :: Transform +-- Don't touch scrutinees that are already simple +scrutsimpl expr@(Case (Var _) _ _ _) = return expr +-- Replace all other cases with a let that binds the scrutinee and a new +-- simple scrutinee, but not when the scrutinee is a function type (to prevent +-- loops with inlinefun, though I don't think a scrutinee can have a function +-- type...) +scrutsimpl (Case scrut b ty alts) | not $ is_fun scrut = do + id <- mkInternalVar "scrut" (CoreUtils.exprType scrut) + change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts) +-- Leave all other expressions unchanged +scrutsimpl expr = return expr +-- Perform this transform everywhere +scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl) + +-------------------------------- +-- Case binder wildening +-------------------------------- +casewild, casewildtop :: Transform +casewild expr@(Case scrut b ty alts) = 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 = (Let (Rec bindings) (Case scrut b 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 || length alts == 1 && length bindings == 1 then return expr else change newlet + where + -- Generate a single wild binder, since they are all the same + wild = Id.mkWildId + -- 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 + bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..] + let bindings = Maybe.catMaybes bindings_maybe + -- We replace the binders with wild binders only. We can leave expr + -- unchanged, since the new bindings bind the same vars as the original + -- did. + let newalt = (con, wildbndrs, expr) + return (bindings, newalt) + where + -- Make all binders wild + wildbndrs = map (\bndr -> Id.mkWildId (Id.idType bndr)) bndrs + -- Creates a case statement to retrieve the ith element from the scrutinee + -- and binds that to b. + mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr)) + mkextracts b i = + if is_wild b || Type.isFunTy (Id.idType b) + -- Don't create extra bindings for binders that are already wild, or + -- for binders that bind function types (to prevent loops with + -- inlinefun). + then return Nothing + else do + -- Create on new binder that will actually capture a value in this + -- case statement, and return it + let bty = (Id.idType b) + id <- mkInternalVar "sel" bty + let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs + return $ Just (b, Case scrut b bty [(con, binders, Var id)]) +-- Leave all other expressions unchanged +casewild expr = return expr +-- Perform this transform everywhere +casewildtop = everywhere ("casewild", casewild) + +-------------------------------- +-- Case value simplification +-------------------------------- +casevalsimpl, casevalsimpltop :: Transform +casevalsimpl expr@(Case scrut b ty alts) = do + -- Try to simplify each alternative, resulting in an optional binding and a + -- new alternative. + (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts + let bindings = Maybe.catMaybes bindings_maybe + -- Create a new let around the case, that binds of the cases values. + let newlet = Let (Rec bindings) (Case scrut b ty alts') + -- If there were no values that needed and allowed simplification, don't + -- change the case. + if null bindings then return expr else change newlet + where + doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt) + -- Don't simplify values that are already simple + doalt alt@(con, bndrs, Var _) = return (Nothing, alt) + -- Simplify each alt by creating a new id, binding the case value to it and + -- replacing the case value with that id. Only do this when the case value + -- does not use any of the binders bound by this alternative, for that would + -- cause those binders to become unbound when moving the value outside of + -- the case statement. Also, don't create a binding for function-typed + -- expressions, to prevent loops with inlinefun. + doalt (con, bndrs, expr) | (not usesvars) && (not $ is_fun expr) = do + id <- mkInternalVar "caseval" (CoreUtils.exprType expr) + -- We don't flag a change here, since casevalsimpl will do that above + -- based on Just we return here. + return $ (Just (id, expr), (con, bndrs, Var id)) + -- Find if any of the binders are used by expr + where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr + -- Don't simplify anything else + doalt alt = return (Nothing, alt) +-- Leave all other expressions unchanged +casevalsimpl expr = return expr +-- Perform this transform everywhere +casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl) + +-------------------------------- +-- Case removal +-------------------------------- +-- Remove case statements that have only a single alternative and only wild +-- binders. +caseremove, caseremovetop :: Transform +-- Replace a useless case by the value of its single alternative +caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr + -- Find if any of the binders are used by expr + where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr +-- Leave all other expressions unchanged +caseremove expr = return expr +-- Perform this transform everywhere +caseremovetop = everywhere ("caseremove", caseremove) + +-------------------------------- +-- Application simplification +-------------------------------- +-- Make sure that all arguments in an application are simple variables. +appsimpl, appsimpltop :: Transform +-- Don't simplify arguments that are already simple +appsimpl expr@(App f (Var _)) = return expr +-- Simplify all arguments that do not have a function type (to prevent loops +-- with inlinefun) and is not a type argument. Do this by introducing a new +-- Let that binds the argument and passing the new binder in the application. +appsimpl (App f expr) | (not $ is_fun expr) && (not $ CoreSyn.isTypeArg expr) = do + id <- mkInternalVar "arg" (CoreUtils.exprType expr) + change $ Let (Rec [(id, expr)]) (App f (Var id)) +-- Leave all other expressions unchanged +appsimpl expr = return expr +-- Perform this transform everywhere +appsimpltop = everywhere ("appsimpl", appsimpl) + +-- TODO: introduce top level let if needed? + +-------------------------------- +-- End of transformations +-------------------------------- + + + + -- What transforms to run? -transforms = [] +transforms = [etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop] -- Normalize a core expression by running transforms until none applies -- anymore. Uses a UniqSupply to generate new identifiers. -- 2.30.2