diff options
| -rw-r--r-- | compiler/coreSyn/CoreSyn.lhs | 5 | ||||
| -rw-r--r-- | compiler/simplCore/SimplEnv.lhs | 81 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.lhs | 8 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.lhs | 23 |
4 files changed, 68 insertions, 49 deletions
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 86786783ca..3efc647c4d 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -1217,8 +1217,9 @@ mkDoubleLitDouble :: Double -> Expr b mkDoubleLit d = Lit (mkMachDouble d) mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) --- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to --- use 'MkCore.mkCoreLets' if possible +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if +-- possible, which does guarantee the invariant mkLets :: [Bind b] -> Expr b -> Expr b -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to -- use 'MkCore.mkCoreLams' if possible diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 1c5ebc501b..d8aec03b03 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -31,8 +31,8 @@ module SimplEnv ( -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, - wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats, - doFloatFromRhs, getFloatBinds, getFloats, mapFloats + wrapFloats, setFloats, zapFloats, addRecFloats, + doFloatFromRhs, getFloatBinds ) where #include "HsVersions.h" @@ -47,7 +47,7 @@ import VarEnv import VarSet import OrdList import Id -import MkCore +import MkCore ( mkWildValBinder ) import TysWiredIn import qualified CoreSubst import qualified Type @@ -344,15 +344,21 @@ Note [Simplifier floats] ~~~~~~~~~~~~~~~~~~~~~~~~~ The Floats is a bunch of bindings, classified by a FloatFlag. +* All of them satisfy the let/app invariant + +Examples + NonRec x (y:ys) FltLifted Rec [(x,rhs)] FltLifted + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n - NonRec x# (a /# b) FltCareful NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge - NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge - -- (where f :: Int -> Int#) + +Can't happen: + NonRec x# (a /# b) -- Might fail; does not satisfy let/app + NonRec x# (f y) -- Might diverge; does not satisfy let/app \begin{code} data Floats = Floats (OrdList OutBind) FloatFlag @@ -388,13 +394,6 @@ andFF FltOkSpec FltCareful = FltCareful andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt -classifyFF :: CoreBind -> FloatFlag -classifyFF (Rec _) = FltLifted -classifyFF (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprOkForSpeculation rhs = FltOkSpec - | otherwise = FltCareful - doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool -- If you change this function look also at FloatIn.noFloatFromRhs doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) @@ -423,8 +422,16 @@ emptyFloats :: Floats emptyFloats = Floats nilOL FltLifted unitFloat :: OutBind -> Floats --- A single-binding float -unitFloat bind = Floats (unitOL bind) (classifyFF bind) +-- This key function constructs a singleton float with the right form +unitFloat bind = Floats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = ASSERT2( not (isUnLiftedType (idType bndr)), ppr bndr ) + FltCareful + -- Unlifted binders can only be let-bound if exprOkForSpeculation holds addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv -- Add a non-recursive binding and extend the in-scope set @@ -437,13 +444,6 @@ addNonRec env id rhs env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } -mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv -mapFloats env@SimplEnv { seFloats = Floats fs ff } fun - = env { seFloats = Floats (mapOL app fs) ff } - where - app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' - app (Rec bs) = Rec (map fun bs) - extendFloats :: SimplEnv -> OutBind -> SimplEnv -- Add these bindings to the floats, and extend the in-scope env too extendFloats env bind @@ -477,31 +477,30 @@ addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} wrapFloats :: SimplEnv -> OutExpr -> OutExpr -wrapFloats env expr = wrapFlts (seFloats env) expr - -wrapFlts :: Floats -> OutExpr -> OutExpr --- Wrap the floats around the expression, using case-binding where necessary -wrapFlts (Floats bs _) body = foldrOL wrap body bs - where - wrap (Rec prs) body = Let (Rec prs) body - wrap (NonRec b r) body = bindNonRec b r body +-- Wrap the floats around the expression; they should all +-- satisfy the let/app invariant, so mkLets should do the job just fine +wrapFloats (SimplEnv {seFloats = Floats bs _}) body + = foldrOL Let body bs getFloatBinds :: SimplEnv -> [CoreBind] -getFloatBinds env = floatBinds (seFloats env) - -getFloats :: SimplEnv -> Floats -getFloats env = seFloats env +getFloatBinds (SimplEnv {seFloats = Floats bs _}) + = fromOL bs isEmptyFloats :: SimplEnv -> Bool -isEmptyFloats env = isEmptyFlts (seFloats env) - -isEmptyFlts :: Floats -> Bool -isEmptyFlts (Floats bs _) = isNilOL bs - -floatBinds :: Floats -> [OutBind] -floatBinds (Floats bs _) = fromOL bs +isEmptyFloats (SimplEnv {seFloats = Floats bs _}) + = isNilOL bs \end{code} +-- mapFloats commented out: used only in a commented-out bit of Simplify, +-- concerning ticks +-- +-- mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv +-- mapFloats env@SimplEnv { seFloats = Floats fs ff } fun +-- = env { seFloats = Floats (mapOL app fs) ff } +-- where +-- app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' +-- app (Rec bs) = Rec (map fun bs) + %************************************************************************ %* * diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 14789c44a4..888c923254 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -854,6 +854,10 @@ the former. \begin{code} preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings preInlineUnconditionally dflags env top_lvl bndr rhs | not active = False | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally] @@ -963,6 +967,10 @@ postInlineUnconditionally -> OutExpr -> Unfolding -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding | not active = False | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1125c2e883..8e010c0092 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -326,7 +326,7 @@ simplLazyBind :: SimplEnv -- The OutId has IdInfo, except arity, unfolding -> InExpr -> SimplEnv -- The RHS and its environment -> SimplM SimplEnv - +-- Precondition: rhs obeys the let/app invariant simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ do { let rhs_env = rhs_se `setInScope` env @@ -378,11 +378,12 @@ simplNonRecX :: SimplEnv -> InId -- Old binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv - +-- Precondition: rhs satisfies the let/app invariant simplNonRecX env bndr new_rhs | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return env -- Here c is dead, and we avoid creating - -- the binding c = (a,b) + = return env -- Here c is dead, and we avoid creating + -- the binding c = (a,b) + | Coercion co <- new_rhs = return (extendCvSubst env bndr co) @@ -397,6 +398,8 @@ completeNonRecX :: TopLevelFlag -> SimplEnv -> OutId -- New binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs @@ -644,7 +647,8 @@ completeBind :: SimplEnv -- completeBind may choose to do its work -- * by extending the substitution (e.g. let x = y in ...) -- * or by adding to the floats in the envt - +-- +-- Precondition: rhs obeys the let/app invariant completeBind env top_lvl old_bndr new_bndr new_rhs | isCoVar old_bndr = case new_rhs of @@ -1177,6 +1181,8 @@ rebuild env expr cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr + -- expr satisfies let/app since it started life + -- in a call to simplNonRecE ; simplLam env' bs body cont } ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] | isSimplified dup_flag -> rebuild env (App expr arg) cont @@ -1327,6 +1333,9 @@ simplNonRecE :: SimplEnv -- It deals with strict bindings, via the StrictBind continuation, -- which may abort the whole process -- +-- Precondition: rhs satisfies the let/app invariant +-- Note [CoreSyn let/app invariant] in CoreSyn +-- -- The "body" of the binding comes as a pair of ([InId],InExpr) -- representing a lambda; so we recurse back to simplLam -- Why? Because of the binder-occ-info-zapping done before @@ -1863,6 +1872,8 @@ rebuildCase env scrut case_bndr alts cont where simple_rhs bs rhs = ASSERT( null bs ) do { env' <- simplNonRecX env case_bndr scrut + -- scrut is a constructor application, + -- hence satisfies let/app invariant ; simplExprF env' rhs cont } @@ -2267,7 +2278,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont -- it via postInlineUnconditionally. -- Nevertheless we must keep it if the case-binder is alive, -- because it may be used in the con_app. See Note [knownCon occ info] - ; env'' <- simplNonRecX env' b' arg + ; env'' <- simplNonRecX env' b' arg -- arg satisfies let/app invariant ; bind_args env'' bs' args } bind_args _ _ _ = |