diff options
| -rw-r--r-- | compiler/coreSyn/CoreSubst.hs | 562 |
1 files changed, 364 insertions, 198 deletions
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index 9d69493d9e..d669569d18 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -797,72 +797,36 @@ InlVanilla. The WARN is just so I can see if it happens a lot. ************************************************************************ * * - The Very Simple Optimiser + The Simple Optimiser * * ************************************************************************ -Note [Getting the map/coerce RULE to work] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to allow the "map/coerce" RULE to fire: - - {-# RULES "map/coerce" map coerce = coerce #-} - -The naive core produced for this is - - forall a b (dict :: Coercible * a b). - map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' - - where dict' :: Coercible [a] [b] - dict' = ... - -This matches literal uses of `map coerce` in code, but that's not what we -want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) -too. Some of this is addressed by compulsorily unfolding coerce on the LHS, -yielding - - forall a b (dict :: Coercible * a b). - map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Getting better. But this isn't exactly what gets produced. This is because -Coercible essentially has ~R# as a superclass, and superclasses get eagerly -extracted during solving. So we get this: - - forall a b (dict :: Coercible * a b). - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Unfortunately, this still abstracts over a Coercible dictionary. We really -want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, -which transforms the above to (see also Note [Desugaring coerce as cast] in -Desugar) - - forall a b (co :: a ~R# b). - let dict = MkCoercible @* @a @b co in - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... - -Now, we need simpleOptExpr to fix this up. It does so by taking three -separate actions: - 1. Inline certain non-recursive bindings. The choice whether to inline - is made in maybe_substitute. Note the rather specific check for - MkCoercible in there. - - 2. Stripping case expressions like the Coercible_SCSel one. - See the `Case` case of simple_opt_expr's `go` function. - - 3. Look for case expressions that unpack something that was - just packed and inline them. This is also done in simple_opt_expr's - `go` function. - -This is all a fair amount of special-purpose hackery, but it's for -a good cause. And it won't hurt other RULES and such that it comes across. +Note [The simple optimiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simple optimiser is a lightweight, pure (non-monadic) function +that rapidly does a lot of simple optimisations, including + + - inlining things that occur just once, + or whose RHS turns out to be trivial + - beta reduction + - case of known constructor + - dead code elimination + +It does NOT do any call-site inlining; it only inlines a function if +it can do so unconditionally, dropping the binding. It thereby +guarantees to leave no un-reduced beta-redexes. + +It is careful to follow the guidance of "Secrets of the GHC inliner", +and in particular the pre-inline-unconditionally and +post-inline-unconditionally story, to do effective beta reduction on +functions called precisely once, without repeatedly optimising the same +expression. In fact, the simple optimiser is a good example of this +little dance in action; the full Simplifier is a lot more complicated. -} simpleOptExpr :: CoreExpr -> CoreExpr +-- See Note [The simple optimiser] -- Do simple optimisation on an expression -- The optimisation is very straightforward: just -- inline non-recursive bindings that are used only once, @@ -894,38 +858,94 @@ simpleOptExpr expr -- three passes instead of two (occ-anal, and go) simpleOptExprWith :: Subst -> InExpr -> OutExpr -simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr) +-- See Note [The simple optimiser] +simpleOptExprWith subst expr + = simple_opt_expr init_env (occurAnalyseExpr expr) + where + init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst } ---------------------- simpleOptPgm :: DynFlags -> Module -> CoreProgram -> [CoreRule] -> [CoreVect] -> IO (CoreProgram, [CoreRule], [CoreVect]) +-- See Note [The simple optimiser] simpleOptPgm dflags this_mod binds rules vects = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings occ_anald_binds $$ pprRules rules ); - ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) } + ; return (reverse binds', rules', vects') } where occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} rules vects emptyVarEnv binds - (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds - do_one (subst, binds') bind - = case simple_opt_bind subst bind of - (subst', Nothing) -> (subst', binds') - (subst', Just bind') -> (subst', bind':binds') + (final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds + final_subst = soe_subst final_env + + rules' = substRulesForImportedIds final_subst rules + vects' = substVects final_subst vects + -- We never unconditionally inline into rules, + -- hence pasing just a substitution + + do_one (env, binds') bind + = case simple_opt_bind env bind of + (env', Nothing) -> (env', binds') + (env', Just bind') -> (env', bind':binds') -- In these functions the substitution maps InVar -> OutExpr ---------------------- -simple_opt_expr :: Subst -> InExpr -> OutExpr -simple_opt_expr subst expr +type SimpleClo = (SimpleOptEnv, InExpr) + +data SimpleOptEnv + = SOE { soe_inl :: IdEnv SimpleClo + -- Deals with preInlineUnconditionally; things + -- that occur exactly once and are inlined + -- without having first been simplified + + , soe_subst :: Subst + -- Deals with cloning; includes the InScopeSet + } + +instance Outputable SimpleOptEnv where + ppr (SOE { soe_inl = inl, soe_subst = subst }) + = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl + , text "soe_subst =" <+> ppr subst ] + <+> text "}" + +emptyEnv :: SimpleOptEnv +emptyEnv = SOE { soe_inl = emptyVarEnv + , soe_subst = emptySubst } + +soeZapSubst :: SimpleOptEnv -> SimpleOptEnv +soeZapSubst (SOE { soe_subst = subst }) + = SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } + +soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv +-- Take in-scope set from env1, and the rest from env2 +soeSetInScope (SOE { soe_subst = subst1 }) + env2@(SOE { soe_subst = subst2 }) + = env2 { soe_subst = setInScope subst2 (substInScope subst1) } + +--------------- +simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr +simple_opt_clo env (e_env, e) + = simple_opt_expr (soeSetInScope env e_env) e + +simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr env expr = go expr where - in_scope_env = (substInScope subst, simpleUnfoldingFun) + subst = soe_subst env + in_scope = substInScope subst + in_scope_env = (in_scope, simpleUnfoldingFun) + + go (Var v) + | Just clo <- lookupVarEnv (soe_inl env) v + = simple_opt_clo env clo + | otherwise + = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v - go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v - go (App e1 e2) = simple_app subst e1 [go e2] + go (App e1 e2) = simple_app env e1 [(env,e2)] go (Type ty) = Type (substTy subst ty) go (Coercion co) = Coercion (optCoercion (getTCvSubst subst) co) go (Lit lit) = Lit lit @@ -935,11 +955,11 @@ simple_opt_expr subst expr where co' = optCoercion (getTCvSubst subst) co - go (Let bind body) = case simple_opt_bind subst bind of - (subst', Nothing) -> simple_opt_expr subst' body - (subst', Just bind) -> Let bind (simple_opt_expr subst' body) + go (Let bind body) = case simple_opt_bind env bind of + (env', Nothing) -> simple_opt_expr env' body + (env', Just bind) -> Let bind (simple_opt_expr env' body) - go lam@(Lam {}) = go_lam [] subst lam + go lam@(Lam {}) = go_lam env [] lam go (Case e b ty as) -- See Note [Getting the map/coerce RULE to work] | isDeadBinder b @@ -947,9 +967,10 @@ simple_opt_expr subst expr , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as = case altcon of DEFAULT -> go rhs - _ -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs - where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst - (zipEqual "simpleOptExpr" bs es) + _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs + where + (env', mb_prs) = mapAccumL simple_out_bind env $ + zipEqual "simpleOptExpr" bs es -- Note [Getting the map/coerce RULE to work] | isDeadBinder b @@ -962,78 +983,94 @@ simple_opt_expr subst expr | otherwise = Case e' b' (substTy subst ty) - (map (go_alt subst') as) - where - e' = go e - (subst', b') = subst_opt_bndr subst b + (map (go_alt env') as) + where + e' = go e + (env', b') = subst_opt_bndr env b ---------------------- - go_alt subst (con, bndrs, rhs) - = (con, bndrs', simple_opt_expr subst' rhs) + go_alt env (con, bndrs, rhs) + = (con, bndrs', simple_opt_expr env' rhs) where - (subst', bndrs') = subst_opt_bndrs subst bndrs + (env', bndrs') = subst_opt_bndrs env bndrs ---------------------- -- go_lam tries eta reduction - go_lam bs' subst (Lam b e) - = go_lam (b':bs') subst' e + go_lam env bs' (Lam b e) + = go_lam env' (b':bs') e where - (subst', b') = subst_opt_bndr subst b - go_lam bs' subst e + (env', b') = subst_opt_bndr env b + go_lam env bs' e | Just etad_e <- tryEtaReduce bs e' = etad_e | otherwise = mkLams bs e' where bs = reverse bs' - e' = simple_opt_expr subst e + e' = simple_opt_expr env e ---------------------- -- simple_app collects arguments for beta reduction -simple_app :: Subst -> InExpr -> [OutExpr] -> CoreExpr -simple_app subst (App e1 e2) as - = simple_app subst e1 (simple_opt_expr subst e2 : as) -simple_app subst (Lam b e) (a:as) - = case maybe_substitute subst b a of - Just ext_subst -> simple_app ext_subst e as - Nothing -> Let (NonRec b2 a) (simple_app subst' e as) - where - (subst', b') = subst_opt_bndr subst b - b2 = add_info subst' b b' -simple_app subst (Var v) as - | isCompulsoryUnfolding (idUnfolding v) +simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr + +simple_app env (Var v) as + | Just (env', e) <- lookupVarEnv (soe_inl env) v + = simple_app (soeSetInScope env env') e as + + | let unf = idUnfolding v + , isCompulsoryUnfolding (idUnfolding v) , isAlwaysActive (idInlineActivation v) - -- See Note [Unfold compulsory unfoldings in LHSs] - = simple_app subst (unfoldingTemplate (idUnfolding v)) as -simple_app subst (Tick t e) as + -- See Note [Unfold compulsory unfoldings in LHSs] + = simple_app (soeZapSubst env) (unfoldingTemplate unf) as + + | otherwise + , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v + = finish_app env out_fn as + +simple_app env (App e1 e2) as + = simple_app env e1 ((env, e2) : as) + +simple_app env (Lam b e) (a:as) + = wrapLet mb_pr (simple_app env' e as) + where + (env', mb_pr) = simple_bind_pair env b Nothing a + +simple_app env (Tick t e) as -- Okay to do "(Tick t e) x ==> Tick t (e x)"? | t `tickishScopesLike` SoftScope - = mkTick t $ simple_app subst e as -simple_app subst e as - = foldl App (simple_opt_expr subst e) as + = mkTick t $ simple_app env e as ----------------------- -simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind) -simple_opt_bind s b -- Can add trace stuff here - = simple_opt_bind' s b +simple_app env e as + = finish_app env (simple_opt_expr env e) as -simple_opt_bind' subst (Rec prs) - = (subst'', res_bind) - where - res_bind = Just (Rec (reverse rev_prs')) - prs' = map (uncurry convert_if_marked) prs - (subst', bndrs') = subst_opt_bndrs subst (map fst prs') - (subst'', rev_prs') = foldl do_pr (subst', []) (prs' `zip` bndrs') - do_pr (subst, prs) ((b,r), b') - = case maybe_substitute subst b r2 of - Just subst' -> (subst', prs) - Nothing -> (subst, (b2,r2):prs) - where - b2 = add_info subst b b' - r2 = simple_opt_expr subst r +finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr +finish_app _ fun [] + = fun +finish_app env fun (arg:args) + = finish_app env (App fun (simple_opt_clo env arg)) args -simple_opt_bind' subst (NonRec b r) - = simple_opt_out_bind subst (b', simple_opt_expr subst r') +---------------------- +simple_opt_bind :: SimpleOptEnv -> InBind + -> (SimpleOptEnv, Maybe OutBind) +simple_opt_bind env (NonRec b r) + = (env', case mb_pr of + Nothing -> Nothing + Just (b,r) -> Just (NonRec b r)) where (b', r') = convert_if_marked b r + (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') + +simple_opt_bind env (Rec prs) + = (env'', res_bind) + where + res_bind = Just (Rec (reverse rev_prs')) + prs' = map (uncurry convert_if_marked) prs + (env', bndrs') = subst_opt_bndrs env (map fst prs') + (env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs') + do_pr (env, prs) ((b,r), b') + = (env', case mb_pr of + Just pr -> pr : prs + Nothing -> prs) + where + (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) convert_if_marked :: InVar -> InExpr -> (InVar, InExpr) convert_if_marked bndr rhs @@ -1047,73 +1084,138 @@ convert_if_marked bndr rhs = (bndr, rhs) ---------------------- -simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind) -simple_opt_out_bind subst (b, r') - | Just ext_subst <- maybe_substitute subst b r' - = (ext_subst, Nothing) - | otherwise - = (subst', Just (NonRec b2 r')) - where - (subst', b') = subst_opt_bndr subst b - b2 = add_info subst' b b' - ----------------------- -maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst - -- (maybe_substitute subst in_var out_rhs) +simple_bind_pair :: SimpleOptEnv + -> InVar -> Maybe OutVar + -> SimpleClo + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) + -- (simple_bind_pair subst in_var out_rhs) -- either extends subst with (in_var -> out_rhs) -- or returns Nothing -maybe_substitute subst b r - | Type ty <- r -- let a::* = TYPE ty in <body> - = ASSERT( isTyVar b ) - Just (extendTvSubst subst b ty) - - | Coercion co <- r - = ASSERT( isCoVar b ) - Just (extendCvSubst subst b co) - - | isId b -- let x = e in <body> - , not (isCoVar b) -- See Note [Do not inline CoVars unconditionally] - -- in SimplUtils - , safe_to_inline (idOccInfo b) - , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] - , not (isStableUnfolding (idUnfolding b)) - , not (isExportedId b) - , let id_ty = idType b - -- A levity-polymorphic id? Impossible you say? - -- See Note [Levity polymorphism invariants] in CoreSyn - -- Ah, but it *is* possible in the compulsory unfolding of unsafeCoerce# - -- This check prevents the isUnliftedType check from panicking. - , isTypeLevPoly id_ty || not (isUnliftedType (idType b)) || exprOkForSpeculation r - = Just (extendIdSubst subst b r) +simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) + in_bndr mb_out_bndr clo@(rhs_env, in_rhs) + | Type ty <- in_rhs -- let a::* = TYPE ty in <body> + , let out_ty = substTy (soe_subst rhs_env) ty + = ASSERT( isTyVar in_bndr ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion co <- in_rhs + , let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | pre_inline_unconditionally + = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) | otherwise - = Nothing + = simple_out_bind_pair env in_bndr mb_out_bndr + (simple_opt_clo env clo) + occ active stable_unf where + stable_unf = isStableUnfolding (idUnfolding in_bndr) + active = isAlwaysActive (idInlineActivation in_bndr) + occ = idOccInfo in_bndr + + pre_inline_unconditionally :: Bool + pre_inline_unconditionally + | isCoVar in_bndr = False -- See Note [Do not inline CoVars unconditionally] + | isExportedId in_bndr = False -- in SimplUtils + | stable_unf = False + | not active = False -- Note [Inline prag in simplOpt] + | not (safe_to_inline occ) = False + | otherwise = True + -- Unconditionally safe to inline safe_to_inline :: OccInfo -> Bool - safe_to_inline (IAmALoopBreaker {}) = False - safe_to_inline IAmDead = True - safe_to_inline occ@(OneOcc {}) = (not (occ_in_lam occ) && - occ_one_br occ) - || trivial - safe_to_inline (ManyOccs {}) = trivial - - trivial | exprIsTrivial r = True - | (Var fun, args) <- collectArgs r - , Just dc <- isDataConWorkId_maybe fun - , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey - , all exprIsTrivial args = True - -- See Note [Getting the map/coerce RULE to work] - | otherwise = False + safe_to_inline (IAmALoopBreaker {}) = False + safe_to_inline IAmDead = True + safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ) + && occ_one_br occ + safe_to_inline (ManyOccs {}) = False + +------------------- +simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr) + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) + | Type out_ty <- out_rhs + = ASSERT( isTyVar in_bndr ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion out_co <- out_rhs + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr Nothing out_rhs + (idOccInfo in_bndr) True False + +------------------- +simple_out_bind_pair :: SimpleOptEnv + -> InId -> Maybe OutId -> OutExpr + -> OccInfo -> Bool -> Bool + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ_info active stable_unf + | post_inline_unconditionally + = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } + , Nothing) + + | otherwise + = ( env', Just (out_bndr, out_rhs) ) + where + (env', bndr1) = case mb_out_bndr of + Just out_bndr -> (env, out_bndr) + Nothing -> subst_opt_bndr env in_bndr + out_bndr = add_info env' in_bndr bndr1 + + post_inline_unconditionally :: Bool + post_inline_unconditionally + | not active = False + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] + | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] + | exprIsTrivial out_rhs = True + | coercible_hack = True + | otherwise = False + + -- See Note [Getting the map/coerce RULE to work] + coercible_hack | (Var fun, args) <- collectArgs out_rhs + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey + = all exprIsTrivial args + | otherwise + = False + +{- Note [Exported Ids and trivial RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously do no want to unconditinally inline an Id that is exported. +In SimplUtils, Note [Top level and postInlineUnconditionally], we +explain why we don't inline /any/ top-level things unconditionally, even +trivial ones. But we do here! Why? In the simple optimiser + + * We do no rule rewrites + * We do no call-site inlining + +Those differences obviate the reasons for not inlining a trivial rhs, +and increase the benefit for doing so. So we unconditaionlly inline trivial +rhss here. +-} ---------------------- -subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar) -subst_opt_bndr subst bndr - | isTyVar bndr = substTyVarBndr subst bndr - | isCoVar bndr = substCoVarBndr subst bndr - | otherwise = subst_opt_id_bndr subst bndr +subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) +subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs + +subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) +subst_opt_bndr env bndr + | isTyVar bndr = (env { soe_subst = subst_tv }, tv') + | isCoVar bndr = (env { soe_subst = subst_cv }, cv') + | otherwise = subst_opt_id_bndr env bndr + where + subst = soe_subst env + (subst_tv, tv') = substTyVarBndr subst bndr + (subst_cv, cv') = substCoVarBndr subst bndr -subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId) +subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) -- Nuke all fragile IdInfo, unfolding, and RULES; -- it gets added back later by add_info -- Rather like SimplEnv.substIdBndr @@ -1121,9 +1223,11 @@ subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId) -- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr -- carefully does not do) because simplOptExpr invalidates it -subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id - = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id) +subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id + = (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id) where + Subst in_scope id_subst tv_subst cv_subst = subst + id1 = uniqAway in_scope old_id id2 = setIdType id1 (substTy subst (idType old_id)) new_id = zapFragileIdInfo id2 @@ -1132,25 +1236,24 @@ subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id new_in_scope = in_scope `extendInScopeSet` new_id + no_change = new_id == old_id + -- Extend the substitution if the unique has changed, - -- or there's some useful occurrence information -- See the notes with substTyVarBndr for the delSubstEnv - new_id_subst | new_id /= old_id - = extendVarEnv id_subst old_id (Var new_id) - | otherwise - = delVarEnv id_subst old_id + new_id_subst + | no_change = delVarEnv id_subst old_id + | otherwise = extendVarEnv id_subst old_id (Var new_id) ----------------------- -subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar]) -subst_opt_bndrs subst bndrs - = mapAccumL subst_opt_bndr subst bndrs + new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst + new_inl = delVarEnv inl old_id ---------------------- -add_info :: Subst -> InVar -> OutVar -> OutVar -add_info subst old_bndr new_bndr +add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar +add_info env old_bndr new_bndr | isTyVar old_bndr = new_bndr | otherwise = maybeModifyIdInfo mb_new_info new_bndr where + subst = soe_subst env mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) simpleUnfoldingFun :: IdUnfoldingFun @@ -1158,6 +1261,10 @@ simpleUnfoldingFun id | isAlwaysActive (idInlineActivation id) = idUnfolding id | otherwise = noUnfolding +wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr +wrapLet Nothing body = body +wrapLet (Just (b,r)) body = Let (NonRec b r) body + {- Note [Inline prag in simplOpt] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1190,6 +1297,65 @@ However, we don't want to inline 'seq', which happens to also have a compulsory unfolding, so we only do this unfolding only for things that are always-active. See Note [User-defined RULES for seq] in MkId. +Note [Getting the map/coerce RULE to work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to allow the "map/coerce" RULE to fire: + + {-# RULES "map/coerce" map coerce = coerce #-} + +The naive core produced for this is + + forall a b (dict :: Coercible * a b). + map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' + + where dict' :: Coercible [a] [b] + dict' = ... + +This matches literal uses of `map coerce` in code, but that's not what we +want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) +too. Some of this is addressed by compulsorily unfolding coerce on the LHS, +yielding + + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Getting better. But this isn't exactly what gets produced. This is because +Coercible essentially has ~R# as a superclass, and superclasses get eagerly +extracted during solving. So we get this: + + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Unfortunately, this still abstracts over a Coercible dictionary. We really +want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, +which transforms the above to (see also Note [Desugaring coerce as cast] in +Desugar) + + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + +Now, we need simpleOptExpr to fix this up. It does so by taking three +separate actions: + 1. Inline certain non-recursive bindings. The choice whether to inline + is made in simple_bind_pair. Note the rather specific check for + MkCoercible in there. + + 2. Stripping case expressions like the Coercible_SCSel one. + See the `Case` case of simple_opt_expr's `go` function. + + 3. Look for case expressions that unpack something that was + just packed and inline them. This is also done in simple_opt_expr's + `go` function. + +This is all a fair amount of special-purpose hackery, but it's for +a good cause. And it won't hurt other RULES and such that it comes across. + ************************************************************************ * * |