X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=9e73359143f159bf56b72eb8ee28c228123c6c49;hb=fb982282ff6307b342d8fbc09b58a990d76c68fb;hp=eec45210408370bfe3047898ebd0c0971b94b800;hpb=9a977e72a47a0e0c2a8bbf254f8b85609f0937f9;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index eec4521..9e73359 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -15,7 +15,8 @@ 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 ) @@ -27,8 +28,9 @@ import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn import Demand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, - exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding + , mkInlineUnfolding, mkSimpleUnfolding + , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils import qualified CoreSubst import CoreArity ( exprArity ) @@ -36,7 +38,6 @@ import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) -import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM ) import Maybes ( orElse ) @@ -321,7 +322,8 @@ simplLazyBind :: SimplEnv -> SimplM SimplEnv simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = do { let rhs_env = rhs_se `setInScope` env + = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let rhs_env = rhs_se `setInScope` env (tvs, body) = case collectTyBinders rhs of (tvs, body) | not_lam body -> (tvs,body) | otherwise -> ([], rhs) @@ -386,7 +388,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv 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) <- + ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet ; return (addFloats env env1, rhs1) } -- Add the floats to the main env @@ -546,7 +548,7 @@ makeTrivialWithInfo top_lvl env info expr = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "a") var = mkLocalIdWithInfo name expr_ty info - ; env' <- completeNonRecX top_lvl env False var var expr + ; 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 @@ -562,7 +564,7 @@ makeTrivialWithInfo top_lvl env info expr expr_ty = exprType expr bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool --- True iff we can have a binding of this expression at this leve +-- 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) @@ -705,15 +707,15 @@ simplUnfolding :: SimplEnv-> TopLevelFlag -> 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 (substExpr (text "simplUnfolding") env) ops simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) - | isInlineRuleSource src + | isStableSource 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) } @@ -721,10 +723,10 @@ simplUnfolding env top_lvl id _ _ where act = idInlineActivation id rule_env = updMode (updModeForInlineRules act) env - -- See Note [Simplifying gently inside InlineRules] in SimplUtils + -- See Note [Simplifying inside InlineRules] in SimplUtils simplUnfolding _ top_lvl id _occ_info new_rhs _ - = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + = return (mkUnfolding InlineRhs (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 @@ -877,7 +879,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) @@ -895,10 +897,9 @@ simplExprF' env (Case scrut bndr _ alts) cont | otherwise = -- If case-of-case is off, simply simplify the case expression -- in a vanilla Stop context, and rebuild the result around it - do { case_expr' <- simplExprC env scrut case_cont + do { case_expr' <- simplExprC env scrut + (Select NoDup bndr alts env mkBoringStop) ; rebuild env case_expr' cont } - where - case_cont = Select NoDup bndr alts env mkBoringStop simplExprF' env (Let (Rec pairs) body) cont = do { env' <- simplRecBndrs env (map fst pairs) @@ -950,7 +951,9 @@ rebuild env expr cont0 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 + ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] + | isSimplified dup_flag -> rebuild env (App expr arg) cont + | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg ; rebuild env (App expr arg') cont } \end{code} @@ -1081,21 +1084,22 @@ 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 } simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont | preInlineUnconditionally env NotTopLevel bndr rhs = do { tick (PreInlineUnconditionally bndr) - ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } | isStrictId bndr = do { simplExprF (rhs_se `setFloats` env) rhs (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 @@ -1137,7 +1141,7 @@ simplNote env (CoreNote s) e cont simplVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment simplVar env var - | isTyVar var + | isTyCoVar var = return (Type (substTyVar env var)) | otherwise = case substId env var of @@ -1236,7 +1240,10 @@ rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) - (ApplyTo _ arg arg_se cont) + (ApplyTo dup_flag arg arg_se cont) + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addArgTo info' arg) cont + | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg @@ -1265,7 +1272,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) ; 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 ; + pushSimplifiedArgs 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 } } @@ -1276,7 +1283,7 @@ 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 (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 @@ -1284,6 +1291,15 @@ 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 [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + Note [Shadowing] ~~~~~~~~~~~~~~~~ This part of the simplifier may break the no-shadowing invariant @@ -1503,7 +1519,7 @@ rebuildCase env scrut case_bndr alts cont rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont -- See if we can get rid of the case altogether - -- See Note [Case eliminiation] + -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, -- then there is now only one (DEFAULT) rhs | all isDeadBinder bndrs -- bndrs are [InId] @@ -1768,7 +1784,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 @@ -1789,7 +1805,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 False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons @@ -1843,7 +1859,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) @@ -2016,7 +2032,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule rhs Nothing + unf = mkInlineUnfolding Nothing rhs rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') @@ -2030,7 +2046,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 @@ -2082,12 +2098,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] ~~~~~~~~~~~~~~~~~~~~~ @@ -2261,10 +2287,14 @@ strict computation enclosing the orginal call to MkT. Then, it won't "see" the MkT any more, because it's big and won't get duplicated. And, what is worse, nothing was gained by the case-of-case transform. -When should use this case of mkDupableCont? -However, matching on *any* single-alternative case is a *disaster*; +So, in circumstances like these, we don't want to build join points +and push the outer case into the branches of the inner one. Instead, +don't duplicate the continuation. + +When should we use this strategy? We should not use it on *every* +single-alternative case: e.g. case (case ....) of (a,b) -> (# a,b #) - We must push the outer case into the inner one! +Here we must push the outer case into the inner one! Other choices: * Match [(DEFAULT,_,_)], but in the common case of Int, @@ -2286,7 +2316,7 @@ Other choices: the *un-simplified* rhs, which is fine. It might get bigger or smaller after simplification; if it gets smaller, this case might fire next time round. NB also that we must test contIsDupable - case_cont *btoo, because case_cont might be big! + case_cont *too, because case_cont might be big! HOWEVER: I found that this version doesn't work well, because we can get let x = case (...) of { small } in ...case x...