\section[Simplify]{The main module of the simplifier}
\begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# 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/WorkingConventions#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Simplify ( simplTopBinds, simplExpr ) where
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}
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) }
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') <- simplNonRecBndr 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}
-- the wrapper didn't occur for things that have specialisations till a
-- later phase, so but now we just try RULES first
--
- -- Note [Self-recursive rules]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- 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:
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])
-- See Note [no-case-of-case]
= (env, case_bndr)
- | otherwise -- Failed try [see Note 2 above]
+ | 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')
do { let alt_env = zapFloats env
; (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 (scrut', case_bndr', alts') }
; 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}
projects / ghc-hetmet.git / blobdiff