diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/MkId.hs | 40 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 138 |
2 files changed, 82 insertions, 96 deletions
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 6be2b5cbba..08b9efa54f 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -1189,7 +1189,6 @@ seqId = pcMiscPrelId seqName ty info where info = noCafIdInfo `setInlinePragInfo` inline_prag `setUnfoldingInfo` mkCompulsoryUnfolding rhs - `setRuleInfo` mkRuleInfo [seq_cast_rule] `setNeverLevPoly` ty inline_prag @@ -1206,28 +1205,6 @@ seqId = pcMiscPrelId seqName ty info [x,y] = mkTemplateLocals [alphaTy, betaTy] rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) - -- See Note [Built-in RULES for seq] - -- NB: ru_nargs = 3, not 4, to match the code in - -- Simplify.rebuildCase which tries to apply this rule - seq_cast_rule = BuiltinRule { ru_name = fsLit "seq of cast" - , ru_fn = seqName - , ru_nargs = 3 - , ru_try = match_seq_of_cast } - -match_seq_of_cast :: RuleFun - -- See Note [Built-in RULES for seq] -match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co] - = Just (fun `App` scrut) - where - fun = Lam x $ Lam y $ - Case (Var x) x res_ty [(DEFAULT,[],Var y)] - -- Generate a Case directly, not a call to seq, which - -- might be ill-kinded if res_ty is unboxed - [x,y] = mkTemplateLocals [scrut_ty, res_ty] - scrut_ty = pFst (coercionKind co) - -match_seq_of_cast _ _ _ _ = Nothing - ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info @@ -1372,7 +1349,7 @@ enough support that you can do this using a rewrite rule: You write that rule. When GHC sees a case expression that discards its result, it mentally transforms it to a call to 'seq' and looks for -a RULE. (This is done in Simplify.rebuildCase.) As usual, the +a RULE. (This is done in Simplify.trySeqRules.) As usual, the correctness of the rule is up to you. VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. @@ -1387,21 +1364,6 @@ with rule arity 2, then two bad things would happen: - The code in Simplify.rebuildCase would need to actually supply the value argument, which turns out to be awkward. -Note [Built-in RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also have the following built-in rule for seq - - seq (x `cast` co) y = seq x y - -This eliminates unnecessary casts and also allows other seq rules to -match more often. Notably, - - seq (f x `cast` co) y --> seq (f x) y - -and now a user-defined rule for seq (see Note [User-defined RULES for seq]) -may fire. - - Note [lazyId magic] ~~~~~~~~~~~~~~~~~~~ lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index e2782d7492..fe8c578106 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -1763,11 +1763,9 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) = do { -- We've accumulated a simplified call in <fun,rev_args> -- so try rewrite rules; see Note [RULEs apply to simplified arguments] -- See also Note [Rules for recursive functions] - ; let env' = zapSubstEnv env -- See Note [zapSubstEnv]; - -- and NB that 'rev_args' are all fully simplified - ; mb_rule <- tryRules env' rules fun (reverse rev_args) cont + mb_rule <- tryRules env rules fun (reverse rev_args) cont ; case mb_rule of { - Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' -- Rules don't match ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules @@ -1829,9 +1827,9 @@ all this at once is TOO HARD! -} tryRules :: SimplEnv -> [CoreRule] - -> Id -> [ArgSpec] -> SimplCont - -> SimplM (Maybe (CoreExpr, SimplCont)) --- The SimplEnv already has zapSubstEnv applied to it + -> Id -> [ArgSpec] + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) tryRules env rules fn args call_cont | null rules @@ -1866,7 +1864,7 @@ tryRules env rules fn args call_cont ; return Nothing } ; -- No rule matches Just (rule, rule_rhs) -> do { checkedTick (RuleFired (ruleName rule)) - ; let cont' = pushSimplifiedArgs env + ; let cont' = pushSimplifiedArgs zapped_env (drop (ruleArity rule) args) call_cont -- (ruleArity rule) says how @@ -1875,8 +1873,12 @@ tryRules env rules fn args call_cont occ_anald_rhs = occurAnalyseExpr rule_rhs -- See Note [Occurrence-analyse after rule firing] ; dump dflags rule rule_rhs - ; return (Just (occ_anald_rhs, cont')) }}} + ; return (Just (zapped_env, occ_anald_rhs, cont')) }}} + -- The occ_anald_rhs and cont' are all Out things + -- hence zapping the environment where + zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + printRuleModule rule = parens (maybe (text "BUILTIN") (pprModuleName . moduleName) (ruleModule rule)) @@ -1912,7 +1914,48 @@ tryRules env rules fn args call_cont = liftIO . dumpSDoc dflags alwaysQualify flag "" $ sep [text hdr, nest 4 details] -{- Note [Occurrence-analyse after rule firing] +trySeqRules :: SimplEnv + -> OutExpr -> InExpr -- Scrutinee and RHS + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) +-- See Note [User-defined RULES for seq] +trySeqRules in_env scrut rhs cont + = do { rule_base <- getSimplRules + ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } + where + no_cast_scrut = drop_casts scrut + scrut_ty = exprType no_cast_scrut + seq_id_ty = idType seqId + rhs_ty = substTy in_env (exprType rhs) + out_args = [ TyArg { as_arg_ty = scrut_ty + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = piResultTy seq_id_ty scrut_ty } + , ValArg no_cast_scrut] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = in_env, sc_cont = cont } + -- Lazily evaluated, so we don't do most of this + + drop_casts (Cast e _) = drop_casts e + drop_casts e = e + +{- Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + case (scrut |> co) of _ -> rhs +look for rules that match the expression + seq @t1 @t2 scrut +where scrut :: t1 + rhs :: t2 + +If you find a match, rewrite it, and apply to 'rhs'. + +Notice that we can simply drop casts on the fly here, which +makes it more likely that a rule will match. + +See Note [User-defined RULES for seq] in MkId. + +Note [Occurrence-analyse after rule firing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ After firing a rule, we occurrence-analyse the instantiated RHS before simplifying it. Usually this doesn't make much difference, but it can @@ -2261,28 +2304,14 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont -- b) a rule for seq applies -- See Note [User-defined RULES for seq] in MkId | is_plain_seq - = do { let scrut_ty = exprType scrut - rhs_ty = substTy env (exprType rhs) - out_args = [ TyArg { as_arg_ty = scrut_ty - , as_hole_ty = seq_id_ty } - , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = piResultTy seq_id_ty scrut_ty } - , ValArg scrut] - rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs - , sc_env = env, sc_cont = cont } - env' = zapSubstEnv env - -- Lazily evaluated, so we don't do most of this - - ; rule_base <- getSimplRules - ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args rule_cont + = do { mb_rule <- trySeqRules env scrut rhs cont ; case mb_rule of - Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } where is_unlifted = isUnliftedType (idType case_bndr) all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect - seq_id_ty = idType seqId scrut_is_demanded_var :: CoreExpr -> Bool -- See Note [Eliminating redundant seqs] @@ -2356,37 +2385,33 @@ Consider type family F :: * -> * type instance F Int = Int - ... case e of x { DEFAULT -> rhs } ... - -where x::F Int. Then we'd like to rewrite (F Int) to Int, getting - - case e `cast` co of x'::Int +We'd like to transform + case e of (x :: F Int) { DEFAULT -> rhs } +===> + case e `cast` co of (x'::Int) 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] (in OccurAnal) 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. +so that 'rhs' can take advantage of the form of x'. Notice that Note +[Case of cast] (in OccurAnal) may then apply to the result. + +We'd also like to eliminate empty types (Trac #13468). So if + + data Void + type instance F Bool = Void + +then we'd like to transform + case (x :: F Bool) of { _ -> error "urk" } +===> + case (x |> co) of (x' :: Void) of {} + +Nota Bene: we used to have a built-in rule for 'seq' that dropped +casts, so that + case (x |> co) of { _ -> blah } +dropped the cast; in order to imporove the chances of trySeqRules +firing. But that works in the /opposite/ direction to Note [Improving +seq] so there's a danger of flip/flopping. Better to make trySeqRules +insensitive to the cast, which is now is. The need for [Improving seq] showed up in Roman's experiments. Example: foo :: F Int -> Int -> Int @@ -2439,8 +2464,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -> 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 Note [Improving seq] - , Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) env2 = extendIdSubst env case_bndr rhs |