X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=10965a18455cfb3e03619b9b206cd1e5e05f7e9b;hb=bd78c94a3b41f8d2097efc0415fa26e0cd1140ef;hp=14d11dff9786861163077978bdf7de4834dda5fa;hpb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 14d11df..10965a1 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -26,6 +26,7 @@ import NewDemand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) import CoreUtils +import CoreArity ( exprArity ) import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) @@ -339,7 +340,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ; (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) + do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2) ; return (env, rhs') } else if null tvs then -- Simple floating @@ -349,7 +350,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se else -- Do type-abstraction first do { tick LetFloatFromLet ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 - ; rhs' <- mkLam tvs' body3 + ; rhs' <- mkLam env tvs' body3 ; let env' = foldl (addPolyBind top_lvl) env poly_binds ; return (env', rhs') } @@ -918,7 +919,7 @@ simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont) simplLam env bndrs body cont = do { (env', bndrs') <- simplLamBndrs env bndrs ; body' <- simplExpr env' body - ; new_lam <- mkLam bndrs' body' + ; new_lam <- mkLam env' bndrs' body' ; rebuild env' new_lam cont } ------------------ @@ -1093,7 +1094,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" ++ showSDoc (ppr var)) (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]) @@ -1437,59 +1438,6 @@ At one point I did transformation in LiberateCase, but it's more robust here. LiberateCase gets to see it.) -Historical note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~ -We *used* to suppress the binder-swap in case expressoins when --fno-case-of-case is on. Old remarks: - "This happens in the first simplifier pass, - and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) - If we eliminate the inner case, we trap it inside the I# v -> arm, - which might prevent some full laziness happening. I've seen this - in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] - Hence the check for NoCaseOfCase." -However, now the full-laziness pass itself reverses the binder-swap, so this -check is no longer necessary. - -Historical note [Suppressing the case binder-swap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is another situation when it might make sense to suppress the -case-expression binde-swap. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - -We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - -But there is no point in doing it for the inner case, because w1 can't -be inlined anyway. Furthermore, doing the case-swapping involves -zapping w2's occurrence info (see paragraphs that follow), and that -forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - -This is plain silly in the common case where w2 is dead. - -Even so, I can't see a good way to implement this idea. I tried -not doing the binder-swap if the scrutinee was already evaluated -but that failed big-time: - - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - -Notice that because MkT is strict, x is marked "evaluated". But to -eliminate the last case, we must either make sure that x (as well as -x1) has unfolding MkT y1. THe straightforward thing to do is to do -the binder-swap. So this whole note is a no-op. \begin{code} @@ -1668,8 +1616,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... } -- ==> case e of t { (a,b) -> ...(a)... } -- Look, Ma, a is alive now. - zap_occ_info | isDeadBinder case_bndr' = \ident -> ident - | otherwise = zapIdOccInfo + zap_occ_info = zapCasePatIdOcc case_bndr' addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs @@ -1678,6 +1625,14 @@ addBinderUnfolding env bndr rhs addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons) + +zapCasePatIdOcc :: Id -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapCasePatIdOcc case_bndr + | isDeadBinder case_bndr = \ pat_id -> pat_id + | otherwise = \ pat_id -> zapIdOccInfo pat_id \end{code} @@ -1727,9 +1682,8 @@ knownAlt env scrut _ bndr (LitAlt _, bs, rhs) cont ; simplExprF env' rhs cont } knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont - = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId - n_drop_tys = length (dataConUnivTyVars dc) - ; env' <- bind_args env dead_bndr bs (drop n_drop_tys the_args) + = do { let n_drop_tys = length (dataConUnivTyVars dc) + ; env' <- bind_args env bs (drop n_drop_tys the_args) ; let -- It's useful to bind bndr to scrut, rather than to a fresh -- binding x = Con arg1 .. argn @@ -1748,25 +1702,27 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont ; env'' <- simplNonRecX env' bndr bndr_rhs ; simplExprF env'' rhs cont } where - -- Ugh! - bind_args env' _ [] _ = return env' + zap_occ = zapCasePatIdOcc bndr -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return env' - bind_args env' dead_bndr (b:bs') (Type ty : args) + bind_args env' (b:bs') (Type ty : args) = ASSERT( isTyVar b ) - bind_args (extendTvSubst env' b ty) dead_bndr bs' args + bind_args (extendTvSubst env' b ty) bs' args - bind_args env' dead_bndr (b:bs') (arg : args) + bind_args env' (b:bs') (arg : args) = ASSERT( isId b ) - do { let b' = if dead_bndr then b else zapIdOccInfo b + do { let b' = zap_occ 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 env'' bs' args } - bind_args _ _ _ _ = + bind_args _ _ _ = pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$ text "scrut:" <+> ppr scrut \end{code}