[Git][ghc/ghc][wip/simplifier-tweaks] Two improvements to coercion optimisation

[Simon Peyton Jones (@simonpj)]

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


Commits:
74d7ab44 by Simon Peyton Jones at 2023-06-29T22:31:52+01:00
Two improvements to coercion optimisation

One (mkSymCo) makes a big difference in GHC.Read
The other (in zapSubstEnv) makes a big diffference in T18223

- - - - -


3 changed files:

- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Utils.hs


Changes:

=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1126,12 +1126,17 @@ mkUnivCo prov role ty1 ty2
 --   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1 at .
 mkSymCo :: Coercion -> Coercion
 
--- Do a few simple optimizations, but don't bother pushing occurrences
--- of symmetry to the leaves; the optimizer will take care of that.
-mkSymCo co | isReflCo co          = co
-mkSymCo    (SymCo co)             = co
-mkSymCo    (SubCo (SymCo co))     = SubCo co
-mkSymCo co                        = SymCo co
+-- Do a few simple optimizations, mainly to expose the underlying
+-- constructors to other 'mk' functions.  E.g.
+--   mkInstCo (mkSymCo (ForAllCo ...)) ty
+-- We want to push the SymCo inside the ForallCo, so that we can instantiate
+-- This can make a big difference.  E.g without coercion optimisation, GHC.Read
+-- totally explodes; but when we push Sym inside ForAll, it's fine.
+mkSymCo co | isReflCo co       = co
+mkSymCo (SymCo co)             = co
+mkSymCo (SubCo (SymCo co))     = SubCo co
+mkSymCo (ForAllCo tcv kco co)  = ForAllCo tcv (mkSymCo kco) (mkSymCo co)
+mkSymCo co                     = SymCo co
 
 -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
 --   (co1 ; co2)


=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -74,6 +74,7 @@ import GHC.Core.Type hiding     ( substTy, substTyVar, substTyVarBndr, substCo
                                 , extendTvSubst, extendCvSubst )
 import qualified GHC.Core.Coercion as Coercion
 import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )
+import GHC.Core.Coercion.Opt( OptCoercionOpts(..) )
 import GHC.Platform ( Platform )
 import GHC.Types.Basic
 import GHC.Utils.Monad
@@ -616,7 +617,11 @@ setInScopeFromE.
 
 ---------------------
 zapSubstEnv :: SimplEnv -> SimplEnv
-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+zapSubstEnv env@(SimplEnv { seMode = mode })
+  = env { seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv
+        , seMode = mode { sm_co_opt_opts = OptCoercionOpts False } }
+    -- Zapping coercion optimisation here saves a /lot/ in T18223;
+    -- reduces compiled time allocation by more than 50%
 
 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }


=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -263,41 +263,29 @@ mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)
 -- | Wrap the given expression in the coercion safely, dropping
 -- identity coercions and coalescing nested coercions
 mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr
-mkCast e co
-  | assertPpr (coercionRole co == Representational)
-              (text "coercion" <+> ppr co <+> text "passed to mkCast"
-               <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co)) $
-    isReflCo co
-  = e
-
-mkCast (Coercion e_co) co
-  | isCoVarType (coercionRKind co)
-       -- The guard here checks that g has a (~#) on both sides,
-       -- otherwise decomposeCo fails.  Can in principle happen
-       -- with unsafeCoerce
-  = Coercion (mkCoCast e_co co)
-
-mkCast (Cast expr co2) co
-  = warnPprTrace (let { from_ty = coercionLKind co;
-                        to_ty2  = coercionRKind co2 } in
-                     not (from_ty `eqType` to_ty2))
-             "mkCast"
-             (vcat ([ text "expr:" <+> ppr expr
-                   , text "co2:" <+> ppr co2
-                   , text "co:" <+> ppr co ])) $
-    mkCast expr (mkTransCo co2 co)
-
-mkCast (Tick t expr) co
-   = Tick t (mkCast expr co)
 
 mkCast expr co
-  = let from_ty = coercionLKind co in
-    warnPprTrace (not (from_ty `eqType` exprType expr))
+  = {- assertPpr (coercionRole co == Representational)
+              (text "coercion" <+> ppr co <+> text "passed to mkCast"
+               <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $
+    warnPprTrace (not (coercionLKind co `eqType` exprType expr))
           "Trying to coerce" (text "(" <> ppr expr
           $$ text "::" <+> ppr (exprType expr) <> text ")"
           $$ ppr co $$ ppr (coercionType co)
           $$ callStackDoc) $
-    (Cast expr co)
+    -}
+    case expr of
+      Cast expr co2 -> mkCast expr (mkTransCo co2 co)
+      Tick t expr   -> Tick t (mkCast expr co)
+
+      Coercion e_co | isCoVarType (coercionRKind co)
+         -- The guard here checks that g has a (~#) on both sides,
+         -- otherwise decomposeCo fails.  Can in principle happen
+         -- with unsafeCoerce
+                      -> Coercion (mkCoCast e_co co)
+
+      _ | isReflCo co -> expr
+        | otherwise   -> Cast expr co
 
 
 {- *********************************************************************



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74d7ab44eb2803994c5ec7cbffaf095805b4d031

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74d7ab44eb2803994c5ec7cbffaf095805b4d031
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/20230629/d7fa41e0/attachment-0001.html>