X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=4c1b6cb07bdd31eae1192066afd9e9907ad43878;hb=5178da7f966c810c3d64fee02c1161406f9ac1d2;hp=5e632211aabd6834e0004637cf0f794b7c263388;hpb=367e603d0136436e783ff9ed610809bf87376262;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 5e63221..4c1b6cb 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -18,12 +18,13 @@ import Id import MkId ( mkImpossibleExpr, seqId ) import Var import IdInfo -import Name ( mkSystemVarName ) +import Name ( mkSystemVarName, isExternalName ) import Coercion 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(..) ) @@ -35,8 +36,7 @@ import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRuleLoopBreaker ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM ) import Maybes ( orElse ) import Data.List ( mapAccumL ) @@ -214,8 +214,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 } @@ -443,33 +442,34 @@ prepareRhs env id (Cast rhs co) -- Note [Float coercions] = do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs ; return (env', Cast rhs' co) } where - sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info - `setNewDemandInfo` newDemandInfo info + sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setDemandInfo` demandInfo info info = idInfo id prepareRhs env0 _ rhs0 - = do { (_is_val, env1, rhs1) <- go 0 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 + = do { (is_exp, env', fun') <- go (n_val_args+1) env fun + ; case is_exp of True -> do { (env'', arg') <- makeTrivial 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} @@ -597,7 +597,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 @@ -645,7 +646,7 @@ 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, @@ -661,7 +662,7 @@ 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] @@ -670,21 +671,28 @@ simplUnfolding env _ _ _ _ (DFunUnfolding con ops) where ops' = map (CoreSubst.substExpr (mkCoreSubst 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 (updMode updModeForInlineRules env) expr - -- See Note [Simplifying gently inside InlineRules] in SimplUtils - ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide) - ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity - (guide { ir_info = mb_wkr' })) } + , uf_src = src, uf_guidance = guide }) + | isInlineRuleSource src + = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $ + do { expr' <- simplExpr rule_env expr + ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst 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] @@ -870,7 +878,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 @@ -879,8 +887,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} @@ -1120,19 +1129,13 @@ completeCall env var cont 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 + unfolding = activeUnfolding env var + maybe_inline = callSiteInline dflags var unfolding + (null args) arg_infos interesting_cont ; case maybe_inline of { Just unfolding -- 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) + ; trace_inline dflags unfolding args call_cont $ simplExprF (zapSubstEnv env) unfolding cont } ; Nothing -> do -- No inlining! @@ -1141,6 +1144,19 @@ completeCall env var cont ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont ; rebuildCall env info cont }}} + where + trace_inline dflags unfolding args call_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 "Before:" <+> ppr var <+> sep (map pprParendExpr args), + text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr call_cont]) + stuff rebuildCall :: SimplEnv -> ArgInfo @@ -1265,20 +1281,26 @@ 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 (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] @@ -1412,7 +1434,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) @@ -1466,7 +1488,7 @@ 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. @@ -1720,7 +1742,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 @@ -1944,7 +1966,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 needSaturated rhs 0 rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs')