[Git][ghc/ghc][wip/dmdanal-precise-exn] Fix the perf regression in T12227/T12545
Sebastian Graf
gitlab at gitlab.haskell.org
Mon Apr 13 08:13:38 UTC 2020
Sebastian Graf pushed to branch wip/dmdanal-precise-exn at Glasgow Haskell Compiler / GHC
Commits:
e4d8912e by Sebastian Graf at 2020-04-13T10:13:30+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
- - - - -
5 changed files:
- compiler/GHC/Core/Op/DmdAnal.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- utils/haddock
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) 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
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 65f22afa9e66195baa6b7d44369e2b23cd8f77d2
+Subproject commit 5ec817a3e41b7eaa50c74701ab2d7642df86464c
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e4d8912eb61de6e2d5de0b6a0b656526e1662705
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e4d8912eb61de6e2d5de0b6a0b656526e1662705
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/20200413/fa75e0c8/attachment-0001.html>
More information about the ghc-commits
mailing list