[Git][ghc/ghc][wip/simplifier-tweaks] 2 commits: Optimise opt_trans_rule a bit

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC


Commits:
63fd7da2 by Simon Peyton Jones at 2023-07-05T17:39:40+01:00
Optimise opt_trans_rule a bit

This make a significant (5% ish) difference in T13386

- - - - -
87886186 by Simon Peyton Jones at 2023-07-05T20:40:23+01:00
Allow join points to inline a bit more

This makes a big difference in T14697 -- but only because we still
don't have #22404 yet.

The critical function is  in GHC.Driver.CmdLine, and is called
    lgo1_uniq
It is called from `processArgs` when we find a "-" sign.

For some reason this function is called (incl recursive calls)
19,021,947 times in T14967.

- - - - -


2 changed files:

- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs


Changes:

=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -854,15 +854,16 @@ opt_trans_rule is co1 co2
   -- If we put TrPushSymAxR first, we'll get
   --    (axN ty ; sym (axN ty)) :: N ty ~ N ty -- Obviously Refl
   --    --> axN (sym (axN ty))  :: N ty ~ N ty -- Very stupid
-  | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe
-  , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe
-  , con1 == con2
+  | Just (sym1, ax1, ind1, cos1) <- isAxiom_maybe co1
+  , Just (sym2, ax2, ind2, cos2) <- isAxiom_maybe co2
+  , ax1 == ax2
   , ind1 == ind2
   , sym1 == not sym2
-  , let branch = coAxiomNthBranch con1 ind1
-        qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch
-        lhs  = coAxNthLHS con1 ind1
-        rhs  = coAxBranchRHS branch
+  , let branch = coAxiomNthBranch ax1 ind1
+        role   = coAxiomRole ax1
+        qtvs   = coAxBranchTyVars branch ++ coAxBranchCoVars branch
+        lhs    = coAxNthLHS ax1 ind1
+        rhs    = coAxBranchRHS branch
         pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)
   , all (`elemVarSet` pivot_tvs) qtvs
   = fireTransRule "TrPushAxSym" co1 co2 $
@@ -875,7 +876,7 @@ opt_trans_rule is co1 co2
   -- See Note [Push transitivity inside axioms] and
   -- Note [Push transitivity inside newtype axioms only]
   -- TrPushSymAxR
-  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
+  | Just (sym, con, ind, cos1) <- isAxiom_maybe co1
   , isNewTyCon (coAxiomTyCon con)
   , True <- sym
   , Just cos2 <- matchAxiom sym con ind co2
@@ -883,7 +884,7 @@ opt_trans_rule is co1 co2
   = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst
 
   -- TrPushAxR
-  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
+  | Just (sym, con, ind, cos1) <- isAxiom_maybe co1
   , isNewTyCon (coAxiomTyCon con)
   , False <- sym
   , Just cos2 <- matchAxiom sym con ind co2
@@ -891,7 +892,7 @@ opt_trans_rule is co1 co2
   = fireTransRule "TrPushAxR" co1 co2 newAxInst
 
   -- TrPushSymAxL
-  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
+  | Just (sym, con, ind, cos2) <- isAxiom_maybe co2
   , isNewTyCon (coAxiomTyCon con)
   , True <- sym
   , Just cos1 <- matchAxiom (not sym) con ind co1
@@ -899,17 +900,13 @@ opt_trans_rule is co1 co2
   = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst
 
   -- TrPushAxL
-  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
+  | Just (sym, con, ind, cos2) <- isAxiom_maybe co2
   , isNewTyCon (coAxiomTyCon con)
   , False <- sym
   , Just cos1 <- matchAxiom (not sym) con ind co1
   , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
   = fireTransRule "TrPushAxL" co1 co2 newAxInst
 
-  where
-    co1_is_axiom_maybe = isAxiom_maybe co1
-    co2_is_axiom_maybe = isAxiom_maybe co2
-    role = coercionRole co1 -- should be the same as coercionRole co2!
 
 opt_trans_rule _ co1 co2        -- Identity rule
   | let ty1 = coercionLKind co1
@@ -1159,11 +1156,13 @@ chooseRole _    r = r
 
 -----------
 isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])
-isAxiom_maybe (SymCo co)
-  | Just (sym, con, ind, cos) <- isAxiom_maybe co
-  = Just (not sym, con, ind, cos)
-isAxiom_maybe (AxiomInstCo con ind cos)
-  = Just (False, con, ind, cos)
+-- We don't expect to see nested SymCo; and that lets us write a simple,
+-- non-recursive function. (If we see a nested SymCo we'll just fail,
+-- which is ok.)
+isAxiom_maybe (SymCo (AxiomInstCo ax ind cos))
+  = Just (True, ax, ind, cos)
+isAxiom_maybe (AxiomInstCo ax ind cos)
+  = Just (False, ax, ind, cos)
 isAxiom_maybe _ = Nothing
 
 matchAxiom :: Bool -- True = match LHS, False = match RHS


=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -4311,7 +4311,7 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
     in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs
   where
     too_many_occs (ManyOccs {})             = True
-    too_many_occs (OneOcc { occ_n_br = n }) = n > 4
+    too_many_occs (OneOcc { occ_n_br = n }) = n > 10
     too_many_occs IAmDead                   = False
     too_many_occs (IAmALoopBreaker {})      = False
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/99d011f850d8d5bc408e2e7abfb955554f869738...878861860bb1bd78d78f2f76cd8bb190b23f64ed

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/99d011f850d8d5bc408e2e7abfb955554f869738...878861860bb1bd78d78f2f76cd8bb190b23f64ed
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/20230705/7af27ae8/attachment-0001.html>