[Git][ghc/ghc][wip/abs-den] WIP
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue Jan 9 14:31:01 UTC 2024
Sebastian Graf pushed to branch wip/abs-den at Glasgow Haskell Compiler / GHC
Commits:
2a218337 by Sebastian Graf at 2024-01-09T15:30:39+01:00
WIP
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Semantics.hs
- compiler/GHC/Types/Demand.hs
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -66,6 +66,9 @@ import GHC.Data.Maybe
import Data.Foldable (foldlM)
import qualified Data.Semigroup as Semi
import Data.Coerce
+import GHC.Types.Name.Env
+import GHC.Types.Name
+import GHC.Types.Unique.FM
{-
************************************************************************
@@ -97,15 +100,15 @@ type WithDmdType a = SPair DmdType a
type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s)
-annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s ()
-annotate ref id !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env id a)
+annotate :: (DmdAnnotations (STRef s) -> STRef s (NameEnv a)) -> Name -> a -> AnalM s ()
+annotate ref x !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendNameEnv env x a)
-readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a)
+readAnn :: (DmdAnnotations (STRef s) -> STRef s (NameEnv a)) -> AnalM s (NameEnv a)
readAnn ref = ReaderT $ \ann -> readSTRef (ref ann)
runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity
runAnalM m = runST $ do
- env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv
+ env <- DA <$> newSTRef emptyNameEnv <*> newSTRef emptyNameEnv
_a <- runReaderT m env
demands <- readSTRef (da_demands env)
sigs <- readSTRef (da_sigs env)
@@ -113,7 +116,7 @@ runAnalM m = runST $ do
discardAnnotations :: (forall s. AnalM s a) -> a
discardAnnotations m = runST $ do
- env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv
+ env <- DA <$> newSTRef emptyNameEnv <*> newSTRef emptyNameEnv
runReaderT m env
-- | Outputs a new copy of the Core program in which binders have been annotated
@@ -335,20 +338,19 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of
-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')
-- with 'topDmd', the rest with the given demand.
-annotateBindIdDemand :: TopLevelFlag -> Id -> Demand -> AnalM s ()
-annotateBindIdDemand top_lvl id dmd = case top_lvl of
- TopLevel | not (isInterestingTopLevelFn id) -> annotate da_demands id topDmd
- _ -> annotate da_demands id dmd
+annotateBindDemand :: TopLevelFlag -> Name -> Demand -> AnalM s ()
+annotateBindDemand top_lvl x dmd = case top_lvl of
+-- TopLevel | not (isInterestingTopLevelFn x) -> annotate da_demands x topDmd
+ _ -> annotate da_demands x dmd
-- | Update the demand signature, but be careful not to change boxity info if
-- `dmd_do_boxity` is True or if the signature is bottom.
-- See Note [Don't change boxity without worker/wrapper]
-- and Note [Boxity for bottoming functions].
-annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s ()
-annotateSig opts id sig = annotate da_sigs id $
- if dmd_do_boxity opts || isBottomingSig sig
- then sig
- else transferArgBoxityDmdSig (idDmdSig id) sig
+annotateSig :: DmdAnalOpts -> Name -> DmdSig -> AnalM s ()
+annotateSig opts x sig
+ | dmd_do_boxity opts || isBottomingSig sig = annotate da_sigs x sig
+ | otherwise = pure ()
-- | Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
@@ -376,7 +378,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = do
-- See Note [Finalising boxity for demand signatures]
let S2 body_ty' id_dmd = findBndrDmd env body_ty id
let id_dmd' = finaliseLetBoxity env (idType id) id_dmd
- annotateBindIdDemand top_lvl id id_dmd'
+ annotateBindDemand top_lvl (idName id) id_dmd'
rhs_ty <- dmdAnalStar env id_dmd' rhs
@@ -413,7 +415,7 @@ dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
-- see Note [Lazy and unleashable free variables]
let S2 final_ty id_dmds = findBndrsDmds env' dmd_ty bndrs
-- pprTraceM "dmdAnalBindLetDown" (ppr bndrs <+> ppr id_dmds)
- zipWithM_ (annotateBindIdDemand top_lvl) bndrs id_dmds
+ zipWithM_ (annotateBindDemand top_lvl . idName) bndrs id_dmds
pure final_ty
-- If the actual demand is better than the vanilla call
-- demand, you might think that we might do better to re-analyse
@@ -506,7 +508,7 @@ dmdAnal' env dmd (Lam var body)
-- See Note [Bringing a new variable into scope]
let S2 body_ty' dmd = findBndrDmd env body_ty var
-- pprTraceM "dmdAnal:Lam" (ppr var <+> ppr dmd $$ ppr body_ty')
- annotate da_demands var dmd
+ annotate da_demands (idName var) dmd
let !lam_ty = addDemand dmd body_ty'
return $! multDmdType n lam_ty
where
@@ -522,7 +524,7 @@ dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs])
rhs_ty <- dmdAnal rhs_env dmd rhs
let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs
S2 alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr
- annotate da_demands case_bndr case_bndr_dmd
+ annotate da_demands (idName case_bndr) case_bndr_dmd
-- Evaluation cardinality on the case binder is irrelevant and a no-op.
-- What matters is its nested sub-demand!
@@ -572,7 +574,7 @@ dmdAnal' env dmd (Case scrut case_bndr _ty alts) = do
alt_tys <- traverse (dmdAnalSumAlt env dmd case_bndr) alts
let lub = foldr lubDmdType botDmdType
let S2 alt_ty1 case_bndr_dmd = findBndrDmd env (lub alt_tys) case_bndr
- annotate da_demands case_bndr case_bndr_dmd
+ annotate da_demands (idName case_bndr) case_bndr_dmd
scrut_ty <- dmdAnal env topSubDmd scrut
let fam_envs = ae_fam_envs env
@@ -638,7 +640,7 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do
-- we can't use the scrut_sd, because it says 'Prod' and we'll use
-- topSubDmd anyway for scrutinees of sum types.
let scrut_sd
- | (_ :* case_bndr_sd) <- findIdDemand alt_ty case_bndr
+ | (_ :* case_bndr_sd) <- findIdDemand alt_ty (idName case_bndr)
= scrutSubDmd case_bndr_sd dmds
case con of
DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds))
@@ -1028,7 +1030,7 @@ dmdTransform env var sd
-- * Case and constructor field binders
| otherwise
= -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $
- noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd))
+ noArgsDmdType (addVarDmdEnv nopDmdEnv (idName var) (C_11 :* sd))
{- *********************************************************************
* *
@@ -1038,7 +1040,7 @@ dmdTransform env var sd
-- | An environment in which all demands are weak according to 'isWeakDmd'.
-- See Note [Lazy and unleashable free variables].
-type WeakDmds = VarEnv Demand
+type WeakDmds = NameEnv Demand
-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature
-- for the LetDown rule. It works as follows:
@@ -1083,7 +1085,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do
-- Attach the demands to the outer lambdas of this expression
-- NB: zipWithM_, not zipWithEqualM_, in contrast to annotateBndrsDemands.
-- We might have more demands than binders (PAP), hence don't panic (#22997).
- zipWithM_ (annotate da_demands) (filter isId lam_bndrs) final_rhs_dmds
+ zipWithM_ (annotate da_demands . idName) (filter isId lam_bndrs) final_rhs_dmds
let
-- See Note [Aggregated demand for cardinality]
@@ -1112,12 +1114,12 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do
!final_env = extendAnalEnv top_lvl env id sig
-- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs)
- annotateSig opts id sig
+ annotateSig opts (idName id) sig
pure $! S2 final_env weak_fvs
splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)
splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)
- where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs
+ where (!weak_fvs, !sig_fvs) = partitionUFM isWeakDmd fvs
thresholdArity :: Id -> CoreExpr -> Arity
-- See Note [Demand signatures are computed for a threshold arity based on idArity]
@@ -2168,7 +2170,7 @@ dmdFix top_lvl env let_sd pairs
read_sigs = do
annotations <- readAnn da_sigs
let init_sigs = [ botSig | _ <- bndrs ]
- pure $! traverse (lookupVarEnv annotations) bndrs `orElse` init_sigs
+ pure $! traverse (lookupNameEnv annotations . idName) bndrs `orElse` init_sigs
-- If fixed-point iteration does not yield a result we use this instead
-- See Note [Safe abortion in the fixed-point iteration]
@@ -2177,8 +2179,8 @@ dmdFix top_lvl env let_sd pairs
S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ])
-- NB: step updates the annotation
-- Note [Lazy and unleashable free variables]
- let weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv) sigs'
- weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs
+ let weak_fvs = plusNameEnvList $ map (de_fvs . dmdSigDmdEnv) sigs'
+ weak_fv' = plusNameEnv_C plusDmd weak_fv $ mapNameEnv (const topDmd) weak_fvs
pure $! S2 env' weak_fv'
-- The fixed-point varies the DmdSig stored in the AnalEnv for bndrs, and
@@ -2201,7 +2203,7 @@ dmdFix top_lvl env let_sd pairs
step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds)
step env = do
- S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs
+ S2 env' weak_fv' <- foldlM do_one (S2 env emptyNameEnv) 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
@@ -2213,7 +2215,7 @@ dmdFix top_lvl env let_sd pairs
do_one (S2 env weak_fv) (id, rhs) = do
-- pprTraceM "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig)
S2 env' weak_fv1 <- dmdAnalRhsSig top_lvl Recursive env let_sd id rhs
- let !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1
+ let !weak_fv' = plusNameEnv_C plusDmd weak_fv weak_fv1
pure $! S2 env' weak_fv'
{- Note [Safe abortion in the fixed-point iteration]
@@ -2293,12 +2295,14 @@ coercionDmdEnv co = coercionsDmdEnv [co]
coercionsDmdEnv :: [Coercion] -> DmdEnv
coercionsDmdEnv cos
- = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos
- -- The VarSet from coVarsOfCos is really a VarEnv Var
+ = mkTermDmdEnv $ varEnv2NameEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos
+ -- The VarSet from coVarsOfCos is really a NameEnv Var
+ where varEnv2NameEnv :: VarEnv a -> NameEnv a
+ varEnv2NameEnv = unsafeCastUFMKey -- This is safe, as varUnique = nameUnique
-addVarDmd :: DmdType -> Var -> Demand -> DmdType
-addVarDmd (DmdType fv ds) var dmd
- = DmdType (addVarDmdEnv fv var dmd) ds
+addVarDmd :: DmdType -> Name -> Demand -> DmdType
+addVarDmd (DmdType fv ds) x dmd
+ = DmdType (addVarDmdEnv fv x dmd) ds
addWeakFVs :: DmdType -> WeakDmds -> DmdType
addWeakFVs dmd_ty weak_fvs
@@ -2330,7 +2334,7 @@ addWeakFVs dmd_ty weak_fvs
annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s ()
annotateBndrsDemands bs ds =
zipWithEqualM_ "annotateBndrsDemands"
- (annotate da_demands) (filter isRuntimeVar bs) ds
+ (annotate da_demands . idName) (filter isRuntimeVar bs) ds
{- Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2425,7 +2429,7 @@ data AnalEnv = AE
-- The DmdEnv gives the demand on the free vars of the function
-- when it is given enough args to satisfy the strictness signature
-type SigEnv = VarEnv (DmdSig, TopLevelFlag)
+type SigEnv = NameEnv (DmdSig, TopLevelFlag)
instance Outputable AnalEnv where
ppr env = text "AE" <+> braces (vcat
@@ -2451,7 +2455,7 @@ enterDFun bind env
= env
emptySigEnv :: SigEnv
-emptySigEnv = emptyVarEnv
+emptySigEnv = emptyNameEnv
-- | Extend an environment with the strictness sigs attached to the Ids
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> [DmdSig] -> AnalEnv
@@ -2460,23 +2464,23 @@ extendAnalEnvs top_lvl env vars sigs
extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> [DmdSig] -> SigEnv
extendSigEnvs top_lvl env vars sigs
- = extendVarEnvList env (zipWith (\v s -> (v, (s, top_lvl))) vars sigs)
+ = extendNameEnvList env (zipWith (\v s -> (idName v, (s, top_lvl))) vars sigs)
-extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv
-extendAnalEnv top_lvl env var sig
- = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
+extendAnalEnv :: TopLevelFlag -> AnalEnv -> Name -> DmdSig -> AnalEnv
+extendAnalEnv top_lvl env x sig
+ = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) x sig }
-extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv
-extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
+extendSigEnv :: TopLevelFlag -> SigEnv -> Name -> DmdSig -> SigEnv
+extendSigEnv top_lvl sigs x sig = extendNameEnv sigs x (sig, top_lvl)
-lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)
-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
+lookupSigEnv :: AnalEnv -> Name -> Maybe (DmdSig, TopLevelFlag)
+lookupSigEnv env x = lookupNameEnv (ae_sigs env) x
addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
-addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }
+addInScopeAnalEnv env id = env { ae_sigs = delFromNameEnv (ae_sigs env) (idName id) }
addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
-addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }
+addInScopeAnalEnvs env ids = env { ae_sigs = delListFromNameEnv (ae_sigs env) (map idName ids) }
findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
-- Return the demands on the Ids in the [Var]
@@ -2499,7 +2503,7 @@ findBndrDmd env dmd_ty id
dmd' = strictify $
trimToType starting_dmd (findTypeShape fam_envs id_ty)
- (dmd_ty', starting_dmd) = peelFV dmd_ty id
+ (dmd_ty', starting_dmd) = peelFV dmd_ty (idName id)
id_ty = idType id
@@ -2691,8 +2695,8 @@ also runtime for the pass is faster! Overall, good wins.
---------------------------------
data DmdAnnotations f = DA
- { da_demands :: !(f (IdEnv Demand))
- , da_sigs :: !(f (IdEnv DmdSig))
+ { da_demands :: !(f (NameEnv Demand))
+ , da_sigs :: !(f (NameEnv DmdSig))
}
annotateProgram :: DmdAnnotations Identity -> CoreProgram -> CoreProgram
@@ -2701,52 +2705,81 @@ annotateProgram anns = runIdentity . traverseBinders (Identity . annotate)
annotate bndr | isTyVar bndr = bndr
| otherwise = annotate_sig $ annotate_demand bndr
annotate_sig bndr
- | Just sig <- lookupVarEnv (runIdentity $ da_sigs anns) bndr
+ | Just sig <- lookupNameEnv (runIdentity $ da_sigs anns) (idName bndr)
= bndr `setIdDmdSig` sig
| otherwise
= bndr
annotate_demand bndr
- | Just dmd <- lookupVarEnv (runIdentity $ da_demands anns) bndr
+ | Just dmd <- lookupNameEnv (runIdentity $ da_demands anns) (idName bndr)
= bndr `setIdDemandInfo` dmd
| otherwise
= bndr
-- Semantics stuff
-newtype LexicalEnv = LE { le_how_bound :: NameEnv TopLevelFlag }
-
newtype PlusDmdEnv = PDE DmdEnv
instance Semi.Semigroup PlusDmdEnv where
(<>) = coerce plusDmdEnv
instance Monoid PlusDmdEnv where
mempty = PDE nopDmdEnv
-newtype DmdT v = DmdT { unDmdT :: LexicalEnv -> SubDemand -> SPair v DmdEnv }
- deriving (Functor,Applicative,Monad) via (ReaderT LexicalEnv (ReaderT SubDemand (SWriter PlusDmdEnv)))
+newtype DmdT s v = DmdT { unDmdT :: AnalEnv -> SubDemand -> AnalM s (SPair v DmdEnv) }
+ deriving (Functor,Applicative,Monad) via (ReaderT AnalEnv (ReaderT SubDemand (SWriterT PlusDmdEnv (AnalM s))))
type DmdVal = [Demand]
-- Think
-- data DmdVal = DmdFun Demand DmdVal | DmdNop
-- NB: lacks constructor values; these are always DmdNop
-type DmdD = DmdT DmdVal
+type DmdD s = DmdT s DmdVal
-- Think: demand transformer, SubDemand -> DmdType
-dmdD2DmdType :: DmdD -> LexicalEnv -> SubDemand -> DmdType
-dmdD2DmdType d le sd = case unDmdT d le sd of S2 val env -> DmdType env val
-dmdType2DmdD :: (LexicalEnv -> SubDemand -> DmdType) -> DmdD
-dmdType2DmdD trans = DmdT $ \le sd -> case trans le sd of DmdType env val -> S2 val env
-
-instance Trace DmdD where
- step (Lookup x) d = DmdT $ \le sd -> case (unDmdT d le sd, lookupNameEnv (le_how_bound le) x) of
- (S2 val env, Just NotTopLevel) -> S2 val (addVarDmdEnv x (C_11 :* sd) env)
- (S2 val env, Just TopLevel)
- | isInterestingTopLevelFn 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.
- -> S2 val (addVarDmdEnv x (C_0N `multDmd` (C_11 :* sd))) -- discard strictness
- -- not interesting: fall through, don't bother tracking;
- -- just annotate with 'topDmd' at bindings site
- (t, _) -> t -- GlobalId or local, top-level and not interesting
+dmdD2DmdType :: DmdD s -> AnalEnv -> SubDemand -> AnalM s DmdType
+dmdD2DmdType d env sd = unDmdT d env sd >>= \(S2 val env) -> pure (DmdType env val)
+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 ->
+ 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))
+ -- 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 @x@ is used strictly or at most
+ -- once, because ultimately it never will.
+ -> pure (S2 val (addVarDmdEnv env x (C_0N `multDmd` (C_11 :* sd)))) -- discard strictness
+ (_, Nothing) -> pure t
step _ d = d
+
+botDmdD, nopDmdD :: DmdD s
+botDmdD = dmdType2DmdD (\_ _ -> pure botDmdType)
+nopDmdD = dmdType2DmdD (\_ _ -> pure nopDmdType)
+
+lubDmdD :: DmdD s -> DmdD s -> DmdD s
+lubDmdD l r = dmdType2DmdD $ \env sd -> lubDmdType <$> dmdD2DmdType l env sd <*> dmdD2DmdType r env sd
+
+instance Domain (DmdD s) where
+ stuck = botDmdD
+ erased = nopDmdD
+ lit _l = nopDmdD
+ primOp _op = nopDmdD
+ fun (x,x_ty) f = DmdT $ \env sd -> do
+ let sentinel = step (Lookup x) 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
+ let S2 body_ty' dmd = findBndrDmd env (DmdType fvs val) x x_ty
+ -- 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
+
+-- body_ty <- dmdAnal body_env body_dmd body
+-- -- See Note [Bringing a new variable into scope]
+-- let S2 body_ty' dmd = findBndrDmd env body_ty var
+-- -- pprTraceM "dmdAnal:Lam" (ppr var <+> ppr dmd $$ ppr body_ty')
+-- annotate da_demands var dmd
+-- let !lam_ty = addDemand dmd body_ty'
+-- return $! multDmdType n lam_ty
+-- where
+-- body_env = addInScopeAnalEnv env var -- See Note [Bringing a new variable into scope]
=====================================
compiler/GHC/Core/Semantics.hs
=====================================
@@ -38,6 +38,7 @@ import Data.Word
import GHC.Core.Utils hiding (findAlt)
import GHC.Core.Type
import GHC.Builtin.PrimOps
+import GHC.Builtin.Types
data Event = Lookup Name | LookupArg CoreExpr | Update | App1 | App2 | Case1 | Case2 | Let1
@@ -52,11 +53,11 @@ class Domain d where
erased :: d -- Think of it like coercionToken#
lit :: Literal -> d
primOp :: PrimOp -> d
- fun :: Id -> Type -> (d -> d) -> d
+ fun :: (Name, Type) -> (d -> d) -> d
con :: DataCon -> [d] -> d
apply :: d -> d -> d
- select :: d -> Id -> [DAlt d] -> d
-type DAlt d = (AltCon, [Id], d -> [d] -> d)
+ select :: d -> Name -> [DAlt d] -> d
+type DAlt d = (AltCon, [Name], d -> [d] -> d)
data BindHint = BindArg | BindNonRec Name | BindRec [Name]
class HasBind d where
@@ -100,7 +101,7 @@ 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) (\d -> step App2 (eval e (extendVarEnv env x d)))
+eval (Lam x e) env = fun (idName x, idType 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
@@ -173,8 +174,8 @@ instance (Trace (D τ), Monad τ) => Domain (D τ) where
IntRemOp -> intop rem
_ -> stuck
where
- intop op = binop (\v1 v2 -> case (v1,v2) of (Litt (LitNumber LitNumInt i1), Litt (LitNumber LitNumInt i2)) -> Litt (LitNumber LitNumInt (i1 `op` i2)); _ -> Stuck)
- binop f = fun x1 $ \d1 -> step App2 $ fun x2 $ \d2 -> step App2 $ f <$> d1 <*> d2
+ 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:
findAlt :: AltCon -> [DAlt d] -> Maybe (DAlt d)
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -99,6 +99,9 @@ import GHC.Utils.Panic
import Data.Coerce (coerce)
import Data.Function
+import GHC.Types.Unique
+import GHC.Types.Name
+import GHC.Types.Name.Env
{-
************************************************************************
@@ -1739,7 +1742,7 @@ a consequence of fixed-point iteration, it's not important that they agree.
-- * Saying whether or not evaluation would surely diverge ('de_div')
--
-- See Note [Demand env Equality].
-data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence }
+data DmdEnv = DE { de_fvs :: !(NameEnv Demand), de_div :: !Divergence }
instance Eq DmdEnv where
DE fv1 div1 == DE fv2 div2
@@ -1748,11 +1751,11 @@ instance Eq DmdEnv where
canonicalise div fv = filterUFM (/= defaultFvDmd div) fv
mkEmptyDmdEnv :: Divergence -> DmdEnv
-mkEmptyDmdEnv div = DE emptyVarEnv div
+mkEmptyDmdEnv div = DE emptyNameEnv div
-- | Build a potentially terminating 'DmdEnv' from a finite map that says what
-- has been evaluated so far
-mkTermDmdEnv :: VarEnv Demand -> DmdEnv
+mkTermDmdEnv :: NameEnv Demand -> DmdEnv
mkTermDmdEnv fvs = DE fvs topDiv
nopDmdEnv :: DmdEnv
@@ -1768,22 +1771,22 @@ lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div
where
-- See Note [Demand env Equality]
- lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)
+ lub_fv = plusNameEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)
lub_div = lubDivergence d1 d2
-addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv
-addVarDmdEnv env@(DE fvs div) id dmd
- = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div
+addVarDmdEnv :: DmdEnv -> Name -> Demand -> DmdEnv
+addVarDmdEnv env@(DE fvs div) x dmd
+ = DE (extendNameEnv fvs x (dmd `plusDmd` lookupDmdEnv env x)) div
plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
plusDmdEnv (DE fv1 d1) (DE fv2 d2)
-- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric.
- | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd
+ | isEmptyNameEnv fv2, defaultFvDmd d2 == absDmd
= DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient
- | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd
+ | isEmptyNameEnv fv1, defaultFvDmd d1 == absDmd
= DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient
| otherwise
- = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2))
+ = DE (plusNameEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2))
(d1 `plusDivergence` d2)
-- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum'
@@ -1794,17 +1797,17 @@ plusDmdEnvs pdas = foldl1' plusDmdEnv pdas
multDmdEnv :: Card -> DmdEnv -> DmdEnv
multDmdEnv C_11 env = env
multDmdEnv C_00 _ = nopDmdEnv
-multDmdEnv n (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div)
+multDmdEnv n (DE fvs div) = DE (mapNameEnv (multDmd n) fvs) (multDivergence n div)
reuseEnv :: DmdEnv -> DmdEnv
reuseEnv = multDmdEnv C_1N
-lookupDmdEnv :: DmdEnv -> Id -> Demand
+lookupDmdEnv :: DmdEnv -> Name -> Demand
-- See Note [Default demand on free variables and arguments]
-lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div
+lookupDmdEnv (DE fv div) x = lookupNameEnv fv x `orElse` defaultFvDmd div
-delDmdEnv :: DmdEnv -> Id -> DmdEnv
-delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div
+delDmdEnv :: DmdEnv -> Name -> DmdEnv
+delDmdEnv (DE fv div) x = DE (fv `delFromNameEnv` x) div
-- | Characterises how an expression
--
@@ -1897,19 +1900,19 @@ multDmdType n (DmdType fv args)
DmdType (multDmdEnv n fv)
(map (multDmd n) args)
-peelFV :: DmdType -> Var -> (DmdType, Demand)
-peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
+peelFV :: DmdType -> Name -> (DmdType, Demand)
+peelFV (DmdType fv ds) x = -- pprTrace "rfv" (ppr x <+> ppr dmd $$ ppr fv)
(DmdType fv' ds, dmd)
where
-- Force these arguments so that old `Env` is not retained.
- !fv' = fv `delDmdEnv` id
- !dmd = lookupDmdEnv fv id
+ !fv' = fv `delDmdEnv` x
+ !dmd = lookupDmdEnv fv x
addDemand :: Demand -> DmdType -> DmdType
addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds)
-findIdDemand :: DmdType -> Var -> Demand
-findIdDemand (DmdType fv _) id = lookupDmdEnv fv id
+findIdDemand :: DmdType -> Name -> Demand
+findIdDemand (DmdType fv _) x = lookupDmdEnv fv x
-- | When e is evaluated after executing an IO action that may throw a precise
-- exception, we act as if there is an additional control flow path that is
@@ -2171,7 +2174,7 @@ dmdSigDmdEnv :: DmdSig -> DmdEnv
dmdSigDmdEnv (DmdSig (DmdType env _)) = env
hasDemandEnvSig :: DmdSig -> Bool
-hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv
+hasDemandEnvSig = not . isEmptyNameEnv . de_fvs . dmdSigDmdEnv
botSig :: DmdSig
botSig = DmdSig botDmdType
@@ -2220,7 +2223,7 @@ isDeadEndAppSig (DmdSig (DmdType env ds)) n
= isDeadEndDiv (de_div env) && not (lengthExceeds ds n)
trimBoxityDmdEnv :: DmdEnv -> DmdEnv
-trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div
+trimBoxityDmdEnv (DE fvs div) = DE (mapNameEnv trimBoxity fvs) div
trimBoxityDmdType :: DmdType -> DmdType
trimBoxityDmdType (DmdType env ds) =
@@ -2761,9 +2764,9 @@ instance Binary Divergence where
_ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))
instance Binary DmdEnv where
- -- Ignore VarEnv when spitting out the DmdType
+ -- Ignore NameEnv when spitting out the DmdType
put_ bh (DE _ d) = put_ bh d
- get bh = DE emptyVarEnv <$> get bh
+ get bh = DE emptyNameEnv <$> get bh
instance Binary DmdType where
put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a218337ea211537bfa5c09d21dd9500241c619d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a218337ea211537bfa5c09d21dd9500241c619d
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/b040e508/attachment-0001.html>
More information about the ghc-commits
mailing list