[Git][ghc/ghc][wip/T23109] Two Simplifier optimistaions

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC


Commits:
9d4130f6 by Simon Peyton Jones at 2023-06-21T10:21:06+01:00
Two Simplifier optimistaions

Inline in exprIsConAppMaybe
Inline in postInlineUnconditinally

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -971,7 +971,9 @@ completeBind env bind_cxt old_bndr new_bndr new_rhs
                 -- substitution will happen, since we are going to discard the binding
 
         else -- Keep the binding; do cast worker/wrapper
-             -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $
+             simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr
+                                             , text "occ" <+> ppr occ_info
+                                             , text "eta_rhs" <+> ppr eta_rhs ]) $
              tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs }
 
 addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
@@ -2151,7 +2153,7 @@ simplCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
 simplCall env var cont
   | ClassOpId clas idx _     <- idDetails var
   , Just (env', arg', cont') <- classOpDictApp_maybe env clas idx cont
-  = -- pprTrace "simplCall:classop" (ppr var $$ ppr arg') $
+  = simplTrace "simplCall:classop" (ppr var $$ ppr arg') $
     simplExprF env' arg' cont'
 
   | otherwise


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1537,7 +1537,7 @@ postInlineUnconditionally env bind_cxt bndr occ_info rhs
 
         -> n_br < 100  -- See Note [Suppress exponential blowup]
 
-           && smallEnoughToInline uf_opts unfolding     -- Small enough to dup
+           && (smallEnoughToInline uf_opts unfolding || n_br == 1)     -- Small enough to dup
                         -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
                         --
                         -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1


=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -512,6 +512,12 @@ do_beta_by_substitution bndr rhs
   = exprIsTrivial rhs                   -- Can duplicate
     || safe_to_inline (idOccInfo bndr)  -- Occurs at most once
 
+do_case_elim :: CoreExpr -> Id -> [Id] -> Bool
+do_case_elim scrut case_bndr alt_bndrs
+  =  exprIsHNF scrut
+  && safe_to_inline (idOccInfo case_bndr)
+  && all isDeadBinder alt_bndrs
+
 -------------------
 simple_out_bind :: TopLevelFlag
                 -> SimpleOptEnv
@@ -1290,13 +1296,17 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
          in go subst' (float:floats) expr cont
 
     go subst floats (Case scrut b _ [Alt con vars expr]) cont
+       | do_case_elim scrut' b vars
+       = go (extend subst b scrut') floats expr cont
+       | otherwise
        = let
-          scrut'           = subst_expr subst scrut
           (subst', b')     = subst_bndr subst b
           (subst'', vars') = subst_bndrs subst' vars
           float            = FloatCase scrut' b' con vars'
          in
            go subst'' (float:floats) expr cont
+       where
+          scrut'           = subst_expr subst scrut
 
     go (Right sub) floats (Var v) cont
        = go (Left (getSubstInScope sub))



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9d4130f649066a5e77a5f718782afac024501818

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9d4130f649066a5e77a5f718782afac024501818
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230621/42f46ecc/attachment-0001.html>