import qualified CoreUtils
import qualified Type
import qualified TcType
+import qualified Name
import qualified Id
import qualified Var
import qualified VarSet
-- β-reduction
--------------------------------
beta, betatop :: Transform
--- Substitute arg for x in expr
-beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
+-- Substitute arg for x in expr. For value lambda's, also clone before
+-- substitution.
+beta (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg expr
+ | otherwise = setChanged >> substitute_clone 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
-- 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 expr = return expr
-- Unused let binding removal
--------------------------------
letremoveunused, letremoveunusedtop :: Transform
-letremoveunused expr@(Let _ _) = do
+letremoveunused expr@(Let (NonRec b bound) res) = do
+ let used = expr_uses_binders [b] res
+ if used
+ then return expr
+ else change res
+letremoveunused 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) (mkNonRecLets binds' res)
+ changeif (length binds' /= length binds) (Let (Rec binds') res)
where
- (binds, res) = flattenLets expr
bound_exprs = map snd binds
-- For each bind check if the bind is used by res or any of the bound
-- expressions
letremoveunused expr = return expr
letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
+{-
--------------------------------
-- Identical let binding merging
--------------------------------
-- Leave all other expressions unchanged
letmerge expr = return expr
letmergetop = everywhere ("letmerge", letmerge)
-
+-}
+
--------------------------------
-- Function inlining
--------------------------------
inlinenonreptop :: Transform
inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
+inlinetoplevel, inlinetopleveltop :: Transform
+-- Any system name is candidate for inlining. Never inline user-defined
+-- functions, to preserve structure.
+inlinetoplevel expr@(Var f) | not $ isUserDefined f = do
+ norm <- isNormalizeable f
+ -- See if this is a top level binding for which we have a body
+ body_maybe <- Trans.lift $ getGlobalBind f
+ if norm && Maybe.isJust body_maybe
+ then do
+ -- Get the normalized version
+ norm <- Trans.lift $ getNormalized f
+ if needsInline norm
+ then do
+ -- Regenerate all uniques in the to-be-inlined expression
+ norm_uniqued <- Trans.lift $ genUniques norm
+ change norm_uniqued
+ else
+ return expr
+ else
+ -- No body or not normalizeable.
+ return expr
+-- Leave all other expressions unchanged
+inlinetoplevel expr = return expr
+inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel)
+
+needsInline :: CoreExpr -> Bool
+needsInline expr = case splitNormalized expr of
+ -- Inline any function that only has a single definition, it is probably
+ -- simple enough. This might inline some stuff that it shouldn't though it
+ -- will never inline user-defined functions (inlinetoplevel only tries
+ -- system names) and inlining should never break things.
+ (args, [bind], res) -> True
+ _ -> False
+
--------------------------------
-- Scrutinee simplification
--------------------------------
-- binding containing a case expression.
dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
dobndr b i = do
- repr <- isRepr (Var b)
+ repr <- isRepr b
-- Is b wild (e.g., not a free var of expr. Since b is only in scope
-- in expr, this means that b is unused if expr does not use it.)
let wild = not (VarSet.elemVarSet b free_vars)
-- Perform this transform everywhere
funextracttop = everywhere ("funextract", funextract)
+--------------------------------
+-- Ensure that a function that just returns another function (or rather,
+-- another top-level binder) is still properly normalized. This is a temporary
+-- solution, we should probably integrate this pass with lambdasimpl and
+-- letsimpl instead.
+--------------------------------
+simplrestop expr@(Lam _ _) = return expr
+simplrestop expr@(Let _ _) = return expr
+simplrestop expr = do
+ local_var <- Trans.lift $ is_local_var expr
+ -- Don't extract values that are not representable, to prevent loops with
+ -- inlinenonrep
+ repr <- isRepr expr
+ if local_var || not repr
+ then
+ return expr
+ else do
+ id <- Trans.lift $ mkBinderFor expr "res"
+ change $ Let (NonRec id expr) (Var id)
--------------------------------
-- End of transformations
--------------------------------
-- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop, lambdasimpltop]
+transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
-- | Returns the normalized version of the given function.
getNormalized ::
-> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
normalizeExpr what expr = do
+ expr_uniqued <- genUniques expr
-- Normalize this expression
- trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr
+ trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return ()
+ expr' <- dotransforms transforms expr_uniqued
trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
return expr'
projects / matthijs / master-project / cλash.git / blobdiff