X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=effd245a2119e6128da5b12635794fb61959e490;hp=d1695184cac7400d293254ed28ff12e21d439530;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=4ea81579160f59983586ea11a56c60010e0c93ce diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index d169518..effd245 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -10,19 +10,23 @@ module Simplify ( simplTopBinds, simplExpr ) where import DynFlags import SimplMonad -import Type hiding ( substTy, extendTvSubst ) +import Type hiding ( substTy, extendTvSubst, substTyVar ) import SimplEnv import SimplUtils import FamInstEnv ( FamInstEnv ) import Id -import MkId ( mkImpossibleExpr, seqId ) +import MkId ( seqId, realWorldPrimId ) +import MkCore ( mkImpossibleExpr ) import Var import IdInfo +import Name ( mkSystemVarName, isExternalName ) import Coercion +import OptCoercion ( optCoercion ) import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) +import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn -import NewDemand ( isStrictDmd, splitStrictSig ) +import Demand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) @@ -33,10 +37,8 @@ import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) -import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRuleLoopBreaker ) -import MonadUtils ( foldlM ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) +import MonadUtils ( foldlM, mapAccumLM ) import Maybes ( orElse ) import Data.List ( mapAccumL ) import Outputable @@ -213,8 +215,7 @@ simplTopBinds env0 binds0 -- It's rather as if the top-level binders were imported. ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) ; dflags <- getDOptsSmpl - ; let dump_flag = dopt Opt_D_dump_inlinings dflags || - dopt Opt_D_dump_rule_firings dflags + ; let dump_flag = dopt Opt_D_verbose_core2core dflags ; env2 <- simpl_binds dump_flag env1 binds0 ; freeTick SimplifierDone ; return env2 } @@ -335,15 +336,14 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- See Note [Floating and type abstraction] in SimplUtils -- Simplify the RHS - ; (body_env1, body1) <- simplExprF body_env body mkBoringStop - + ; (body_env1, body1) <- simplExprF body_env body mkRhsStop -- ANF-ise a constructor or PAP rhs - ; (body_env2, body2) <- prepareRhs body_env1 body1 + ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1 ; (env', rhs') <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) - then -- No floating, just wrap up! - do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2) + then -- No floating, revert to body1 + do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) ; return (env, rhs') } else if null tvs then -- Simple floating @@ -374,17 +374,18 @@ simplNonRecX env bndr new_rhs = return env -- Here b is dead, and we avoid creating | otherwise -- the binding b = (a,b) = do { (env', bndr') <- simplBinder env bndr - ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs } + ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } + -- simplNonRecX is only used for NotTopLevel things -completeNonRecX :: SimplEnv +completeNonRecX :: TopLevelFlag -> SimplEnv -> Bool -> InId -- Old binder -> OutId -- New binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv -completeNonRecX env is_strict old_bndr new_bndr new_rhs - = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs +completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs + = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet @@ -435,37 +436,42 @@ Here we want to make e1,e2 trivial and get That's what the 'go' loop in prepareRhs does \begin{code} -prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS -prepareRhs env (Cast rhs co) -- Note [Float coercions] +prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] - = do { (env', rhs') <- makeTrivial env rhs + = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs ; return (env', Cast rhs' co) } + where + sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setDemandInfo` demandInfo info + info = idInfo id -prepareRhs env0 rhs0 - = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0 +prepareRhs top_lvl env0 _ rhs0 + = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 ; return (env1, rhs1) } where go n_val_args env (Cast rhs co) - = do { (is_val, env', rhs') <- go n_val_args env rhs - ; return (is_val, env', Cast rhs' co) } + = do { (is_exp, env', rhs') <- go n_val_args env rhs + ; return (is_exp, env', Cast rhs' co) } go n_val_args env (App fun (Type ty)) - = do { (is_val, env', rhs') <- go n_val_args env fun - ; return (is_val, env', App rhs' (Type ty)) } + = do { (is_exp, env', rhs') <- go n_val_args env fun + ; return (is_exp, env', App rhs' (Type ty)) } go n_val_args env (App fun arg) - = do { (is_val, env', fun') <- go (n_val_args+1) env fun - ; case is_val of - True -> do { (env'', arg') <- makeTrivial env' arg + = do { (is_exp, env', fun') <- go (n_val_args+1) env fun + ; case is_exp of + True -> do { (env'', arg') <- makeTrivial top_lvl env' arg ; return (True, env'', App fun' arg') } False -> return (False, env, App fun arg) } go n_val_args env (Var fun) - = return (is_val, env, Var fun) + = return (is_exp, env, Var fun) where - is_val = n_val_args > 0 -- There is at least one arg - -- ...and the fun a constructor or PAP - && (isConLikeId fun || n_val_args < idArity fun) - -- See Note [CONLIKE pragma] in BasicTypes + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- OccurAnal.occAnalApp + go _ env other = return (False, env, other) \end{code} @@ -493,6 +499,17 @@ and lead to further optimisation. Example: go n = case x of { T m -> go (n-m) } -- This case should optimise +Note [Preserve strictness when floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Float coercions] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + Note [Float coercions (unlifted)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT don't do [Float coercions] if 'e' has an unlifted type. @@ -511,28 +528,68 @@ These strange casts can happen as a result of case-of-case \begin{code} -makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial env expr - | exprIsTrivial expr +makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr + +makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo + -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Propagate strictness and demand info to the new binder +-- Note [Preserve strictness when floating coercions] +-- Returned SimplEnv has same substitution as incoming one +makeTrivialWithInfo top_lvl env info expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] = return (env, expr) | otherwise -- See Note [Take care] below - = do { var <- newId (fsLit "a") (exprType expr) - ; env' <- completeNonRecX env False var var expr --- pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var))) --- , ppr expr --- , ppr (substExpr env' (Var var)) --- , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $ - ; return (env', substExpr env' (Var var)) } - -- The substitution is needed becase we're constructing a new binding + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "a") + var = mkLocalIdWithInfo name expr_ty info + ; env' <- completeNonRecX top_lvl env False var var expr + ; expr' <- simplVar env' var + ; return (env', expr') } + -- The simplVar is needed becase we're constructing a new binding -- a = rhs -- And if rhs is of form (rhs1 |> co), then we might get -- a1 = rhs1 -- a = a1 |> co -- and now a's RHS is trivial and can be substituted out, and that -- is what completeNonRecX will do + -- To put it another way, it's as if we'd simplified + -- let var = e in var + where + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl _ expr_ty + | isTopLevel top_lvl = not (isUnLiftedType expr_ty) + | otherwise = True \end{code} +Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider tih + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +A case in point is literal strings (a MachStr is not regarded as +trivial): + + foo = Ptr "blob"# + +We don't want to ANF-ise this. %************************************************************************ %* * @@ -579,7 +636,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding -- Inline and discard the binding then do { tick (PostInlineUnconditionally old_bndr) - ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $ + return (extendIdSubst env old_bndr (DoneEx new_rhs)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding @@ -627,12 +685,12 @@ addNonRecWithUnf env new_bndr new_rhs new_unfolding | otherwise = info2 final_id = new_bndr `setIdInfo` info3 - dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr + dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr in ASSERT( isId new_bndr ) WARN( new_arity < old_arity || new_arity < dmd_arity, - (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity - <+> ppr new_arity <+> ppr dmd_arity) ) + (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity + <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) ) -- Note [Arity decrease] final_id `seq` -- This seq forces the Id, and hence its IdInfo, @@ -643,29 +701,36 @@ addNonRecWithUnf env new_bndr new_rhs new_unfolding ------------------------------ simplUnfolding :: SimplEnv-> TopLevelFlag - -> Id -- Debug output only + -> Id -> OccInfo -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ _ (DFunUnfolding con ops) - = return (DFunUnfolding con ops') +simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) + = return (DFunUnfolding ar con ops') where - ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops + ops' = map (substExpr (text "simplUnfolding") env) ops -simplUnfolding env top_lvl _ _ _ +simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity - , uf_guidance = guide@(InlineRule {}) }) - = do { expr' <- simplExpr (setMode SimplGently env) expr - ; let mb_wkr' = CoreSubst.substInlineRuleGuidance (mkCoreSubst env) (ug_ir_info guide) - ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity - (guide { ug_ir_info = mb_wkr' })) } + , uf_src = src, uf_guidance = guide }) + | isInlineRuleSource src + = do { expr' <- simplExpr rule_env expr + ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src + ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } -- See Note [Top-level flag on inline rules] in CoreUnfold - -simplUnfolding _ top_lvl _ occ_info new_rhs _ - | omit_unfolding = return NoUnfolding - | otherwise = return (mkUnfolding (isTopLevel top_lvl) new_rhs) where - omit_unfolding = isNonRuleLoopBreaker occ_info + act = idInlineActivation id + rule_env = updMode (updModeForInlineRules act) env + -- See Note [Simplifying gently inside InlineRules] in SimplUtils + +simplUnfolding _ top_lvl id _occ_info new_rhs _ + = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. \end{code} Note [Arity decrease] @@ -792,7 +857,7 @@ simplExprF env e cont simplExprF' :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF' env (Var v) cont = simplVar env v cont +simplExprF' env (Var v) cont = simplVarF env v cont simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont simplExprF' env (Note n expr) cont = simplNote env n expr cont simplExprF' env (Cast body co) cont = simplCast env body co cont @@ -812,7 +877,7 @@ simplExprF' env expr@(Lam _ _) cont n_params = length bndrs (bndrs, body) = collectBinders expr zap | n_args >= n_params = \b -> b - | otherwise = \b -> if isTyVar b then b + | otherwise = \b -> if isTyCoVar b then b else zapLamIdInfo b -- NB: we count all the args incl type args -- so we must count all the binders (incl type lambdas) @@ -851,7 +916,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType -- Kept monadic just so we can do the seqType simplType env ty = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` return new_ty + seqType new_ty `seq` return new_ty where new_ty = substTy env ty @@ -860,8 +925,9 @@ simplCoercion :: SimplEnv -> InType -> SimplM OutType -- The InType isn't *necessarily* a coercion, but it might be -- (in a type application, say) and optCoercion is a no-op on types simplCoercion env co - = do { co' <- simplType env co - ; return (optCoercion co') } + = seqType new_co `seq` return new_co + where + new_co = optCoercion (getTvSubst env) co \end{code} @@ -881,7 +947,7 @@ rebuild env expr cont0 Stop {} -> return (env, expr) CoerceIt co cont -> rebuild env (mkCoerce co expr) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont - StrictArg fun _ info cont -> rebuildCall env (fun `App` expr) info cont + StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr ; simplLam env' bs body cont } ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg @@ -923,14 +989,19 @@ simplCast env body co0 cont0 add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) -- (f |> g) ty ---> (f ty) |> (g @ ty) - -- This implements the PushT rule from the paper + -- This implements the PushT and PushC rules from the paper | Just (tyvar,_) <- splitForAllTy_maybe s1s2 - , not (isCoVar tyvar) - = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont) + = let + (new_arg_ty, new_cast) + | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule + | otherwise = (ty', mkInstCoercion co ty') -- PushT rule + in + ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont) where ty' = substTy (arg_se `setInScope` env) arg_ty - - -- ToDo: the PushC rule is not implemented at all + new_arg_co = mkCsel1Coercion co `mkTransCoercion` + ty' `mkTransCoercion` + mkSymCoercion (mkCsel2Coercion co) add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont) | not (isTypeArg arg) -- This implements the Push rule from the paper @@ -949,14 +1020,14 @@ simplCast env body co0 cont0 -- But it isn't a common case. -- -- Example of use: Trac #995 - = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont) + = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont) where -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and -- t2 ~ s2 with left and right on the curried form: -- (->) t1 t2 ~ (->) s1 s2 [co1, co2] = decomposeCo 2 co new_arg = mkCoerce (mkSymCoercion co1) arg' - arg' = substExpr (arg_se `setInScope` env) arg + arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg add_coerce co _ cont = CoerceIt co cont \end{code} @@ -1010,7 +1081,7 @@ simplNonRecE :: SimplEnv -- First deal with type applications and type lets -- (/\a. e) (Type ty) and (let a = Type ty in e) simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont - = ASSERT( isTyVar bndr ) + = ASSERT( isTyCoVar bndr ) do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } @@ -1024,7 +1095,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont (StrictBind bndr bndrs body env cont) } | otherwise - = ASSERT( not (isTyVar bndr) ) + = ASSERT( not (isTyCoVar bndr) ) do { (env1, bndr1) <- simplNonRecBndr env bndr ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se @@ -1058,17 +1129,28 @@ simplNote env (CoreNote s) e cont %************************************************************************ %* * -\subsection{Dealing with calls} + Variables %* * %************************************************************************ \begin{code} -simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplVar env var cont +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + | isTyCoVar var + = return (Type (substTyVar env var)) + | otherwise + = case substId env var of + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e + +simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplVarF env var cont = case substId env var of DoneEx e -> simplExprF (zapSubstEnv env) e cont ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont - DoneId var1 -> completeCall (zapSubstEnv env) var1 cont + DoneId var1 -> completeCall env var1 cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -1084,69 +1166,50 @@ simplVar env var cont completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont - = do { let (args,call_cont) = contArgs cont + = do { ------------- Try inlining ---------------- + dflags <- getDOptsSmpl + ; let (lone_variable, arg_infos, call_cont) = contArgs cont -- The args are OutExprs, obtained by *lazily* substituting -- in the args found in cont. These args are only examined -- to limited depth (unless a rule fires). But we must do -- the substitution; rule matching on un-simplified args would -- be bogus - ------------- First try rules ---------------- - -- Do this before trying inlining. Some functions have - -- rules *and* are strict; in this case, we don't want to - -- inline the wrapper of the non-specialised thing; better - -- to call the specialised thing instead. - -- - -- We used to use the black-listing mechanism to ensure that inlining of - -- the wrapper didn't occur for things that have specialisations till a - -- later phase, so but now we just try RULES first - -- - -- See also Note [Rules for recursive functions] - ; rule_base <- getSimplRules - ; let rules = getRules rule_base var - ; mb_rule <- tryRules env var rules args call_cont - ; case mb_rule of { - Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ; - -- The ruleArity says how many args the rule consumed - ; Nothing -> do -- No rules - - - ------------- Next try inlining ---------------- - { dflags <- getDOptsSmpl - ; let arg_infos = [interestingArg arg | arg <- args, isValArg arg] - n_val_args = length arg_infos - interesting_cont = interestingCallContext call_cont - active_inline = activeInline env var - maybe_inline = callSiteInline dflags active_inline var - (null args) arg_infos interesting_cont + n_val_args = length arg_infos + interesting_cont = interestingCallContext call_cont + unfolding = activeUnfolding env var + maybe_inline = callSiteInline dflags var unfolding + lone_variable arg_infos interesting_cont ; case maybe_inline of { - Just unfolding -- There is an inlining! + Just expr -- There is an inlining! -> do { tick (UnfoldingDone var) - ; (if dopt Opt_D_dump_inlinings dflags then - pprTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [ - text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr call_cont]) - else - id) - simplExprF env unfolding cont } - - ; Nothing -> -- No inlining! - - ------------- No inlining! ---------------- - -- Next, look for rules or specialisations that match - -- - rebuildCall env (Var var) - (mkArgInfo var rules n_val_args call_cont) - cont - }}}} + ; trace_inline dflags expr cont $ + simplExprF (zapSubstEnv env) expr cont } + + ; Nothing -> do -- No inlining! + + { rule_base <- getSimplRules + ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont + ; rebuildCall env info cont + }}} + where + trace_inline dflags unfolding cont stuff + | not (dopt Opt_D_dump_inlinings dflags) = stuff + | not (dopt Opt_D_verbose_core2core dflags) + = if isExternalName (idName var) then + pprTrace "Inlining done:" (ppr var) stuff + else stuff + | otherwise + = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont]) + stuff rebuildCall :: SimplEnv - -> OutExpr -- Function -> ArgInfo -> SimplCont -> SimplM (SimplEnv, OutExpr) -rebuildCall env fun (ArgInfo { ai_strs = [] }) cont +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont -- When we run out of strictness args, it means -- that the call is definitely bottom; see SimplUtils.mkArgInfo -- Then we want to discard the entire strict continuation. E.g. @@ -1158,25 +1221,26 @@ rebuildCall env fun (ArgInfo { ai_strs = [] }) cont -- the continuation, leaving just the bottoming expression. But the -- type might not be right, so we may have to add a coerce. | not (contIsTrivial cont) -- Only do this if there is a non-trivial - = return (env, mk_coerce fun) -- contination to discard, else we do it + = return (env, mk_coerce res) -- contination to discard, else we do it where -- again and again! - fun_ty = exprType fun - cont_ty = contResultType env fun_ty cont - co = mkUnsafeCoercion fun_ty cont_ty - mk_coerce expr | cont_ty `coreEqType` fun_ty = expr + res = mkApps (Var fun) (reverse rev_args) + res_ty = exprType res + cont_ty = contResultType env res_ty cont + co = mkUnsafeCoercion res_ty cont_ty + mk_coerce expr | cont_ty `coreEqType` res_ty = expr | otherwise = mkCoerce co expr -rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont) +rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) = do { ty' <- simplCoercion (se `setInScope` env) arg_ty - ; rebuildCall env (fun `App` Type ty') info cont } + ; rebuildCall env (info `addArgTo` Type ty') cont } -rebuildCall env fun - (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs }) - (ApplyTo _ arg arg_se cont) +rebuildCall env info@(ArgInfo { ai_encl = encl_rules + , ai_strs = str:strs, ai_discs = disc:discs }) + (ApplyTo _ arg arg_se cont) | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg - (StrictArg fun cci arg_info' cont) + (StrictArg info' cci cont) -- Note [Shadowing] | otherwise -- Lazy argument @@ -1186,16 +1250,40 @@ rebuildCall env fun -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScope` env) arg (mkLazyArgStop cci) - ; rebuildCall env (fun `App` arg') arg_info' cont } + ; rebuildCall env (addArgTo info' arg') cont } where - arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs } - cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting - -rebuildCall env fun _ cont - = rebuild env fun cont + info' = info { ai_strs = strs, ai_discs = discs } + cci | encl_rules || disc > 0 = ArgCtxt encl_rules -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + = do { -- We've accumulated a simplified call in + -- so try rewrite rules; see Note [RULEs apply to simplified arguments] + -- See also Note [Rules for recursive functions] + ; let args = reverse rev_args + env' = zapSubstEnv env + ; mb_rule <- tryRules env rules fun args cont + ; case mb_rule of { + Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $ + pushArgs env' (drop n_args args) cont ; + -- n_args says how many args the rule consumed + ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules + } } \end{code} +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweeep. + Note [Shadowing] ~~~~~~~~~~~~~~~~ This part of the simplifier may break the no-shadowing invariant @@ -1228,11 +1316,11 @@ all this at once is TOO HARD! %************************************************************************ \begin{code} -tryRules :: SimplEnv - -> Id -> [CoreRule] -> [OutExpr] -> SimplCont +tryRules :: SimplEnv -> [CoreRule] + -> Id -> [OutExpr] -> SimplCont -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of -- args consumed by the rule -tryRules env fn rules args call_cont +tryRules env rules fn args call_cont | null rules = return Nothing | otherwise @@ -1240,21 +1328,26 @@ tryRules env fn rules args call_cont ; case activeRule dflags env of { Nothing -> return Nothing ; -- No rules apply Just act_fn -> - - case lookupRule act_fn (getInScope env) fn args rules of { + case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> do { tick (RuleFired (ru_name rule)) - ; (if dopt Opt_D_dump_rule_firings dflags then - pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ftext (ru_name rule), - text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), - text "After: " <+> pprCoreExpr rule_rhs, - text "Cont: " <+> ppr call_cont]) - else - id) $ - return (Just (ruleArity rule, rule_rhs)) }}}} + ; trace_dump dflags rule rule_rhs $ + return (Just (ruleArity rule, rule_rhs)) }}}} + where + trace_dump dflags rule rule_rhs stuff + | not (dopt Opt_D_dump_rule_firings dflags) = stuff + | not (dopt Opt_D_verbose_core2core dflags) + + = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff + | otherwise + = pprTrace "Rule fired" + (vcat [text "Rule:" <+> ftext (ru_name rule), + text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), + text "After: " <+> pprCoreExpr rule_rhs, + text "Cont: " <+> ppr call_cont]) + stuff \end{code} Note [Rules for recursive functions] @@ -1388,7 +1481,7 @@ rebuildCase env scrut case_bndr alts cont Nothing -> missingAlt env case_bndr alts cont Just (_, bs, rhs) -> simple_rhs bs rhs } - | Just (con, ty_args, other_args) <- exprIsConApp_maybe scrut + | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut -- Works when the scrutinee is a variable with a known unfolding -- as well as when it's an explicit constructor application = do { tick (KnownBranch case_bndr) @@ -1442,23 +1535,25 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont where -- The case binder is going to be evaluated later, -- and the scrutinee is a simple variable - var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr) + var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr) && not (isTickBoxOp v) -- ugly hack; covering this case is what -- exprOkForSpeculation was intended for. var_demanded_later _ = False +-------------------------------------------------- +-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId +-------------------------------------------------- + rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' - = -- For this case, see Note [User-defined RULES for seq] in MkId - do { let rhs' = substExpr env rhs + = do { let rhs' = substExpr (text "rebuild-case") env rhs out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this ; rule_base <- getSimplRules - ; let rules = getRules rule_base seqId - ; mb_rule <- tryRules env seqId rules out_args cont + ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont ; case mb_rule of Just (n_args, res) -> simplExprF (zapSubstEnv env) (mkApps res (drop n_args out_args)) @@ -1483,9 +1578,11 @@ reallyRebuildCase env scrut case_bndr alts cont -- Check for empty alternatives ; if null alts' then missingAlt env case_bndr alts cont else do - { case_expr <- mkCase scrut' case_bndr' alts' + { dflags <- getDOptsSmpl + ; case_expr <- mkCase dflags scrut' case_bndr' alts' - -- Notice that rebuild gets the in-scope set from env, not alt_env + -- Notice that rebuild gets the in-scope set from env', not alt_env + -- (which in any case is only build in simplAlts) -- The case binder *not* scope over the whole returned case-expression ; rebuild env' case_expr nodup_cont } } \end{code} @@ -1576,90 +1673,6 @@ At one point I did transformation in LiberateCase, but it's more robust here. (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before LiberateCase gets to see it.) - -\begin{code} -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv - -> OutExpr -> InId -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) --- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note! - , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - -improveSeq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - -{- - improve_case_bndr env scrut case_bndr - -- See Note [no-case-of-case] - -- | switchIsOn (getSwitchChecker env) NoCaseOfCase - -- = (env, case_bndr) - - | otherwise -- Failed try; see Note [Suppressing the case binder-swap] - -- not (isEvaldUnfolding (idUnfolding v)) - = case scrut of - Var v -> (modifyInScope env1 v case_bndr', case_bndr') - -- Note about using modifyInScope for v here - -- We could extend the substitution instead, but it would be - -- a hack because then the substitution wouldn't be idempotent - -- any more (v is an OutId). And this does just as well. - - Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr') - where - rhs = Cast (Var case_bndr') (mkSymCoercion co) - - _ -> (env, case_bndr) - where - case_bndr' = zapIdOccInfo case_bndr - env1 = modifyInScope env case_bndr case_bndr' --} -\end{code} - - -simplAlts does two things: - -1. Eliminate alternatives that cannot match, including the - DEFAULT alternative. - -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. - -Here "cannot match" includes knowledge from GADTs - -It's a good idea do do this stuff before simplifying the alternatives, to -avoid simplifying alternatives we know can't happen, and to come up with -the list of constructors that are handled, to put into the IdInfo of the -case binder, for use when simplifying the alternatives. - -Eliminating the default alternative in (1) isn't so obvious, but it can -happen: - -data Colour = Red | Green | Blue - -f x = case x of - Red -> .. - Green -> .. - DEFAULT -> h x - -h y = case y of - Blue -> .. - DEFAULT -> [ case y of ... ] - -If we inline h into f, the default case of the inlined h can't happen. -If we don't notice this, we may end up filtering out *all* the cases -of the inner case y, which give us nowhere to go! - - \begin{code} simplAlts :: SimplEnv -> OutExpr @@ -1668,10 +1681,10 @@ simplAlts :: SimplEnv -> SimplCont -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation -- Like simplExpr, this just returns the simplified alternatives; --- it not return an environment +-- it does not return an environment simplAlts env scrut case_bndr alts cont' - = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ + = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $ do { let env0 = zapFloats env ; (env1, case_bndr1) <- simplBinder env0 case_bndr @@ -1680,11 +1693,29 @@ simplAlts env scrut case_bndr alts cont' ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut case_bndr case_bndr1 alts - ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note! + , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + ------------------------------------ simplAlt :: SimplEnv -> [AltCon] -- These constructors can't be present when @@ -1737,7 +1768,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) = go vs the_strs where go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') strs | isTyCoVar v = v : go vs' strs go (v:vs') (str:strs) | isMarkedStrict str = evald_v : go vs' strs | otherwise = zapped_v : go vs' strs @@ -1758,7 +1789,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons @@ -1802,23 +1833,8 @@ knownCon :: SimplEnv -> SimplM (SimplEnv, OutExpr) knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont - = do { env' <- bind_args env bs dc_args - ; let - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bndr_rhs | exprIsTrivial scrut = scrut - | otherwise = con_app - con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs] - -- dc_ty_args are aready OutTypes, but bs are InBndrs - - ; env'' <- simplNonRecX env' bndr bndr_rhs + = do { env' <- bind_args env bs dc_args + ; env'' <- bind_case_bndr env' ; simplExprF env'' rhs cont } where zap_occ = zapCasePatIdOcc bndr -- bndr is an InId @@ -1827,7 +1843,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont bind_args env' [] _ = return env' bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyVar b ) + = ASSERT( isTyCoVar b ) bind_args (extendTvSubst env' b ty) bs' args bind_args env' (b:bs') (arg : args) @@ -1845,6 +1861,24 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ text "scrut:" <+> ppr scrut + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return env + | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut)) + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are aready OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) -- This isn't strictly an error, although it is unusual. @@ -1897,18 +1931,11 @@ mkDupableCont env cont@(StrictBind {}) = return (env, mkBoringStop, cont) -- See Note [Duplicating StrictBind] -mkDupableCont env (StrictArg fun cci ai cont) +mkDupableCont env (StrictArg info cci cont) -- See Note [Duplicating StrictArg] = do { (env', dup, nodup) <- mkDupableCont env cont - ; (env'', fun') <- mk_dupable_call env' fun - ; return (env'', StrictArg fun' cci ai dup, nodup) } - where - mk_dupable_call env (Var v) = return (env, Var v) - mk_dupable_call env (App fun arg) = do { (env', fun') <- mk_dupable_call env fun - ; (env'', arg') <- makeTrivial env' arg - ; return (env'', fun' `App` arg') } - mk_dupable_call _ other = pprPanic "mk_dupable_call" (ppr other) - -- The invariant of StrictArg is that the first arg is always an App chain + ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info) + ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } mkDupableCont env (ApplyTo _ arg se cont) = -- e.g. [...hole...] (...arg...) @@ -1917,7 +1944,7 @@ mkDupableCont env (ApplyTo _ arg se cont) -- in [...hole...] a do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont ; arg' <- simplExpr (se `setInScope` env') arg - ; (env'', arg'') <- makeTrivial env' arg' + ; (env'', arg'') <- makeTrivial NotTopLevel env' arg' ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont ; return (env'', app_cont, nodup_cont) } @@ -1989,7 +2016,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule InlSat rhs 0 + unf = mkInlineRule rhs Nothing rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') @@ -2003,7 +2030,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') | otherwise = bndrs' ++ [case_bndr_w_unf] abstract_over bndr - | isTyVar bndr = True -- Abstract over all type variables just in case + | isTyCoVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) -- The deadness info on the new Ids is preserved by simplBinders @@ -2055,12 +2082,22 @@ An alternative plan is this: but that is bad if 'c' is *not* later scrutinised. So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -that it's really I# c#, thus +(an InlineRule) that it's really I# c#, thus $j = \c# -> \c[=I# c#] -> ...c.... Absence analysis may later discard 'c'. +NB: take great care when doing strictness analysis; + see Note [Lamba-bound unfoldings] in DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. Note [Duplicated env] ~~~~~~~~~~~~~~~~~~~~~