[Git][ghc/ghc][wip/dmdanal-precise-exn] Hopefully fix the perf regression

[Sebastian Graf]

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


Commits:
8ae14a25 by Sebastian Graf at 2020-04-06T17:57:37+02:00
Hopefully fix the perf regression

- - - - -


1 changed file:

- compiler/GHC/Core/Op/DmdAnal.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
@@ -518,19 +519,37 @@ dmdTransform env var dmd
   = 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])
+  , let res = dmdTransformSig (globalIdStrictness env var) dmd
+  = -- pprTrace "dmdTransform:global" (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
   , let fn_ty = dmdTransformSig sig dmd
-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
+  = -- pprTrace "dmdTransform:local" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
     if isTopLevel top_lvl
     then fn_ty   -- Don't record top level things
     else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
 
   | otherwise                                    -- Local non-letrec-bound thing
-  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
+  = dmdTransformSig (mkConservativeSig env (idType var) (unitVarEnv var (mkOnceUsedDmd dmd))) 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) emptyVarEnv
+  | otherwise                   = idStrictness var
+
+mkConservativeSig :: AnalEnv -> Type -> DmdEnv -> StrictSig
+mkConservativeSig env ty fvs
+  = tryClearPreciseException fam_envs ty pessimistic_sig
+  where
+    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 fvs args conDiv
+    args            = replicate (length (typeArity ty)) topDmd
 
 {-
 ************************************************************************
@@ -944,9 +963,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



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8ae14a25c07748b23f79dd67cfd01b8f814ff9da
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/20200406/42f6d97f/attachment-0001.html>