Commit db17d58d authored by Simon Peyton Jones's avatar Simon Peyton Jones

Document the maintenance of the let/app invariant in the simplifier

It's not obvious why the simplifier generates code that correctly satisfies
the let/app invariant.   This patch does some minor refactoring, but the main
point is to document pre-conditions to key functions, namely that the rhs
passed in satisfies the let/app invariant.

There shouldn't be any change in behaviour.
parent d174f49c
......@@ -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
......
......@@ -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)
%************************************************************************
%* *
......
......@@ -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
......
......@@ -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 _ _ _ =
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment