import qualified Maybe
import qualified "transformers" Control.Monad.Trans as Trans
import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.Writer as Writer
import qualified Data.Map as Map
+import qualified Data.Monoid as Monoid
import Data.Accessor
-- GHC API
import qualified Var
import qualified VarSet
import qualified CoreFVs
+import qualified CoreUtils
+import qualified MkCore
import Outputable ( showSDoc, ppr, nest )
-- Local imports
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
+ ty' = CoreUtils.applyTypeToArg ty arg
-- Leave all other expressions unchanged
beta expr = return expr
-- Perform this transform everywhere
-- 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
+-- expression is applicable (to prevent loops with inlinefun).
+letsimpl (Let (Rec binds) expr) | not $ is_applicable expr = do
id <- mkInternalVar "foo" (CoreUtils.exprType expr)
let bind = (id, expr)
change $ Let (Rec (bind:binds)) (Var id)
--------------------------------
-- Function inlining
--------------------------------
--- Remove a = B bindings, with B :: a -> b, from let expressions everywhere.
+-- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
+-- expressions everywhere. This means that any value that still needs to be
+-- applied to something else (polymorphic values need to be applied to a
+-- Type) will be inlined, and will eventually be applied to all their
+-- arguments.
+--
-- 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
-- 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))
+inlinefuntop = everywhere ("inlinefun", inlinebind (is_applicable . snd))
--------------------------------
-- Scrutinee simplification
-- 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
+-- simple scrutinee, but not when the scrutinee is applicable (to prevent
+-- loops with inlinefun, though I don't think a scrutinee can be
+-- applicable...)
+scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do
id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
-- Leave all other expressions unchanged
-- 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
+ -- the case statement. Also, don't create a binding for applicable
-- expressions, to prevent loops with inlinefun.
- doalt (con, bndrs, expr) | (not usesvars) && (not $ is_fun expr) = do
+ doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable 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.
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
+-- 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))
-- Leave all other expressions unchanged
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.
-typeprop expr@(App (Var f) (Type ty)) = do
- id <- cloneVar f
- let newty = Type.applyTy (Id.idType f) ty
- let newf = Var.setVarType id newty
+-- 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)
- Trans.lift $ addGlobalBind newf newbody
+ -- 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).
-- 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
+-- 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
+ -- 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 <- mkFunction f newbody
+ -- 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 | is_fun arg = do
+ 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)
+-- Leave all other expressions unchanged
+funprop expr = return expr
+-- Perform this transform everywhere
+funproptop = everywhere ("funprop", funprop)
+
+
-- TODO: introduce top level let if needed?
--------------------------------
-- What transforms to run?
-transforms = [typeproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [typeproptop, funproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
-- Turns the given bind into VHDL
normalizeModule ::
case expr_maybe of
Just expr -> do
-- Normalize this expression
+ trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
expr' <- dotransforms transforms expr
- let expr'' = trace ("Before:\n\n" ++ showSDoc ( ppr expr ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr expr')) expr'
+ trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
-- And store the normalized version in the session
- modA tsBindings (Map.insert bndr expr'')
+ modA tsBindings (Map.insert bndr expr')
-- Find all vars used with a function type. All of these should be global
-- binders (i.e., functions used), since any local binders with a function
-- type should have been inlined already.
- let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr''
+ let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr'
let used_funcs = VarSet.varSetElems used_funcs_set
-- Process each of the used functions recursively
mapM normalizeBind used_funcs