X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=df80c4a66e6dd978e676436609d677e3adf60650;hb=491b818a4a9bd2160107178499e160d62933f58c;hp=9e73359143f159bf56b72eb8ee28c228123c6c49;hpb=fb982282ff6307b342d8fbc09b58a990d76c68fb;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 9e73359..df80c4a 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -24,16 +24,16 @@ import Coercion import OptCoercion ( optCoercion ) import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) -import CoreMonad ( SimplifierSwitch(..), Tick(..) ) +import CoreMonad ( Tick(..), SimplifierMode(..) ) import CoreSyn -import Demand ( isStrictDmd, splitStrictSig ) +import Demand ( isStrictDmd ) import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkUnfolding, mkCoreUnfolding , mkInlineUnfolding, mkSimpleUnfolding , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils import qualified CoreSubst -import CoreArity ( exprArity ) +import CoreArity import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) @@ -237,7 +237,7 @@ simplTopBinds env0 binds0 trace_bind False _ = \x -> x simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs - simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r + simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r where (env', b') = addBndrRules env b (lookupRecBndr env b) \end{code} @@ -272,7 +272,7 @@ simplRecBind env0 top_lvl pairs0 go env [] = return env go env ((old_bndr, new_bndr, rhs) : pairs) - = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs + = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs ; go env' pairs } \end{code} @@ -284,18 +284,17 @@ It assumes the binder has already been simplified, but not its IdInfo. \begin{code} simplRecOrTopPair :: SimplEnv - -> TopLevelFlag + -> TopLevelFlag -> RecFlag -> InId -> OutBndr -> InExpr -- Binder and rhs -> SimplM SimplEnv -- Returns an env that includes the binding -simplRecOrTopPair env top_lvl old_bndr new_bndr rhs +simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline = do { tick (PreInlineUnconditionally old_bndr) ; return (extendIdSubst env old_bndr (mkContEx env rhs)) } | otherwise - = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env - -- May not actually be recursive, but it doesn't matter + = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env \end{code} @@ -629,21 +628,41 @@ completeBind :: SimplEnv -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs - = do { let old_info = idInfo old_bndr - old_unf = unfoldingInfo old_info - occ_info = occInfo old_info + = ASSERT( isId new_bndr ) + do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info - ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in SimplUtils + ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs - ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding + -- Simplify the unfolding + ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info final_rhs old_unf + + ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding -- Inline and discard the binding - then do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $ - return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + then do { tick (PostInlineUnconditionally old_bndr) + ; -- pprTrace "postInlineUnconditionally" + -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $ + return (extendIdSubst env old_bndr (DoneEx final_rhs)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding + else + do { let info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unfolding + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 + | otherwise = info2 + + final_id = new_bndr `setIdInfo` info3 - else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) } + ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + return (addNonRec env final_id final_rhs) } } + -- The addNonRec adds it to the in-scope set too ------------------------------ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv @@ -662,44 +681,17 @@ addPolyBind top_lvl env (NonRec poly_id rhs) = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding -- Assumes that poly_id did not have an INLINE prag -- which is perhaps wrong. ToDo: think about this - ; return (addNonRecWithUnf env poly_id rhs unfolding) } + ; let final_id = setIdInfo poly_id $ + idInfo poly_id `setUnfoldingInfo` unfolding + `setArityInfo` exprArity rhs -addPolyBind _ env bind@(Rec _) = return (extendFloats env bind) - -- Hack: letrecs are more awkward, so we extend "by steam" - -- without adding unfoldings etc. At worst this leads to - -- more simplifier iterations + ; return (addNonRec env final_id rhs) } ------------------------------- -addNonRecWithUnf :: SimplEnv - -> OutId -> OutExpr -- New binder and RHS - -> Unfolding -- New unfolding - -> SimplEnv -addNonRecWithUnf env new_bndr new_rhs new_unfolding - = let new_arity = exprArity new_rhs - old_arity = idArity new_bndr - info1 = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info: Note [Setting the new unfolding] - info2 = info1 `setUnfoldingInfo` new_unfolding - - -- Demand info: Note [Setting the demand info] - info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 - | otherwise = info2 - - final_id = new_bndr `setIdInfo` info3 - 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) $$ ppr new_rhs) ) - -- Note [Arity decrease] - - final_id `seq` -- This seq forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ - addNonRec env final_id new_rhs - -- The addNonRec adds it to the in-scope set too +addPolyBind _ env bind@(Rec _) + = return (extendFloats env bind) + -- Hack: letrecs are more awkward, so we extend "by steam" + -- without adding unfoldings etc. At worst this leads to + -- more simplifier iterations ------------------------------ simplUnfolding :: SimplEnv-> TopLevelFlag @@ -718,15 +710,30 @@ simplUnfolding env top_lvl id _ _ | 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) } + is_top_lvl = isTopLevel top_lvl + ; case guide of + UnfIfGoodArgs{} -> + -- We need to force bottoming, or the new unfolding holds + -- on to the old unfolding (which is part of the id). + let bottoming = isBottomingId id + in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr') + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + _other -> + return (mkCoreUnfolding src' is_top_lvl expr' arity guide) -- See Note [Top-level flag on inline rules] in CoreUnfold + } where act = idInlineActivation id rule_env = updMode (updModeForInlineRules act) env -- See Note [Simplifying inside InlineRules] in SimplUtils simplUnfolding _ top_lvl id _occ_info new_rhs _ - = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs) + = -- We need to force bottoming, or the new unfolding holds + -- on to the old unfolding (which is part of the id). + let bottoming = isBottomingId id + in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming 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 @@ -867,22 +874,26 @@ simplExprF' env (App fun arg) cont = simplExprF env fun $ ApplyTo NoDup arg env cont simplExprF' env expr@(Lam _ _) cont - = simplLam env (map zap bndrs) body cont + = simplLam env zapped_bndrs body cont -- The main issue here is under-saturated lambdas -- (\x1. \x2. e) arg1 -- Here x1 might have "occurs-once" occ-info, because occ-info -- is computed assuming that a group of lambdas is applied -- all at once. If there are too few args, we must zap the - -- occ-info. + -- occ-info, UNLESS the remaining binders are one-shot where - n_args = countArgs cont - n_params = length bndrs (bndrs, body) = collectBinders expr - zap | n_args >= n_params = \b -> 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) + zapped_bndrs | need_to_zap = map zap bndrs + | otherwise = bndrs + + need_to_zap = any zappable_bndr (drop n_args bndrs) + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyCoVar b = b + | otherwise = zapLamIdInfo b simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) @@ -890,7 +901,7 @@ simplExprF' env (Type ty) cont ; rebuild env (Type ty') cont } simplExprF' env (Case scrut bndr _ alts) cont - | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) + | sm_case_case (getMode env) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -942,9 +953,8 @@ simplCoercion env co rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -- At this point the substitution in the SimplEnv should be irrelevant -- only the in-scope set and floats should matter -rebuild env expr cont0 - = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $ - case cont0 of +rebuild env expr cont + = case cont of 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 @@ -1344,7 +1354,7 @@ tryRules env rules fn args call_cont ; case activeRule dflags env of { Nothing -> return Nothing ; -- No rules apply Just act_fn -> - case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of { + case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> @@ -1497,7 +1507,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 (activeUnfInRule env) scrut + | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch 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)