X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=dbad116eae6fe733140a182e89ed83e0d9c4e687;hb=58e45ee86bbda3f24a4caf41c0aea7a6b787367e;hp=cab6460e76235b7a66e1f150c34b09b4fa43dd72;hpb=4c7846e8a0336f71d5c16798e103980f83532c30;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index cab6460..dbad116 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -4,6 +4,13 @@ \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" @@ -17,8 +24,8 @@ import Id import Var import IdInfo import Coercion -import DataCon ( dataConTyCon, dataConRepStrictness, dataConUnivTyVars ) -import TyCon ( tyConArity ) +import FamInstEnv ( topNormaliseType ) +import DataCon ( dataConRepStrictness, dataConUnivTyVars ) import CoreSyn import NewDemand ( isStrictDmd ) import PprCore ( pprParendExpr, pprCoreExpr ) @@ -32,6 +39,7 @@ import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRuleLoopBreaker ) import Maybes ( orElse ) +import Data.List ( mapAccumL ) import Outputable import Util \end{code} @@ -227,8 +235,10 @@ simplTopBinds env binds 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} @@ -246,15 +256,22 @@ simplRecBind :: SimplEnv -> TopLevelFlag -> [(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} @@ -267,18 +284,16 @@ It assumes the binder has already been simplified, but not its IdInfo. \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} @@ -306,46 +321,38 @@ simplLazyBind :: SimplEnv -> 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. @@ -370,7 +377,11 @@ completeNonRecX :: SimplEnv 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} @@ -419,6 +430,8 @@ That's what the 'go' loop in prepareRhs does 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) } @@ -448,6 +461,7 @@ prepareRhs env rhs = return (False, env, other) \end{code} + Note [Float coercions] ~~~~~~~~~~~~~~~~~~~~~~ When we find the binding @@ -470,6 +484,22 @@ and lead to further optimisation. Example: 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) @@ -556,6 +586,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- (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 @@ -569,6 +601,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs 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 @@ -874,9 +907,10 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont (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} @@ -895,10 +929,10 @@ simplNote env (SCC cc) e cont -- 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 @@ -955,6 +989,8 @@ completeCall env var cont -- 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: @@ -966,9 +1002,9 @@ completeCall env var cont -- 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 @@ -1001,7 +1037,7 @@ completeCall env var cont 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]) @@ -1034,7 +1070,7 @@ rebuildCall env fun fun_ty (has_rules, []) 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 @@ -1181,9 +1217,9 @@ rebuildCase env scrut case_bndr alts 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 @@ -1281,6 +1317,35 @@ arranging that inside the outer case we add the unfolding 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] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -1370,30 +1435,56 @@ I don't really know how to improve this situation. \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 @@ -1445,19 +1536,19 @@ simplAlts :: SimplEnv -> 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 @@ -1601,25 +1692,27 @@ knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont ; 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}