X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=f8462be79fccc3dd4f1ab0ac841dfcc4fb712929;hb=e97df85e14fa5b088fcfee0c2acbd961869e05fe;hp=1f691eaa437b5f8718e9ef75aa715f11868676df;hpb=40b82d31494eabb51ef2eb47d6e6191e0db764fd;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1f691ea..f8462be 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -18,6 +18,7 @@ import Id import MkId ( mkImpossibleExpr, seqId ) import Var import IdInfo +import Name ( mkSystemVarName ) import Coercion import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) @@ -335,10 +336,9 @@ 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 body_env1 bndr1 body1 ; (env', rhs') <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) @@ -384,7 +384,7 @@ completeNonRecX :: SimplEnv -> SimplM SimplEnv completeNonRecX env is_strict old_bndr new_bndr new_rhs - = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs + = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet @@ -435,15 +435,19 @@ 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 :: 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 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 env sanitised_info rhs ; return (env', Cast rhs' co) } + where + sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info + `setNewDemandInfo` newDemandInfo info + info = idInfo id -prepareRhs env0 rhs0 +prepareRhs env0 _ rhs0 = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0 ; return (env1, rhs1) } where @@ -493,6 +497,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. @@ -513,16 +528,19 @@ These strange casts can happen as a result of case-of-case \begin{code} makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial env expr +makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr + +makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Propagate strictness and demand info to the new binder +-- Note [Preserve strictness when floating coercions] +makeTrivialWithInfo env info expr | exprIsTrivial expr = return (env, expr) | otherwise -- See Note [Take care] below - = do { var <- newId (fsLit "a") (exprType expr) + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "a") + var = mkLocalIdWithInfo name (exprType expr) info ; 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 -- a = rhs @@ -632,7 +650,7 @@ addNonRecWithUnf env new_bndr new_rhs new_unfolding 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 ) + <+> ppr new_arity <+> ppr dmd_arity) ) -- Note [Arity decrease] final_id `seq` -- This seq forces the Id, and hence its IdInfo, @@ -655,10 +673,11 @@ simplUnfolding env _ _ _ _ (DFunUnfolding con ops) simplUnfolding env top_lvl _ _ _ (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) + = do { expr' <- simplExpr (setMode simplGentlyForInlineRules 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 { ug_ir_info = mb_wkr' })) } + (guide { ir_info = mb_wkr' })) } -- See Note [Top-level flag on inline rules] in CoreUnfold simplUnfolding _ top_lvl _ occ_info new_rhs _ @@ -1189,8 +1208,8 @@ rebuildCall env fun ; rebuildCall env (fun `App` arg') arg_info' 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 + cci | has_rules || disc > 0 = ArgCtxt has_rules -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting rebuildCall env fun _ cont = rebuild env fun cont @@ -1450,7 +1469,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' - = -- For this case, see Note [Rules for seq] in MkId + = -- For this case, see Note [User-defined RULES for seq] in MkId do { let rhs' = substExpr env rhs out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] @@ -1518,7 +1537,7 @@ much always zap the OccInfo of the binders. It doesn't matter much though. Note [Case of cast] ~~~~~~~~~~~~~~~~~~~ -Consider case (v `cast` co) of x { I# -> +Consider case (v `cast` co) of x { I# y -> ... (case (v `cast` co) of {...}) ... We'd like to eliminate the inner case. We can get this neatly by arranging that inside the outer case we add the unfolding @@ -1539,10 +1558,31 @@ where x::F Int. Then we'd like to rewrite (F Int) to Int, getting I# x# -> let x = x' `cast` sym co in rhs -so that 'rhs' can take advantage of the form of x'. Notice that Note -[Case of cast] may then apply to the result. - -This showed up in Roman's experiments. Example: +so that 'rhs' can take advantage of the form of x'. + +Notice that Note [Case of cast] may then apply to the result. + +Nota Bene: We only do the [Improving seq] transformation if the +case binder 'x' is actually used in the rhs; that is, if the case +is *not* a *pure* seq. + a) There is no point in adding the cast to a pure seq. + b) There is a good reason not to: doing so would interfere + with seq rules (Note [Built-in RULES for seq] in MkId). + In particular, this [Improving seq] thing *adds* a cast + while [Built-in RULES for seq] *removes* one, so they + just flip-flop. + +You might worry about + case v of x { __DEFAULT -> + ... case (v `cast` co) of y { I# -> ... }} +This is a pure seq (since x is unused), so [Improving seq] won't happen. +But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get + case v of x { __DEFAULT -> + ... case (x `cast` co) of y { I# -> ... }} +Now the outer case is not a pure seq, so [Improving seq] will happen, +and then the inner case will disappear. + +The need for [Improving seq] showed up in Roman's experiments. Example: foo :: F Int -> Int -> Int foo t n = t `seq` bar n where @@ -1551,11 +1591,9 @@ This showed up in Roman's experiments. Example: Here we'd like to avoid repeated evaluating t inside the loop, by taking advantage of the `seq`. -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.) - - +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} @@ -1564,39 +1602,15 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 + | 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}