X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=1f691eaa437b5f8718e9ef75aa715f11868676df;hb=40b82d31494eabb51ef2eb47d6e6191e0db764fd;hp=b38bdc8a7b15497283dde898a2049deafa2d7252;hpb=90ce88a0a9b5611416e592a6ff96781ba884975f;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index b38bdc8..1f691ea 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -20,20 +20,23 @@ import Var import IdInfo import Coercion import FamInstEnv ( topNormaliseType ) -import DataCon ( dataConRepStrictness, dataConUnivTyVars ) +import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) import CoreSyn import NewDemand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, + exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils +import qualified CoreSubst import CoreArity ( exprArity ) import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) -import CostCentre ( currentCCS ) +import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRuleLoopBreaker ) +import MonadUtils ( foldlM ) import Maybes ( orElse ) import Data.List ( mapAccumL ) import Outputable @@ -201,7 +204,7 @@ expansion at a let RHS can concentrate solely on the PAP case. %************************************************************************ \begin{code} -simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] +simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv simplTopBinds env0 binds0 = do { -- Put all the top-level binders into scope at the start @@ -214,7 +217,7 @@ simplTopBinds env0 binds0 dopt Opt_D_dump_rule_firings dflags ; env2 <- simpl_binds dump_flag env1 binds0 ; freeTick SimplifierDone - ; return (getFloats env2) } + ; return env2 } where -- We need to track the zapped top-level binders, because -- they should have their fragile IdInfo zapped (notably occurrence info) @@ -351,7 +354,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se do { tick LetFloatFromLet ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 ; rhs' <- mkLam env tvs' body3 - ; let env' = foldl (addPolyBind top_lvl) env poly_binds + ; env' <- foldlM (addPolyBind top_lvl) env poly_binds ; return (env', rhs') } ; completeBind env' top_lvl bndr bndr1 rhs' } @@ -462,6 +465,7 @@ prepareRhs env0 rhs0 is_val = n_val_args > 0 -- There is at least one arg -- ...and the fun a constructor or PAP && (isConLikeId fun || n_val_args < idArity fun) + -- See Note [CONLIKE pragma] in BasicTypes go _ env other = return (False, env, other) \end{code} @@ -566,29 +570,23 @@ completeBind :: SimplEnv -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs - | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding - -- Inline and discard the binding - = do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $ - return (extendIdSubst env old_bndr (DoneEx new_rhs)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding + = do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info - | otherwise - = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr) - where - unfolding | omit_unfolding = NoUnfolding - | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs - old_info = idInfo old_bndr - occ_info = occInfo old_info - wkr = substWorker env (workerInfo old_info) - omit_unfolding = isNonRuleLoopBreaker occ_info - -- or not (activeInline env old_bndr) - -- Do *not* trim the unfolding in SimplGently, else - -- the specialiser can't see it! - ------------------ -addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv + ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf + + ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding + -- Inline and discard the binding + then do { tick (PostInlineUnconditionally old_bndr) + ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) } + +------------------------------ +addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv -- Add a new binding to the environment, complete with its unfolding -- but *do not* do postInlineUnconditionally, because we have already -- processed some of the scope of the binding @@ -601,71 +599,73 @@ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv -- opportunity to inline 'y' too. addPolyBind top_lvl env (NonRec poly_id rhs) - = addNonRecWithUnf env poly_id rhs unfolding NoWorker - where - unfolding | not (activeInline env poly_id) = NoUnfolding - | otherwise = mkUnfolding (isTopLevel top_lvl) rhs - -- addNonRecWithInfo adds the new binding in the - -- proper way (ie complete with unfolding etc), - -- and extends the in-scope set + = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding + -- Assumes that poly_id did not have an INLINE prag + -- which is perhaps wrong. ToDo: think about this + ; return (addNonRecWithUnf env poly_id rhs unfolding) } -addPolyBind _ env bind@(Rec _) = extendFloats env bind +addPolyBind _ env bind@(Rec _) = return (extendFloats env bind) -- Hack: letrecs are more awkward, so we extend "by steam" -- without adding unfoldings etc. At worst this leads to -- more simplifier iterations ------------------ +------------------------------ addNonRecWithUnf :: SimplEnv - -> OutId -> OutExpr -- New binder and RHS - -> Unfolding -> WorkerInfo -- and unfolding - -> SimplEnv --- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set -addNonRecWithUnf env new_bndr rhs unfolding wkr - = ASSERT( isId new_bndr ) + -> OutId -> OutExpr -- New binder and RHS + -> Unfolding -- New unfolding + -> SimplEnv +addNonRecWithUnf env new_bndr new_rhs new_unfolding + = let new_arity = exprArity new_rhs + old_arity = idArity new_bndr + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unfolding + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 + | otherwise = info2 + + final_id = new_bndr `setIdInfo` info3 + dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr + in + ASSERT( isId new_bndr ) WARN( new_arity < old_arity || new_arity < dmd_arity, (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity - <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs ) + <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs ) -- Note [Arity decrease] - final_id `seq` -- This seq forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - addNonRec env final_id rhs - -- The addNonRec adds it to the in-scope set too - where - dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr - old_arity = idArity new_bndr - -- Arity info - new_arity = exprArity rhs - new_bndr_info = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info - -- Add the unfolding *only* for non-loop-breakers - -- Making loop breakers not have an unfolding at all - -- means that we can avoid tests in exprIsConApp, for example. - -- This is important: if exprIsConApp says 'yes' for a recursive - -- thing, then we can get into an infinite loop - - -- Demand info - -- If the unfolding is a value, the demand info may - -- go pear-shaped, so we nuke it. Example: - -- let x = (a,b) in - -- case x of (p,q) -> h p q x - -- Here x is certainly demanded. But after we've nuked - -- the case, we'll get just - -- let x = (a,b) in h a b x - -- and now x is not demanded (I'm assuming h is lazy) - -- This really happens. Similarly - -- let f = \x -> e in ...f..f... - -- After inlining f at some of its call sites the original binding may - -- (for example) be no longer strictly demanded. - -- The solution here is a bit ad hoc... - info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding - `setWorkerInfo` wkr - - final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf - | otherwise = info_w_unf - - final_id = new_bndr `setIdInfo` final_info + final_id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + addNonRec env final_id new_rhs + -- The addNonRec adds it to the in-scope set too + +------------------------------ +simplUnfolding :: SimplEnv-> TopLevelFlag + -> Id -- Debug output only + -> OccInfo -> OutExpr + -> Unfolding -> SimplM Unfolding +-- Note [Setting the new unfolding] +simplUnfolding env _ _ _ _ (DFunUnfolding con ops) + = return (DFunUnfolding con ops') + where + ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops + +simplUnfolding env top_lvl _ _ _ + (CoreUnfolding { uf_tmpl = expr, uf_arity = arity + , uf_guidance = guide@(InlineRule {}) }) + = do { expr' <- simplExpr (setMode SimplGently env) expr + ; let mb_wkr' = CoreSubst.substInlineRuleGuidance (mkCoreSubst env) (ug_ir_info guide) + ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity + (guide { ug_ir_info = mb_wkr' })) } + -- See Note [Top-level flag on inline rules] in CoreUnfold + +simplUnfolding _ top_lvl _ occ_info new_rhs _ + | omit_unfolding = return NoUnfolding + | otherwise = return (mkUnfolding (isTopLevel top_lvl) new_rhs) + where + omit_unfolding = isNonRuleLoopBreaker occ_info \end{code} Note [Arity decrease] @@ -691,6 +691,38 @@ Here opInt has arity 1; but when we apply the rule its arity drops to 0. That's why Specialise goes to a little trouble to pin the right arity on specialised functions too. +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's an InlineRule on a loop breaker, we hang on to the inlining. +It's pretty dodgy, but the user did say 'INLINE'. May need to revisit +this choice. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + %************************************************************************ %* * @@ -787,7 +819,7 @@ simplExprF' env expr@(Lam _ _) cont simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) - do { ty' <- simplType env ty + do { ty' <- simplCoercion env ty ; rebuild env (Type ty') cont } simplExprF' env (Case scrut bndr _ alts) cont @@ -822,6 +854,14 @@ simplType env ty seqType new_ty `seq` return new_ty where new_ty = substTy env ty + +--------------------------------- +simplCoercion :: SimplEnv -> InType -> SimplM OutType +-- The InType isn't *necessarily* a coercion, but it might be +-- (in a type application, say) and optCoercion is a no-op on types +simplCoercion env co + = do { co' <- simplType env co + ; return (optCoercion co') } \end{code} @@ -859,7 +899,7 @@ rebuild env expr cont0 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM (SimplEnv, OutExpr) simplCast env body co0 cont0 - = do { co1 <- simplType env co0 + = do { co1 <- simplCoercion env co0 ; simplExprF env body (addCoerce co1 cont0) } where addCoerce co cont = add_coerce co (coercionKind co) cont @@ -871,8 +911,8 @@ simplCast env body co0 cont0 | (_l1, t1) <- coercionKind co2 -- e |> (g1 :: S1~L) |> (g2 :: L~T1) -- ==> - -- e, if T1=T2 - -- e |> (g1 . g2 :: T1~T2) otherwise + -- e, if S1=T1 + -- e |> (g1 . g2 :: S1~T1) otherwise -- -- For example, in the initial form of a worker -- we may find (coerce T (coerce S (\x.e))) y @@ -948,7 +988,7 @@ simplLam env bndrs body cont ------------------ simplNonRecE :: SimplEnv - -> InId -- The binder + -> InBndr -- The binder -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) -> ([InBndr], InExpr) -- Body of the let/lambda -- \xs.e @@ -1004,24 +1044,15 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) simplNote env (SCC cc) e cont + | pushCCisNop cc (getEnclosingCC env) -- scc "f" (...(scc "f" e)...) + = simplExprF env e cont -- ==> scc "f" (...e...) + | otherwise = do { e' <- simplExpr (setEnclosingCC env currentCCS) e ; rebuild env (mkSCC cc e') cont } --- See notes with SimplMonad.inlineMode -simplNote env InlineMe e cont - | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above - = do { -- Don't inline inside an INLINE expression - 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 - -- (even a type application -- anything except Stop) - = simplExprF env e cont - -simplNote env (CoreNote s) e cont = do - e' <- simplExpr env e - rebuild env (Note (CoreNote s) e') cont +simplNote env (CoreNote s) e cont + = do { e' <- simplExpr env e + ; rebuild env (Note (CoreNote s) e') cont } \end{code} @@ -1071,7 +1102,9 @@ completeCall env var cont -- later phase, so but now we just try RULES first -- -- See also Note [Rules for recursive functions] - ; mb_rule <- tryRules env var args call_cont + ; rule_base <- getSimplRules + ; let rules = getRules rule_base var + ; mb_rule <- tryRules env var rules args call_cont ; case mb_rule of { Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ; -- The ruleArity says how many args the rule consumed @@ -1104,7 +1137,8 @@ completeCall env var cont -- Next, look for rules or specialisations that match -- rebuildCall env (Var var) - (mkArgInfo var n_val_args call_cont) cont + (mkArgInfo var rules n_val_args call_cont) + cont }}}} rebuildCall :: SimplEnv @@ -1133,7 +1167,7 @@ rebuildCall env fun (ArgInfo { ai_strs = [] }) cont | otherwise = mkCoerce co expr rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont) - = do { ty' <- simplType (se `setInScope` env) arg_ty + = do { ty' <- simplCoercion (se `setInScope` env) arg_ty ; rebuildCall env (fun `App` Type ty') info cont } rebuildCall env fun @@ -1194,33 +1228,33 @@ all this at once is TOO HARD! %************************************************************************ \begin{code} -tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont +tryRules :: SimplEnv + -> Id -> [CoreRule] -> [OutExpr] -> SimplCont -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of -- args consumed by the rule -tryRules env fn args call_cont - = do { dflags <- getDOptsSmpl - ; rule_base <- getSimplRules - ; let in_scope = getInScope env - rules = getRules rule_base fn - maybe_rule = case activeRule dflags env of - Nothing -> Nothing -- No rules apply - Just act_fn -> lookupRule act_fn in_scope - fn args rules - ; case (rules, maybe_rule) of { - ([], _) -> return Nothing ; - (_, Nothing) -> return Nothing ; - (_, Just (rule, rule_rhs)) -> do - - { tick (RuleFired (ru_name rule)) - ; (if dopt Opt_D_dump_rule_firings dflags then - pprTrace "Rule fired" (vcat [ +tryRules env fn rules args call_cont + | null rules + = return Nothing + | otherwise + = do { dflags <- getDOptsSmpl + ; case activeRule dflags env of { + Nothing -> return Nothing ; -- No rules apply + Just act_fn -> + + case lookupRule act_fn (getInScope env) fn args rules of { + Nothing -> return Nothing ; -- No rule matches + Just (rule, rule_rhs) -> + + do { tick (RuleFired (ru_name rule)) + ; (if dopt Opt_D_dump_rule_firings dflags then + pprTrace "Rule fired" (vcat [ text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) - else + else id) $ - return (Just (ruleArity rule, rule_rhs)) }}} + return (Just (ruleArity rule, rule_rhs)) }}}} \end{code} Note [Rules for recursive functions] @@ -1347,14 +1381,27 @@ rebuildCase, reallyRebuildCase -------------------------------------------------- rebuildCase env scrut case_bndr alts cont - | Just (con,args) <- exprIsConApp_maybe scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - = knownCon env scrut (DataAlt con) args case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors -- because literals are inlined more vigorously - = knownCon env scrut (LitAlt lit) [] case_bndr alts cont + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (_, bs, rhs) -> simple_rhs bs rhs } + + | Just (con, ty_args, other_args) <- exprIsConApp_maybe scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + = do { tick (KnownBranch case_bndr) + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs + Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args + case_bndr bs rhs cont + } + where + simple_rhs bs rhs = ASSERT( null bs ) + do { env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } -------------------------------------------------- @@ -1408,7 +1455,10 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this - ; mb_rule <- tryRules env seqId out_args cont + + ; rule_base <- getSimplRules + ; let rules = getRules rule_base seqId + ; mb_rule <- tryRules env seqId rules out_args cont ; case mb_rule of Just (n_args, res) -> simplExprF (zapSubstEnv env) (mkApps res (drop n_args out_args)) @@ -1462,6 +1512,19 @@ The point is that we bring into the envt a binding after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. +In practice, the scrutinee is almost always a variable, so we pretty +much always zap the OccInfo of the binders. It doesn't matter much though. + + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (v `cast` co) of x { I# -> + ... (case (v `cast` co) of {...}) ... +We'd like to eliminate the inner case. We can get this neatly by +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 @@ -1711,26 +1774,15 @@ and then All this should happen in one sweep. \begin{code} -knownCon :: SimplEnv -> OutExpr -> AltCon - -> [OutExpr] -- Args *including* the universal args - -> InId -> [InAlt] -> SimplCont - -> SimplM (SimplEnv, OutExpr) - -knownCon env scrut con args bndr alts cont - = do { tick (KnownBranch bndr) - ; case findAlt con alts of - Nothing -> missingAlt env bndr alts cont - Just alt -> knownAlt env scrut args bndr alt cont - } - -------------------- -knownAlt :: SimplEnv -> OutExpr -> [OutExpr] - -> InId -> InAlt -> SimplCont +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont -> SimplM (SimplEnv, OutExpr) -knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont - = do { let n_drop_tys = length (dataConUnivTyVars dc) - ; env' <- bind_args env bs (drop n_drop_tys the_args) +knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont + = do { env' <- bind_args env bs dc_args ; let -- It's useful to bind bndr to scrut, rather than to a fresh -- binding x = Con arg1 .. argn @@ -1739,12 +1791,12 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont -- BUT, if scrut is a not a variable, we must be careful -- about duplicating the arg redexes; in that case, make -- a new con-app from the args - bndr_rhs = case scrut of - Var _ -> scrut - _ -> con_app - con_app = mkConApp dc (take n_drop_tys the_args ++ con_args) - con_args = [substExpr env' (varToCoreExpr b) | b <- bs] - -- args are aready OutExprs, but bs are InIds + bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs] + -- dc_ty_args are aready OutTypes, but bs are InBndrs ; env'' <- simplNonRecX env' bndr bndr_rhs ; simplExprF env'' rhs cont } @@ -1770,15 +1822,9 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont ; bind_args env'' bs' args } bind_args _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$ + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ text "scrut:" <+> ppr scrut -knownAlt env scrut _ bndr (_, bs, rhs) cont - = ASSERT( null bs ) -- Works for LitAlt and DEFAULT - do { env' <- simplNonRecX env bndr scrut - ; simplExprF env' rhs cont } - - ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) -- This isn't strictly an error, although it is unusual. @@ -1911,12 +1957,31 @@ mkDupableAlts env case_bndr' the_alts mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) -mkDupableAlt env case_bndr' (con, bndrs', rhs') +mkDupableAlt env case_bndr (con, bndrs', rhs') | exprIsDupable rhs' -- Note [Small alternative rhs] = return (env, (con, bndrs', rhs')) | otherwise - = do { let rhs_ty' = exprType rhs' - used_bndrs' = filter abstract_over (case_bndr' : bndrs') + = do { let rhs_ty' = exprType rhs' + scrut_ty = idType case_bndr + case_bndr_w_unf + = case con of + DEFAULT -> case_bndr + DataAlt dc -> setIdUnfolding case_bndr unf + where + -- See Note [Case binders and join points] + unf = mkInlineRule InlSat rhs 0 + rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) + ++ varsToCoreExprs bndrs') + + LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt") + <+> ppr case_bndr <+> ppr con ) + case_bndr + -- The case binder is alive but trivial, so why has + -- it not been substituted away? + + used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs' + | otherwise = bndrs' ++ [case_bndr_w_unf] + abstract_over bndr | isTyVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) @@ -1941,10 +2006,42 @@ mkDupableAlt env case_bndr' (con, bndrs', rhs') join_rhs = mkLams really_final_bndrs rhs' join_call = mkApps (Var join_bndr) final_args - ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) } + ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs) + ; return (env', (con, bndrs', join_call)) } -- See Note [Duplicated env] \end{code} +Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutines the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + + Note [Duplicated env] ~~~~~~~~~~~~~~~~~~~~~ Some of the alternatives are simplified, but have not been turned into a join point