--- Perform this transform everywhere
-castsimpltop = everywhere ("castsimpl", castsimpl)
-
---------------------------------
--- 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.
-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
-
-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
--- Perform this transform everywhere
-retvalsimpltop = everywhere ("retvalsimpl", retvalsimpl)
-
---------------------------------
--- let derecursification
---------------------------------
-letrec, letrectop :: 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
--- Perform this transform everywhere
-letrectop = everywhere ("letrec", letrec)
-
---------------------------------
--- 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))
projects / matthijs / master-project / cλash.git / blobdiff