X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=b187897f890de47ba85b2ea78df75135b47b55a9;hb=3bb66cc52ced70cd7081fb8a2e32a1005528d5a0;hp=6fe24df49ea88943fefc65a5c07c5fc3cb03f4f7;hpb=d056dfedcf9c7e5e58031ad5948c480f9cdca16f;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 6fe24df..b187897 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -17,10 +17,9 @@ import FamInstEnv ( FamInstEnv ) import Id import MkId ( seqId, realWorldPrimId ) import MkCore ( mkImpossibleExpr ) -import Var import IdInfo import Name ( mkSystemVarName, isExternalName ) -import Coercion +import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst ) import OptCoercion ( optCoercion ) import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) @@ -38,10 +37,11 @@ import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM ) -import Maybes ( orElse ) +import Maybes ( orElse, isNothing ) import Data.List ( mapAccumL ) import Outputable import FastString +import Pair \end{code} @@ -369,8 +369,11 @@ simplNonRecX :: SimplEnv -> SimplM SimplEnv simplNonRecX env bndr new_rhs - | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p } - = return env -- Here b is dead, and we avoid creating + | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return env -- Here c is dead, and we avoid creating + -- the binding c = (a,b) + | Coercion co <- new_rhs + = return (extendCvSubst env bndr co) | otherwise -- the binding b = (a,b) = do { (env', bndr') <- simplBinder env bndr ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } @@ -438,7 +441,7 @@ That's what the 'go' loop in prepareRhs does prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] - | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type + | Pair 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') <- makeTrivialWithInfo top_lvl env sanitised_info rhs ; return (env', Cast rhs' co) } @@ -626,6 +629,12 @@ completeBind :: SimplEnv -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (extendCvSubst env old_bndr co) + _ -> return (addNonRec env new_bndr new_rhs) + + | otherwise = ASSERT( isId new_bndr ) do { let old_info = idInfo old_bndr old_unf = unfoldingInfo old_info @@ -641,9 +650,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding -- Inline and discard the binding then do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" - -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $ - return (extendIdSubst env old_bndr (DoneEx final_rhs)) } + ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding else @@ -658,7 +665,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs final_id = new_bndr `setIdInfo` info3 - ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $ return (addNonRec env final_id final_rhs) } } -- The addNonRec adds it to the in-scope set too @@ -870,18 +877,21 @@ simplExprF :: SimplEnv -> InExpr -> SimplCont simplExprF env e cont = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $ - simplExprF' env e cont + simplExprF1 env e cont -simplExprF' :: SimplEnv -> InExpr -> SimplCont +simplExprF1 :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF' env (Var v) cont = simplVarF env v cont -simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont -simplExprF' env (Note n expr) cont = simplNote env n expr cont -simplExprF' env (Cast body co) cont = simplCast env body co cont -simplExprF' env (App fun arg) cont = simplExprF env fun $ +simplExprF1 env (Var v) cont = simplIdF env v cont +simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont +simplExprF1 env (Note n expr) cont = simplNote env n expr cont +simplExprF1 env (Cast body co) cont = simplCast env body co cont +simplExprF1 env (Coercion co) cont = simplCoercionF env co cont +simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) + rebuild env (Type (substTy env ty)) cont +simplExprF1 env (App fun arg) cont = simplExprF env fun $ ApplyTo NoDup arg env cont -simplExprF' env expr@(Lam _ _) cont +simplExprF1 env expr@(Lam {}) cont = simplLam env zapped_bndrs body cont -- The main issue here is under-saturated lambdas -- (\x1. \x2. e) arg1 @@ -898,17 +908,12 @@ simplExprF' env expr@(Lam _ _) cont n_args = countArgs cont -- NB: countArgs counts all the args (incl type args) -- and likewise drop counts all binders (incl type lambdas) - - zappable_bndr b = isId b && not (isOneShotBndr b) - zap b | isTyCoVar b = b - | otherwise = zapLamIdInfo b -simplExprF' env (Type ty) cont - = ASSERT( contIsRhsOrArg cont ) - do { ty' <- simplCoercion env ty - ; rebuild env (Type ty') cont } + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyVar b = b + | otherwise = zapLamIdInfo b -simplExprF' env (Case scrut bndr _ alts) cont +simplExprF1 env (Case scrut bndr _ alts) cont | sm_case_case (getMode env) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -920,7 +925,7 @@ simplExprF' env (Case scrut bndr _ alts) cont (Select NoDup bndr alts env mkBoringStop) ; rebuild env case_expr' cont } -simplExprF' env (Let (Rec pairs) body) cont +simplExprF1 env (Let (Rec pairs) body) cont = do { env' <- simplRecBndrs env (map fst pairs) -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -928,7 +933,7 @@ simplExprF' env (Let (Rec pairs) body) cont ; env'' <- simplRecBind env' NotTopLevel pairs ; simplExprF env'' body cont } -simplExprF' env (Let (NonRec bndr rhs) body) cont +simplExprF1 env (Let (NonRec bndr rhs) body) cont = simplNonRecE env bndr (rhs, env) ([], body) cont --------------------------------- @@ -941,13 +946,30 @@ simplType env ty 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 +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) +-- We are simplifying a term of form (Coercion co) +-- Simplify the InCoercion, and then try to combine with the +-- context, to implememt the rule +-- (Coercion co) |> g +-- = Coercion (syn (nth 0 g) ; co ; nth 1 g) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; simpl_co co' cont } + where + simpl_co co (CoerceIt g cont) + = simpl_co new_co cont + where + new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1 + [g0, g1] = decomposeCo 2 g + + simpl_co co cont + = seqCo co `seq` rebuild env (Coercion co) cont + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = seqType new_co `seq` return new_co - where - new_co = optCoercion (getTvSubst env) co + = let opt_co = optCoercion (getCvSubst env) co + in opt_co `seq` return opt_co \end{code} @@ -964,7 +986,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) rebuild env expr cont = case cont of Stop {} -> return (env, expr) - CoerceIt co cont -> rebuild env (mkCoerce co expr) cont + CoerceIt co cont -> rebuild env (Cast expr co) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr @@ -991,11 +1013,11 @@ simplCast env body co0 cont0 where addCoerce co cont = add_coerce co (coercionKind co) cont - add_coerce _co (s1, k1) cont -- co :: ty~ty - | s1 `coreEqType` k1 = cont -- is a no-op + add_coerce _co (Pair s1 k1) cont -- co :: ty~ty + | s1 `eqType` k1 = cont -- is a no-op - add_coerce co1 (s1, _k2) (CoerceIt co2 cont) - | (_l1, t1) <- coercionKind co2 + add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont) + | (Pair _l1 t1) <- coercionKind co2 -- e |> (g1 :: S1~L) |> (g2 :: L~T1) -- ==> -- e, if S1=T1 @@ -1005,28 +1027,40 @@ simplCast env body co0 cont0 -- we may find (coerce T (coerce S (\x.e))) y -- and we'd like it to simplify to e[y/x] in one round -- of simplification - , s1 `coreEqType` t1 = cont -- The coerces cancel out - | otherwise = CoerceIt (mkTransCoercion co1 co2) cont + , s1 `eqType` t1 = cont -- The coerces cancel out + | otherwise = CoerceIt (mkTransCo co1 co2) cont - add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) + add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) -- (f |> g) ty ---> (f ty) |> (g @ ty) - -- This implements the PushT and PushC rules from the paper + -- This implements the PushT rule from the paper | Just (tyvar,_) <- splitForAllTy_maybe s1s2 - = let - (new_arg_ty, new_cast) - | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule - | otherwise = (ty', mkInstCoercion co ty') -- PushT rule - in - ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont) + = ASSERT( isTyVar tyvar ) + ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont) where - ty' = substTy (arg_se `setInScope` env) arg_ty - new_arg_co = mkCsel1Coercion co `mkTransCoercion` - ty' `mkTransCoercion` - mkSymCoercion (mkCsel2Coercion co) - - add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont) - | not (isTypeArg arg) -- This implements the Push rule from the paper - , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied + new_cast = mkInstCo co arg_ty' + arg_ty' | isSimplified dup = arg_ty + | otherwise = substTy (arg_se `setInScope` env) arg_ty + +{- + add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Coercion arg_co) arg_se cont) + -- This implements the PushC rule from the paper + | Just (covar,_) <- splitForAllTy_maybe s1s2 + = ASSERT( isCoVar covar ) + ApplyTo Simplified (Coercion new_arg_co) (zapSubstEnv arg_se) (addCoerce co1 cont) + where + [co0, co1] = decomposeCo 2 co + [co00, co01] = decomposeCo 2 co0 + + arg_co' | isSimplified dup = arg_co + | otherwise = substCo (arg_se `setInScope` env) arg_co + new_arg_co = co00 `mkTransCo` + arg_co' `mkTransCo` + mkSymCo co01 +-} + + add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont) + | isFunTy s1s2 -- This implements the Push rule from the paper + , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg -- (e |> (g :: s1s2 ~ t1->t2)) f -- ===> -- (e (f |> (arg g :: t1~s1)) @@ -1047,7 +1081,7 @@ simplCast env body co0 cont0 -- t2 ~ s2 with left and right on the curried form: -- (->) t1 t2 ~ (->) s1 s2 [co1, co2] = decomposeCo 2 co - new_arg = mkCoerce (mkSymCoercion co1) arg' + new_arg = mkCoerce (mkSymCo co1) arg' arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg add_coerce co _ cont = CoerceIt co cont @@ -1120,7 +1154,7 @@ simplNonRecE :: SimplEnv -- First deal with type applications and type lets -- (/\a. e) (Type ty) and (let a = Type ty in e) simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont - = ASSERT( isTyCoVar bndr ) + = ASSERT( isTyVar bndr ) do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } @@ -1130,12 +1164,12 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - | isStrictId bndr + | isStrictId bndr -- Includes coercions = do { simplExprF (rhs_se `setFloats` env) rhs (StrictBind bndr bndrs body env cont) } | otherwise - = ASSERT( not (isTyCoVar bndr) ) + = ASSERT( not (isTyVar bndr) ) do { (env1, bndr1) <- simplNonRecBndr env bndr ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se @@ -1177,20 +1211,20 @@ simplNote env (CoreNote s) e cont simplVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment simplVar env var - | isTyCoVar var - = return (Type (substTyVar env var)) + | isTyVar var = return (Type (substTyVar env var)) + | isCoVar var = return (Coercion (substCoVar env var)) | otherwise = case substId env var of - DoneId var1 -> return (Var var1) - DoneEx e -> return e - ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e -simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplVarF env var cont +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplIdF env var cont = case substId env var of - DoneEx e -> simplExprF (zapSubstEnv env) e cont - ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont - DoneId var1 -> completeCall env var1 cont + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont + DoneId var1 -> completeCall env var1 cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -1237,10 +1271,10 @@ completeCall env var cont | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then - pprTrace "Inlining done:" (ppr var) stuff + pprDefiniteTrace "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff @@ -1266,13 +1300,14 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con res = mkApps (Var fun) (reverse rev_args) res_ty = exprType res cont_ty = contResultType env res_ty cont - co = mkUnsafeCoercion res_ty cont_ty - mk_coerce expr | cont_ty `coreEqType` res_ty = expr + co = mkUnsafeCo res_ty cont_ty + mk_coerce expr | cont_ty `eqType` res_ty = expr | otherwise = mkCoerce co expr -rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) - = do { ty' <- simplCoercion (se `setInScope` env) arg_ty - ; rebuildCall env (info `addArgTo` Type ty') cont } +rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont) + = do { arg_ty' <- if isSimplified dup_flag then return arg_ty + else simplType (se `setInScope` env) arg_ty + ; rebuildCall env (info `addArgTo` Type arg_ty') cont } rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) @@ -1280,7 +1315,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules | isSimplified dup_flag -- See Note [Avoid redundant simplification] = rebuildCall env (addArgTo info' arg) cont - | str -- Strict argument + | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg (StrictArg info' cci cont) @@ -1391,11 +1426,12 @@ tryRules env rules fn args call_cont trace_dump dflags rule rule_rhs stuff | not (dopt Opt_D_dump_rule_firings dflags) , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff + | not (dopt Opt_D_dump_rule_rewrites dflags) + = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff - = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff | otherwise - = pprTrace "Rule fired" + = pprDefiniteTrace "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), text "After: " <+> pprCoreExpr rule_rhs, @@ -1682,16 +1718,6 @@ 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# y -> - ... (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 @@ -1708,7 +1734,7 @@ where x::F Int. Then we'd like to rewrite (F Int) to Int, getting so that 'rhs' can take advantage of the form of x'. -Notice that Note [Case of cast] may then apply to the result. +Notice that Note [Case of cast] (in OccurAnal) may then apply to the result. Nota Bene: We only do the [Improving seq] transformation if the case binder 'x' is actually used in the rhs; that is, if the case @@ -1765,7 +1791,9 @@ simplAlts env scrut case_bndr alts cont' ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts - ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts + ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing } + ; alts' <- mapM (simplAlt alt_env' mb_var_scrut + imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } @@ -1778,7 +1806,7 @@ improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq] , 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) + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } @@ -1788,27 +1816,30 @@ improveSeq _ env scrut _ case_bndr1 _ ------------------------------------ simplAlt :: SimplEnv - -> [AltCon] -- These constructors can't be present when - -- matching the DEFAULT alternative - -> OutId -- The case binder + -> Maybe OutId -- Scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder -> SimplCont -> InAlt -> SimplM OutAlt -simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) +simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) = ASSERT( null bndrs ) - do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons + do { let env' = addBinderUnfolding env scrut case_bndr' + (mkOtherCon imposs_deflt_cons) -- Record the constructors that the case-binder *can't* be. ; rhs' <- simplExprC env' rhs cont' ; return (DEFAULT, [], rhs') } -simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs) +simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs) = ASSERT( null bndrs ) - do { let env' = addBinderUnfolding env case_bndr' (Lit lit) + do { let env' = addBinderUnfolding env scrut case_bndr' + (mkSimpleUnfolding (Lit lit)) ; rhs' <- simplExprC env' rhs cont' ; return (LitAlt lit, [], rhs') } -simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) +simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs) = do { -- Deal with the pattern-bound variables -- Mark the ones that are in ! positions in the -- data constructor as certainly-evaluated. @@ -1819,8 +1850,8 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) -- Bind the case-binder to (con args) ; let inst_tys' = tyConAppArgs (idType case_bndr') con_args = map Type inst_tys' ++ varsToCoreExprs vs' - env'' = addBinderUnfolding env' case_bndr' - (mkConApp con con_args) + unf = mkSimpleUnfolding (mkConApp con con_args) + env'' = addBinderUnfolding env' scrut case_bndr' unf ; rhs' <- simplExprC env'' rhs cont' ; return (DataAlt con, vs', rhs') } @@ -1838,12 +1869,12 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) = go vs the_strs where go [] [] = [] - go (v:vs') strs | isTyCoVar v = v : go vs' strs + go (v:vs') strs | isTyVar v = v : go vs' strs go (v:vs') (str:strs) | isMarkedStrict str = evald_v : go vs' strs | otherwise = zapped_v : go vs' strs where - zapped_v = zap_occ_info v + zapped_v = zapBndrOccInfo keep_occ_info v evald_v = zapped_v `setIdUnfolding` evaldUnfolding go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs) @@ -1855,25 +1886,49 @@ 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 = zapCasePatIdOcc case_bndr' + keep_occ_info = isDeadBinder case_bndr' && isNothing scrut -addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv -addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) - -addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv -addBinderOtherCon env bndr cons - = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons) +addBinderUnfolding :: SimplEnv -> Maybe OutId -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env scrut bndr unf + = case scrut of + Just v -> modifyInScope env1 (v `setIdUnfolding` unf) + _ -> env1 + where + env1 = modifyInScope env bndr_w_unf + bndr_w_unf = bndr `setIdUnfolding` unf -zapCasePatIdOcc :: Id -> Id -> Id +zapBndrOccInfo :: Bool -> 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 +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id \end{code} +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccAnal has got rid of all such occcurrences +See Note [Binder swap] in OccAnal. + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimintation -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +Exactly the same issue arises in SpecConstr; +see Note [Add scrutinee to ValueEnv too] in SpecConstr %************************************************************************ %* * @@ -1907,13 +1962,13 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont ; env'' <- bind_case_bndr env' ; simplExprF env'' rhs cont } where - zap_occ = zapCasePatIdOcc bndr -- bndr is an InId + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId -- Ugh! bind_args env' [] _ = return env' bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyCoVar b ) + = ASSERT( isTyVar b ) bind_args (extendTvSubst env' b ty) bs' args bind_args env' (b:bs') (arg : args) @@ -1973,16 +2028,44 @@ missingAlt env case_bndr alts cont \begin{code} prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (SimplEnv, SimplCont,SimplCont) - -- Return a duplicatable continuation, a non-duplicable part - -- plus some extra bindings (that scope over the entire - -- continunation) - - -- No need to make it duplicatable if there's only one alternative -prepareCaseCont env [_] cont = return (env, cont, mkBoringStop) -prepareCaseCont env _ cont = mkDupableCont env cont + -> SimplM (SimplEnv, SimplCont, SimplCont) +-- We are considering +-- K[case _ of { p1 -> r1; ...; pn -> rn }] +-- where K is some enclosing continuation for the case +-- Goal: split K into two pieces Kdup,Knodup so that +-- a) Kdup can be duplicated +-- b) Knodup[Kdup[e]] = K[e] +-- The idea is that we'll transform thus: +-- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] } +-- +-- We also return some extra bindings in SimplEnv (that scope over +-- the entire continuation) + +prepareCaseCont env alts cont + | many_alts alts = mkDupableCont env cont + | otherwise = return (env, cont, mkBoringStop) + where + many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative + many_alts [] = False -- See Note [Bottom alternatives] + many_alts [_] = False + many_alts (alt:alts) + | is_bot_alt alt = many_alts alts + | otherwise = not (all is_bot_alt alts) + + is_bot_alt (_,_,rhs) = exprIsBottom rhs \end{code} +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away; and in some cases we would +not even create the join points (see Note [Single-alternative case]) +and we would keep the case-of-case which is silly. See Trac #4930. + \begin{code} mkDupableCont :: SimplEnv -> SimplCont -> SimplM (SimplEnv, SimplCont, SimplCont) @@ -2033,14 +2116,17 @@ mkDupableCont env (Select _ case_bndr alts se cont) -- let ji = \xij -> ei -- in case [...hole...] of { pi -> ji xij } do { tick (CaseOfCase case_bndr) - ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont - -- NB: call mkDupableCont here, *not* prepareCaseCont - -- We must make a duplicable continuation, whereas prepareCaseCont - -- doesn't when there is a single case branch + ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont + -- NB: We call prepareCaseCont here. If there is only one + -- alternative, then dup_cont may be big, but that's ok + -- becuase we push it into the single alternative, and then + -- use mkDupableAlt to turn that simplified alternative into + -- a join point if it's too big to duplicate. + -- And this is important: see Note [Fusing case continuations] ; let alt_env = se `setInScope` env' ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr - ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts -- Safe to say that there are no handled-cons for the DEFAULT case -- NB: simplBinder does not zap deadness occ-info, so -- a dead case_bndr' will still advertise its deadness @@ -2100,7 +2186,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') | otherwise = bndrs' ++ [case_bndr_w_unf] abstract_over bndr - | isTyCoVar bndr = True -- Abstract over all type variables just in case + | isTyVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) -- The deadness info on the new Ids is preserved by simplBinders @@ -2128,6 +2214,37 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') -- See Note [Duplicated env] \end{code} +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StricgtBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See Trac #4957 a fuller example. + Note [Case binders and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this @@ -2309,9 +2426,6 @@ Note [Duplicating StrictBind] Unlike StrictArg, there doesn't seem anything to gain from duplicating a StrictBind continuation, so we don't. -The desire not to duplicate is the entire reason that -mkDupableCont returns a pair of continuations. - Note [Single-alternative cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2381,8 +2495,7 @@ Note [Single-alternative-unlifted] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here's another single-alternative where we really want to do case-of-case: -data Mk1 = Mk1 Int# -data Mk1 = Mk2 Int# +data Mk1 = Mk1 Int# | Mk2 Int# M1.f = \r [x_s74 y_s6X] @@ -2407,7 +2520,15 @@ M1.f = So the outer case is doing *nothing at all*, other than serving as a join-point. In this case we really want to do case-of-case and decide -whether to use a real join point or just duplicate the continuation. +whether to use a real join point or just duplicate the continuation: + + let $j s7c = case x of + Mk1 ipv77 -> (==) s7c ipv77 + Mk1 ipv79 -> (==) s7c ipv79 + in + case y of + Mk1 ipv70 -> $j ipv70 + Mk2 ipv72 -> $j ipv72 Hence: check whether the case binder's type is unlifted, because then the outer case is *not* a seq.