From a7dbafe9292212f3cbc21be42eb326ab0701db7e Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 17 Mar 2017 16:25:41 +0000 Subject: [PATCH] No join-point from an INLINE function with wrong arity The main payload of this patch is NOT to make a join-point from a function with an INLINE pragma and the wrong arity; see Note [Join points and INLINE pragmas] in CoreOpt. This is what caused Trac #13413. But we must do the exact same thing in simpleOptExpr, which drove me to the following refactoring: * Move simpleOptExpr and simpleOptPgm from CoreSubst to a new module CoreOpt along with a few others (exprIsConApp_maybe, pushCoArg, etc) This eliminates a module loop altogether (delete CoreArity.hs-boot), and stops CoreSubst getting too huge. * Rename Simplify.matchOrConvertToJoinPoint to joinPointBinding_maybe Move it to the new CoreOpt Use it in simpleOptExpr as well as in Simplify * Define CoreArity.joinRhsArity and use it --- compiler/coreSyn/CoreArity.hs | 13 +- compiler/coreSyn/CoreArity.hs-boot | 6 - compiler/coreSyn/CoreOpt.hs | 1176 +++++++++++++++++ compiler/coreSyn/CoreSubst.hs | 1084 +-------------- compiler/coreSyn/CoreSyn.hs | 5 + compiler/coreSyn/CoreUnfold.hs | 2 +- compiler/deSugar/Desugar.hs | 4 +- compiler/deSugar/DsBinds.hs | 2 +- compiler/ghc.cabal.in | 1 + compiler/ghc.mk | 1 + compiler/main/GhcPlugins.hs | 3 +- compiler/prelude/PrelRules.hs | 2 +- compiler/simplCore/Simplify.hs | 30 +- compiler/specialise/Rules.hs | 1 + compiler/specialise/Specialise.hs | 3 +- .../tests/simplCore/should_compile/T13413.hs | 19 + .../tests/simplCore/should_compile/all.T | 1 + 17 files changed, 1231 insertions(+), 1122 deletions(-) delete mode 100644 compiler/coreSyn/CoreArity.hs-boot create mode 100644 compiler/coreSyn/CoreOpt.hs create mode 100644 testsuite/tests/simplCore/should_compile/T13413.hs diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index 49f58c66ae..88c3a7abaf 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -10,9 +10,10 @@ -- | Arity and eta expansion module CoreArity ( - manifestArity, exprArity, typeArity, exprBotStrictness_maybe, + manifestArity, joinRhsArity, exprArity, typeArity, exprEtaExpandArity, findRhsArity, CheapFun, etaExpand, - etaExpandToJoinPoint, etaExpandToJoinPointRule + etaExpandToJoinPoint, etaExpandToJoinPointRule, + exprBotStrictness_maybe ) where #include "HsVersions.h" @@ -77,6 +78,14 @@ manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e manifestArity (Cast e _) = manifestArity e manifestArity _ = 0 +joinRhsArity :: CoreExpr -> JoinArity +-- Join points are supposed to have manifestly-visible +-- lambdas at the top: no ticks, no casts, nothing +-- Moreover, type lambdas count in JoinArity +joinRhsArity (Lam _ e) = 1 + joinRhsArity e +joinRhsArity _ = 0 + + --------------- exprArity :: CoreExpr -> Arity -- ^ An approximate, fast, version of 'exprEtaExpandArity' diff --git a/compiler/coreSyn/CoreArity.hs-boot b/compiler/coreSyn/CoreArity.hs-boot deleted file mode 100644 index 4c155daa9c..0000000000 --- a/compiler/coreSyn/CoreArity.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module CoreArity where - -import BasicTypes -import CoreSyn - -etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs new file mode 100644 index 0000000000..98a590bb3d --- /dev/null +++ b/compiler/coreSyn/CoreOpt.hs @@ -0,0 +1,1176 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +module CoreOpt ( + -- ** Simple expression optimiser + simpleOptPgm, simpleOptExpr, simpleOptExprWith, + + -- ** Join points + joinPointBinding_maybe, joinPointBindings_maybe, + + -- ** Predicates on expressions + exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, + + -- ** Coercions and casts + pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo + ) where + +#include "HsVersions.h" + +import CoreArity( joinRhsArity, etaExpandToJoinPoint ) + +import CoreSyn +import CoreSubst +import CoreUtils +import CoreFVs +import PprCore ( pprCoreBindings, pprRules ) +import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) +import Literal ( Literal(MachStr) ) +import Id +import Var ( varType ) +import VarSet +import VarEnv +import DataCon +import OptCoercion ( optCoercion ) +import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substCo, substCoVarBndr ) +import TyCon ( tyConArity ) +import TysWiredIn +import PrelNames +import BasicTypes +import Module ( Module ) +import ErrUtils +import DynFlags +import Outputable +import Pair +import Util +import Maybes ( orElse ) +import FastString +import Data.List +import qualified Data.ByteString as BS + +{- +************************************************************************ +* * + The Simple Optimiser +* * +************************************************************************ + +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, +-- or where the RHS is trivial +-- +-- We also inline bindings that bind a Eq# box: see +-- See Note [Getting the map/coerce RULE to work]. +-- +-- Also we convert functions to join points where possible (as +-- the occurrence analyser does most of the work anyway). +-- +-- The result is NOT guaranteed occurrence-analysed, because +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically + +simpleOptExpr expr + = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) + simpleOptExprWith init_subst expr + where + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + -- It's potentially important to make a proper in-scope set + -- Consider let x = ..y.. in \y. ...x... + -- Then we should remember to clone y before substituting + -- for x. It's very unlikely to occur, because we probably + -- won't *be* substituting for x if it occurs inside a + -- lambda. + -- + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + +simpleOptExprWith :: Subst -> InExpr -> OutExpr +-- 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', rules', vects') } + where + occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} + rules vects emptyVarSet 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 + +---------------------- +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 + 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 (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 + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) | isReflCo co' = go e + | otherwise = Cast (go e) co' + where + co' = optCoercion (getTCvSubst subst) co + + 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 env [] lam + go (Case e b ty as) + -- See Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as + = case altcon of + DEFAULT -> go rhs + _ -> 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 + , [(DEFAULT, _, rhs)] <- as + , isCoercionType (varType b) + , (Var fun, _args) <- collectArgs e + , fun `hasKey` coercibleSCSelIdKey + -- without this last check, we get #11230 + = go rhs + + | otherwise + = Case e' b' (substTy subst ty) + (map (go_alt env') as) + where + e' = go e + (env', b') = subst_opt_bndr env b + + ---------------------- + go_alt env (con, bndrs, rhs) + = (con, bndrs', simple_opt_expr env' rhs) + where + (env', bndrs') = subst_opt_bndrs env bndrs + + ---------------------- + -- go_lam tries eta reduction + go_lam env bs' (Lam b e) + = go_lam env' (b':bs') e + where + (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 env e + +---------------------- +-- simple_app collects arguments for beta reduction +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 (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 env e as + +simple_app env e as + = finish_app env (simple_opt_expr env e) as + +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 :: 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') = joinPointBinding_maybe b r `orElse` (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' = joinPointBindings_maybe prs `orElse` 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) + +---------------------- +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 +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 + , 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 + = 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 + 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 not want to unconditionally 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 unconditionally inline trivial +rhss here. +-} + +---------------------- +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 :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) +-- Nuke all fragile IdInfo, unfolding, and RULES; +-- it gets added back later by add_info +-- Rather like SimplEnv.substIdBndr +-- +-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr +-- carefully does not do) because simplOptExpr invalidates it + +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 + -- Zaps rules, worker-info, unfolding, and fragile OccInfo + -- The unfolding and rules will get added back later, by add_info + + new_in_scope = in_scope `extendInScopeSet` new_id + + no_change = new_id == old_id + + -- Extend the substitution if the unique has changed, + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst + | no_change = delVarEnv id_subst old_id + | otherwise = extendVarEnv id_subst old_id (Var new_id) + + new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst + new_inl = delVarEnv inl old_id + +---------------------- +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 +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 + +------------------ +substVects :: Subst -> [CoreVect] -> [CoreVect] +substVects subst = map (substVect subst) + +------------------ +substVect :: Subst -> CoreVect -> CoreVect +substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs) +substVect _subst vd@(NoVect _) = vd +substVect _subst vd@(VectType _ _ _) = vd +substVect _subst vd@(VectClass _) = vd +substVect _subst vd@(VectInst _) = vd + +{- +Note [Inline prag in simplOpt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there's an INLINE/NOINLINE pragma that restricts the phase in +which the binder can be inlined, we don't inline here; after all, +we don't know what phase we're in. Here's an example + + foo :: Int -> Int -> Int + {-# INLINE foo #-} + foo m n = inner m + where + {-# INLINE [1] inner #-} + inner m = m+n + + bar :: Int -> Int + bar n = foo n 1 + +When inlining 'foo' in 'bar' we want the let-binding for 'inner' +to remain visible until Phase 1 + +Note [Unfold compulsory unfoldings in LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user writes `RULES map coerce = coerce` as a rule, the rule +will only ever match if simpleOptExpr replaces coerce by its unfolding +on the LHS, because that is the core that the rule matching engine +will find. So do that for everything that has a compulsory +unfolding. Also see Note [Desugaring coerce as cast] in Desugar. + +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. + + +************************************************************************ +* * + Join points +* * +************************************************************************ +-} + +-- | Returns Just (bndr,rhs) if the binding is a join point: +-- If it's a JoinId, just return it +-- If it's not yet a JoinId but is always tail-called, +-- make it into a JoinId and return it. +-- In the latter case, eta-expand the RHS if necessary, to make the +-- lambdas explicit, as is required for join points +-- +-- Precondition: the InBndr has been occurrence-analysed, +-- so its OccInfo is valid +joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) +joinPointBinding_maybe bndr rhs + | not (isId bndr) + = Nothing + + | isJoinId bndr + = Just (bndr, rhs) + + | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) + , not (bad_unfolding join_arity (idUnfolding bndr)) + , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs + = Just (bndr `asJoinId` join_arity, mkLams bndrs body) + + | otherwise + = Nothing + + where + -- bad_unfolding returns True if we should /not/ convert a non-join-id + -- into a join-id, even though it is AlwaysTailCalled + -- See Note [Join points and INLINE pragmas] + bad_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) + = isStableSource src && join_arity > joinRhsArity rhs + bad_unfolding _ (DFunUnfolding {}) + = True + bad_unfolding _ _ + = False + +joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] +joinPointBindings_maybe bndrs + = mapM (uncurry joinPointBinding_maybe) bndrs + + +{- Note [Join points and INLINE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let g = \x. not -- Arity 1 + {-# INLINE g #-} + in case x of + A -> g True True + B -> g True False + C -> blah2 + +Here 'g' is always tail-called applied to 2 args, but the stable +unfolding captured by the INLINE pragma has arity 1. If we try to +convert g to be a join point, its unfolding will still have arity 1 +(since it is stable, and we don't meddle with stable unfoldings), and +Lint will complain (see Note [Invariants on join points], (2a), in +CoreSyn. Trac #13413. + +Moreover, since g is going to be inlined anyway, there is no benefit +from making it a join point. + +If it is recursive, and uselessly marked INLINE, this will stop us +making it a join point, which is a annoying. But occasionally +(notably in class methods; see Note [Instances and loop breakers] in +TcInstDcls) we mark recurive things as INLINE but the recursion +unravels; so ignoring INLINE pragmas on recursive things isn't good +either. + + +************************************************************************ +* * + exprIsConApp_maybe +* * +************************************************************************ + +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if + + +Note [exprIsConApp_maybe on literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #9400 and #13317. + +Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core +they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or +unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. + +For optimizations we want to be able to treat it as a list, so they can be +decomposed when used in a case-statement. exprIsConApp_maybe detects those +calls to unpackCString# and returns: + +Just (':', [Char], ['a', unpackCString# "bc"]). + +We need to be careful about UTF8 strings here. ""# contains a ByteString, so +we must parse it back into a FastString to split off the first character. +That way we can treat unpackCString# and unpackCStringUtf8# in the same way. + +We must also be caeful about + lvl = "foo"# + ...(unpackCString# lvl)... +to ensure that we see through the let-binding for 'lvl'. Hence the +(exprIsLiteral_maybe .. arg) in the guard before the call to +dealWithStringLiteral. + +Note [Push coercions in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Trac #13025 I found a case where we had + op (df @t1 @t2) -- op is a ClassOp +where + df = (/\a b. K e1 e2) |> g + +To get this to come out we need to simplify on the fly + ((/\a b. K e1 e2) |> g) @t1 @t2 + +Hence the use of pushCoArgs. +-} + +data ConCont = CC [CoreExpr] Coercion + -- Substitution already applied + +-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is +-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, +-- where t1..tk are the *universally-qantified* type args of 'dc' +exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr))) + where + go :: Either InScopeSet Subst + -- Left in-scope means "empty substitution" + -- Right subst means "apply this substitution to the CoreExpr" + -> CoreExpr -> ConCont + -> Maybe (DataCon, [Type], [CoreExpr]) + go subst (Tick t expr) cont + | not (tickishIsCode t) = go subst expr cont + go subst (Cast expr co1) (CC args co2) + | Just (args', co1') <- pushCoArgs (subst_co subst co1) args + -- See Note [Push coercions in exprIsConApp_maybe] + = go subst expr (CC args' (co1' `mkTransCo` co2)) + go subst (App fun arg) (CC args co) + = go subst fun (CC (subst_arg subst arg : args) co) + go subst (Lam var body) (CC (arg:args) co) + | exprIsTrivial arg -- Don't duplicate stuff! + = go (extend subst var arg) body (CC args co) + go (Right sub) (Var v) cont + = go (Left (substInScope sub)) + (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) + cont + + go (Left in_scope) (Var fun) cont@(CC args co) + + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + = pushCoDataCon con args co + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let subst = mkOpenSubst in_scope (bndrs `zip` args) + = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co + + -- Look through unfoldings, but only arity-zero one; + -- if arity > 0 we are effectively inlining a function call, + -- and that is the business of callSiteInline. + -- In practice, without this test, most of the "hits" were + -- CPR'd workers getting inlined back into their wrappers, + | idArity fun == 0 + , Just rhs <- expandUnfolding_maybe unfolding + , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) + = go (Left in_scope') rhs cont + + -- See Note [exprIsConApp_maybe on literal strings] + | (fun `hasKey` unpackCStringIdKey) || + (fun `hasKey` unpackCStringUtf8IdKey) + , [arg] <- args + , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg + = dealWithStringLiteral fun str co + where + unfolding = id_unf fun + + go _ _ _ = Nothing + + ---------------------------- + -- Operations on the (Either InScopeSet CoreSubst) + -- The Left case is wildly dominant + subst_co (Left {}) co = co + subst_co (Right s) co = CoreSubst.substCo s co + + subst_arg (Left {}) e = e + subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e + + extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) + extend (Right s) v e = Right (extendSubst s v e) + + +-- See Note [exprIsConApp_maybe on literal strings] +dealWithStringLiteral :: Var -> BS.ByteString -> Coercion + -> Maybe (DataCon, [Type], [CoreExpr]) + +-- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS +-- turns those into [] automatically, but just in case something else in GHC +-- generates a string literal directly. +dealWithStringLiteral _ str co + | BS.null str + = pushCoDataCon nilDataCon [Type charTy] co + +dealWithStringLiteral fun str co + = let strFS = mkFastStringByteString str + + char = mkConApp charDataCon [mkCharLit (headFS strFS)] + charTail = fastStringToByteString (tailFS strFS) + + -- In singleton strings, just add [] instead of unpackCstring# ""#. + rest = if BS.null charTail + then mkConApp nilDataCon [Type charTy] + else App (Var fun) + (Lit (MachStr charTail)) + + in pushCoDataCon consDataCon [Type charTy, char, rest] co + +{- +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + +Note [DFun arity check] +~~~~~~~~~~~~~~~~~~~~~~~ +Here we check that the total number of supplied arguments (inclding +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn +-} + +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal +-- Same deal as exprIsConApp_maybe, but much simpler +-- Nevertheless we do need to look through unfoldings for +-- Integer and string literals, which are vigorously hoisted to top level +-- and not subsequently inlined +exprIsLiteral_maybe env@(_, id_unf) e + = case e of + Lit l -> Just l + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? + Var v | Just rhs <- expandUnfolding_maybe (id_unf v) + -> exprIsLiteral_maybe env rhs + _ -> Nothing + +{- +Note [exprIsLambda_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsLambda_maybe will, given an expression `e`, try to turn it into the form +`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through +casts (using the Push rule), and it unfolds function calls if the unfolding +has a greater arity than arguments are present. + +Currently, it is used in Rules.match, and is required to make +"map coerce = coerce" match. +-} + +exprIsLambda_maybe :: InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[Tickish Id]) + -- See Note [exprIsLambda_maybe] + +-- The simple case: It is a lambda already +exprIsLambda_maybe _ (Lam x e) + = Just (x, e, []) + +-- Still straightforward: Ticks that we can float out of the way +exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) + | tickishFloatable t + , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + = Just (x, e, t:ts) + +-- Also possible: A casted lambda. Push the coercion inside +exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e + -- Only do value lambdas. + -- this implies that x is not in scope in gamma (makes this code simpler) + , not (isTyVar x) && not (isCoVar x) + , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co + , let res = Just (x',e',ts) + = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) + res + +-- Another attempt: See if we find a partial unfolding +exprIsLambda_maybe (in_scope_set, id_unf) e + | (Var f, as, ts) <- collectArgsTicks tickishFloatable e + , idArity f > count isValArg as + -- Make sure there is hope to get a lambda + , Just rhs <- expandUnfolding_maybe (id_unf f) + -- Optimize, for beta-reduction + , let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as) + -- Recurse, because of possible casts + , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , let res = Just (x', e'', ts++ts') + = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) + res + +exprIsLambda_maybe _ _e + = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) + Nothing + + +{- ********************************************************************* +* * + The "push rules" +* * +************************************************************************ + +Here we implement the "push rules" from FC papers: + +* The push-argument rules, where we can move a coercion past an argument. + We have + (fun |> co) arg + and we want to transform it to + (fun arg') |> co' + for some suitable co' and tranformed arg'. + +* The PushK rule for data constructors. We have + (K e1 .. en) |> co + and we want to tranform to + (K e1' .. en') + by pushing the coercion into the oarguments +-} + +pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion) +pushCoArgs co [] = return ([], co) +pushCoArgs co (arg:args) = do { (arg', co1) <- pushCoArg co arg + ; (args', co2) <- pushCoArgs co1 args + ; return (arg':args', co2) } + +pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion) +-- We have (fun |> co) arg, and we want to transform it to +-- (fun arg) |> co +-- This may fail, e.g. if (fun :: N) where N is a newtype +-- C.f. simplCast in Simplify.hs +-- 'co' is always Representational + +pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty + ; return (Type ty', co') } +pushCoArg co val_arg = do { (arg_co, co') <- pushCoValArg co + ; return (mkCast val_arg arg_co, co') } + +pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion) +-- We have (fun |> co) @ty +-- Push the coercion through to return +-- (fun @ty') |> co' +-- 'co' is always Representational +pushCoTyArg co ty + | tyL `eqType` tyR + = Just (ty, mkRepReflCo (piResultTy tyR ty)) + + | isForAllTy tyL + = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty ) + Just (ty `mkCastTy` mkSymCo co1, co2) + + | otherwise + = Nothing + where + Pair tyL tyR = coercionKind co + -- co :: tyL ~ tyR + -- tyL = forall (a1 :: k1). ty1 + -- tyR = forall (a2 :: k2). ty2 + + co1 = mkNthCo 0 co + -- co1 :: k1 ~ k2 + -- Note that NthCo can extract an equality between the kinds + -- of the types related by a coercion between forall-types. + -- See the NthCo case in CoreLint. + + co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1) + -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] + -- Arg of mkInstCo is always nominal, hence mkNomReflCo + +pushCoValArg :: Coercion -> Maybe (Coercion, Coercion) +-- We have (fun |> co) arg +-- Push the coercion through to return +-- (fun (arg |> co_arg)) |> co_res +-- 'co' is always Representational +pushCoValArg co + | tyL `eqType` tyR + = Just (mkRepReflCo arg, mkRepReflCo res) + + | isFunTy tyL + , (co1, co2) <- decomposeFunCo co + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) + -- then co1 :: tyL1 ~ tyR1 + -- co2 :: tyL2 ~ tyR2 + = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) + Just (mkSymCo co1, co2) + + | otherwise + = Nothing + where + (arg, res) = splitFunTy tyR + Pair tyL tyR = coercionKind co + +pushCoercionIntoLambda + :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr) +-- This implements the Push rule from the paper on coercions +-- (\x. e) |> co +-- ===> +-- (\x'. e |> co') +pushCoercionIntoLambda in_scope x e co + | ASSERT(not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind co + , Just (_s1,_s2) <- splitFunTy_maybe s1s2 + , Just (t1,_t2) <- splitFunTy_maybe t1t2 + = let (co1, co2) = decomposeFunCo co + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') co1) + in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2) + | otherwise + = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) + Nothing + +pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion + -> Maybe (DataCon + , [Type] -- Universal type args + , [CoreExpr]) -- All other args incl existentials +-- Implement the KPush reduction rule as described in "Down with kinds" +-- The transformation applies iff we have +-- (C e1 ... en) `cast` co +-- where co :: (T t1 .. tn) ~ to_ty +-- The left-hand one must be a T, because exprIsConApp returned True +-- but the right-hand one might not be. (Though it usually will.) +pushCoDataCon dc dc_args co + | isReflCo co || from_ty `eqType` to_ty -- try cheap test first + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, map exprToType univ_ty_args, rest_args) + + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there't nothing wrong with it + + = let + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tyvars = dataConExTyVars dc + arg_tys = dataConRepArgTys dc + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args + + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx Representational + dc_univ_tyvars + omegas + dc_ex_tyvars + (map exprToType ex_args) + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + + to_ex_args = map Type to_ex_arg_tys + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, + ppr arg_tys, ppr dc_args, + ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] + in + ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) + Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + + | otherwise + = Nothing + + where + Pair from_ty to_ty = coercionKind co + +collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) +-- Collect lambda binders, pushing coercions inside if possible +-- E.g. (\x.e) |> g g :: -> blah +-- = (\x. e |> Nth 1 g) +-- +-- That is, +-- +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) +collectBindersPushingCo e + = go [] e + where + -- Peel off lambdas until we hit a cast. + go :: [Var] -> CoreExpr -> ([Var], CoreExpr) + -- The accumulator is in reverse order + go bs (Lam b e) = go (b:bs) e + go bs (Cast e co) = go_c bs e co + go bs e = (reverse bs, e) + + -- We are in a cast; peel off casts until we hit a lambda. + go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr) + -- (go_c bs e c) is same as (go bs e (e |> c)) + go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) + go_c bs (Lam b e) co = go_lam bs b e co + go_c bs e co = (reverse bs, mkCast e co) + + -- We are in a lambda under a cast; peel off lambdas and build a + -- new coercion for the body. + go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr) + -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) + go_lam bs b e co + | isTyVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy tyL ) + isForAllTy tyR + , isReflCo (mkNthCo 0 co) -- See Note [collectBindersPushingCo] + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + + | isId b + , let Pair tyL tyR = coercionKind co + , ASSERT( isFunTy tyL) isFunTy tyR + , (co_arg, co_res) <- decomposeFunCo co + , isReflCo co_arg -- See Note [collectBindersPushingCo] + = go_c (b:bs) e co_res + + | otherwise = (reverse bs, mkCast (Lam b e) co) + +{- Note [collectBindersPushingCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We just look for coercions of form + -> blah +(and similarly for foralls) to keep this function simple. We could do +more elaborate stuff, but it'd involve substitution etc. +-} diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index f2485f3863..640c7f1170 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -17,40 +17,29 @@ module CoreSubst ( substTy, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, lookupTCvSubst, substIdOcc, - substTickish, substDVarSet, + substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, - isInScope, setInScope, + isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, delBndr, delBndrs, -- ** Substituting and cloning binders - substBndr, substBndrs, substRecBndrs, + substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, - -- ** Simple expression optimiser - simpleOptPgm, simpleOptExpr, simpleOptExprWith, - exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, - pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo ) where #include "HsVersions.h" -import {-# SOURCE #-} CoreArity ( etaExpandToJoinPoint ) - -- Needed for simpleOptPgm to convert bindings to join - -- points, but CoreArity uses substitutions throughout import CoreSyn import CoreFVs import CoreSeq import CoreUtils -import Literal ( Literal(MachStr) ) -import qualified Data.ByteString as BS -import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) - import qualified Type import qualified Coercion @@ -59,12 +48,7 @@ import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstLis , isInScope, substTyVarBndr, cloneTyVarBndr ) import Coercion hiding ( substCo, substCoVarBndr ) -import TyCon ( tyConArity ) -import DataCon import PrelNames -import OptCoercion ( optCoercion ) -import PprCore ( pprCoreBindings, pprRules ) -import Module ( Module ) import VarSet import VarEnv import Id @@ -73,18 +57,11 @@ import Var import IdInfo import UniqSupply import Maybes -import ErrUtils -import DynFlags -import BasicTypes ( isAlwaysActive ) import Util -import Pair import Outputable import PprCore () -- Instances -import FastString - import Data.List -import TysWiredIn {- @@ -723,18 +700,6 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args doc = text "subst-rule" <+> ppr fn_name (subst', bndrs') = substBndrs subst bndrs ------------------- -substVects :: Subst -> [CoreVect] -> [CoreVect] -substVects subst = map (substVect subst) - ------------------- -substVect :: Subst -> CoreVect -> CoreVect -substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs) -substVect _subst vd@(NoVect _) = vd -substVect _subst vd@(VectType _ _ _) = vd -substVect _subst vd@(VectClass _) = vd -substVect _subst vd@(VectInst _) = vd - ------------------ substDVarSet :: Subst -> DVarSet -> DVarSet substDVarSet subst fvs @@ -793,1048 +758,5 @@ analyser, so it's possible that the worker is not even in scope any more. In all all these cases we simply drop the special case, returning to InlVanilla. The WARN is just so I can see if it happens a lot. - - -************************************************************************ -* * - The Simple Optimiser -* * -************************************************************************ - -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, --- or where the RHS is trivial --- --- We also inline bindings that bind a Eq# box: see --- See Note [Getting the map/coerce RULE to work]. --- --- Also we convert functions to join points where possible (as --- the occurrence analyser does most of the work anyway). --- --- The result is NOT guaranteed occurrence-analysed, because --- in (let x = y in ....) we substitute for x; so y's occ-info --- may change radically - -simpleOptExpr expr - = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) - simpleOptExprWith init_subst expr - where - init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) - -- It's potentially important to make a proper in-scope set - -- Consider let x = ..y.. in \y. ...x... - -- Then we should remember to clone y before substituting - -- for x. It's very unlikely to occur, because we probably - -- won't *be* substituting for x if it occurs inside a - -- lambda. - -- - -- It's a bit painful to call exprFreeVars, because it makes - -- three passes instead of two (occ-anal, and go) - -simpleOptExprWith :: Subst -> InExpr -> OutExpr --- 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', rules', vects') } - where - occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} - rules vects emptyVarSet 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 - ----------------------- -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 - 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 (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 - go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) - go (Cast e co) | isReflCo co' = go e - | otherwise = Cast (go e) co' - where - co' = optCoercion (getTCvSubst subst) co - - 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 env [] lam - go (Case e b ty as) - -- See Note [Getting the map/coerce RULE to work] - | isDeadBinder b - , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' - , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as - = case altcon of - DEFAULT -> go rhs - _ -> 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 - , [(DEFAULT, _, rhs)] <- as - , isCoercionType (varType b) - , (Var fun, _args) <- collectArgs e - , fun `hasKey` coercibleSCSelIdKey - -- without this last check, we get #11230 - = go rhs - - | otherwise - = Case e' b' (substTy subst ty) - (map (go_alt env') as) - where - e' = go e - (env', b') = subst_opt_bndr env b - - ---------------------- - go_alt env (con, bndrs, rhs) - = (con, bndrs', simple_opt_expr env' rhs) - where - (env', bndrs') = subst_opt_bndrs env bndrs - - ---------------------- - -- go_lam tries eta reduction - go_lam env bs' (Lam b e) - = go_lam env' (b':bs') e - where - (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 env e - ----------------------- --- simple_app collects arguments for beta reduction -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 (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 env e as - -simple_app env e as - = finish_app env (simple_opt_expr env e) as - -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 :: 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 - | isId bndr - , AlwaysTailCalled ar <- tailCallInfo (idOccInfo bndr) - -- Marked to become a join point - , (bndrs, body) <- etaExpandToJoinPoint ar rhs - = -- Tail call info now unnecessary - (zapIdTailCallInfo (bndr `asJoinId` ar), mkLams bndrs body) - | otherwise - = (bndr, 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 -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 - , 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 - = 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 - 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 not want to unconditionally 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 unconditionally inline trivial -rhss here. --} - ----------------------- -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 :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) --- Nuke all fragile IdInfo, unfolding, and RULES; --- it gets added back later by add_info --- Rather like SimplEnv.substIdBndr --- --- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr --- carefully does not do) because simplOptExpr invalidates it - -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 - -- Zaps rules, worker-info, unfolding, and fragile OccInfo - -- The unfolding and rules will get added back later, by add_info - - new_in_scope = in_scope `extendInScopeSet` new_id - - no_change = new_id == old_id - - -- Extend the substitution if the unique has changed, - -- See the notes with substTyVarBndr for the delSubstEnv - new_id_subst - | no_change = delVarEnv id_subst old_id - | otherwise = extendVarEnv id_subst old_id (Var new_id) - - new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst - new_inl = delVarEnv inl old_id - ----------------------- -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 -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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If there's an INLINE/NOINLINE pragma that restricts the phase in -which the binder can be inlined, we don't inline here; after all, -we don't know what phase we're in. Here's an example - - foo :: Int -> Int -> Int - {-# INLINE foo #-} - foo m n = inner m - where - {-# INLINE [1] inner #-} - inner m = m+n - - bar :: Int -> Int - bar n = foo n 1 - -When inlining 'foo' in 'bar' we want the let-binding for 'inner' -to remain visible until Phase 1 - -Note [Unfold compulsory unfoldings in LHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user writes `RULES map coerce = coerce` as a rule, the rule -will only ever match if simpleOptExpr replaces coerce by its unfolding -on the LHS, because that is the core that the rule matching engine -will find. So do that for everything that has a compulsory -unfolding. Also see Note [Desugaring coerce as cast] in Desugar. - -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. - - -************************************************************************ -* * - exprIsConApp_maybe -* * -************************************************************************ - -Note [exprIsConApp_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~ -exprIsConApp_maybe is a very important function. There are two principal -uses: - * case e of { .... } - * cls_op e, where cls_op is a class operation - -In both cases you want to know if e is of form (C e1..en) where C is -a data constructor. - -However e might not *look* as if - - -Note [exprIsConApp_maybe on literal strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #9400 and #13317. - -Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core -they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or -unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. - -For optimizations we want to be able to treat it as a list, so they can be -decomposed when used in a case-statement. exprIsConApp_maybe detects those -calls to unpackCString# and returns: - -Just (':', [Char], ['a', unpackCString# "bc"]). - -We need to be careful about UTF8 strings here. ""# contains a ByteString, so -we must parse it back into a FastString to split off the first character. -That way we can treat unpackCString# and unpackCStringUtf8# in the same way. - -We must also be caeful about - lvl = "foo"# - ...(unpackCString# lvl)... -to ensure that we see through the let-binding for 'lvl'. Hence the -(exprIsLiteral_maybe .. arg) in the guard before the call to -dealWithStringLiteral. - -Note [Push coercions in exprIsConApp_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Trac #13025 I found a case where we had - op (df @t1 @t2) -- op is a ClassOp -where - df = (/\a b. K e1 e2) |> g - -To get this to come out we need to simplify on the fly - ((/\a b. K e1 e2) |> g) @t1 @t2 - -Hence the use of pushCoArgs. -} -data ConCont = CC [CoreExpr] Coercion - -- Substitution already applied - --- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is --- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, --- where t1..tk are the *universally-qantified* type args of 'dc' -exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe (in_scope, id_unf) expr - = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr))) - where - go :: Either InScopeSet Subst - -- Left in-scope means "empty substitution" - -- Right subst means "apply this substitution to the CoreExpr" - -> CoreExpr -> ConCont - -> Maybe (DataCon, [Type], [CoreExpr]) - go subst (Tick t expr) cont - | not (tickishIsCode t) = go subst expr cont - go subst (Cast expr co1) (CC args co2) - | Just (args', co1') <- pushCoArgs (subst_co subst co1) args - -- See Note [Push coercions in exprIsConApp_maybe] - = go subst expr (CC args' (co1' `mkTransCo` co2)) - go subst (App fun arg) (CC args co) - = go subst fun (CC (subst_arg subst arg : args) co) - go subst (Lam var body) (CC (arg:args) co) - | exprIsTrivial arg -- Don't duplicate stuff! - = go (extend subst var arg) body (CC args co) - go (Right sub) (Var v) cont - = go (Left (substInScope sub)) - (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) - cont - - go (Left in_scope) (Var fun) cont@(CC args co) - - | Just con <- isDataConWorkId_maybe fun - , count isValArg args == idArity fun - = pushCoDataCon con args co - - -- Look through dictionary functions; see Note [Unfolding DFuns] - | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding - , bndrs `equalLength` args -- See Note [DFun arity check] - , let subst = mkOpenSubst in_scope (bndrs `zip` args) - = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co - - -- Look through unfoldings, but only arity-zero one; - -- if arity > 0 we are effectively inlining a function call, - -- and that is the business of callSiteInline. - -- In practice, without this test, most of the "hits" were - -- CPR'd workers getting inlined back into their wrappers, - | idArity fun == 0 - , Just rhs <- expandUnfolding_maybe unfolding - , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) - = go (Left in_scope') rhs cont - - -- See Note [exprIsConApp_maybe on literal strings] - | (fun `hasKey` unpackCStringIdKey) || - (fun `hasKey` unpackCStringUtf8IdKey) - , [arg] <- args - , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg - = dealWithStringLiteral fun str co - where - unfolding = id_unf fun - - go _ _ _ = Nothing - - ---------------------------- - -- Operations on the (Either InScopeSet CoreSubst) - -- The Left case is wildly dominant - subst_co (Left {}) co = co - subst_co (Right s) co = CoreSubst.substCo s co - - subst_arg (Left {}) e = e - subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e - - extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) - extend (Right s) v e = Right (extendSubst s v e) - - --- See Note [exprIsConApp_maybe on literal strings] -dealWithStringLiteral :: Var -> BS.ByteString -> Coercion - -> Maybe (DataCon, [Type], [CoreExpr]) - --- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS --- turns those into [] automatically, but just in case something else in GHC --- generates a string literal directly. -dealWithStringLiteral _ str co - | BS.null str - = pushCoDataCon nilDataCon [Type charTy] co - -dealWithStringLiteral fun str co - = let strFS = mkFastStringByteString str - - char = mkConApp charDataCon [mkCharLit (headFS strFS)] - charTail = fastStringToByteString (tailFS strFS) - - -- In singleton strings, just add [] instead of unpackCstring# ""#. - rest = if BS.null charTail - then mkConApp nilDataCon [Type charTy] - else App (Var fun) - (Lit (MachStr charTail)) - - in pushCoDataCon consDataCon [Type charTy, char, rest] co - -{- -Note [Unfolding DFuns] -~~~~~~~~~~~~~~~~~~~~~~ -DFuns look like - - df :: forall a b. (Eq a, Eq b) -> Eq (a,b) - df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) - ($c2 a b d_a d_b) - -So to split it up we just need to apply the ops $c1, $c2 etc -to the very same args as the dfun. It takes a little more work -to compute the type arguments to the dictionary constructor. - -Note [DFun arity check] -~~~~~~~~~~~~~~~~~~~~~~~ -Here we check that the total number of supplied arguments (inclding -type args) matches what the dfun is expecting. This may be *less* -than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn --} - -exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal --- Same deal as exprIsConApp_maybe, but much simpler --- Nevertheless we do need to look through unfoldings for --- Integer and string literals, which are vigorously hoisted to top level --- and not subsequently inlined -exprIsLiteral_maybe env@(_, id_unf) e - = case e of - Lit l -> Just l - Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? - Var v | Just rhs <- expandUnfolding_maybe (id_unf v) - -> exprIsLiteral_maybe env rhs - _ -> Nothing - -{- -Note [exprIsLambda_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprIsLambda_maybe will, given an expression `e`, try to turn it into the form -`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through -casts (using the Push rule), and it unfolds function calls if the unfolding -has a greater arity than arguments are present. - -Currently, it is used in Rules.match, and is required to make -"map coerce = coerce" match. --} - -exprIsLambda_maybe :: InScopeEnv -> CoreExpr - -> Maybe (Var, CoreExpr,[Tickish Id]) - -- See Note [exprIsLambda_maybe] - --- The simple case: It is a lambda already -exprIsLambda_maybe _ (Lam x e) - = Just (x, e, []) - --- Still straightforward: Ticks that we can float out of the way -exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) - | tickishFloatable t - , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e - = Just (x, e, t:ts) - --- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) - | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e - -- Only do value lambdas. - -- this implies that x is not in scope in gamma (makes this code simpler) - , not (isTyVar x) && not (isCoVar x) - , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True - , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co - , let res = Just (x',e',ts) - = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) - res - --- Another attempt: See if we find a partial unfolding -exprIsLambda_maybe (in_scope_set, id_unf) e - | (Var f, as, ts) <- collectArgsTicks tickishFloatable e - , idArity f > count isValArg as - -- Make sure there is hope to get a lambda - , Just rhs <- expandUnfolding_maybe (id_unf f) - -- Optimize, for beta-reduction - , let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as) - -- Recurse, because of possible casts - , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' - , let res = Just (x', e'', ts++ts') - = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) - res - -exprIsLambda_maybe _ _e - = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) - Nothing - - -{- ********************************************************************* -* * - The "push rules" -* * -************************************************************************ - -Here we implement the "push rules" from FC papers: - -* The push-argument rules, where we can move a coercion past an argument. - We have - (fun |> co) arg - and we want to transform it to - (fun arg') |> co' - for some suitable co' and tranformed arg'. - -* The PushK rule for data constructors. We have - (K e1 .. en) |> co - and we want to tranform to - (K e1' .. en') - by pushing the coercion into the oarguments --} - -pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion) -pushCoArgs co [] = return ([], co) -pushCoArgs co (arg:args) = do { (arg', co1) <- pushCoArg co arg - ; (args', co2) <- pushCoArgs co1 args - ; return (arg':args', co2) } - -pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion) --- We have (fun |> co) arg, and we want to transform it to --- (fun arg) |> co --- This may fail, e.g. if (fun :: N) where N is a newtype --- C.f. simplCast in Simplify.hs --- 'co' is always Representational - -pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty - ; return (Type ty', co') } -pushCoArg co val_arg = do { (arg_co, co') <- pushCoValArg co - ; return (mkCast val_arg arg_co, co') } - -pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion) --- We have (fun |> co) @ty --- Push the coercion through to return --- (fun @ty') |> co' --- 'co' is always Representational -pushCoTyArg co ty - | tyL `eqType` tyR - = Just (ty, mkRepReflCo (piResultTy tyR ty)) - - | isForAllTy tyL - = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty ) - Just (ty `mkCastTy` mkSymCo co1, co2) - - | otherwise - = Nothing - where - Pair tyL tyR = coercionKind co - -- co :: tyL ~ tyR - -- tyL = forall (a1 :: k1). ty1 - -- tyR = forall (a2 :: k2). ty2 - - co1 = mkNthCo 0 co - -- co1 :: k1 ~ k2 - -- Note that NthCo can extract an equality between the kinds - -- of the types related by a coercion between forall-types. - -- See the NthCo case in CoreLint. - - co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1) - -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] - -- Arg of mkInstCo is always nominal, hence mkNomReflCo - -pushCoValArg :: Coercion -> Maybe (Coercion, Coercion) --- We have (fun |> co) arg --- Push the coercion through to return --- (fun (arg |> co_arg)) |> co_res --- 'co' is always Representational -pushCoValArg co - | tyL `eqType` tyR - = Just (mkRepReflCo arg, mkRepReflCo res) - - | isFunTy tyL - , (co1, co2) <- decomposeFunCo co - -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) - -- then co1 :: tyL1 ~ tyR1 - -- co2 :: tyL2 ~ tyR2 - = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) - Just (mkSymCo co1, co2) - - | otherwise - = Nothing - where - (arg, res) = splitFunTy tyR - Pair tyL tyR = coercionKind co - -pushCoercionIntoLambda - :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr) --- This implements the Push rule from the paper on coercions --- (\x. e) |> co --- ===> --- (\x'. e |> co') -pushCoercionIntoLambda in_scope x e co - | ASSERT(not (isTyVar x) && not (isCoVar x)) True - , Pair s1s2 t1t2 <- coercionKind co - , Just (_s1,_s2) <- splitFunTy_maybe s1s2 - , Just (t1,_t2) <- splitFunTy_maybe t1t2 - = let (co1, co2) = decomposeFunCo co - -- Should we optimize the coercions here? - -- Otherwise they might not match too well - x' = x `setIdType` t1 - in_scope' = in_scope `extendInScopeSet` x' - subst = extendIdSubst (mkEmptySubst in_scope') - x - (mkCast (Var x') co1) - in Just (x', subst_expr (text "pushCoercionIntoLambda") subst e `mkCast` co2) - | otherwise - = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) - Nothing - -pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion - -> Maybe (DataCon - , [Type] -- Universal type args - , [CoreExpr]) -- All other args incl existentials --- Implement the KPush reduction rule as described in "Down with kinds" --- The transformation applies iff we have --- (C e1 ... en) `cast` co --- where co :: (T t1 .. tn) ~ to_ty --- The left-hand one must be a T, because exprIsConApp returned True --- but the right-hand one might not be. (Though it usually will.) -pushCoDataCon dc dc_args co - | isReflCo co || from_ty `eqType` to_ty -- try cheap test first - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args - = Just (dc, map exprToType univ_ty_args, rest_args) - - | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty - , to_tc == dataConTyCon dc - -- These two tests can fail; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there't nothing wrong with it - - = let - tc_arity = tyConArity to_tc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tyvars = dataConExTyVars dc - arg_tys = dataConRepArgTys dc - - non_univ_args = dropList dc_univ_tyvars dc_args - (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args - - -- Make the "Psi" from the paper - omegas = decomposeCo tc_arity co - (psi_subst, to_ex_arg_tys) - = liftCoSubstWithEx Representational - dc_univ_tyvars - omegas - dc_ex_tyvars - (map exprToType ex_args) - - -- Cast the value arguments (which include dictionaries) - new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) - - to_ex_args = map Type to_ex_arg_tys - - dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, - ppr arg_tys, ppr dc_args, - ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] - in - ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) - ASSERT2( equalLength val_args arg_tys, dump_doc ) - Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) - - | otherwise - = Nothing - - where - Pair from_ty to_ty = coercionKind co - -collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) --- Collect lambda binders, pushing coercions inside if possible --- E.g. (\x.e) |> g g :: -> blah --- = (\x. e |> Nth 1 g) --- --- That is, --- --- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) -collectBindersPushingCo e - = go [] e - where - -- Peel off lambdas until we hit a cast. - go :: [Var] -> CoreExpr -> ([Var], CoreExpr) - -- The accumulator is in reverse order - go bs (Lam b e) = go (b:bs) e - go bs (Cast e co) = go_c bs e co - go bs e = (reverse bs, e) - - -- We are in a cast; peel off casts until we hit a lambda. - go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr) - -- (go_c bs e c) is same as (go bs e (e |> c)) - go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) - go_c bs (Lam b e) co = go_lam bs b e co - go_c bs e co = (reverse bs, mkCast e co) - - -- We are in a lambda under a cast; peel off lambdas and build a - -- new coercion for the body. - go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr) - -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) - go_lam bs b e co - | isTyVar b - , let Pair tyL tyR = coercionKind co - , ASSERT( isForAllTy tyL ) - isForAllTy tyR - , isReflCo (mkNthCo 0 co) -- See Note [collectBindersPushingCo] - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) - - | isId b - , let Pair tyL tyR = coercionKind co - , ASSERT( isFunTy tyL) isFunTy tyR - , (co_arg, co_res) <- decomposeFunCo co - , isReflCo co_arg -- See Note [collectBindersPushingCo] - = go_c (b:bs) e co_res - - | otherwise = (reverse bs, mkCast (Lam b e) co) - -{- Note [collectBindersPushingCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We just look for coercions of form - -> blah -(and similarly for foralls) to keep this function simple. We could do -more elaborate stuff, but it'd involve substitution etc. --} diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index ad504ac1b9..6762ed6fb2 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -589,6 +589,11 @@ Join points must follow these invariants: "join arity" (to distinguish from regular arity, which only counts values). 2. For join arity n, the right-hand side must begin with at least n lambdas. + No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity. + + 2a. Moreover, this same constraint applies to any unfolding of the binder. + Reason: if we want to push a continuation into the RHS we must push it + into the unfolding as well. 3. If the binding is recursive, then all other bindings in the recursive group must also be join points. diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index 0e3efbf5de..e629467d07 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -46,7 +46,7 @@ import DynFlags import CoreSyn import PprCore () -- Instances import OccurAnal ( occurAnalyseExpr ) -import CoreSubst hiding( substTy ) +import CoreOpt import CoreArity ( manifestArity ) import CoreUtils import Id diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 6c939d4f79..6ae7fb4df4 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -29,8 +29,8 @@ import InstEnv import Class import Avail import CoreSyn -import CoreFVs( exprsSomeFreeVarsList ) -import CoreSubst +import CoreFVs ( exprsSomeFreeVarsList ) +import CoreOpt ( simpleOptPgm, simpleOptExpr ) import PprCore import DsMonad import DsExpr diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index e31f23fffa..1ff04b2548 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -28,7 +28,7 @@ import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things import Literal ( Literal(MachStr) ) -import CoreSubst +import CoreOpt ( simpleOptExpr ) import OccurAnal ( occurAnalyseExpr ) import MkCore import CoreUtils diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 33c218c903..8c9bc3bfaa 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -277,6 +277,7 @@ Library CoreLint CorePrep CoreSubst + CoreOpt CoreSyn TrieMap CoreTidy diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 86091f5fc0..3f6e77ca4b 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -452,6 +452,7 @@ compiler_stage2_dll0_MODULES = \ CoreArity \ CoreFVs \ CoreSubst \ + CoreOpt \ CoreSyn \ CoreTidy \ CoreUnfold \ diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs index 2af2da8e7a..c064c0e833 100644 --- a/compiler/main/GhcPlugins.hs +++ b/compiler/main/GhcPlugins.hs @@ -41,7 +41,8 @@ import DataCon import CoreUtils import MkCore import CoreFVs -import CoreSubst +import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) + -- These names are also exported by Type -- Core "extras" import Rules diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 2b1bf76571..5406b0d494 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -31,7 +31,7 @@ import CoreSyn import MkCore import Id import Literal -import CoreSubst ( exprIsLiteral_maybe ) +import CoreOpt ( exprIsLiteral_maybe ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn import TysPrim diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index b63e7456cd..4b158b607a 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -35,7 +35,8 @@ import PprCore ( pprCoreExpr ) import CoreUnfold import CoreUtils import CoreArity -import CoreSubst ( pushCoTyArg, pushCoValArg ) +import CoreOpt ( pushCoTyArg, pushCoValArg + , joinPointBinding_maybe, joinPointBindings_maybe ) --import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326 import Rules ( mkRuleInfo, lookupRule, getRules ) --import TysPrim ( intPrimTy ) -- temporalily commented out. See #8326 @@ -1462,7 +1463,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont -> simplExprF (rhs_se `setFloats` env) rhs (StrictBind bndr bndrs body env cont) - | Just (bndr', rhs') <- matchOrConvertToJoinPoint bndr rhs + | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs -> do { let cont_dup_res_ty = resultTypeOfDupableCont (getMode env) [bndr'] cont ; (env1, bndr1) <- simplNonRecJoinBndr env @@ -1498,7 +1499,7 @@ simplRecE :: SimplEnv -- simplRecE is used for -- * non-top-level recursive lets in expressions simplRecE env pairs body cont - | Just pairs' <- matchOrConvertToJoinPoints pairs + | Just pairs' <- joinPointBindings_maybe pairs = do { let bndrs' = map fst pairs' cont_dup_res_ty = resultTypeOfDupableCont (getMode env) bndrs' cont @@ -1525,29 +1526,6 @@ simplRecE env pairs body cont ; env2 <- simplRecBind env1 NotTopLevel (Just cont) pairs ; simplExprF env2 body cont } --- | Returns Just (bndr,rhs) if the binding is a join point: --- If it's a JoinId, just return it --- If it's not yet a JoinId but is always tail-called, --- make it into a JoinId and return it. -matchOrConvertToJoinPoint :: InBndr -> InExpr -> Maybe (InBndr, InExpr) -matchOrConvertToJoinPoint bndr rhs - | not (isId bndr) - = Nothing - - | isJoinId bndr - = -- No point in keeping tailCallInfo around; very fragile - Just (bndr, rhs) - - | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) - , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs - = Just (bndr `asJoinId` join_arity, mkLams bndrs body) - - | otherwise - = Nothing - -matchOrConvertToJoinPoints :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] -matchOrConvertToJoinPoints bndrs - = mapM (uncurry matchOrConvertToJoinPoint) bndrs {- ************************************************************************ diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 47193c66bc..192b6bb212 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -31,6 +31,7 @@ module Rules ( import CoreSyn -- All of it import Module ( Module, ModuleSet, elemModuleSet ) import CoreSubst +import CoreOpt ( exprIsLambda_maybe ) import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index bd1c7aecf0..0dd295d695 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -21,6 +21,7 @@ import VarSet import VarEnv import CoreSyn import Rules +import CoreOpt ( collectBindersPushingCo ) import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars, exprsFreeIdsList ) import CoreArity ( etaExpandToJoinPointRule ) @@ -1194,7 +1195,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] - (rhs_bndrs, rhs_body) = CoreSubst.collectBindersPushingCo rhs + (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] (rhs_tyvars, rhs_bndrs1) = span isTyVar rhs_bndrs (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1 diff --git a/testsuite/tests/simplCore/should_compile/T13413.hs b/testsuite/tests/simplCore/should_compile/T13413.hs new file mode 100644 index 0000000000..63de8b3268 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T13413.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MagicHash #-} +module T13413 where + +import GHC.Exts + +fillBlock2 :: (Int# -> Int# -> IO ()) + -> Int# -> Int# -> IO () + +fillBlock2 write x0 y0 + = fillBlock y0 x0 + where + {-# INLINE fillBlock #-} + fillBlock y ix + | 1# <- y >=# y0 + = return () + | otherwise + = do write ix x0 + fillBlock (y +# 1#) ix + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 5265569503..98d7d79835 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -251,3 +251,4 @@ test('T13340', normal, run_command, ['$MAKE -s --no-print-directory T13340']) test('T13338', only_ways(['optasm']), compile, ['-dcore-lint']) test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367']) test('T13417', normal, compile, ['-O']) +test('T13413', normal, compile, ['']) -- GitLab