unTagBinders, squashableDictishCcExpr
)
import Id ( idType, idWantsToBeINLINEd,
+ externallyVisibleId,
getIdDemandInfo, addIdDemandInfo,
GenId{-instance NamedThing-}
)
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit )
import Maybes ( maybeToBool )
-import Name ( isLocallyDefined )
+--import Name ( isExported )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import Pretty ( ppAbove )
simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
= -- No cloning necessary at top level
-- Process the binding
- simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds1') ->
+ simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
+ completeNonRec env binder in_id rhs' `thenSmpl` \ (new_env, binds1') ->
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds2' ->
simpl_bind env rhs | will_be_demanded &&
try_let_to_case &&
type_ok_for_let_to_case rhs_ty &&
- rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
+ not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
= tick Let2Case `thenSmpl_`
mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
- simplCase env rhs id_alts (\env rhs -> simpl_bind env rhs) body_ty
+ simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
+ -- NB: it's tidier to call complete_bind not simpl_bind, else
+ -- we nearly end up in a loop. Consider:
+ -- let x = rhs in b
+ -- ==> case rhs of (p,q) -> let x=(p,q) in b
+ -- This effectively what the above simplCase call does.
+ -- Now, the inner let is a let-to-case target again! Actually, since
+ -- the RHS is in WHNF it won't happen, but it's a close thing!
-- Try let-from-let
simpl_bind env (Let bind rhs) | let_floating_ok
returnSmpl (Let extra_binding case_expr)
-- None of the above; simplify rhs and tidy up
- simpl_bind env rhs
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds) ->
- body_c new_env `thenSmpl` \ body' ->
+ simpl_bind env rhs = complete_bind env rhs
+
+ complete_bind env rhs
+ = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
+ cloneId env binder `thenSmpl` \ new_id ->
+ completeNonRec env binder new_id rhs' `thenSmpl` \ (new_env, binds) ->
+ body_c new_env `thenSmpl` \ body' ->
returnSmpl (mkCoLetsAny binds body')
let
env_w_clones = extendIdEnvWithClones env binders ids'
in
- simplRecursiveGroup env ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
+ simplRecursiveGroup env_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
body_c new_env `thenSmpl` \ body' ->
simplRecursiveGroup env new_ids pairs
= -- Add unfoldings to the new_ids corresponding to their RHS
let
- occs = [occ | ((_,occ), _) <- pairs]
+ binders = map fst pairs
+ occs = map snd binders
new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
rhs_env = foldl extendEnvForRecBinding
env new_ids_w_pairs
mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
let
- new_pairs = zipEqual "simplRecGp" new_ids new_rhss
+ new_pairs = zipEqual "simplRecGp" new_ids new_rhss
occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
- new_env = foldl (\env (occ_info,(new_id,new_rhs)) ->
- extendEnvGivenBinding env occ_info new_id new_rhs)
- env occs_w_new_pairs
+ new_env = foldl add_binding env occs_w_new_pairs
+
+ add_binding env (occ_info,(new_id,new_rhs))
+ = extendEnvGivenBinding env occ_info new_id new_rhs
in
returnSmpl (Rec new_pairs, new_env)
\end{code}
\begin{code}
- -- Sigh: rather disgusting case for coercions. We want to
- -- ensure that all let-bound Coerces have atomic bodies, so
- -- they can freely be inlined.
-completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs)
- = (case rhs of
- Var v -> returnSmpl (env, [], rhs)
- Lit l -> returnSmpl (env, [], rhs)
- other -> newId (coreExprType rhs) `thenSmpl` \ inner_id ->
- completeNonRec env
- (inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) ->
- -- Dangerous occ because, like constructor args,
- -- it can be duplicated easily
- let
- atomic_rhs = case lookupId env1 inner_id of
- LitArg l -> Lit l
- VarArg v -> Var v
- in
- returnSmpl (env1, extra_bind, atomic_rhs)
- ) `thenSmpl` \ (env1, extra_bind, atomic_rhs) ->
- -- Tiresome to do all this, but we must treat the lit/var cases specially
- -- or we get a tick for atomic rhs when effectively it's a no-op.
-
- cloneId env1 binder `thenSmpl` \ new_id ->
- let
- new_rhs = Coerce coercion ty atomic_rhs
- env2 = extendIdEnvWithClone env1 binder new_id
- new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs
- in
- returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs])
-
-completeNonRec env binder new_rhs
- -- See if RHS is an atom, or a reusable constructor
- | maybeToBool maybe_atomic_rhs
- = let
- new_env = extendIdEnvWithAtom env binder rhs_atom
- in
- tick atom_tick_type `thenSmpl_`
- returnSmpl (new_env, [])
- where
- maybe_atomic_rhs = exprToAtom env new_rhs
- Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-
-completeNonRec env binder@(_,occ_info) new_rhs
- = cloneId env binder `thenSmpl` \ new_id ->
+ -- We want to ensure that all let-bound Coerces have
+ -- atomic bodies, so they can freely be inlined.
+completeNonRec env binder new_id (Coerce coercion ty rhs)
+ | not (is_atomic rhs)
+ = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
+ completeNonRec env
+ (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
+ -- Dangerous occ because, like constructor args,
+ -- it can be duplicated easily
let
- env1 = extendIdEnvWithClone env binder new_id
- new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
+ atomic_rhs = case lookupId env1 inner_id of
+ LitArg l -> Lit l
+ VarArg v -> Var v
in
- returnSmpl (new_env, [NonRec new_id new_rhs])
+ completeNonRec env1 binder new_id
+ (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
+
+ returnSmpl (env2, binds1 ++ binds2)
+ where
+ is_atomic (Var v) = True
+ is_atomic (Lit l) = not (isNoRepLit l)
+ is_atomic other = False
+
+ -- Atomic right-hand sides.
+ -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
+ -- than it's worth. For a top-level binding a = b, where a is exported,
+ -- we can't drop the binding, so we get repeated AtomicRhs ticks
+completeNonRec env binder new_id rhs@(Var v)
+ = returnSmpl (extendIdEnvWithAtom env binder (VarArg v), [NonRec new_id rhs])
+
+completeNonRec env binder new_id rhs@(Lit lit)
+ | not (isNoRepLit lit)
+ = returnSmpl (extendIdEnvWithAtom env binder (LitArg lit), [NonRec new_id rhs])
+
+ -- Right hand sides that are constructors
+ -- let v = C args
+ -- in
+ --- ...(let w = C same-args in ...)...
+ -- Then use v instead of w. This may save
+ -- re-constructing an existing constructor.
+completeNonRec env binder new_id rhs@(Con con con_args)
+ | switchIsSet env SimplReuseCon &&
+ maybeToBool maybe_existing_con &&
+ not (externallyVisibleId new_id) -- Don't bother for exported things
+ -- because we won't be able to drop
+ -- its binding.
+ = tick ConReused `thenSmpl_`
+ returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
+ where
+ maybe_existing_con = lookForConstructor env con con_args
+ Just it = maybe_existing_con
+
+ -- Default case
+completeNonRec env binder@(id,occ_info) new_id rhs
+ = returnSmpl (new_env, [NonRec new_id rhs])
+ where
+ env1 = extendIdEnvWithClone env binder new_id
+ new_env = extendEnvGivenBinding env1 occ_info new_id rhs
\end{code}
%************************************************************************
simplArg env (VarArg id) = lookupId env id
\end{code}
-
-\begin{code}
-exprToAtom env (Var var)
- = Just (VarArg var, AtomicRhs)
-
-exprToAtom env (Lit lit)
- | not (isNoRepLit lit)
- = Just (LitArg lit, AtomicRhs)
-
-exprToAtom env (Con con con_args)
- | switchIsSet env SimplReuseCon
- -- Look out for
- -- let v = C args
- -- in
- --- ...(let w = C same-args in ...)...
- -- Then use v instead of w. This may save
- -- re-constructing an existing constructor.
- = case (lookForConstructor env con con_args) of
- Nothing -> Nothing
- Just var -> Just (VarArg var, ConReused)
-
-exprToAtom env other
- = Nothing
-\end{code}
-
%************************************************************************
%* *
\subsection[Simplify-quickies]{Some local help functions}
projects / ghc-hetmet.git / blobdiff