[Git][ghc/ghc][wip/dmdanal-precise-exn] Fix the perf regression in T12227/T12545

Sebastian Graf gitlab at gitlab.haskell.org
Wed Apr 8 09:48:09 UTC 2020



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


Commits:
fcd81dbc by Sebastian Graf at 2020-04-08T11:47:45+02:00
Fix the perf regression in T12227/T12545

But now T9233 fails because we are doing more work. Temporarily marking
as accepted increase.

Metric Increase:
    T9233

Metric Decrease:
    hie002

- - - - -


4 changed files:

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


Changes:

=====================================
compiler/GHC/Core/Op/DmdAnal.hs
=====================================
@@ -27,6 +27,7 @@ import Data.List        ( mapAccumL )
 import GHC.Core.DataCon
 import GHC.Types.Id
 import GHC.Types.Id.Info
+import GHC.Core.Arity ( typeArity )
 import GHC.Core.Utils
 import GHC.Core.TyCon
 import GHC.Core.Type
@@ -152,7 +153,7 @@ dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
 dmdAnal' _ _ (Lit lit)     = (emptyDmdType conDiv, Lit lit)
 dmdAnal' _ _ (Type ty)     = (emptyDmdType conDiv, Type ty) -- Doesn't happen, in fact
 dmdAnal' _ _ (Coercion co)
-  = (unitDmdType (coercionDmdEnv co), Coercion co)
+  = (DmdType (coercionDmdEnv co) [] conDiv, Coercion co)
 
 dmdAnal' env dmd (Var var)
   = (dmdTransform env var dmd, Var var)
@@ -410,7 +411,7 @@ forcesRealWorld fam_envs = go initRecTc
       -- search depth-first
       | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }
           <- deepSplitProductType_maybe fam_envs ty
-      -- don't check the same TyCon twice
+      -- don't check the same TyCon more than n times
       , Just rec_tc' <- checkRecTc rec_tc (dataConTyCon dc)
       = any (strict_field_forces rec_tc') field_tys
       | otherwise
@@ -510,27 +511,63 @@ dmdTransform :: AnalEnv         -- The strictness environment
         -- this function plus demand on its free variables
 
 dmdTransform env var dmd
-  | isDataConWorkId var                          -- Data constructor
+  -- Data constructors
+  | isDataConWorkId var
   = dmdTransformDataConSig (idArity var) (idStrictness var) dmd
-
+  -- Dictionary component selectors
   | gopt Opt_DmdTxDictSel (ae_dflags env),
-    Just _ <- isClassOpId_maybe var -- Dictionary component selector
+    Just _ <- isClassOpId_maybe var
   = dmdTransformDictSelSig (idStrictness var) dmd
-
-  | isGlobalId var                               -- Imported function
-  , let res = dmdTransformSig (idStrictness var) dmd
-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
+  -- Imported functions
+  | isGlobalId var
+  , let res = dmdTransformSig (globalIdStrictness env var) dmd
+  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr (globalIdStrictness var), ppr dmd, ppr res])
     res
-
-  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
+  -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').
+  -- In that case, we have a strictness signature to unleash in our AnalEnv.
+  | Just (sig, top_lvl) <- lookupSigEnv env var
   , let fn_ty = dmdTransformSig sig dmd
-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
+  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
     if isTopLevel top_lvl
-    then fn_ty   -- Don't record top level things
+    then fn_ty   -- Don't record demand on top-level things
     else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
