From 0b4ef1955eb1480700e19720f38a59e3518408d7 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 17 Oct 2001 15:44:40 +0000 Subject: [PATCH] [project @ 2001-10-17 15:44:40 by simonpj] --------------------------- Better floating in CorePrep --------------------------- ** DO NOT MERGE ** [NB: this commit also changes the wrongly-named -ddump-sat flag to be called -ddump-prep ] Earlier fiddling with CorePrep meant that it was ANF-ing the top-level defn: x = length [True,False] to x = let s1 = False : [] s2 = True : s1 in length s2 This is Very Bad for big constant data structures, as show up in Happy-generated parsers, and that's why we get the big-block-alloc crash in hssource. Instead we want s1 = False : [] s2 = True : s1 x = length s2 This happens now, (I hope), but it's part of an ongoing jiggling process in the CoreTidy-CorePrep-CoreToStg part of the compiler, so it's possible I have broken something else. --- ghc/compiler/coreSyn/CorePrep.lhs | 259 +++++++++++++++++++------------------ ghc/compiler/main/CmdLineOpts.lhs | 2 +- ghc/compiler/main/DriverFlags.hs | 4 +- 3 files changed, 136 insertions(+), 129 deletions(-) diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 298e599..61f7d0a 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -23,10 +23,11 @@ import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, - setIdType, isPrimOpId_maybe, isFCallId, isLocalId, - hasNoBinding, idNewStrictness + setIdType, isPrimOpId_maybe, isFCallId, isGlobalId, + hasNoBinding, idNewStrictness, setIdArity ) import HscTypes ( ModDetails(..) ) +import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel ) import UniqSupply import Maybes import OrdList @@ -85,8 +86,13 @@ corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails corePrepPgm dflags mod_details = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let new_binds = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details)) - endPass dflags "CorePrep" Opt_D_dump_sat new_binds + + let floats = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details)) + new_binds = foldrOL get [] floats + get (FloatLet b) bs = b:bs + get b bs = pprPanic "corePrepPgm" (ppr b) + + endPass dflags "CorePrep" Opt_D_dump_prep new_binds return (mod_details { md_binds = new_binds }) corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr @@ -94,7 +100,7 @@ corePrepExpr dflags expr = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_sat "CorePrep" + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) return new_expr @@ -127,51 +133,21 @@ allLazy floats -- Bindings -- --------------------------------------------------------------------------- -corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind] -corePrepTopBinds env [] = returnUs [] +corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind) +corePrepTopBinds env [] = returnUs nilOL corePrepTopBinds env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') -> corePrepTopBinds env' binds `thenUs` \ binds' -> - returnUs (bind' : binds') - --- From top level bindings we don't get any floats --- (a) it isn't necessary because the mkAtomicArgs in Simplify --- has already done all the floating necessary --- (b) floating would give rise to top-level LocaIds, generated --- by CorePrep.newVar. That breaks the invariant that --- after CorePrep all top-level vars are GlobalIds + returnUs (bind' `appOL` binds') -corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, CoreBind) -corePrepTopBind env (NonRec bndr rhs) - = corePrepRhs env (bndr, rhs) `thenUs` \ rhs' -> - cloneBndr env bndr `thenUs` \ (env', bndr') -> - returnUs (env', NonRec bndr' rhs') - -corePrepTopBind env (Rec pairs) - = corePrepRecPairs env pairs `thenUs` \ (env', pairs') -> - returnUs (env, Rec pairs') - -corePrepRecPairs env pairs - = cloneBndrs env bndrs `thenUs` \ (env', bndrs') -> - mapUs (corePrepRhs env') pairs `thenUs` \ rhss' -> - returnUs (env', bndrs' `zip` rhss') - where - bndrs = map fst pairs - -corePrepRhs :: CloneEnv -> (Id, CoreExpr) -> UniqSM CoreExpr - -- Used for top-level bindings, and local recursive bindings - -- c.f. mkLocalNonRec, which does the other case - -- No nonsense about floating. - -- Prepare the RHS and eta expand it. -corePrepRhs env (bndr, rhs) - = corePrepAnExpr env rhs `thenUs` \ rhs' -> - getUniquesUs `thenUs` \ us -> - returnUs (etaExpand (exprArity rhs') us rhs' (idType bndr)) +-- NB: we do need to float out of top-level bindings +-- Consider x = length [True,False] +-- We want to get +-- s1 = False : [] +-- s2 = True : s1 +-- x = length s2 - -corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) --- This one is used for *local* bindings -- We return a *list* of bindings, because we may start with -- x* = f (g y) -- where x is demanded, in which case we want to finish with @@ -179,17 +155,42 @@ corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) -- x* = f a -- And then x will actually end up case-bound +corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) +corePrepTopBind env (NonRec bndr rhs) + = cloneBndr env bndr `thenUs` \ (env', bndr') -> + corePrepRhs TopLevel env (bndr, rhs) `thenUs` \ (floats, rhs') -> + returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs')) + +corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs + +corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) + -- This one is used for *local* bindings corePrepBind env (NonRec bndr rhs) = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') -> cloneBndr env bndr `thenUs` \ (env', bndr') -> mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' -> returnUs (env', floats') -corePrepBind env (Rec pairs) - -- Don't bother to try to float bindings out of RHSs - -- (compare mkNonRec, which does try) - = corePrepRecPairs env pairs `thenUs` \ (env', pairs') -> - returnUs (env', unitOL (FloatLet (Rec pairs'))) +corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs + +-------------------------------- +corePrepRecPairs :: TopLevelFlag -> CloneEnv + -> [(Id,CoreExpr)] -- Recursive bindings + -> UniqSM (CloneEnv, OrdList FloatingBind) +-- Used for all recursive bindings, top level and otherwise +corePrepRecPairs lvl env pairs + = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') -> + mapAndUnzipUs (corePrepRhs lvl env') pairs `thenUs` \ (floats_s, rhss') -> + returnUs (env', concatOL floats_s `snocOL` FloatLet (Rec (bndrs' `zip` rhss'))) + +-------------------------------- +corePrepRhs :: TopLevelFlag -> CloneEnv -> (Id, CoreExpr) + -> UniqSM (OrdList FloatingBind, CoreExpr) +-- Used for top-level bindings, and local recursive bindings +corePrepRhs top_lvl env (bndr, rhs) + = corePrepExprFloat env rhs `thenUs` \ floats_w_rhs -> + floatRhs top_lvl bndr floats_w_rhs + -- --------------------------------------------------------------------------- -- Making arguments atomic (function args & constructor args) @@ -200,14 +201,14 @@ corePrepArg :: CloneEnv -> CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg) corePrepArg env arg dem = corePrepExprFloat env arg `thenUs` \ (floats, arg') -> - if needs_binding arg' - then returnUs (floats, arg') - else newVar (exprType arg') `thenUs` \ v -> - mkLocalNonRec v dem floats arg' `thenUs` \ floats' -> - returnUs (floats', Var v) + if no_binding_needed arg' + then returnUs (floats, arg') + else newVar (exprType arg') (exprArity arg') `thenUs` \ v -> + mkLocalNonRec v dem floats arg' `thenUs` \ floats' -> + returnUs (floats', Var v) -needs_binding | opt_RuntimeTypes = exprIsAtom - | otherwise = exprIsTrivial +no_binding_needed | opt_RuntimeTypes = exprIsAtom + | otherwise = exprIsTrivial -- version that doesn't consider an scc annotation to be trivial. exprIsTrivial (Var v) @@ -356,9 +357,9 @@ corePrepExprFloat env expr@(App _ _) -- non-variable fun, better let-bind it collect_args fun depth - = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) -> - newVar ty `thenUs` \ fn_id -> - mkLocalNonRec fn_id onceDem fun_floats fun `thenUs` \ floats -> + = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') -> + newVar ty (exprArity fun') `thenUs` \ fn_id -> + mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats -> returnUs (Var fn_id, (Var fn_id, depth), ty, floats, []) where ty = exprType fun @@ -388,71 +389,50 @@ maybeSaturate fn expr n_args ty -- Precipitating the floating bindings -- --------------------------------------------------------------------------- --- mkLocalNonRec is used only for local bindings -mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand - -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body - -> UniqSM (OrdList FloatingBind) +floatRhs :: TopLevelFlag -> Id + -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body + -> UniqSM (OrdList FloatingBind, -- Floats out of this bind + CoreExpr) -- Final Rhs -mkLocalNonRec bndr dem floats rhs - | exprIsValue rhs && allLazy floats -- Notably constructor applications - = -- Why the test for allLazy? You might think that the only - -- floats we can get out of a value are eta expansions - -- e.g. C $wJust ==> let s = \x -> $wJust x in C s - -- Here we want to float the s binding. - -- - -- But if the programmer writes this: - -- f x = case x of { (a,b) -> \y -> a } - -- then the strictness analyser may say that f has strictness "S" - -- Later the eta expander will transform to - -- f x y = case x of { (a,b) -> a } - -- So now f has arity 2. Now CorePrep may see - -- v = f E - -- so the E argument will turn into a FloatCase. - -- Indeed we should end up with - -- v = case E of { r -> f r } - -- That is, we should not float, even though (f r) is a value - -- - -- Similarly, given +floatRhs top_lvl bndr (floats, rhs) + | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or + allLazy floats -- at top level + = -- Why the test for allLazy? -- v = f (x `divInt#` y) -- we don't want to float the case, even if f has arity 2, -- because floating the case would make it evaluated too early -- -- Finally, eta-expand the RHS, for the benefit of the code gen - -- This might not have happened already, because eta expansion - -- is done by the simplifier only when there at least one lambda already. - -- - -- NB: we could refrain when the RHS is trivial (which can happen - -- for exported things. This would reduce the amount of code - -- generated (a little) and make things a little words for - -- code compiled without -O. The case in point is data constructor - -- wrappers. - -- - -- NB2: we have to be careful that the result of etaExpand doesn't - -- invalidate any of the assumptions that CorePrep is attempting - -- to establish. One possible cause is eta expanding inside of - -- an SCC note - we're now careful in etaExpand to make sure the - -- SCC is pushed inside any new lambdas that are generated. - -- - getUniquesUs `thenUs` \ us -> - let - rhs' = etaExpand (exprArity rhs) us rhs bndr_ty - in - returnUs (floats `snocOL` FloatLet (NonRec bndr rhs')) + etaExpandRhs bndr rhs `thenUs` \ rhs' -> + returnUs (floats, rhs') - | isUnLiftedType bndr_rep_ty || isStrict dem + | otherwise + -- Don't float; the RHS isn't a value + = mkBinds floats rhs `thenUs` \ rhs' -> + etaExpandRhs bndr rhs' `thenUs` \ rhs'' -> + returnUs (nilOL, rhs'') + +-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings +mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand + -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body + -> UniqSM (OrdList FloatingBind) + +mkLocalNonRec bndr dem floats rhs + | isUnLiftedType (idType bndr) || isStrict dem -- It's a strict let, or the binder is unlifted, -- so we definitely float all the bindings - = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) - returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs)) + = ASSERT( not (isUnboxedTupleType (idType bndr)) ) + let -- Don't make a case for a value binding, + -- even if it's strict. Otherwise we get + -- case (\x -> e) of ...! + float | exprIsValue rhs = FloatLet (NonRec bndr rhs) + | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs) + in + returnUs (floats `snocOL` float) | otherwise - -- Don't float; the RHS isn't a value - = mkBinds floats rhs `thenUs` \ rhs' -> - returnUs (unitOL (FloatLet (NonRec bndr rhs'))) - - where - bndr_ty = idType bndr - bndr_rep_ty = repType bndr_ty + = floatRhs NotTopLevel bndr (floats, rhs) `thenUs` \ (floats', rhs') -> + returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs')) mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr mkBinds binds body @@ -463,6 +443,29 @@ mkBinds binds body mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)] mk_bind (FloatLet bind) body = Let bind body +etaExpandRhs bndr rhs + = -- Eta expand to match the arity claimed by the binder + -- Remember, after CorePrep we must not change arity + -- + -- Eta expansion might not have happened already, + -- because it is done by the simplifier only when + -- there at least one lambda already. + -- + -- NB1:we could refrain when the RHS is trivial (which can happen + -- for exported things). This would reduce the amount of code + -- generated (a little) and make things a little words for + -- code compiled without -O. The case in point is data constructor + -- wrappers. + -- + -- NB2: we have to be careful that the result of etaExpand doesn't + -- invalidate any of the assumptions that CorePrep is attempting + -- to establish. One possible cause is eta expanding inside of + -- an SCC note - we're now careful in etaExpand to make sure the + -- SCC is pushed inside any new lambdas that are generated. + -- + getUniquesUs `thenUs` \ us -> + returnUs (etaExpand (idArity bndr) us rhs (idType bndr)) + -- --------------------------------------------------------------------------- -- Eliminate Lam as a non-rhs (STG doesn't have such a thing) -- We arrange that they only show up as the RHS of a let(rec) @@ -479,10 +482,11 @@ deLam (Note n expr) deLam expr | null bndrs = returnUs expr - | otherwise = case tryEta bndrs body of - Just no_lam_result -> returnUs no_lam_result - Nothing -> newVar (exprType expr) `thenUs` \ fn -> - returnUs (Let (NonRec fn expr) (Var fn)) + | otherwise + = case tryEta bndrs body of + Just no_lam_result -> returnUs no_lam_result + Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn -> + returnUs (Let (NonRec fn expr) (Var fn)) where (bndrs,body) = collectBinders expr @@ -628,16 +632,16 @@ cloneBndrs env bs = mapAccumLUs cloneBndr env bs cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var) cloneBndr env bndr - | isId bndr && isLocalId bndr -- Top level things, which we don't want - -- to clone, have become GlobalIds by now + | isGlobalId bndr -- Top level things, which we don't want + = returnUs (env, bndr) -- to clone, have become GlobalIds by now + + | otherwise = getUniqueUs `thenUs` \ uniq -> let bndr' = setVarUnique bndr uniq in returnUs (extendVarEnv env bndr bndr', bndr') - | otherwise = returnUs (env, bndr) - ------------------------------------------------------------------------------ -- Cloning ccall Ids; each must have a unique name, -- to give the code generator a handle to hang it on @@ -653,9 +657,12 @@ fiddleCCall id -- Generating new binders -- --------------------------------------------------------------------------- -newVar :: Type -> UniqSM Id -newVar ty - = getUniqueUs `thenUs` \ uniq -> - seqType ty `seq` - returnUs (mkSysLocal SLIT("sat") uniq ty) +newVar :: Type -> Arity -> UniqSM Id +-- We're creating a new let binder, and we must give +-- it the right arity for the benefit of the code generator. +newVar ty arity + = seqType ty `seq` + getUniqueUs `thenUs` \ uniq -> + returnUs (mkSysLocal SLIT("sat") uniq ty + `setIdArity` arity) \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 0f204ff..3b99939 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -233,7 +233,7 @@ data DynFlag | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_spec - | Opt_D_dump_sat + | Opt_D_dump_prep | Opt_D_dump_stg | Opt_D_dump_stranal | Opt_D_dump_tc diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 1785f16..3332a22 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.75 2001/10/10 17:17:44 ken Exp $ +-- $Id: DriverFlags.hs,v 1.76 2001/10/17 15:44:40 simonpj Exp $ -- -- Driver flags -- @@ -347,7 +347,7 @@ dynamic_flags = [ , ( "ddump-simpl", NoArg (setDynFlag Opt_D_dump_simpl) ) , ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) ) , ( "ddump-spec", NoArg (setDynFlag Opt_D_dump_spec) ) - , ( "ddump-sat", NoArg (setDynFlag Opt_D_dump_sat) ) + , ( "ddump-prep", NoArg (setDynFlag Opt_D_dump_prep) ) , ( "ddump-stg", NoArg (setDynFlag Opt_D_dump_stg) ) , ( "ddump-stranal", NoArg (setDynFlag Opt_D_dump_stranal) ) , ( "ddump-tc", NoArg (setDynFlag Opt_D_dump_tc) ) -- 1.7.10.4