\section[Simplify]{The main module of the simplifier}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Simplify ( simplTopBinds, simplExpr ) where
#include "HsVersions.h"
import Var
import IdInfo
import Coercion
+import FamInstEnv ( topNormaliseType )
import DataCon ( dataConRepStrictness, dataConUnivTyVars )
import CoreSyn
import NewDemand ( isStrictDmd )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRuleLoopBreaker )
import Maybes ( orElse )
+import Data.List ( mapAccumL )
import Outputable
import Util
\end{code}
trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
trace False bind = \x -> x
- simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
- simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
+ simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
+ simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
+ where
+ (env', b') = addBndrRules env b (lookupRecBndr env b)
\end{code}
-> [(InId, InExpr)]
-> SimplM SimplEnv
simplRecBind env top_lvl pairs
- = do { env' <- go (zapFloats env) pairs
+ = do { let (env_with_info, triples) = mapAccumL add_rules env pairs
+ ; env' <- go (zapFloats env_with_info) triples
; return (env `addRecFloats` env') }
-- addFloats adds the floats from env',
-- *and* updates env with the in-scope set from env'
where
+ add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
+ -- Add the (substituted) rules to the binder
+ add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
+ where
+ (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
+
go env [] = return env
- go env ((bndr, rhs) : pairs)
- = do { env <- simplRecOrTopPair env top_lvl bndr rhs
+ go env ((old_bndr, new_bndr, rhs) : pairs)
+ = do { env <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
; go env pairs }
\end{code}
\begin{code}
simplRecOrTopPair :: SimplEnv
-> TopLevelFlag
- -> InId -> InExpr -- Binder and rhs
+ -> InId -> OutBndr -> InExpr -- Binder and rhs
-> SimplM SimplEnv -- Returns an env that includes the binding
-simplRecOrTopPair env top_lvl bndr rhs
- | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
- = do { tick (PreInlineUnconditionally bndr)
- ; return (extendIdSubst env bndr (mkContEx env rhs)) }
+simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+ | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
+ = do { tick (PreInlineUnconditionally old_bndr)
+ ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
| otherwise
- = do { let bndr' = lookupRecBndr env bndr
- (env', bndr'') = addLetIdInfo env bndr bndr'
- ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' }
+ = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
-- May not actually be recursive, but it doesn't matter
\end{code}
-> SimplM SimplEnv
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
- = do { let rhs_env = rhs_se `setInScope` env
- rhs_cont = mkRhsStop (idType bndr1)
+ = do { let rhs_env = rhs_se `setInScope` env
+ (tvs, body) = collectTyBinders rhs
+ ; (body_env, tvs') <- simplBinders rhs_env tvs
+ -- See Note [Floating and type abstraction]
+ -- in SimplUtils
-- Simplify the RHS; note the mkRhsStop, which tells
-- the simplifier that this is the RHS of a let.
- ; (rhs_env1, rhs1) <- simplExprF rhs_env rhs rhs_cont
-
- -- If any of the floats can't be floated, give up now
- -- (The canFloat predicate says True for empty floats.)
- ; if (not (canFloat top_lvl is_rec False rhs_env1))
- then completeBind env top_lvl bndr bndr1
- (wrapFloats rhs_env1 rhs1)
- else do
+ ; let rhs_cont = mkRhsStop (applyTys (idType bndr1) (mkTyVarTys tvs'))
+ ; (body_env1, body1) <- simplExprF body_env body rhs_cont
+
-- ANF-ise a constructor or PAP rhs
- { (rhs_env2, rhs2) <- prepareRhs rhs_env1 rhs1
- ; (env', rhs3) <- chooseRhsFloats top_lvl is_rec False env rhs_env2 rhs2
- ; completeBind env' top_lvl bndr bndr1 rhs3 } }
-
-chooseRhsFloats :: TopLevelFlag -> RecFlag -> Bool
- -> SimplEnv -- Env for the let
- -> SimplEnv -- Env for the RHS, with RHS floats in it
- -> OutExpr -- ..and the RHS itself
- -> SimplM (SimplEnv, OutExpr) -- New env for let, and RHS
-
-chooseRhsFloats top_lvl is_rec is_strict env rhs_env rhs
- | not (isEmptyFloats rhs_env) -- Something to float
- , canFloat top_lvl is_rec is_strict rhs_env -- ...that can float
- , (isTopLevel top_lvl || exprIsCheap rhs) -- ...and we want to float
- = do { tick LetFloatFromLet -- Float
- ; return (addFloats env rhs_env, rhs) } -- Add the floats to the main env
- | otherwise -- Don't float
- = return (env, wrapFloats rhs_env rhs) -- Wrap the floats around the RHS
-\end{code}
+ ; (body_env2, body2) <- prepareRhs body_env1 body1
+ ; (env', rhs')
+ <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
+ then -- No floating, just wrap up!
+ do { rhs' <- mkLam tvs' (wrapFloats body_env2 body2)
+ ; return (env, rhs') }
-%************************************************************************
-%* *
-\subsection{simplNonRec}
-%* *
-%************************************************************************
+ else if null tvs then -- Simple floating
+ do { tick LetFloatFromLet
+ ; return (addFloats env body_env2, body2) }
+
+ else -- Do type-abstraction first
+ do { tick LetFloatFromLet
+ ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
+ ; rhs' <- mkLam tvs' body3
+ ; return (extendFloats env poly_binds, rhs') }
+
+ ; completeBind env' top_lvl bndr bndr1 rhs' }
+\end{code}
A specialised variant of simplNonRec used when the RHS is already simplified,
notably in knownCon. It uses case-binding where necessary.
completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs
= do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
- ; (env2, rhs2) <- chooseRhsFloats top_lvl is_rec is_strict env env1 rhs1
+ ; (env2, rhs2) <-
+ if doFloatFromRhs top_lvl is_rec is_strict rhs1 env1
+ then do { tick LetFloatFromLet
+ ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
+ else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
\end{code}
prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
prepareRhs env (Cast rhs co) -- Note [Float coercions]
+ | (ty1, ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
+ , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
= do { (env', rhs') <- makeTrivial env rhs
; return (env', Cast rhs' co) }
= return (False, env, other)
\end{code}
+
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
go n = case x of { T m -> go (n-m) }
-- This case should optimise
+Note [Float coercions (unlifted)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+BUT don't do [Float coercions] if 'e' has an unlifted type.
+This *can* happen:
+
+ foo :: Int = (error (# Int,Int #) "urk")
+ `cast` CoUnsafe (# Int,Int #) Int
+
+If do the makeTrivial thing to the error call, we'll get
+ foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
+But 'v' isn't in scope!
+
+These strange casts can happen as a result of case-of-case
+ bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
+ (# p,q #) -> p+q
+
\begin{code}
makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+ `setWorkerInfo` worker_info
+
final_info | loop_breaker = new_bndr_info
| isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
| otherwise = info_w_unf
return (addNonRec env final_id new_rhs)
where
unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ worker_info = substWorker env (workerInfo old_info)
loop_breaker = isNonRuleLoopBreaker occ_info
old_info = idInfo old_bndr
occ_info = occInfo old_info
(StrictBind bndr bndrs body env cont) }
| otherwise
- = do { (env, bndr') <- simplBinder env bndr
- ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
- ; simplLam env bndrs body cont }
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
+ ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+ ; simplLam env3 bndrs body cont }
\end{code}
-- See notes with SimplMonad.inlineMode
simplNote env InlineMe e cont
- | contIsRhsOrArg cont -- Totally boring continuation; see notes above
+ | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
= do { -- Don't inline inside an INLINE expression
- e' <- simplExpr (setMode inlineMode env) e
- ; rebuild env (mkInlineMe e') cont }
+ e' <- simplExprC (setMode inlineMode env) e inside
+ ; rebuild env (mkInlineMe e') outside }
| otherwise -- Dissolve the InlineMe note if there's
-- an interesting context of any kind to combine with
-- the wrapper didn't occur for things that have specialisations till a
-- later phase, so but now we just try RULES first
--
+ -- Note [Rules for recursive functions]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- You might think that we shouldn't apply rules for a loop breaker:
-- doing so might give rise to an infinite loop, because a RULE is
-- rather like an extra equation for the function:
-- is recursive, and hence a loop breaker:
-- foldr k z (build g) = g k z
-- So it's up to the programmer: rules can cause divergence
+ ; rules <- getRules
; let in_scope = getInScope env
- rules = getRules env
- maybe_rule = case activeRule env of
+ maybe_rule = case activeRule dflags env of
Nothing -> Nothing -- No rules apply
Just act_fn -> lookupRule act_fn in_scope
rules var args
------------- Next try inlining ----------------
{ let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
n_val_args = length arg_infos
- interesting_cont = interestingCallContext (notNull args)
- (notNull arg_infos)
- call_cont
+ interesting_cont = interestingCallContext call_cont
active_inline = activeInline env var
- maybe_inline = callSiteInline dflags active_inline
- var arg_infos interesting_cont
+ maybe_inline = callSiteInline dflags active_inline var
+ (null args) arg_infos interesting_cont
; case maybe_inline of {
Just unfolding -- There is an inlining!
-> do { tick (UnfoldingDone var)
; (if dopt Opt_D_dump_inlinings dflags then
- pprTrace "Inlining done" (vcat [
+ pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr call_cont])
-- Then, especially in the first of these cases, we'd like to discard
-- the continuation, leaving just the bottoming expression. But the
-- type might not be right, so we may have to add a coerce.
- | not (contIsTrivial cont) -- Only do thia if there is a non-trivial
+ | not (contIsTrivial cont) -- Only do this if there is a non-trivial
= return (env, mk_coerce fun) -- contination to discard, else we do it
where -- again and again!
cont_ty = contResultType cont
(env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
-- Simplify the alternatives
- ; (case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
+ ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
; let res_ty' = contResultType dup_cont
- ; case_expr <- mkCase scrut case_bndr' res_ty' alts'
+ ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
-- Notice that rebuildDone returns the in-scope set from env, not alt_env
-- The case binder *not* scope over the whole returned case-expression
v |-> x `cast` (sym co)
to v. Then we should inline v at the inner case, cancel the casts, and away we go
+Note [Improving seq]
+~~~~~~~~~~~~~~~~~~~
+Consider
+ type family F :: * -> *
+ type instance F Int = Int
+
+ ... case e of x { DEFAULT -> rhs } ...
+
+where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
+
+ case e `cast` co of x'::Int
+ I# x# -> let x = x' `cast` sym co
+ in rhs
+
+so that 'rhs' can take advantage of hte form of x'. Notice that Note
+[Case of cast] may then apply to the result.
+
+This showed up in Roman's experiments. Example:
+ foo :: F Int -> Int -> Int
+ foo t n = t `seq` bar n
+ where
+ bar 0 = 0
+ bar n = bar (n - case t of TI i -> i)
+Here we'd like to avoid repeated evaluating t inside the loop, by
+taking advantage of the `seq`.
+
+At one point I did transformation in LiberateCase, but it's more robust here.
+(Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
+LiberateCase gets to see it.)
Note [Case elimination]
~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId)
-simplCaseBinder env scrut case_bndr
- | switchIsOn (getSwitchChecker env) NoCaseOfCase
- -- See Note [no-case-of-case]
- = do { (env, case_bndr') <- simplBinder env case_bndr
- ; return (env, case_bndr') }
-
-simplCaseBinder env (Var v) case_bndr
--- Failed try [see Note 2 above]
--- not (isEvaldUnfolding (idUnfolding v))
- = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
- ; return (modifyInScope env v case_bndr', case_bndr') }
- -- We could extend the substitution instead, but it would be
- -- a hack because then the substitution wouldn't be idempotent
- -- any more (v is an OutId). And this does just as well.
-
-simplCaseBinder env (Cast (Var v) co) case_bndr -- Note [Case of cast]
- = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
- ; let rhs = Cast (Var case_bndr') (mkSymCoercion co)
- ; return (addBinderUnfolding env v rhs, case_bndr') }
-
-simplCaseBinder env other_scrut case_bndr
- = do { (env, case_bndr') <- simplBinder env case_bndr
- ; return (env, case_bndr') }
+simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
+ -> SimplM (SimplEnv, OutExpr, OutId)
+simplCaseBinder env scrut case_bndr alts
+ = do { (env1, case_bndr1) <- simplBinder env case_bndr
+
+ ; fam_envs <- getFamEnvs
+ ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
+ case_bndr case_bndr1 alts
+ -- Note [Improving seq]
+
+ ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
+ -- Note [Case of cast]
+
+ ; return (env3, scrut2, case_bndr3) }
+ where
+
+ improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
+ | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
+ = do { case_bndr2 <- newId FSLIT("nt") ty2
+ ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
+ env2 = extendIdSubst env1 case_bndr rhs
+ ; return (env2, scrut `Cast` co, case_bndr2) }
+
+ improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
+ = return (env1, scrut, case_bndr1)
+
+
+ improve_case_bndr env scrut case_bndr
+ | switchIsOn (getSwitchChecker env) NoCaseOfCase
+ -- See Note [no-case-of-case]
+ = (env, case_bndr)
+
+ | otherwise -- Failed try; see Note [Suppressing the case binder-swap]
+ -- not (isEvaldUnfolding (idUnfolding v))
+ = case scrut of
+ Var v -> (modifyInScope env1 v case_bndr', case_bndr')
+ -- Note about using modifyInScope for v here
+ -- We could extend the substitution instead, but it would be
+ -- a hack because then the substitution wouldn't be idempotent
+ -- any more (v is an OutId). And this does just as well.
+
+ Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
+ where
+ rhs = Cast (Var case_bndr') (mkSymCoercion co)
+
+ other -> (env, case_bndr)
+ where
+ case_bndr' = zapOccInfo case_bndr
+ env1 = modifyInScope env case_bndr case_bndr'
+
zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
zapOccInfo b = b `setIdOccInfo` NoOccInfo
-> OutExpr
-> InId -- Case binder
-> [InAlt] -> SimplCont
- -> SimplM (OutId, [OutAlt]) -- Includes the continuation
+ -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
-- Like simplExpr, this just returns the simplified alternatives;
-- it not return an environment
simplAlts env scrut case_bndr alts cont'
= -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
do { let alt_env = zapFloats env
- ; (alt_env, case_bndr') <- simplCaseBinder alt_env scrut case_bndr
+ ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
- ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
+ ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts
; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
- ; return (case_bndr', alts') }
+ ; return (scrut', case_bndr', alts') }
------------------------------------
simplAlt :: SimplEnv
; env <- simplNonRecX env bndr bndr_rhs
; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
simplExprF env rhs cont }
-
--- Ugh!
-bind_args env dead_bndr [] _ = return env
-
-bind_args env dead_bndr (b:bs) (Type ty : args)
- = ASSERT( isTyVar b )
- bind_args (extendTvSubst env b ty) dead_bndr bs args
-
-bind_args env dead_bndr (b:bs) (arg : args)
- = ASSERT( isId b )
- do { let b' = if dead_bndr then b else zapOccInfo b
- -- Note that the binder might be "dead", because it doesn't occur
- -- in the RHS; and simplNonRecX may therefore discard 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 [zapOccInfo]
- ; env <- simplNonRecX env b' arg
- ; bind_args env dead_bndr bs args }
-
-bind_args _ _ _ _ = panic "bind_args"
+ where
+ -- Ugh!
+ bind_args env dead_bndr [] _ = return env
+
+ bind_args env dead_bndr (b:bs) (Type ty : args)
+ = ASSERT( isTyVar b )
+ bind_args (extendTvSubst env b ty) dead_bndr bs args
+
+ bind_args env dead_bndr (b:bs) (arg : args)
+ = ASSERT( isId b )
+ do { let b' = if dead_bndr then b else zapOccInfo b
+ -- Note that the binder might be "dead", because it doesn't occur
+ -- in the RHS; and simplNonRecX may therefore discard 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 [zapOccInfo]
+ ; env <- simplNonRecX env b' arg
+ ; bind_args env dead_bndr bs args }
+
+ bind_args _ _ _ _ =
+ pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr args $$
+ text "scrut:" <+> ppr scrut
\end{code}