-
-  | otherwise                                    -- Local non-letrec-bound thing
-  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
+  -- Everything else:
+  --   * Local let binders for which we use LetUp (cf. 'useLetUp')
+  --   * Lambda binders
+  --   * Case and constructor field binders
+  | let sig     = mkConservativeSig env (idType var)
+  , let res     = dmdTransformSig sig dmd
+  = -- pprTrace "dmdTransform:Other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $
+    addVarDmd res var (mkOnceUsedDmd dmd)
+
+-- | Returns 'idStrictness' or a conservative strictness signature for an
+-- imported global variable for which 'idStrictness' is Top.
+globalIdStrictness :: AnalEnv -> Id -> StrictSig
+globalIdStrictness env var
+  | isTopSig (idStrictness var) = mkConservativeSig env (idType var)
+  | otherwise                   = idStrictness var
+
+mkConservativeSig :: AnalEnv -> Type -> StrictSig
+mkConservativeSig env ty
+  -- Binders of unlifted types can't throw anything. This special case isn't
+  -- handled well by forcesRealWorld, which focuses on case scrutinees.
+  | unlifted  = emptySig conDiv
+  -- no point in retaining cleared_sig when it's just Top
+  | no_change = topSig
+  | otherwise = cleared_sig
+  where
+    unlifted        = isLiftedType_maybe ty == Just False
+    fam_envs        = ae_fam_envs env
+    -- This is isomorphic to topSig. But this one has the right number of
+    -- arguments and will possibly have conDiv after the call to
+    -- tryClearPreciseException!
+    pessimistic_sig = StrictSig $ DmdType emptyVarEnv args topDiv
+    args            = replicate (length (typeArity ty)) topDmd
+    -- In contrast to pessimistic_sig, cleared_sig might not have conDiv
+    -- Divergence!
+    cleared_sig     = tryClearPreciseException fam_envs ty pessimistic_sig
+    sig_div         = snd . splitStrictSig
+    no_change       = sig_div cleared_sig == topDiv
 
 {-
 ************************************************************************
@@ -603,7 +640,7 @@ dmdFix top_lvl env let_dmd orig_pairs
 
     zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
     zapIdStrictness pairs
-      = [(setIdStrictnessClearExn env id (emptySig topDiv), rhs) | (id, rhs) <- pairs ]
+      = [(setIdStrictnessClearExn env id topSig, rhs) | (id, rhs) <- pairs ]
 
 {-
 Note [Safe abortion in the fixed-point iteration]
@@ -658,7 +695,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
       = mkRhsDmd env rhs_arity rhs
     (DmdType rhs_fv rhs_dmds rhs_div, rhs')
                    = dmdAnal env rhs_dmd rhs
-    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)
+    sig            = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
     id'            = -- pprTraceWith "dmdAnalRhsLetDown" (\sig'-> ppr id <+> ppr sig <+> ppr sig') $
                      setIdStrictnessClearExn env id sig
         -- See Note [NOINLINE and strictness]
@@ -944,9 +981,6 @@ deleted the special case.
 ************************************************************************
 -}
 
-unitDmdType :: DmdEnv -> DmdType
-unitDmdType dmd_env = DmdType dmd_env [] conDiv
-
 coercionDmdEnv :: Coercion -> DmdEnv
 coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
                     -- The VarSet from coVarsOfCo is really a VarEnv Var


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -23,8 +23,7 @@ module GHC.Types.Demand (
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
-        emptyDmdType, botDmdType, mkDmdType, addDemand,
-        mayThrowPreciseDmdType,
+        emptyDmdType, botDmdType, addDemand, mayThrowPreciseDmdType,
 
         DmdEnv, emptyDmdEnv,
         peelFV, findIdDemand,
@@ -33,7 +32,7 @@ module GHC.Types.Demand (
         topDiv, botDiv, exnDiv, conDiv,
         appIsDeadEnd, isDeadEndSig, pprIfaceStrictSig,
         StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
-        emptySig, botSig, cprProdSig,
+        emptySig, topSig, botSig, cprProdSig,
         isTopSig, hasDemandEnvSig,
         splitStrictSig, strictSigDmdEnv,
         prependArgsStrictSig, etaConvertStrictSig,
@@ -1275,6 +1274,9 @@ emptyDmdType div = DmdType emptyDmdEnv [] div
 botDmdType :: DmdType
 botDmdType = emptyDmdType botDiv
 
+topDmdType :: DmdType
+topDmdType = emptyDmdType topDiv
+
 isTopDmdType :: DmdType -> Bool
 isTopDmdType (DmdType env args div)
   = div == topDiv && null args && isEmptyVarEnv env
@@ -1284,9 +1286,6 @@ mayThrowPreciseDmdType (DmdType _ _ Dunno)    = True
 mayThrowPreciseDmdType (DmdType _ _ ExnOrDiv) = True
 mayThrowPreciseDmdType _                      = False
 
-mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType
-mkDmdType fv ds res = DmdType fv ds res
-
 dmdTypeDepth :: DmdType -> Arity
 dmdTypeDepth (DmdType _ ds _) = length ds
 
@@ -1788,6 +1787,9 @@ emptySig div = StrictSig (emptyDmdType div)
 botSig :: StrictSig
 botSig = StrictSig botDmdType
 
+topSig :: StrictSig
+topSig = StrictSig topDmdType
+
 cprProdSig :: Arity -> StrictSig
 cprProdSig _arity = emptySig conDiv -- constructor applications never throw precise exceptions
 


=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -658,7 +658,7 @@ setIdCprInfo :: Id -> CprSig -> Id
 setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id
 
 zapIdStrictness :: Id -> Id
-zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` emptySig topDiv) id
+zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` topSig) id
 
 -- | This predicate says whether the 'Id' has a strict demand placed on it or
 -- has a type such that it can always be evaluated strictly (i.e an


=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -324,7 +324,7 @@ vanillaIdInfo
             inlinePragInfo      = defaultInlinePragma,
             occInfo             = noOccInfo,
             demandInfo          = topDmd,
-            strictnessInfo      = emptySig topDiv,
+            strictnessInfo      = topSig,
             cprInfo             = topCprSig,
             callArityInfo       = unknownArity,
             levityInfo          = NoLevityInfo



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcd81dbcb6a3368a4bba530930f583700c98c582
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/20200408/21f693e2/attachment-0001.html>


More information about the ghc-commits mailing list