X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=d66a1885be7062ea207561d4b17762b07f551033;hb=9fb1f6af219599d84cb085061b126b30db16a165;hp=85760bebd7e63026fc8f7ff815615c0123252a91;hpb=2290559dd61c1cb5f16ef8fe3fc0fecccc29e792;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 85760be..d66a188 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -23,6 +23,7 @@ import qualified UniqSupply import qualified CoreUtils import qualified Type import qualified TcType +import qualified Name import qualified Id import qualified Var import qualified VarSet @@ -205,8 +206,23 @@ letsimpltop = everywhere ("letsimpl", letsimpl) -- to: -- let b' = expr' in (let b = res' in res) letflat, letflattop :: Transform -letflat (Let (NonRec b (Let (NonRec b' expr') res')) res) = - change $ Let (NonRec b' expr') (Let (NonRec b res') res) +-- Turn a nonrec let that binds a let into two nested lets. +letflat (Let (NonRec b (Let binds res')) res) = + change $ Let binds (Let (NonRec b res') res) +letflat (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 expr = return expr -- Perform this transform everywhere @@ -234,13 +250,17 @@ letremovesimpletop = everywhere ("letremovesimple", inlinebind (\(b, e) -> Trans -- 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 @@ -249,6 +269,7 @@ letremoveunused expr@(Let _ _) = do letremoveunused expr = return expr letremoveunusedtop = everywhere ("letremoveunused", letremoveunused) +{- -------------------------------- -- Identical let binding merging -------------------------------- @@ -279,7 +300,8 @@ letmerge expr@(Let _ _) = do -- Leave all other expressions unchanged letmerge expr = return expr letmergetop = everywhere ("letmerge", letmerge) - +-} + -------------------------------- -- Function inlining -------------------------------- @@ -298,6 +320,37 @@ letmergetop = everywhere ("letmerge", letmerge) 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 preserver structure. +inlinetoplevel expr@(Var f) | (Name.isSystemName . Id.idName) f = do + -- See if this is a top level binding for which we have a body + body_maybe <- Trans.lift $ getGlobalBind f + case body_maybe of + Just body -> do + -- Get the normalized version + norm <- Trans.lift $ getNormalized f + if needsInline norm + then + change norm + else + return expr + -- No body, this is probably a local variable or builtin or external + -- function. + Nothing -> 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 -------------------------------- @@ -362,7 +415,7 @@ casesimpl expr@(Case scrut b ty alts) = do (exprbinding_maybe, expr') <- doexpr expr uses_bndrs -- Create a new alternative let newalt = (con, newbndrs, expr') - let bindings = Maybe.catMaybes (exprbinding_maybe : bindings_maybe) + let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe]) return (bindings, newalt) where -- Make wild alternatives for each binder @@ -588,6 +641,22 @@ funextract expr = return expr -- 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 + if local_var + then + return expr + else do + id <- Trans.lift $ mkBinderFor expr "res" + change $ Let (NonRec id expr) (Var id) -------------------------------- -- End of transformations -------------------------------- @@ -596,7 +665,7 @@ funextracttop = everywhere ("funextract", funextract) -- 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 ::