X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=a7223e3d8d0433ca55f21a3c5e7a729afb63a4d2;hb=a0c0376c707a66ac50485faab6f7e4cec2725bf4;hp=8cbebad6978b29b687fbc4e6f1f133e2ac145b42;hpb=c4aa528c379ea8c2fa2fb0d5f8d8c70ba41fb699;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 8cbebad..a7223e3 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -115,6 +115,36 @@ castsimpl expr = return expr -- 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 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 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 expr = return expr +-- Perform this transform everywhere +lambdasimpltop = everywhere ("lambdasimpl", lambdasimpl) + -------------------------------- -- let derecursification -------------------------------- @@ -123,15 +153,12 @@ letderec 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 $ MkCore.mkCoreLets newbinds res + _ -> 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 - -- Create nonrec bindings for each liftable binding and a single recursive - -- binding for all others - newbinds = (map (uncurry NonRec) liftable) ++ [Rec nonliftable] -- 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 @@ -178,8 +205,22 @@ 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, expr) = return [(b, expr)] -- Leave all other expressions unchanged letflat expr = return expr -- Perform this transform everywhere @@ -207,12 +248,13 @@ letremovesimpletop = everywhere ("letremovesimple", inlinebind (\(b, e) -> Trans -- Unused let binding removal -------------------------------- letremoveunused, letremoveunusedtop :: Transform -letremoveunused expr@(Let (Rec binds) res) = do +letremoveunused expr@(Let _ _) = 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) + changeif (length binds' /= length binds) (mkNonRecLets 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 @@ -228,9 +270,10 @@ letremoveunusedtop = everywhere ("letremoveunused", letremoveunused) -- 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 expr@(Let (Rec binds) res) = do +letmerge expr@(Let _ _) = do + let (binds, res) = flattenLets expr binds' <- domerge binds - return (Let (Rec binds') res) + return $ mkNonRecLets binds' res where domerge :: [(CoreBndr, CoreExpr)] -> TransformMonad [(CoreBndr, CoreExpr)] domerge [] = return [] @@ -310,7 +353,7 @@ casesimpl expr@(Case scrut b ty alts) = do (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts let bindings = concat bindingss -- Replace the case with a let with bindings and a case - let newlet = (Let (Rec bindings) (Case scrut b ty alts')) + let newlet = mkNonRecLets bindings (Case scrut b ty alts') -- If there are no non-wild binders, or this case is already a simple -- selector (i.e., a single alt with exactly one binding), already a simple -- selector altan no bindings (i.e., no wild binders in the original case), @@ -333,7 +376,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 @@ -567,7 +610,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] +transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop, lambdasimpltop] -- | Returns the normalized version of the given function. getNormalized :: @@ -620,18 +663,3 @@ splitNormalized expr = (args, binds, res) res = case resexpr of (Var x) -> x _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n" - --- | Flattens nested lets into a single list of bindings. The expression --- passed does not have to be a let expression, if it isn't an empty list of --- bindings is returned. -flattenLets :: - CoreExpr -- ^ The expression to flatten. - -> ([Binding], CoreExpr) -- ^ The bindings and resulting expression. -flattenLets (Let binds expr) = - (bindings ++ bindings', expr') - where - -- Recursively flatten the contained expression - (bindings', expr') =flattenLets expr - -- Flatten our own bindings to remove the Rec / NonRec constructors - bindings = CoreSyn.flattenBinds [binds] -flattenLets expr = ([], expr)