--- Perform this transform everywhere
-castsimpltop = everywhere ("castsimpl", castsimpl)
-
-
---------------------------------
--- Lambda simplication
---------------------------------
--- 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
- if not local_var && repr
- then do
- id <- Trans.lift $ mkBinderFor res "res"
- change $ Lam bndr (Let (NonRec id res) (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
--- Perform this transform everywhere
-lambdasimpltop = everywhere ("lambdasimpl", lambdasimpl)
-
---------------------------------
--- let derecursification
---------------------------------
-letderec, letderectop :: Transform
-letderec c expr@(Let (Rec binds) res) = case liftable of
- -- Nothing is liftable, just return
- [] -> return expr
- -- Something can be lifted, generate a new let expression
- _ -> change $ mkNonRecLets liftable (Let (Rec nonliftable) res)
- where
- -- Make a list of all the binders bound in this recursive let
- bndrs = map fst binds
- -- See which bindings are liftable
- (liftable, nonliftable) = List.partition canlift binds
- -- Any expression that does not use any of the binders in this recursive let
- -- can be lifted into a nonrec let. It can't use its own binder either,
- -- since that would mean the binding is self-recursive and should be in a
- -- single bind recursive let.
- canlift (bndr, e) = not $ expr_uses_binders bndrs e
--- Leave all other expressions unchanged
-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
---------------------------------
--- 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, letflattop :: 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
--- Perform this transform everywhere
-letflattop = everywhere ("letflat", letflat)
-
---------------------------------
--- empty let removal
---------------------------------
--- Remove empty (recursive) lets
-letremove, letremovetop :: Transform
-letremove c (Let (Rec []) res) = change res
--- Leave all other expressions unchanged
-letremove c expr = return expr
--- Perform this transform everywhere
-letremovetop = everywhere ("letremove", letremove)
-
---------------------------------
--- Simple let binding removal
---------------------------------
--- Remove a = b bindings from let expressions everywhere
-letremovesimpletop :: Transform
-letremovesimpletop = everywhere ("letremovesimple", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
-
---------------------------------
--- Unused let binding removal
---------------------------------
-letremoveunused, letremoveunusedtop :: 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
-letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
-
-{-
---------------------------------
--- 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, letmergetop :: 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
-letmergetop = everywhere ("letmerge", letmerge)
--}
-
---------------------------------
--- 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.
-inlinenonreptop :: Transform
-inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))