[Git][ghc/ghc][wip/abs-den] 3 commits: stuff
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Fri Feb 9 16:18:31 UTC 2024
Sebastian Graf pushed to branch wip/abs-den at Glasgow Haskell Compiler / GHC
Commits:
f5633c11 by Sebastian Graf at 2024-02-09T16:29:45+01:00
stuff
- - - - -
5d521ee8 by Sebastian Graf at 2024-02-09T16:30:17+01:00
Questionable IdEnv change to `bind` that I can't wrap my head around
- - - - -
4707eb9e by Sebastian Graf at 2024-02-09T16:30:50+01:00
Revert "Questionable IdEnv change to `bind` that I can't wrap my head around"
This reverts commit 5d521ee8677f9604537862f138fe4cd5525cc3e3.
- - - - -
3 changed files:
- compiler/GHC/Builtin/Uniques.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Semantics.hs
Changes:
=====================================
compiler/GHC/Builtin/Uniques.hs
=====================================
@@ -308,7 +308,7 @@ Allocation of unique supply characters:
v,u: for renumbering value-, and usage- vars.
B: builtin
C-E: pseudo uniques (used in native-code generator)
- I: GHCi evaluation
+ I: GHCi and GHC.Core.Semantics evaluation
X: uniques from mkLocalUnique
_: unifiable tyvars (above)
0-9: prelude things below
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -65,7 +65,6 @@ import Data.Foldable (foldlM)
import GHC.Types.Unique.FM
import Data.IORef
import System.IO.Unsafe
-import GHC.Types.Unique
{-
************************************************************************
@@ -375,7 +374,7 @@ dmdAnalBindLetUp :: TopLevelFlag
-> AnalM DmdType
dmdAnalBindLetUp top_lvl env id rhs anal_body = do
-- See Note [Bringing a new variable into scope]
- body_ty <- anal_body (addInScopeAnalEnv env id)
+ body_ty <- anal_body (addInScopeAnalEnv top_lvl env id)
-- See Note [Finalising boxity for demand signatures]
let S2 body_ty' id_dmd = findBndrDmd env body_ty id
@@ -461,11 +460,11 @@ dmdAnalStar env (n :* sd) e = do
pure $! discardArgDmds $ multDmdType n' dmd_ty
-- Main Demand Analysis machinery
-dmdAnal, dmdAnal' :: AnalEnv
+dmdAnal'', dmdAnal' :: AnalEnv
-> SubDemand -- The main one takes a *SubDemand*
-> CoreExpr -> AnalM DmdType
-dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
+dmdAnal'' env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
dmdAnal' env d e
dmdAnal' env sd (Var var) = pure $! dmdTransform env var sd
@@ -514,14 +513,14 @@ dmdAnal' env dmd (Lam var body)
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]
+ body_env = addInScopeAnalEnv NotTopLevel env var -- See Note [Bringing a new variable into scope]
dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs])
-- Only one alternative.
-- If it's a DataAlt, it should be the only constructor of the type and we
-- can consider its field demands when analysing the scrutinee.
| want_precise_field_dmds alt_con = do
- let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+ let rhs_env = addInScopeAnalEnvs NotTopLevel env (case_bndr:bndrs)
-- See Note [Bringing a new variable into scope]
rhs_ty <- dmdAnal rhs_env dmd rhs
let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs
@@ -634,7 +633,7 @@ forcesRealWorld fam_envs ty
dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM DmdType
dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do
- let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+ let rhs_env = addInScopeAnalEnvs NotTopLevel env (case_bndr:bndrs)
-- See Note [Bringing a new variable into scope]
rhs_ty <- dmdAnal rhs_env dmd rhs
let S2 alt_ty dmds = findBndrsDmds env rhs_ty bndrs
@@ -1012,7 +1011,7 @@ 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 var
, let fn_ty = dmdTransformSig sig sd
= -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $
case top_lvl of
@@ -1077,7 +1076,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do
-- See Note [Unboxed demand on function bodies returning small products]
= unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd
- rhs_dmd_ty <- _dmdAnalNew env rhs_dmd rhs
+ rhs_dmd_ty <- dmdAnal env rhs_dmd rhs
let
(lam_bndrs, _) = collectBinders rhs
@@ -2209,7 +2208,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 sndOf3 . lookupSigEnv env') bndrs
-- annotation done in dmdAnalRhsSig
-- zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs'
pure $! S3 env' sigs' weak_fv'
@@ -2429,7 +2428,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 = IdEnv (DmdSig, TopLevelFlag)
+type SigEnv = IdEnv (Id, DmdSig, TopLevelFlag)
instance Outputable AnalEnv where
ppr env = text "AE" <+> braces (vcat
@@ -2464,23 +2463,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)
+ = extendVarEnvList env (zipWith (\v s -> (v, (v, s, top_lvl))) vars sigs)
extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> 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 x sig = extendVarEnv sigs x (sig, top_lvl)
+extendSigEnv top_lvl sigs x sig = extendVarEnv sigs x (x, sig, top_lvl)
-lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)
+lookupSigEnv :: AnalEnv -> Id -> Maybe (Id, DmdSig, TopLevelFlag)
lookupSigEnv env x = lookupVarEnv (ae_sigs env) x
-addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
-addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }
+addInScopeAnalEnv :: TopLevelFlag -> AnalEnv -> Var -> AnalEnv
+addInScopeAnalEnv top_lvl env id = extendAnalEnv top_lvl env id nopSig
-addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
-addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }
+addInScopeAnalEnvs :: TopLevelFlag -> AnalEnv -> [Var] -> AnalEnv
+addInScopeAnalEnvs top_lvl env ids = extendAnalEnvs top_lvl env ids (repeat nopSig)
findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
-- Return the demands on the Ids in the [Var]
@@ -2740,16 +2739,19 @@ sPair2DmdType (S2 val env) = DmdType env val
instance Trace DmdD where
step (Lookup x) d = \env sd -> 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))
+ (S2 val env, Just (_,_,NotTopLevel)) -> -- pprTrace "local" (ppr x <+> ppr sd) $
+ 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.
| isInterestingTopLevelFn x
- -> pure $! S2 val (addVarDmdEnv env x (C_0N `multDmd` (C_11 :* sd))) -- discard strictness
+ -> -- pprTrace "interesting" (ppr x <+> ppr sd) $
+ pure $! S2 val (addVarDmdEnv env x (C_0N `multDmd` (C_11 :* sd))) -- discard strictness
-- otherwise, fall through; we'll annotate with topDmd at the binding site.
- _ -> pure t
+ _ -> -- pprTrace "fall" (ppr x <+> ppr sd) $
+ pure t
step _ d = d
botDmdD, nopDmdD :: DmdD
@@ -2763,7 +2765,7 @@ instance Domain DmdD where
keepAlive ds env _ = do
-- This is called for denotations of free variables of Coercions, RULE RHSs
-- and unfoldings
- fvs <- plusDmdEnvs <$> traverse (\d -> squeezeSubDmd env d topSubDmd) ds
+ fvs <- plusDmdEnvs <$> traverse (\d -> squeezeDmd env d topDmd) ds
pure $! S2 [] fvs -- Nop value
stuck = botDmdD
erased = nopDmdD
@@ -2772,15 +2774,15 @@ instance Domain DmdD where
global x = -- pprTrace "dmdAnal:global" (ppr x <+> ppr (idDmdSig x)) $
sig2DmdHnf (idDmdSig x)
classOp x _cls _env sd = do
- pprTraceM "dmdAnal:classOp" (ppr x <+> ppr (idDmdSig x))
+ -- pprTraceM "dmdAnal:classOp" (ppr x <+> ppr (idDmdSig x))
pure $! dmdType2SPair (dmdTransformDictSelSig (idDmdSig x) sd)
- fun x f env sd | isTyVar x = f nopDmdD (addInScopeAnalEnv env x) sd
+ fun x f env sd | isTyVar x = f nopDmdD (addInScopeAnalEnv NotTopLevel env x) sd
| otherwise = do
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 <- f (mkSurrogate x) body_env body_sd
let S2 body_ty' dmd = findBndrDmd env (DmdType fvs val) x
- pprTraceM "dmdAnal:Lam" (ppr x <+> ppr dmd $$ ppr sd <+> ppr body_ty')
+ -- pprTraceM "dmdAnal:Lam" (ppr x <+> ppr dmd $$ ppr sd <+> ppr body_ty')
annotate da_demands x dmd
let !lam_ty = addDemand dmd body_ty'
let DmdType fvs val = multDmdType n lam_ty
@@ -2789,9 +2791,9 @@ instance Domain DmdD where
let call_sd = mkCalledOnceDmds (dataConRepArity dc) sd
let DmdType _env dmds = dmdTransformDataConSig (dataConRepStrictness dc) call_sd
let value_ds = dropList (dataConUnivAndExTyCoVars dc) ds
- massert (equalLength value_ds dmds)
+ massertPpr (equalLength value_ds dmds) (ppr dc <+> ppr (dataConRepArity dc) <+> ppr sd <+> ppr dmds <+> ppr (length value_ds))
fvs <- plusDmdEnvs <$> zipWithM (squeezeDmd env) value_ds dmds
- pprTraceM "dmdAnal:Con" (ppr dc <+> ppr sd <+> ppr dmds $$ ppr fvs)
+ -- pprTraceM "dmdAnal:Con" (ppr dc <+> ppr sd <+> ppr dmds $$ ppr fvs)
pure $! S2 [] fvs
applyTy f = f
apply f a env sd = do
@@ -2800,19 +2802,19 @@ instance Domain DmdD where
let (arg_dmd, res_ty) = splitDmdTy fun_ty
arg_fvs <- squeezeDmd env a arg_dmd
let combined_ty = res_ty `plusDmdType` arg_fvs
--- pprTraceM "dmdAnal:app" vcat $
--- [ text "sd =" <+> ppr sd
--- , text "fun dmd_ty =" <+> ppr fun_ty
--- , text "arg dmd =" <+> ppr arg_dmd
--- , text "arg dmd_ty =" <+> ppr arg_fvs
--- , text "res dmd_ty =" <+> ppr res_ty
--- , text "overall res dmd_ty =" <+> ppr combined_ty ]
+ -- pprTraceM "dmdAnal:app" $ vcat
+ -- [ text "sd =" <+> ppr sd
+ -- , text "fun dmd_ty =" <+> ppr fun_ty
+ -- , text "arg dmd =" <+> ppr arg_dmd
+ -- , text "arg dmd_ty =" <+> ppr arg_fvs
+ -- , text "res dmd_ty =" <+> ppr res_ty
+ -- , text "overall res dmd_ty =" <+> ppr combined_ty ]
pure $! dmdType2SPair combined_ty
seq_ a b env sd = do
fvs <- sSnd <$> a env seqSubDmd
dmd_ty <- sPair2DmdType <$> b env sd
pure $! dmdType2SPair (dmd_ty `plusDmdType` fvs) -- plain and simple :)
- select d test_scrut case_bndr alts env sd
+ select d scrut case_bndr alts env sd
| [(alt_con, bndrs, rhs)] <- alts, want_precise_field_dmds alt_con = do
let rhs_env = extendAnalEnvs NotTopLevel env (case_bndr:bndrs) (repeat nopSig)
-- See Note [Bringing a new variable into scope]
@@ -2837,7 +2839,7 @@ instance Domain DmdD where
let alt_ty3
-- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
- | test_scrut (exprMayThrowPreciseException (ae_fam_envs env))
+ | exprMayThrowPreciseException (ae_fam_envs env) scrut
= deferAfterPreciseException alt_ty2
| otherwise
= alt_ty2
@@ -2880,17 +2882,17 @@ instance Domain DmdD where
let fam_envs = ae_fam_envs env
alt_ty2
-- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
- | test_scrut (exprMayThrowPreciseException fam_envs)
+ | exprMayThrowPreciseException fam_envs scrut
= deferAfterPreciseException alt_ty1
| otherwise
= alt_ty1
res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2
- -- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
- -- , text "scrut_ty" <+> ppr scrut_ty
- -- , text "alt_ty1" <+> ppr alt_ty1
- -- , text "alt_ty2" <+> ppr alt_ty2
- -- , text "res_ty" <+> ppr res_ty ])
+ -- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
+ -- , text "scrut_ty" <+> ppr scrut_ty
+ -- , text "alt_ty1" <+> ppr alt_ty1
+ -- , text "alt_ty2" <+> ppr alt_ty2
+ -- , text "res_ty" <+> ppr res_ty ])
pure $! dmdType2SPair res_ty
where
want_precise_field_dmds (DataAlt dc)
@@ -2919,8 +2921,10 @@ squeezeDmd env d (n :* sd) = do
-- the results when evaluating the arg. TODO think about it more
squeezeDmdShared :: AnalEnv -> DmdD -> Demand -> AnalM DmdEnv
squeezeDmdShared env d (n :* sd) = do
- env <- squeezeSubDmd env d sd
- pure $! oneifyCard n `multDmdEnv` env
+ fvs <- squeezeSubDmd env d sd
+ -- pprTraceM "squeezeDmdShared" (ppr n <+> text ":*" <+> ppr sd $$ ppr fvs)
+ pure $! oneifyCard n `multDmdEnv` fvs
+
instance HasBind DmdD where
bind (BindArg x) arg body env sd = do
@@ -3089,9 +3093,9 @@ bindFix top_lvl pairs rhss env let_sd
-- For convenience, we also pass the bndr's DmdSig instead of fetching it
-- from AnalEnv on every iteration.
loop :: Int -> [DmdSig] -> AnalM (SPair [DmdSig] WeakDmds)
- loop n sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)
- -- | (id,_) <- sigs]) $
- loop' n sigs
+ loop n sigs = -- pprTrace "bindFix" (ppr n <+> vcat [ ppr x <+> ppr sig
+ -- | (x,sig) <- zip bndrs sigs]) $
+ loop' n sigs
loop' n sigs | n == 10 = abort
| otherwise = do
@@ -3127,19 +3131,15 @@ updateListAt 0 x (_:xs) = x:xs
updateListAt n x (y:xs) = y:updateListAt (n-1) x xs
updateListAt _ _ [] = panic "oops"
-_dmdAnalNew :: AnalEnv
+dmdAnal :: AnalEnv
-> SubDemand -- The main one takes a *SubDemand*
-> CoreExpr -> AnalM DmdType
-_dmdAnalNew env sd e = sPair2DmdType <$> eval e (mapUFM_Directly f (ae_sigs env)) env sd
+dmdAnal env sd e = do
+ let _old = discardAnnotations $ dmdAnal'' env sd e
+ _new <- sPair2DmdType <$> eval e (mapVarEnv f (ae_sigs env)) env sd
+ -- warnPprTraceM (_new /= _old) "URGH" (ppr e $$ ppr sd $$ text "old:" <+> ppr _old $$ text "new:" <+> ppr _new)
+ -- pprTraceM "_dmdAnal" (ppr e $$ ppr sd <+> arrow <+> ppr _new)
+ -- dmdAnal'' env sd e
+ pure $! _old
where
- f x (sig, top_lvl) env sd = do
- -- We imitate `step (Lookup x)` here, for a top-level thing.
- S2 val fvs <- sig2DmdHnf sig env sd
- pure $! case top_lvl of
- NotTopLevel -> S2 val (addVarDmdEnv_Directly fvs x (C_11 :* sd))
- TopLevel -> S2 val (addVarDmdEnv_Directly fvs x (C_0N `multDmd` (C_11 :* sd))) -- discard strictness
-
- addVarDmdEnv_Directly :: DmdEnv -> Unique -> Demand -> DmdEnv
- -- like addVarDmdEnv, but working on a Unique (which is all we have)
- addVarDmdEnv_Directly (DE fvs div) x dmd
- = DE (addToUFM_Directly fvs x (dmd `plusDmd` (lookupVarEnv_Directly fvs x `orElse` defaultFvDmd div))) div
+ f (x, sig, _top_lvl) = step (Lookup x) (sig2DmdHnf sig)
=====================================
compiler/GHC/Core/Semantics.hs
=====================================
@@ -14,8 +14,6 @@ module GHC.Core.Semantics where
import GHC.Prelude
-import GHC.Builtin.Uniques
-
import GHC.Core
import GHC.Core.Coercion
import GHC.Core.DataCon
@@ -43,6 +41,7 @@ import GHC.Core.TyCo.Rep
import GHC.Core.FVs
import GHC.Core.Class
import GHC.Types.Id.Info
+import GHC.Types.Unique
data Event = Lookup Id | LookupArg CoreExpr | Update | App1 | App2 | Case1 | Case2 | Let1
@@ -63,7 +62,7 @@ class Domain d where
con :: DataCon -> [d] -> d
apply :: d -> d -> d
applyTy :: d -> d -- URGHHH otherwise we have no easy way to discern Type Apps
- select :: d -> ((CoreExpr -> Bool) -> Bool) -> Id -> [DAlt d] -> d
+ select :: d -> CoreExpr -> Id -> [DAlt d] -> d
keepAlive :: [d] -> d -- Used for coercion FVs, unfolding and RULE FVs. No simple semantic description for those; pretend that they may or may not be seq'd.
seq_ :: d -> d -> d -- The primitive one. Just like `select a (const False) wildCardId [(DEFAULT, [], \_a _ds -> b)]`, but we don't have available the type of the LHS.
type DAlt d = (AltCon, [Id], d -> [d] -> d)
@@ -83,6 +82,16 @@ feignBndr n (Named (Bndr tcv _)) = tcv `setVarName` n
feignId :: Name -> Type -> Id
feignId n ty = mkLocalIdOrCoVar n ManyTy ty
+mkPap :: (Trace d, Domain d) => [PiTyBinder] -> ([d] -> d) -> d
+mkPap arg_bndrs app_head = go [] (zipWith feignBndr localNames arg_bndrs)
+ where
+ go ds [] = app_head (reverse ds)
+ go ds (x:xs) = fun x (\d -> step App2 $ go (d:ds) xs) -- cf. the Lam case of eval
+
+x1,x2 :: Name
+localNames :: [Name]
+localNames@(x1:x2:_) = [ mkSystemName (mkUniqueInt 'I' i) (mkVarOcc "local") | i <- [0..] ]
+
-- The following does not work, because we need the `idType` of `a` in `select`:
-- seq_ :: Domain d => d -> d -> d
-- seq_ a b = select a (const False) wildCardId [(DEFAULT, [], \_a _ds -> b)]
@@ -129,35 +138,37 @@ keepAliveUnfRules :: Domain d => Id -> IdEnv d -> d
-- ^ `keepAlive` the free Ids of an Id's unfolding and RULE RHSs.
keepAliveUnfRules x = keepAliveVars (nonDetEltsUniqSet $ bndrRuleAndUnfoldingIds x)
+evalConApp :: (Trace d, Domain d, HasBind d) => DataCon -> [d] -> d
+evalConApp dc args = case compareLength rep_ty_bndrs args of
+ EQ -> con dc args
+ GT -> stuck -- oversaturated => stuck
+ LT -> mkPap rest_bndrs $ \etas -> con dc (args ++ etas) -- undersaturated => PAP
+ where
+ rep_ty_bndrs = fst $ splitPiTys (dataConRepType dc) -- TODO: Cache this in DataCon?
+ rest_bndrs = dropList args rep_ty_bndrs
+
evalVar :: (Trace d, Domain d, HasBind d) => Var -> IdEnv d -> (d -> d) -> d
evalVar x env k = case idDetails x of
- _ | isTyVar x -> erased
- DataConWorkId dc -> k (con dc []) -- TODO
+ _ | isTyVar x -> k erased
+ DataConWorkId dc -> k (evalConApp dc [])
DataConWrapId _ -> -- pprTrace "unfolding wrapper" (ppr x $$ ppr (unfoldingTemplate (idUnfolding x))) $
k (eval (unfoldingTemplate (idUnfolding x)) emptyVarEnv)
PrimOpId op _ -> k (primOp x op)
ClassOpId cls _ -> k (classOp x cls)
_ | isGlobalId x -> k (global x)
- _ -> case lookupVarEnv env x of
- Just d -> k d
- _ -> stuck -- Scoping error. Actually ruled out by the Core type system
+ _ -> maybe stuck k (lookupVarEnv env x)
eval :: (Trace d, Domain d, HasBind d) => CoreExpr -> IdEnv d -> d
eval (Coercion co) env = keepAliveCo co env
eval (Type _ty) _ = erased
eval (Lit l) _ = lit l
eval (Tick _t e) env = eval e env
-eval (Cast e _co) env = eval e env
+eval (Cast e co) env = keepAliveCo co env `seq_` eval e env
eval (Var x) env = evalVar x env id
eval (Lam x e) env = fun 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 $ \es -> case compare (dataConRepArity dc) (length es) of
- EQ -> con dc es
- GT -> stuck -- oversaturated => stuck
- LT -> mkPap rest_bndrs $ \etas -> con dc (es ++ etas) -- undersaturated => PAP
- where
- rest_bndrs = dropList es (fst $ splitPiTys (dataConRepType dc))
+ = anfiseMany as env (evalConApp dc)
| otherwise
= anfiseMany (f:as) env $ \(df:das) -> -- NB: anfise is a no-op for Vars
go df (zipWith (\d a -> (d, isTypeArg a)) das as)
@@ -182,20 +193,37 @@ eval (Let b@(Rec binds) body) env =
xs = map fst binds
new_env ds = extendVarEnvList env (zipWith (\x d -> (x, step (Lookup x) d)) xs ds)
eval (Case e b _ty alts) env = step Case1 $
- select (eval e env) ($ e) b
+ select (eval e env) e b
[ (con, 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) => [PiTyBinder] -> ([d] -> d) -> d
-mkPap arg_bndrs f = go [] (zipWith feignBndr localNames arg_bndrs)
- where
- go ds [] = f (reverse ds)
- go ds (x:xs) = fun x (\d -> step App2 $ go (d:ds) xs)
-
-x1,x2 :: Name
-localNames :: [Name]
-localNames@(x1:x2:_) = [ mkSystemName (mkBuiltinUnique i) (mkVarOcc "local") | i <- [0..] ]
+ cont xs rhs scrut ds = step Case2 $
+ eval rhs (extendVarEnvList env (zipEqual "eval Case{}" (b:xs) (scrut:ds)))
+ -- TODO: Do we want (step (Lookup b) scrut)? I think not, because Case
+ -- does not actually allocate itself. On the other hand, not all Values
+ -- are currently heap-bound... e.g., case Just x of b -> b would not do
+ -- a lookup transition at all, despite `Just x` living on the heap...
+ -- Urgh, think about it later.
+ -- Literature does not often handle case binders.
+ -- Fast Curry and Frame-limited re-use do not, for example.
+ -- But the former unconditionally let-binds values, thus absolving of
+ -- the problem. Perhaps we should do the same. It's what CorePrep does,
+ -- after all.
+
+--evalProgram :: (Trace d, Domain d, HasBind d) => [CoreRule] -> CoreProgram -> [d]
+--evalProgram rules binds
+-- where
+-- go [] =
+-- keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv
+-- -- See Note [Absence analysis for stable unfoldings and RULES]
+-- -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in
+-- -- orphan RULES
+-- keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids))
+--
+-- is_root :: Id -> Bool
+-- is_root id = isExportedId id || elemVarSet id rule_fvs
+--
+-- rule_fvs :: IdSet
+-- rule_fvs = rulesRhsFreeIds rules
-- By-need semantics, from the paper
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b30b44215a8fc538d9af29eefe3fa43ec33ec756...4707eb9ee0cab489018ac22e44e348a7b3690473
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b30b44215a8fc538d9af29eefe3fa43ec33ec756...4707eb9ee0cab489018ac22e44e348a7b3690473
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/20240209/2ec50465/attachment-0001.html>
More information about the ghc-commits
mailing list