[Git][ghc/ghc][wip/abs-den] WIP
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue Jan 9 16:27:58 UTC 2024
Sebastian Graf pushed to branch wip/abs-den at Glasgow Haskell Compiler / GHC
Commits:
a6845c2c by Sebastian Graf at 2024-01-09T17:27:51+01:00
WIP
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Semantics.hs
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -169,13 +169,13 @@ demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids)
-- Any other top-level bindings are boring.
--
-- See also Note [Why care for top-level demand annotations?].
-isInterestingTopLevelFn :: Id -> Bool
+isInterestingTopLevelTy :: Type -> Bool
-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642
-- (which is dominated by the Simplifier) at no gain in analysis precision.
-- If there was a gain, that regression might be acceptable.
-- Plus, we could use LetUp for thunks and share some code with local let
-- bindings.
-isInterestingTopLevelFn id = typeArity (idType id) > 0
+isInterestingTopLevelTy ty = typeArity ty > 0
{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -336,11 +336,11 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of
where
env_rhs = enterDFun bind env
--- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')
+-- | Annotates uninteresting top level functions ('isInterestingTopLevelTy)
-- with 'topDmd', the rest with the given demand.
annotateBindDemand :: TopLevelFlag -> Name -> Demand -> AnalM s ()
annotateBindDemand top_lvl x dmd = case top_lvl of
--- TopLevel | not (isInterestingTopLevelFn x) -> annotate da_demands x topDmd
+-- TopLevel | not (isInterestingTopLevelTy x) -> annotate da_demands x topDmd
_ -> annotate da_demands x dmd
-- | Update the demand signature, but be careful not to change boxity info if
@@ -1010,18 +1010,18 @@ dmdTransform env var sd
res
-- 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
+ | Just (sig, top_lvl) <- lookupSigEnv env (idName var)
, let fn_ty = dmdTransformSig sig sd
= -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $
case top_lvl of
- NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd)
+ NotTopLevel -> addVarDmd fn_ty (idName var) (C_11 :* sd)
TopLevel
- | isInterestingTopLevelFn var
+ | isInterestingTopLevelTy (idType var)
-- Top-level things will be used multiple times or not at
-- all anyway, hence the multDmd below: It means we don't
-- have to track whether @var@ is used strictly or at most
-- once, because ultimately it never will.
- -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness
+ -> addVarDmd fn_ty (idName var) (C_0N `multDmd` (C_11 :* sd)) -- discard strictness
| otherwise
-> fn_ty -- don't bother tracking; just annotate with 'topDmd' later
-- Everything else:
@@ -1111,7 +1111,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do
!(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2
sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds)
opts = ae_opts env
- !final_env = extendAnalEnv top_lvl env id sig
+ !final_env = extendAnalEnv top_lvl env (idName id) sig
-- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs)
annotateSig opts (idName id) sig
@@ -2207,7 +2207,7 @@ dmdFix top_lvl env let_sd pairs
-- foldlM: Use the new signature to do the next pair
-- The occurrence analyser has arranged them in a good order
-- so this can significantly reduce the number of iterations needed
- let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env') bndrs
+ let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env' . idName) bndrs
-- annotation done in dmdAnalRhsSig
-- zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs'
pure $! S3 env' sigs' weak_fv'
@@ -2490,28 +2490,26 @@ findBndrsDmds env dmd_ty bndrs
go dmd_ty [] = S2 dmd_ty []
go dmd_ty (b:bs)
| isId b = let S2 dmd_ty1 dmds = go dmd_ty bs
- S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 b
+ S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 (idName b) (idType b)
in S2 dmd_ty2 (dmd : dmds)
| otherwise = go dmd_ty bs
-findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand
+findBndrDmd :: AnalEnv -> DmdType -> Name -> Type -> WithDmdType Demand
-- See Note [Trimming a demand to a type]
-findBndrDmd env dmd_ty id
+findBndrDmd env dmd_ty x ty
= -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $
S2 dmd_ty' dmd'
where
dmd' = strictify $
- trimToType starting_dmd (findTypeShape fam_envs id_ty)
+ trimToType starting_dmd (findTypeShape fam_envs ty)
- (dmd_ty', starting_dmd) = peelFV dmd_ty (idName id)
-
- id_ty = idType id
+ (dmd_ty', starting_dmd) = peelFV dmd_ty x
strictify dmd
-- See Note [Making dictionary parameters strict]
-- and Note [Do not strictify a DFun's parameter dictionaries]
| dmd_strict_dicts (ae_opts env)
- = strictifyDictDmd id_ty dmd
+ = strictifyDictDmd ty dmd
| otherwise
= dmd
@@ -2739,7 +2737,7 @@ dmdType2DmdD :: (AnalEnv -> SubDemand -> AnalM s DmdType) -> DmdD s
dmdType2DmdD trans = DmdT $ \env sd -> trans env sd >>= \(DmdType env val) -> pure (S2 val env)
instance Trace (DmdD s) where
- step (Lookup x) d = DmdT $ \env sd -> unDmdT d env sd >>= \t ->
+ step (Lookup (x,x_ty)) d = DmdT $ \env sd -> unDmdT d env sd >>= \t ->
case (t, lookupSigEnv env x) of
(S2 val env, Just (_,NotTopLevel)) -> pure (S2 val (addVarDmdEnv env x (C_11 :* sd)))
(S2 val env, Just (_,TopLevel))
@@ -2747,8 +2745,10 @@ instance Trace (DmdD s) where
-- all anyway, hence the multDmd below: It means we don't
-- have to track whether @x@ is used strictly or at most
-- once, because ultimately it never will.
+ | isInterestingTopLevelTy x_ty
-> pure (S2 val (addVarDmdEnv env x (C_0N `multDmd` (C_11 :* sd)))) -- discard strictness
- (_, Nothing) -> pure t
+ -- otherwise, fall through; we'll annotate with topDmd at the binding site.
+ _ -> pure t
step _ d = d
botDmdD, nopDmdD :: DmdD s
@@ -2764,7 +2764,7 @@ instance Domain (DmdD s) where
lit _l = nopDmdD
primOp _op = nopDmdD
fun (x,x_ty) f = DmdT $ \env sd -> do
- let sentinel = step (Lookup x) nopDmdD
+ let sentinel = step (Lookup (x,x_ty)) nopDmdD
let body_env = extendAnalEnv NotTopLevel env x nopSig -- Ultimately, we will not store nopDmdD here. This is just for compatibility with existing code
let (n,body_sd) = peelCallDmd sd
S2 val fvs <- unDmdT (f sentinel) body_env body_sd
@@ -2772,7 +2772,15 @@ instance Domain (DmdD s) where
-- pprTraceM "dmdAnal:Lam" (ppr x <+> ppr dmd $$ ppr body_ty')
annotate da_demands x dmd
let !lam_ty = addDemand dmd body_ty'
- return $! multDmdType n lam_ty
+ let DmdType fvs val = multDmdType n lam_ty
+ return $! S2 val fvs
+ con dc ds = DmdT $ \env sd -> do
+ let DmdType _env dmds = dmdTransformDataConSig (dataConRepStrictness dc) sd
+ let value_ds = dropList (dataConUnivAndExTyCoVars dc) ds
+ massert (equalLength value_ds dmds)
+ fvs <- concat <$> zipWithM squeezeDmd value_ds dmds
+ pure $! S2 [] fvs
+
-- body_ty <- dmdAnal body_env body_dmd body
-- -- See Note [Bringing a new variable into scope]
=====================================
compiler/GHC/Core/Semantics.hs
=====================================
@@ -39,27 +39,33 @@ import GHC.Core.Utils hiding (findAlt)
import GHC.Core.Type
import GHC.Builtin.PrimOps
import GHC.Builtin.Types
+import GHC.Utils.Panic
-data Event = Lookup Name | LookupArg CoreExpr | Update | App1 | App2 | Case1 | Case2 | Let1
+type NaTy = (Name, Type)
+var2NaTy :: Var -> NaTy
+var2NaTy v = (idName v, idType v)
+
+data Event = Lookup NaTy | LookupArg CoreExpr | Update | App1 | App2 | Case1 | Case2 | Let1
class Trace d where
step :: Event -> d -> d
-- A slight extension of the Domain type from the paper.
--- Note that the 'Name's bear no semantic significance: The `Domain (D τ)`
--- instance simply ignores them. They are useful for analyses, however.
+-- Note that the 'NaTy's bear no semantic significance: The `Domain (D τ)`
+-- instance simply ignores them. They are needed for analyses and debugging, however.
class Domain d where
stuck :: d
erased :: d -- Think of it like coercionToken#
lit :: Literal -> d
primOp :: PrimOp -> d
- fun :: (Name, Type) -> (d -> d) -> d
+ fun :: NaTy -> (d -> d) -> d
con :: DataCon -> [d] -> d
apply :: d -> d -> d
- select :: d -> Name -> [DAlt d] -> d
-type DAlt d = (AltCon, [Name], d -> [d] -> d)
+ select :: d -> NaTy -> [DAlt d] -> d
+type DAlt d = (AltCon, [NaTy], d -> [d] -> d)
+
-data BindHint = BindArg | BindNonRec Name | BindRec [Name]
+data BindHint = BindArg | BindNonRec NaTy | BindRec [NaTy]
class HasBind d where
bind :: BindHint -> [[d] -> d] -> ([d] -> d) -> d
-- NB: The `BindHint` bears no semantic sigificance:
@@ -67,7 +73,9 @@ class HasBind d where
-- Still useful for analyses!
seq_ :: Domain d => d -> d -> d
-seq_ a b = select a wildCardName [(DEFAULT, [], \_a _ds -> b)]
+seq_ a b = select a (wildCardName, panicType) [(DEFAULT, [], \_a _ds -> b)]
+panicType :: HasCallStack => Type
+panicType = panic "should not need the type"
anfise :: (Trace d, Domain d, HasBind d) => CoreExpr -> IdEnv d -> (d -> d) -> d
anfise (Lit l) _ k = k (lit l)
@@ -101,16 +109,15 @@ eval (Var x) env
| isDataConWrapId x = eval (unfoldingTemplate (idUnfolding x)) emptyVarEnv
| Just d <- lookupVarEnv env x = d
| otherwise = stuck -- Scoping error. Actually ruled out by the Core type system
-eval (Lam x e) env = fun (idName x, idType x) (\d -> step App2 (eval e (extendVarEnv env x d)))
+eval (Lam x e) env = fun (var2NaTy x) (\d -> step App2 (eval e (extendVarEnv env x d)))
eval e at App{} env
| Var v <- f, Just dc <- isDataConWorkId_maybe v
= anfiseMany as env $ \ds -> case compare (dataConRepArity dc) (length ds) of
EQ -> con dc ds
- GT -> stuck -- oversaturated => stuck
- LT -> expand [] (take (length ds - dataConRepArity dc) papNames) -- undersaturated => PAP
+ GT -> stuck -- oversaturated => stuck
+ LT -> mkPap (\etas -> con dc (ds ++ etas)) rest_tys -- undersaturated => PAP
where
- expand etas [] = con dc (ds ++ reverse etas)
- expand etas (x:xs) = fun x (\d -> expand (d:etas) xs)
+ rest_tys = dropList ds (map piTyBinderType $ fst $ splitPiTys (dataConRepType dc))
| otherwise
= go (eval f env) as
where
@@ -118,22 +125,28 @@ eval e at App{} env
go df [] = df
go df (a:as) = go (anfise a env (step App1 . apply df)) as
eval (Let (NonRec x rhs) body) env =
- bind (BindNonRec (idName x))
- [const (step (Lookup (idName x)) (eval rhs env))]
- (\ds -> step Let1 (eval body (extendVarEnv env x (only ds))))
+ bind (BindNonRec (var2NaTy x))
+ [const (step (Lookup (var2NaTy x)) (eval rhs env))]
+ (\ds -> step Let1 (eval body (extendVarEnv env x (only ds))))
eval (Let (Rec binds) body) env =
- bind (BindRec (map idName xs))
- [\ds -> step (Lookup (idName x)) (eval rhs (new_env ds)) | (x,rhs) <- binds]
- (\ds -> step Let1 (eval body (new_env ds)))
+ bind (BindRec (map var2NaTy xs))
+ [\ds -> step (Lookup (var2NaTy x)) (eval rhs (new_env ds)) | (x,rhs) <- binds]
+ (\ds -> step Let1 (eval body (new_env ds)))
where
xs = map fst binds
new_env ds = extendVarEnvList env (zip xs ds)
eval (Case e b _ty alts) env = step Case1 $
- select (eval e env) (idName b)
- [ (con, map idName xs, cont xs rhs) | Alt con xs rhs <- alts ]
+ select (eval e env) (idName b, idType b)
+ [ (con, map var2NaTy xs, cont xs rhs) | Alt con xs rhs <- alts ]
where
cont xs rhs scrut ds = step Case2 $ eval rhs (extendVarEnvList env (zipEqual "eval Case{}" (b:xs) (scrut:ds)))
+mkPap :: (Trace d, Domain d) => ([d] -> d) -> [Type] -> d
+mkPap f arg_tys = go [] (zip papNames arg_tys)
+ where
+ go ds [] = f (reverse ds)
+ go ds ((x,arg_ty):xs_arg_tys) = fun (x,arg_ty) (\d -> go (d:ds) xs_arg_tys)
+
x1,x2 :: Name
papNames :: [Name]
papNames@(x1:x2:_) = [ mkSystemName (mkTempDataConArgUnique i) (mkVarOcc "pap") | i <- [0..] ]
@@ -174,7 +187,10 @@ instance (Trace (D τ), Monad τ) => Domain (D τ) where
IntRemOp -> intop rem
_ -> stuck
where
- intop op = binop intTy intTy (\v1 v2 -> case (v1,v2) of (Litt (LitNumber LitNumInt i1), Litt (LitNumber LitNumInt i2)) -> Litt (LitNumber LitNumInt (i1 `op` i2)); _ -> Stuck)
+ intop op = binop intTy intTy $ \v1 v2 -> case (v1,v2) of
+ (Litt (LitNumber LitNumInt i1), Litt (LitNumber LitNumInt i2))
+ -> Litt (LitNumber LitNumInt (i1 `op` i2))
+ _ -> Stuck
binop ty1 ty2 f = fun (x1,ty1) $ \d1 -> step App2 $ fun (x2,ty2) $ \d2 -> step App2 $ f <$> d1 <*> d2
-- The following function was copy and pasted from GHC.Core.Utils.findAlt:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6845c2c38d9237c7a7533630fcab2ced75409b8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6845c2c38d9237c7a7533630fcab2ced75409b8
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/20240109/fe296d67/attachment-0001.html>
More information about the ghc-commits
mailing list