[Git][ghc/ghc][wip/abs-den] 2 commits: Switch back to ST
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Mon Jun 24 16:32:49 UTC 2024
Sebastian Graf pushed to branch wip/abs-den at Glasgow Haskell Compiler / GHC
Commits:
f345205a by Sebastian Graf at 2024-06-05T18:48:30+02:00
Switch back to ST
- - - - -
33f4bdda by Sebastian Graf at 2024-06-24T18:32:35+02:00
Improvements
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Semantics.hs
- ghdi.hs
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -58,13 +58,15 @@ import GHC.Utils.Outputable
import Data.List ( mapAccumL )
import Data.Functor.Identity
-import Control.Monad.Trans.Reader
import Control.Monad
+import Control.Monad.ST
+import Control.Monad.Trans.Reader
+import Data.STRef
import GHC.Data.Maybe
import Data.Foldable (foldlM)
import GHC.Types.Unique.FM
-import Data.IORef
import System.IO.Unsafe
+import Control.Monad.ST.Unsafe
{-
************************************************************************
@@ -94,28 +96,28 @@ data DmdAnalOpts = DmdAnalOpts
-- See Note [Space Leaks in Demand Analysis]
type WithDmdType a = SPair DmdType a
-type AnalM = ReaderT (DmdAnnotations IORef) IO
+type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s)
-annotate :: (DmdAnnotations IORef -> IORef (IdEnv a)) -> Id -> a -> AnalM ()
-annotate ref x !a = ReaderT $ \ann -> modifyIORef' (ref ann) (\env -> extendVarEnv env x a)
+annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s ()
+annotate ref x !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env x a)
-readAnn :: (DmdAnnotations IORef -> IORef (IdEnv a)) -> AnalM (IdEnv a)
-readAnn ref = ReaderT $ \ann -> readIORef (ref ann)
+readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a)
+readAnn ref = ReaderT $ \ann -> readSTRef (ref ann)
-runAnalM :: AnalM a -> IO (DmdAnnotations Identity)
-runAnalM m = do -- unsafePerformIO would be fine, too; we are just using IO for local IORefs
- env <- DA <$> newIORef emptyVarEnv <*> newIORef emptyVarEnv
+runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity
+runAnalM m = runST $ do
+ env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv
_a <- runReaderT m env
- demands <- readIORef (da_demands env)
- sigs <- readIORef (da_sigs env)
+ demands <- readSTRef (da_demands env)
+ sigs <- readSTRef (da_sigs env)
pure $! DA (Identity demands) (Identity sigs)
-discardAnnotations :: AnalM a -> a
+discardAnnotations :: AnalM s a -> a
-- a is either DmdEnv or DmdType.
--- IO is just used for local IORefs for annotations that will be discarded
--- afterwards, hence the use of unsafePerformIO below is safe
-discardAnnotations m = unsafePerformIO $ do
- env <- DA <$> newIORef emptyVarEnv <*> newIORef emptyVarEnv
+-- The state thread is just used for local STRefs for annotations that will be
+-- discarded afterwards, hence the use of unsafePerformIO below is safe
+discardAnnotations m = unsafePerformIO $ unsafeSTToIO $ do
+ env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv
runReaderT m env
-- | Outputs a new copy of the Core program in which binders have been annotated
@@ -125,7 +127,7 @@ discardAnnotations m = unsafePerformIO $ do
-- [Stamp out space leaks in demand analysis])
dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
dmdAnalProgram opts fam_envs rules binds = do
- anns <- runAnalM (go (emptyAnalEnv opts fam_envs) binds)
+ let anns = runAnalM (go (emptyAnalEnv opts fam_envs) binds)
pure $! annotateProgram anns binds
where
-- See Note [Analysing top-level bindings]
@@ -325,9 +327,9 @@ dmdAnalBind
-> SubDemand -- ^ Demand put on the "body"
-- (important for join points)
-> CoreBind
- -> (AnalEnv -> AnalM DmdType) -- ^ How to analyse the "body", e.g.
+ -> (AnalEnv -> AnalM s DmdType) -- ^ How to analyse the "body", e.g.
-- where the binding is in scope
- -> AnalM DmdType
+ -> AnalM s DmdType
dmdAnalBind top_lvl env dmd bind anal_body = case bind of
NonRec id rhs
| useLetUp top_lvl id
@@ -338,7 +340,7 @@ 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.
-annotateBindDemand :: TopLevelFlag -> Id -> Demand -> AnalM ()
+annotateBindDemand :: TopLevelFlag -> Id -> 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
@@ -347,7 +349,7 @@ annotateBindDemand top_lvl x dmd = case top_lvl of
-- `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 ()
+annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s ()
annotateSig opts id sig = annotate da_sigs id $
if dmd_do_boxity opts || isBottomingSig sig
then sig
@@ -370,8 +372,8 @@ dmdAnalBindLetUp :: TopLevelFlag
-> AnalEnv
-> Id
-> CoreExpr
- -> (AnalEnv -> AnalM DmdType)
- -> AnalM DmdType
+ -> (AnalEnv -> AnalM s DmdType)
+ -> AnalM s DmdType
dmdAnalBindLetUp top_lvl env id rhs anal_body = do
-- See Note [Bringing a new variable into scope]
body_ty <- anal_body (addInScopeAnalEnv top_lvl env id)
@@ -401,7 +403,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = do
-- Local non-recursive definitions without a lambda are handled with LetUp.
--
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
-dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM DmdType) -> AnalM DmdType
+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM s DmdType) -> AnalM s DmdType
dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
NonRec id rhs -> do
S2 env' weak_fv <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs
@@ -450,7 +452,7 @@ anticipateANF e n
dmdAnalStar :: AnalEnv
-> Demand -- This one takes a *Demand*
-> CoreExpr
- -> AnalM DmdEnv
+ -> AnalM s DmdEnv
dmdAnalStar env (n :* sd) e = do
-- NB: (:*) expands AbsDmd and BotDmd as needed
dmd_ty <- dmdAnal env sd e
@@ -462,7 +464,7 @@ dmdAnalStar env (n :* sd) e = do
-- Main Demand Analysis machinery
dmdAnal'', dmdAnal' :: AnalEnv
-> SubDemand -- The main one takes a *SubDemand*
- -> CoreExpr -> AnalM DmdType
+ -> CoreExpr -> AnalM s DmdType
dmdAnal'' env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
dmdAnal' env d e
@@ -631,7 +633,7 @@ forcesRealWorld fam_envs ty
| otherwise
= False
-dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM DmdType
+dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM s DmdType
dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do
let rhs_env = addInScopeAnalEnvs NotTopLevel env (case_bndr:bndrs)
-- See Note [Bringing a new variable into scope]
@@ -1057,7 +1059,7 @@ dmdAnalRhsSig
-> RecFlag
-> AnalEnv -> SubDemand
-> Id -> CoreExpr
- -> AnalM (SPair AnalEnv WeakDmds)
+ -> AnalM s (SPair AnalEnv WeakDmds)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
@@ -1123,7 +1125,7 @@ _dmdAnalRhsSig2
-> RecFlag
-> AnalEnv -> SubDemand
-> Id -> CoreExpr
- -> AnalM (SPair AnalEnv WeakDmds)
+ -> AnalM s (SPair AnalEnv WeakDmds)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
@@ -2226,7 +2228,7 @@ dmdFix :: TopLevelFlag
-> AnalEnv -- Does not include bindings for this binding
-> SubDemand
-> [(Id,CoreExpr)]
- -> AnalM (SPair AnalEnv WeakDmds)
+ -> AnalM s (SPair AnalEnv WeakDmds)
dmdFix top_lvl env let_sd pairs
= do sigs <- read_sigs; loop 1 (next_env sigs) sigs
where
@@ -2241,7 +2243,7 @@ dmdFix top_lvl env let_sd pairs
-- If fixed-point iteration does not yield a result we use this instead
-- See Note [Safe abortion in the fixed-point iteration]
- abort :: AnalM (SPair AnalEnv WeakDmds)
+ abort :: AnalM s (SPair AnalEnv WeakDmds)
abort = do
S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ])
-- NB: step updates the annotation
@@ -2254,7 +2256,7 @@ dmdFix top_lvl env let_sd pairs
-- terminates if that annotation does not change any more.
-- For convenience, we also pass the bndr's DmdSig instead of fetching it
-- from AnalEnv on every iteration.
- loop :: Int -> AnalEnv -> [DmdSig] -> AnalM (SPair AnalEnv WeakDmds)
+ loop :: Int -> AnalEnv -> [DmdSig] -> AnalM s (SPair AnalEnv WeakDmds)
loop n env sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)
-- | (id,_) <- sigs]) $
loop' n env sigs
@@ -2268,7 +2270,7 @@ dmdFix top_lvl env let_sd pairs
then pure $! S2 env' weak_fv'
else loop (n+1) env' sigs'
- step :: AnalEnv -> AnalM (STriple AnalEnv [DmdSig] WeakDmds)
+ step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds)
step env = do
S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs
-- foldlM: Use the new signature to do the next pair
@@ -2396,7 +2398,7 @@ addWeakFVs dmd_ty weak_fvs
-- L demand doesn't get both'd with the Bot coming up from the inner
-- call to f. So we just get an L demand for x for g.
-annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM ()
+annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s ()
annotateBndrsDemands bs ds =
zipWithEqualM_ "annotateBndrsDemands"
(annotate da_demands) (filter isRuntimeVar bs) ds
@@ -2481,7 +2483,6 @@ data AnalEnv = AE
{ ae_opts :: !DmdAnalOpts
-- ^ Analysis options
, ae_sigs :: !SigEnv
- -- ^ True on first iteration only. See Note [Initialising strictness]
, ae_fam_envs :: !FamInstEnvs
, ae_rec_dc :: DataCon -> IsRecDataConResult
-- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
@@ -2782,17 +2783,17 @@ annotateProgram anns = runIdentity . traverseBinders (Identity . annotate)
-- Semantics stuff
-type DmdT v = AnalEnv -> SubDemand -> AnalM (SPair v DmdEnv)
+type DmdT s v = AnalEnv -> SubDemand -> AnalM s (SPair v DmdEnv)
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
-type DmdHnf = DmdD
+type DmdHnf s = DmdD s
-- Denotation of a (syntactic) value;
-- squeezing with `seqSubDmd` yields nothing.
-- DmdHnf can be freely duplicated.
@@ -2802,8 +2803,8 @@ dmdType2SPair (DmdType env val) = S2 val env
sPair2DmdType :: SPair DmdVal DmdEnv -> DmdType
sPair2DmdType (S2 val env) = DmdType env val
-instance Trace DmdD where
- step (Lookup x) d = \env sd -> d env sd >>= \t ->
+instance Trace (DmdD s) where
+ step (Look x) d = \env sd -> d env sd >>= \t ->
case (t, lookupSigEnv env x) of
(S2 val env, Just (_,_,NotTopLevel)) -> -- pprTrace "local" (ppr x <+> ppr sd) $
pure $! S2 val (addVarDmdEnv env x (C_11 :* sd))
@@ -2820,19 +2821,14 @@ instance Trace DmdD where
pure t
step _ d = d
-botDmdD, nopDmdD :: DmdD
+botDmdD, nopDmdD :: DmdD s
botDmdD _ _ = pure (dmdType2SPair botDmdType)
nopDmdD _ _ = pure (dmdType2SPair nopDmdType)
-mkSurrogate :: Id -> DmdD
-mkSurrogate x = step (Lookup x) nopDmdD
+mkSurrogate :: Id -> DmdD s
+mkSurrogate x = step (Look x) nopDmdD
-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 -> squeezeDmd env d topDmd) ds
- pure $! S2 [] fvs -- Nop value
+instance Domain (DmdD s) where
stuck = botDmdD
erased = nopDmdD
lit _l = nopDmdD
@@ -2861,8 +2857,8 @@ instance Domain DmdD where
fvs <- plusDmdEnvs <$> zipWithM (squeezeDmd env) value_ds dmds
-- pprTraceM "dmdAnal:Con" (ppr dc <+> ppr sd <+> ppr dmds $$ ppr fvs)
pure $! S2 [] fvs
- applyTy f = f
- apply f a env sd = do
+ apply f (True, _d) = f
+ apply f (False, a) = \env sd -> do
let call_sd = mkCalledOnceDmd sd
fun_ty <- sPair2DmdType <$> f env call_sd
let (arg_dmd, res_ty) = splitDmdTy fun_ty
@@ -2876,10 +2872,6 @@ instance Domain DmdD where
-- , 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 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)
@@ -2971,11 +2963,17 @@ instance Domain DmdD where
= True
want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above
want_precise_field_dmds DEFAULT = True
+ keepAlive ds d env sd = do
+ -- This is called for denotations of free variables of Coercions, RULE RHSs
+ -- and unfoldings
+ fvs <- plusDmdEnvs <$> traverse (\d -> squeezeDmd env d topDmd) ds
+ dmd_ty <- sPair2DmdType <$> d env sd
+ pure $! dmdType2SPair (dmd_ty `plusDmdType` fvs) -- plain and simple :)
-squeezeSubDmd :: AnalEnv -> DmdD -> SubDemand -> AnalM DmdEnv
+squeezeSubDmd :: AnalEnv -> DmdD s -> SubDemand -> AnalM s DmdEnv
squeezeSubDmd env d sd = sSnd <$> d env sd
-squeezeDmd :: AnalEnv -> DmdD -> Demand -> AnalM DmdEnv
+squeezeDmd :: AnalEnv -> DmdD s -> Demand -> AnalM s DmdEnv
squeezeDmd env d (n :* sd) = do
deep <- squeezeSubDmd env d sd
let hnf = discardAnnotations $ squeezeSubDmd env d seqSubDmd
@@ -2985,14 +2983,14 @@ squeezeDmd env d (n :* sd) = do
-- | Here we assume that repeated evaluation shares work; still, we must lazify
-- the results when evaluating the arg. TODO think about it more
-squeezeDmdShared :: AnalEnv -> DmdD -> Demand -> AnalM DmdEnv
+squeezeDmdShared :: AnalEnv -> DmdD s -> Demand -> AnalM s DmdEnv
squeezeDmdShared env d (n :* sd) = do
fvs <- squeezeSubDmd env d sd
-- pprTraceM "squeezeDmdShared" (ppr n <+> text ":*" <+> ppr sd $$ ppr fvs)
pure $! oneifyCard n `multDmdEnv` fvs
-instance HasBind DmdD where
+instance HasBind (DmdD s) where
bind (BindArg x) arg body env sd = do
-- TODO this is pretty much bindLetUp, with some differences:
-- 1. we need a surrogate to track eval of x
@@ -3013,10 +3011,10 @@ instance HasBind DmdD where
where
env_rhs = enterDFun bind env
-sig2DmdHnf :: DmdSig -> DmdHnf
+sig2DmdHnf :: DmdSig -> DmdHnf s
sig2DmdHnf sig _env sd = pure (dmdType2SPair (dmdTransformSig sig sd))
-bindLetDown :: TopLevelFlag -> CoreBind -> [[DmdD] -> DmdD] -> ([DmdD] -> DmdD) -> DmdD
+bindLetDown :: TopLevelFlag -> CoreBind -> [[DmdD s] -> DmdD s] -> ([DmdD s] -> DmdD s) -> DmdD s
bindLetDown top_lvl bind rhss body env sd = case bind of
NonRec x e | let rhs = only rhss -> do
S2 sig weak_fv <- bindRhsSig NonRecursive x e (rhs []) env sd
@@ -3048,7 +3046,7 @@ bindLetDown top_lvl bind rhss body env sd = case bind of
-- bother to re-analyse the RHS.
-bindLetUp :: Id -> DmdD -> ([DmdD] -> DmdD) -> DmdD
+bindLetUp :: Id -> DmdD s -> ([DmdD s] -> DmdD s) -> DmdD s
bindLetUp x rhs body env sd = do
let body_env = extendAnalEnv NotTopLevel env x nopSig
-- See Note [Bringing a new variable into scope]
@@ -3064,8 +3062,8 @@ bindLetUp x rhs body env sd = do
bindRhsSig
- :: RecFlag -> Id -> CoreExpr -> DmdD
- -> AnalEnv -> SubDemand -> AnalM (SPair DmdSig WeakDmds)
+ :: RecFlag -> Id -> CoreExpr -> DmdD s
+ -> AnalEnv -> SubDemand -> AnalM s (SPair DmdSig WeakDmds)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
@@ -3125,12 +3123,12 @@ bindRhsSig rec_flag x e rhs env let_sd = do
annotateSig opts x sig
pure $! S2 sig weak_fvs
-bindFix :: TopLevelFlag
+bindFix :: forall s. TopLevelFlag
-> [(Id,CoreExpr)]
- -> [[DmdD] -> DmdD]
+ -> [[DmdD s] -> DmdD s]
-> AnalEnv -- Does not include bindings for this binding
-> SubDemand
- -> AnalM (SPair [DmdSig] WeakDmds)
+ -> AnalM s (SPair [DmdSig] WeakDmds)
bindFix top_lvl pairs rhss env let_sd
= do sigs <- read_sigs; loop 1 sigs
where
@@ -3145,7 +3143,7 @@ bindFix top_lvl pairs rhss env let_sd
-- If fixed-point iteration does not yield a result we use this instead
-- See Note [Safe abortion in the fixed-point iteration]
- abort :: AnalM (SPair [DmdSig] WeakDmds)
+ abort :: AnalM s (SPair [DmdSig] WeakDmds)
abort = do
S2 sigs' weak_fv <- step [ nopSig | _ <- bndrs ]
-- NB: step updates the annotation
@@ -3159,7 +3157,7 @@ bindFix top_lvl pairs rhss env let_sd
-- terminates if that annotation does not change any more.
-- 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 :: Int -> [DmdSig] -> AnalM s (SPair [DmdSig] WeakDmds)
loop n sigs = -- pprTrace "bindFix" (ppr n <+> vcat [ ppr x <+> ppr sig
-- | (x,sig) <- zip bndrs sigs]) $
loop' n sigs
@@ -3173,7 +3171,7 @@ bindFix top_lvl pairs rhss env let_sd
then pure $! S2 sigs' weak_fv'
else loop (n+1) sigs'
- step :: [DmdSig] -> AnalM (SPair [DmdSig] WeakDmds)
+ step :: [DmdSig] -> AnalM s (SPair [DmdSig] WeakDmds)
step sigs = do
-- TODO URGH updating one list entry at a time is easily the worst case
-- for linked lists. Unfortunately, it's linked lists all the way in
@@ -3204,7 +3202,7 @@ updateListAt _ _ [] = panic "oops"
dmdAnal :: AnalEnv
-> SubDemand -- The main one takes a *SubDemand*
- -> CoreExpr -> AnalM DmdType
+ -> CoreExpr -> AnalM s DmdType
dmdAnal env sd e = do
let _old = discardAnnotations $ dmdAnal'' env sd e
_new <- sPair2DmdType <$> eval e (mapVarEnv f (ae_sigs env)) env sd
@@ -3213,4 +3211,4 @@ dmdAnal env sd e = do
-- dmdAnal'' env sd e
pure $! _new
where
- f (x, sig, _top_lvl) = step (Lookup x) (sig2DmdHnf sig)
+ f (x, sig, _top_lvl) = step (Look x) (sig2DmdHnf sig)
=====================================
compiler/GHC/Core/Semantics.hs
=====================================
@@ -42,8 +42,9 @@ import GHC.Core.FVs
import GHC.Core.Class
import GHC.Types.Id.Info
import GHC.Types.Unique
+import GHC.Builtin.Names
-data Event = Lookup Id | LookupArg CoreExpr | Update | App1 | App2 | Case1 | Case2 | Let1
+data Event = Look Id | LookArg CoreExpr | Update | App1 | App2 | Case1 | Case2 | Let1
class Trace d where
step :: Event -> d -> d
@@ -58,16 +59,16 @@ class Domain d where
global :: Id -> d
classOp :: Id -> Class -> d
primOp :: Id -> PrimOp -> d
- fun :: Id -> (d -> d) -> d
+ fun :: Var -> (d -> d) -> d
con :: DataCon -> [d] -> d
- apply :: d -> d -> d
- applyTy :: d -> d -- URGHHH otherwise we have no easy way to discern Type Apps
+ apply :: d -> (Bool, 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.
+ keepAlive :: [d] -> d -> d
+ -- ^ "keep alive" the list, but return the second argument.
+ -- Used for coercion FVs, unfolding and RULE FVs. No simple semantic
+ -- description for those; pretend that they may or may not be seq'd.
type DAlt d = (AltCon, [Id], d -> [d] -> d)
-
data BindHint = BindArg Id | BindLet CoreBind
class HasBind d where
bind :: BindHint -> [[d] -> d] -> ([d] -> d) -> d
@@ -75,6 +76,23 @@ class HasBind d where
-- `HasBind (D (ByNeed T))` does not look at it.
-- Still useful for analyses!
+keepAliveVars :: Domain d => [Id] -> IdEnv d -> d -> d
+-- Make sure that the given (local) Ids are all "alive", that is, in scope and
+-- reachable through `keepAlive` (which itself is a rather abstract concept).
+keepAliveVars xs env | Just ds <- traverse (lookupVarEnv env) xs = keepAlive ds
+ | otherwise = const stuck
+
+keepAliveCo :: Domain d => Coercion -> IdEnv d -> d -> d
+-- Coercions are ultimately erased to `coercionToken#` because they are
+-- irrelevant to runtime behavior (of a /well-typed/ program).
+-- Nevertheless, they have a static semantics that requires its free variables
+-- to be present; otherwise the coercion is considered stuck.
+keepAliveCo co = keepAliveVars (nonDetEltsUniqSet $ coVarsOfCo co)
+
+keepAliveUnfRules :: Domain d => Id -> IdEnv d -> d -> d
+-- ^ `keepAlive` the free Ids of an Id's unfolding and RULE RHSs.
+keepAliveUnfRules x = keepAliveVars (nonDetEltsUniqSet $ bndrRuleAndUnfoldingIds x)
+
feignBndr :: Name -> PiTyBinder -> Var
feignBndr n (Anon (Scaled mult ty) _) = mkLocalIdOrCoVar n mult ty
feignBndr n (Named (Bndr tcv _)) = tcv `setVarName` n
@@ -92,51 +110,29 @@ 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)]
---
--- wildCardId :: Id
--- wildCardId = feignBndr wildCardName (Anon (Scaled ManyTy panicType) FTF_T_T)
---
--- panicType :: HasCallStack => Type
--- panicType = panic "The seq_ case binder should be dead, we don't need its type"
-
-anfise :: (Trace d, Domain d, HasBind d) => Name -> CoreExpr -> IdEnv d -> (d -> d) -> d
-anfise _ (Lit l) _ k = k (lit l)
-anfise _ (Var x) env k = evalVar x env k
-anfise _ (Coercion co) env k = keepAliveCo co env `seq_` k erased
-anfise _ (Type _ty) _ k = k erased
-anfise x (Tick _t e) env k = anfise x e env k
-anfise x (Cast e co) env k = keepAliveCo co env `seq_` anfise x e env k
-anfise x e env k = bind (BindArg (feignId x (exprType e))) [\_ -> eval e env]
- (\ds -> let d = step (LookupArg e) (only ds) in
- if isUnliftedType (exprType e) && not (exprOkForSpeculation e)
- then d `seq_` k d
- else k d)
-
-anfiseMany :: (Trace d, Domain d, HasBind d) => [CoreExpr] -> IdEnv d -> ([d] -> d) -> d
-anfiseMany es env k = go (zip localNames es) []
+anfise :: (Trace d, Domain d, HasBind d) => [CoreExpr] -> IdEnv d -> ([d] -> d) -> d
+anfise es env k = go (zip localNames es) []
where
go [] ds = k (reverse ds)
- go ((x,e):es) ds = anfise x e env $ \d -> go es (d:ds)
-
-keepAliveVars :: Domain d => [Id] -> IdEnv d -> d
--- Make sure that the given (local) Ids are all "alive", that is, in scope and
--- reachable through `keepAlive` (which itself is a rather abstract concept).
-keepAliveVars xs env | Just ds <- traverse (lookupVarEnv env) xs = keepAlive ds
- | otherwise = stuck
-
-keepAliveCo :: Domain d => Coercion -> IdEnv d -> d
--- Coercions are ultimately erased to `coercionToken#` because they are
--- irrelevant to runtime behavior (of a /well-typed/ program).
--- Nevertheless, they have a static semantics that requires its free variables
--- to be present; otherwise the coercion is considered stuck.
-keepAliveCo co = keepAliveVars (nonDetEltsUniqSet $ coVarsOfCo co)
-
-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)
+ go ((x,e):es) ds = anf_one x e env $ \d -> go es (d:ds)
+ anf_one _ (Lit l) _ k = k (lit l)
+ anf_one _ (Var x) env k = evalVar x env k
+ anf_one _ (Coercion co) env k = keepAliveCo co env (k erased)
+ anf_one _ (Type _ty) _ k = k erased
+ anf_one x (Tick _t e) env k = anf_one x e env k
+ anf_one x (Cast e co) env k = keepAliveCo co env (anf_one x e env k)
+ anf_one x e env k = bind (BindArg (feignId x e_ty)) [\_ -> eval e env]
+ (\ds -> let d = step (LookArg e) (only ds) in
+ if isUnliftedType e_ty && not (exprOkForSpeculation e)
+ then seq_ (d,e,e_ty) (k d)
+ else k d)
+ where
+ e_ty = exprType e
+ seq_ :: Domain d => (d,CoreExpr,Type) -> d -> d
+ seq_ (a,e,ty) b = select a e wildCardId [(DEFAULT, [], \_a _ds -> b)]
+ where
+ wildCardId :: Id
+ wildCardId = feignBndr wildCardName (Anon (Scaled ManyTy ty) FTF_T_T)
evalConApp :: (Trace d, Domain d, HasBind d) => DataCon -> [d] -> d
evalConApp dc args = case compareLength args rep_ty_bndrs of
@@ -159,56 +155,49 @@ evalVar x env k = case idDetails x of
_ -> 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 (Coercion co) env = keepAliveCo co env erased
eval (Type _ty) _ = erased
eval (Lit l) _ = lit l
eval (Tick _t e) env = eval e env
-eval (Cast e co) env = keepAliveCo co env `seq_` eval e env
+eval (Cast e co) env = keepAliveCo co env (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 (evalConApp dc)
+ = anfise as env (evalConApp dc)
| otherwise
- = anfiseMany (f:as) env $ \(df:das) -> -- NB: anfise is a no-op for Vars
+ = anfise (f:as) env $ \(df:das) -> -- NB: anfise is a no-op for Vars
go df (zipWith (\d a -> (d, isTypeArg a)) das as)
where
(f, as) = collectArgs e
go df [] = df
- go df ((d,is_ty):ds) = go (step App1 $ app df is_ty d) ds
- app df {-isTypeArg=-}True _da = applyTy df -- There must be a better way...
- app df False da = apply df da
+ go df ((d,is_ty):ds) = go (step App1 $ apply df (is_ty,d)) ds
eval (Let b@(NonRec x rhs) body) env =
bind (BindLet b)
-- See Note [Absence analysis for stable unfoldings and RULES]
- [\_ -> keepAliveUnfRules x env `seq_`
+ [\_ -> keepAliveUnfRules x env $
eval rhs env]
- (\ds -> step Let1 (eval body (extendVarEnv env x (step (Lookup x) (only ds)))))
+ (\ds -> step Let1 (eval body (extendVarEnv env x (step (Look x) (only ds)))))
eval (Let b@(Rec binds) body) env =
bind (BindLet b)
- [\ds -> keepAliveUnfRules x (new_env ds) `seq_`
+ [\ds -> keepAliveUnfRules x (new_env ds) $
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 (zipWith (\x d -> (x, step (Lookup x) d)) xs ds)
+ new_env ds = extendVarEnvList env (zipWith (\x d -> (x, step (Look x) d)) xs ds)
eval (Case e b _ty alts) env = step Case1 $
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)))
- -- 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.
+ -- TODO: I think we should ANFise the scrutinee so that the semantics of
+ -- an expression like `case Just x of b -> b` actually reflects the heap
+ -- allocation. Not now.
+-- Haven't figured out yet how to do whole programs, because there is no notion
+-- of "evaluation":
--evalProgram :: (Trace d, Domain d, HasBind d) => [CoreRule] -> CoreProgram -> [d]
--evalProgram rules binds
-- where
@@ -225,7 +214,6 @@ eval (Case e b _ty alts) env = step Case1 $
-- rule_fvs :: IdSet
-- rule_fvs = rulesRhsFreeIds rules
-
-- By-need semantics, from the paper
data T v = Step Event (T v) | Ret v
@@ -243,23 +231,19 @@ data Value τ
| Con DataCon [D τ]
instance (Trace (D τ), Monad τ) => Domain (D τ) where
- keepAlive _ = return Erased
stuck = return Stuck
- erased = return Erased
lit l = return (Litt l)
fun _x f = return (Fun f)
con k ds = return (Con k ds)
- apply d a = d >>= \case Fun f -> f a; _ -> stuck
- applyTy d = d
+ apply d (_b,a) = d >>= \case Fun f -> f a; _ -> stuck
select d _f _b fs = d >>= \v -> case v of
Stuck -> stuck
Con k ds | Just (_con, _xs, f) <- findAlt (DataAlt k) fs -> f (return v) ds
Litt l | Just (_con, _xs, f) <- findAlt (LitAlt l) fs -> f (return v) []
_ | Just (_con, _xs, f) <- findAlt DEFAULT fs -> f (return v) []
_ -> stuck
- seq_ a b = a >> b -- The caller may want to insert steps here... Not sure
- global _ = return Stuck -- For now; looking at the unfolding would need to call `eval`
- classOp _x _cls = return Stuck -- For now; looking at the unfolding would need to call `eval`
+ global _ = stuck -- For now; looking at the unfolding would need to call `eval`
+ classOp _x _cls = stuck -- For now; looking at the unfolding would need to call `eval`
primOp _x op = case op of
IntAddOp -> intop (+)
IntMulOp -> intop (*)
@@ -272,6 +256,8 @@ instance (Trace (D τ), Monad τ) => Domain (D τ) where
_ -> Stuck
binop ty1 ty2 f = mkPap [ty1,ty2] $ \[d1,d2] -> f <$> d1 <*> d2
int_ty = Anon (Scaled ManyTy intTy) FTF_T_T
+ erased = return Erased
+ keepAlive _ d = d
-- The following function was copy and pasted from GHC.Core.Utils.findAlt:
findAlt :: AltCon -> [DAlt d] -> Maybe (DAlt d)
@@ -323,8 +309,8 @@ evalByNeed e = runStateT (runByNeed (eval e emptyVarEnv)) WM.empty
-- Boilerplate
instance Outputable Event where
- ppr (Lookup n) = text "Lookup" <> parens (ppr n)
- ppr (LookupArg e) = text "LookupArg" <> parens (ppr e)
+ ppr (Look n) = text "Look" <> parens (ppr n)
+ ppr (LookArg e) = text "LookArg" <> parens (ppr e)
ppr Update = text "Update"
ppr App1 = text "App1"
ppr App2 = text "App2"
=====================================
ghdi.hs
=====================================
@@ -48,11 +48,11 @@ compileToCore libdir args expression = do
when (not (null err_messages)) $ liftIO $ pprPrint err_messages >> exitFailure
setSessionDynFlags $
- -- flip gopt_unset Opt_FullLaziness $
- -- flip gopt_unset Opt_WorkerWrapper $
- -- updOptLevel 1 $ -- if you want to compile with -O1 opts, make sure to unset -ffull-laziness and -fworker-wrapper above in addition to -flocal-float-out-top-level
+ flip gopt_unset Opt_FullLaziness $
+ flip gopt_unset Opt_WorkerWrapper $
flip gopt_unset Opt_LocalFloatOutTopLevel $
flip gopt_unset Opt_IgnoreInterfacePragmas $ -- This enables cross-module inlining
+ updOptLevel 1 $ -- if you want to compile with -O1 opts, make sure to unset -ffull-laziness and -fworker-wrapper above in addition to -flocal-float-out-top-level
flip xopt_set LangExt.MagicHash $
dflags
mod_guts <- compileToCoreSimplified file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64ae8fff5239b7c2c58692ce3b0e03f63f01bca1...33f4bdda34f92efb2958c1552922f2d7ec026432
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64ae8fff5239b7c2c58692ce3b0e03f63f01bca1...33f4bdda34f92efb2958c1552922f2d7ec026432
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/20240624/43cdfba9/attachment-0001.html>
More information about the ghc-commits
mailing list