[Git][ghc/ghc][wip/dmdanal-precise-exn] Performance tweaks for tryClearPreciseException

[Sebastian Graf]

Sebastian Graf pushed to branch wip/dmdanal-precise-exn at Glasgow Haskell Compiler / GHC


Commits:
29822102 by Sebastian Graf at 2020-03-31T18:23:07+02:00
Performance tweaks for tryClearPreciseException

Apparently the function wasn't really responsible for regressing T12545.
Maybe it's the fact that we have to serialise more stuff to the
interface file, I don't know.

- - - - -


2 changed files:

- compiler/GHC/Core/Op/DmdAnal.hs
- compiler/GHC/Types/Demand.hs


Changes:

=====================================
compiler/GHC/Core/Op/DmdAnal.hs
=====================================
@@ -338,9 +338,9 @@ dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
 -- precise exception guarantees are off the table.
 -- See Note [Precise exceptions and strictness analysis] in Demand.hs
 mayThrowPreciseException :: FamInstEnvs -> Type -> DmdType -> Bool
-mayThrowPreciseException _        _  (DmdType _ _ ConOrDiv) = False
-mayThrowPreciseException _        _  (DmdType _ _ Diverges) = False
-mayThrowPreciseException fam_envs ty _                      = forcesRealWorld fam_envs ty
+mayThrowPreciseException fam_envs ty dmd_ty
+  | not (mayThrowPreciseDmdType dmd_ty) = False
+  | otherwise                           = pprTrace "mayThrow" (ppr ty) $ forcesRealWorld fam_envs ty
 
 -- | Whether a 'seqDmd' on an expression of the given type may force
 -- @State# RealWorld@, incurring a side-effect (ignoring unsafe shenigans like
@@ -374,6 +374,8 @@ forcesRealWorld fam_envs = go initRecTc
 -- precise excpetions.
 tryClearPreciseException :: FamInstEnvs -> Type -> StrictSig -> StrictSig
 tryClearPreciseException fam_envs ty sig@(StrictSig dmd_ty@(DmdType fvs args div))
+  | not (mayThrowPreciseDmdType dmd_ty) -- Why bother clearing if there is nothing to clear?
+  = sig
   | (arg_tys, res_ty) <- splitPiTys ty
   , args `equalLength` filter (not . isNamedBinder) arg_tys
   , mayThrowPreciseException fam_envs res_ty dmd_ty


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.Types.Demand (
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
         emptyDmdType, botDmdType, mkDmdType, addDemand,
+        mayThrowPreciseDmdType,
 
         DmdEnv, emptyDmdEnv,
         peelFV, findIdDemand,
@@ -1277,6 +1278,11 @@ isTopDmdType (DmdType env [] Dunno)
   | isEmptyVarEnv env = True
 isTopDmdType _                        = False
 
+mayThrowPreciseDmdType :: DmdType -> Bool
+mayThrowPreciseDmdType (DmdType _ _ Dunno)    = True
+mayThrowPreciseDmdType (DmdType _ _ ExnOrDiv) = True
+mayThrowPreciseDmdType _                      = False
+
 mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType
 mkDmdType fv ds res = DmdType fv ds res
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/298221029c18c2b2831c07bda03d2e2954eabf7a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/298221029c18c2b2831c07bda03d2e2954eabf7a
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/20200331/fcf63258/attachment-0001.html>