From: Christiaan Baaij Date: Fri, 3 Jul 2009 19:42:19 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=35d10dbd4dcd24f3bd8a46e3a359d6f16dccfd32;hp=8d8e5446f4558cd5bfbd78f3378e6cf96a9c3fc8;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Let inlinefun inline everything non-representable. Unify typeprop and funprop into argprop. Extract only representable arguments. Add predicates for testing representability of types. --- diff --git a/Normalize.hs b/Normalize.hs index 9336921..2ecf2fa 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -140,7 +140,7 @@ letflattop = everywhere ("letflat", letflat) -------------------------------- -- Remove a = b bindings from let expressions everywhere letremovetop :: Transform -letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False)) +letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> return True; otherwise -> return False)) -------------------------------- -- Function inlining @@ -157,8 +157,8 @@ letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) -- 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 (is_applicable . snd)) +inlinenonreptop :: Transform +inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd)) -------------------------------- -- Scrutinee simplification @@ -291,61 +291,33 @@ caseremovetop = everywhere ("caseremove", caseremove) appsimpl, appsimpltop :: Transform -- Don't simplify arguments that are already simple. appsimpl expr@(App f (Var v)) = return expr --- Simplify all non-applicable (to prevent loops with inlinefun) arguments, --- except for type arguments (since a let can't bind type vars, only a lambda --- can). 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_applicable expr) && (not $ CoreSyn.isTypeArg expr) = do - id <- mkInternalVar "arg" (CoreUtils.exprType expr) - change $ Let (Rec [(id, expr)]) (App f (Var id)) +-- Simplify all representable arguments. Do this by introducing a new Let +-- that binds the argument and passing the new binder in the application. +appsimpl expr@(App f arg) = do + -- Check runtime representability + repr <- isRepr arg + if repr + then do -- Extract representable arguments + id <- mkInternalVar "arg" (CoreUtils.exprType arg) + change $ Let (Rec [(id, arg)]) (App f (Var id)) + else -- Leave non-representable arguments unchanged + return expr -- Leave all other expressions unchanged appsimpl expr = return expr -- Perform this transform everywhere appsimpltop = everywhere ("appsimpl", appsimpl) - --------------------------------- --- Type argument propagation --------------------------------- --- Remove all applications to type arguments, by duplicating the function --- called with the type application in its new definition. We leave --- dictionaries that might be associated with the type untouched, the funprop --- transform should propagate these later on. -typeprop, typeproptop :: Transform --- Transform any function that is applied to a type argument. Since type --- arguments are always the first ones to apply and we'll remove all type --- arguments, we can simply do them one by one. We only propagate type --- arguments without any free tyvars, since tyvars those wouldn't be in scope --- in the new function. -typeprop expr@(App (Var f) arg@(Type ty)) | not $ has_free_tyvars arg = do - body_maybe <- Trans.lift $ getGlobalBind f - case body_maybe of - Just body -> do - let newbody = App body (Type ty) - -- Create a new function with the same name but a new body - newf <- mkFunction f newbody - -- Replace the application with this new function - change (Var newf) - -- If we don't have a body for the function called, leave it unchanged (it - -- should be a primitive function then). - Nothing -> return expr --- Leave all other expressions unchanged -typeprop expr = return expr --- Perform this transform everywhere -typeproptop = everywhere ("typeprop", typeprop) - - -------------------------------- -- Function-typed argument propagation -------------------------------- -- Remove all applications to function-typed arguments, by duplication the -- function called with the function-typed parameter replaced by the free -- variables of the argument passed in. -funprop, funproptop :: Transform +argprop, argproptop :: 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. -funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do +argprop expr@(App _ _) | is_var fexpr = do -- Find the body of the function called body_maybe <- Trans.lift $ getGlobalBind f case body_maybe of @@ -384,32 +356,38 @@ funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do -- 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 | is_fun arg = do + doarg arg = do + repr <- isRepr arg bndrs <- Trans.lift getGlobalBinders - -- 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 interesting var = Var.isLocalVar var && (not $ var `elem` bndrs) - let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg - -- Mark the current expression as changed - setChanged - return (map Var free_vars, free_vars, arg) - -- Non-functiontyped arguments can be unchanged. Note that this handles - -- both values and types. - doarg arg = do - -- TODO: preserve original naming? - id <- 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) + 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 + 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. + -- TODO: preserve original naming? + id <- 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 -funprop expr = return expr +argprop expr = return expr -- Perform this transform everywhere -funproptop = everywhere ("funprop", funprop) +argproptop = everywhere ("argprop", argprop) -------------------------------- -- Function-typed argument extraction @@ -470,7 +448,7 @@ funextracttop = everywhere ("funextract", funextract) -- What transforms to run? -transforms = [typeproptop, funproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop] +transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop] -- Turns the given bind into VHDL normalizeModule :: diff --git a/NormalizeTools.hs b/NormalizeTools.hs index 1785eed..85fae47 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -7,6 +7,7 @@ module NormalizeTools where import Debug.Trace import qualified List import qualified Data.Monoid as Monoid +import qualified Data.Either as Either import qualified Control.Arrow as Arrow import qualified Control.Monad as Monad import qualified Control.Monad.Trans.State as State @@ -14,6 +15,7 @@ import qualified Control.Monad.Trans.Writer as Writer import qualified "transformers" Control.Monad.Trans as Trans import qualified Data.Map as Map import Data.Accessor +import Data.Accessor.MonadState as MonadState -- GHC API import CoreSyn @@ -32,6 +34,8 @@ import Outputable ( showSDoc, ppr, nest ) -- Local imports import NormalizeTypes +import Pretty +import qualified VHDLTools -- Create a new internal var with the given name and type. A Unique is -- appended to the given name, to ensure uniqueness (not strictly neccesary, @@ -182,14 +186,23 @@ dotransforms transs expr = do if Monoid.getAny changed then dotransforms transs expr' else return expr' -- Inline all let bindings that satisfy the given condition -inlinebind :: ((CoreBndr, CoreExpr) -> Bool) -> Transform -inlinebind condition (Let (Rec binds) expr) | not $ null replace = - change newexpr +inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform +inlinebind condition expr@(Let (Rec binds) res) = do + -- Find all bindings that adhere to the condition + res_eithers <- mapM docond binds + case Either.partitionEithers res_eithers of + -- No replaces? No change + ([], _) -> return expr + (replace, others) -> do + -- Substitute the to be replaced binders with their expression + let newexpr = substitute replace (Let (Rec others) res) + change newexpr where - -- Find all simple bindings - (replace, others) = List.partition condition binds - -- Substitute the to be replaced binders with their expression - newexpr = substitute replace (Let (Rec others) expr) + docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr)) + docond b = do + res <- condition b + return $ case res of True -> Left b; False -> Right b + -- Leave all other expressions unchanged inlinebind _ expr = return expr @@ -235,3 +248,8 @@ substitute ((b, e):subss) expr = substitute subss' expr' -- an initial state. runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply) + +-- Is the given expression representable at runtime, based on the type? +isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool +isRepr (Type ty) = return False +isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr) diff --git a/VHDLTools.hs b/VHDLTools.hs index 359597f..8bc45f7 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -479,3 +479,11 @@ mkTyConHType tycon args = where tyvars = TyCon.tyConTyVars tycon subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) + +-- Is the given type representable at runtime? +isReprType :: Type.Type -> TypeSession Bool +isReprType ty = do + ty_either <- vhdl_ty_either ty + return $ case ty_either of + Left _ -> False + Right _ -> True