[Git][ghc/ghc][wip/par-simpl] 3 commits: good
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Nov 17 22:33:41 UTC 2022
Matthew Pickering pushed to branch wip/par-simpl at Glasgow Haskell Compiler / GHC
Commits:
19a4123b by Matthew Pickering at 2022-11-17T22:15:35+00:00
good
- - - - -
d99f3e4d by Matthew Pickering at 2022-11-17T22:18:48+00:00
undo
- - - - -
87b78878 by Matthew Pickering at 2022-11-17T22:24:45+00:00
undo
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Types/Var/Env.hs
- hadrian/cabal.project
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -35,13 +35,13 @@ module GHC.Core.Opt.Simplify.Env (
-- * Floats
SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,
- mkFloatBind, addLetFloats, addJoinFloats, addFloats, unionFloats,
+ mkFloatBind, addLetFloats, addJoinFloats, addFloats,
extendFloats, wrapFloats,
isEmptyJoinFloats, isEmptyLetFloats,
doFloatFromRhs, getTopFloatBinds,
-- * LetFloats
- LetFloats(..), FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,
+ LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,
addLetFlts, mapLetFloats,
-- * JoinFloats
@@ -86,7 +86,6 @@ import GHC.Types.Unique.FM ( pprUniqFM )
import Data.List ( intersperse, mapAccumL )
-
{-
************************************************************************
* *
@@ -831,14 +830,6 @@ addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })
, sfJoinFloats = jf1 `addJoinFlts` jf2
, sfInScope = in_scope }
-
-unionFloats :: SimplFloats -> SimplFloats -> SimplFloats
-unionFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1, sfInScope = in_scope1 })
- (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope2 })
- = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2
- , sfJoinFloats = jf1 `addJoinFlts` jf2
- , sfInScope = in_scope1 `unionInScope` in_scope2 }
-
addLetFlts :: LetFloats -> LetFloats -> LetFloats
addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)
= LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)
@@ -1009,7 +1000,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
simplBinder !env bndr
| isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
; seqTyVar tv `seq` return (env', tv) }
- | otherwise = do { let (env', id) = substIdBndr env bndr
+ | otherwise = do { (env', id) <- substIdBndr env bndr
; seqId id `seq` return (env', id) }
---------------
@@ -1017,7 +1008,7 @@ simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- A non-recursive let binder
simplNonRecBndr !env id
-- See Note [Bangs in the Simplifier]
- = do { let (!env1, id1) = substIdBndr env id
+ = do { (!env1, id1) <- substIdBndr env id
; seqId id1 `seq` return (env1, id1) }
---------------
@@ -1026,21 +1017,21 @@ simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
simplRecBndrs env@(SimplEnv {}) ids
-- See Note [Bangs in the Simplifier]
= assert (all (not . isJoinId) ids) $
- do { let (!env1, ids1) = mapAccumL substIdBndr env ids
+ do { (!env1, ids1) <- mapAccumLM substIdBndr env ids
; seqIds ids1 `seq` return env1 }
---------------
-substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+substIdBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- Might be a coercion variable
substIdBndr env bndr
- | isCoVar bndr = substCoVarBndr env bndr
+ | isCoVar bndr = return $ substCoVarBndr env bndr
| otherwise = substNonCoVarIdBndr env bndr
---------------
substNonCoVarIdBndr
:: SimplEnv
-> InBndr -- Env and binder to transform
- -> (SimplEnv, OutBndr)
+ -> SimplM (SimplEnv, OutBndr)
-- Clone Id if necessary, substitute its type
-- Return an Id with its
-- * Type substituted
@@ -1067,34 +1058,36 @@ substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)
subst_id_bndr :: SimplEnv
-> InBndr -- Env and binder to transform
-> (OutId -> OutId) -- Adjust the type
- -> (SimplEnv, OutBndr)
+ -> SimplM (SimplEnv, OutBndr)
subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
old_id adjust_type
- = assertPpr (not (isCoVar old_id)) (ppr old_id)
- (env { seInScope = new_in_scope,
- seIdSubst = new_subst }, new_id)
- -- It's important that both seInScope and seIdSubst are updated with
- -- the new_id, /after/ applying adjust_type. That's why adjust_type
- -- is done here. If we did adjust_type in simplJoinBndr (the only
- -- place that gives a non-identity adjust_type) we'd have to fiddle
- -- afresh with both seInScope and seIdSubst
- where
- -- See Note [Bangs in the Simplifier]
- !id1 = uniqAway in_scope old_id
- !id2 = substIdType env id1
- !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
- -- and fragile OccInfo
- !new_id = adjust_type id3
-
- -- Extend the substitution if the unique has changed,
- -- or there's some useful occurrence information
- -- See the notes with substTyVarBndr for the delSubstEnv
- !new_subst | new_id /= old_id
- = extendVarEnv id_subst old_id (DoneId new_id)
- | otherwise
- = delVarEnv id_subst old_id
-
- !new_in_scope = in_scope `extendInScopeSet` new_id
+ = do
+ -- See Note [Bangs in the Simplifier]
+ new_unique <- getUniqueM
+ let
+ !id1 = setVarUnique old_id new_unique
+ !id2 = substIdType env id1
+ !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ -- and fragile OccInfo
+ !new_id = adjust_type id3
+
+ -- Extend the substitution if the unique has changed,
+ -- or there's some useful occurrence information
+ -- See the notes with substTyVarBndr for the delSubstEnv
+ !new_subst | new_id /= old_id
+ = extendVarEnv id_subst old_id (DoneId new_id)
+ | otherwise
+ = delVarEnv id_subst old_id
+
+ !new_in_scope = in_scope `extendInScopeSet` new_id
+ assertPpr (not (isCoVar old_id)) (ppr old_id) $
+ return (env { seInScope = new_in_scope,
+ seIdSubst = new_subst }, new_id)
+ -- It's important that both seInScope and seIdSubst are updated with
+ -- the new_id, /after/ applying adjust_type. That's why adjust_type
+ -- is done here. If we did adjust_type in simplJoinBndr (the only
+ -- place that gives a non-identity adjust_type) we'd have to fiddle
+ -- afresh with both seInScope and seIdSubst
------------------------------------
seqTyVar :: TyVar -> ()
@@ -1148,7 +1141,7 @@ simplNonRecJoinBndr :: SimplEnv -> InBndr
-- context being pushed inward may change the type
-- See Note [Return type for join points]
simplNonRecJoinBndr env id mult res_ty
- = do { let (env1, id1) = simplJoinBndr mult res_ty env id
+ = do { (env1, id1) <- simplJoinBndr mult res_ty env id
; seqId id1 `seq` return (env1, id1) }
simplRecJoinBndrs :: SimplEnv -> [InBndr]
@@ -1159,13 +1152,13 @@ simplRecJoinBndrs :: SimplEnv -> [InBndr]
-- See Note [Return type for join points]
simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty
= assert (all isJoinId ids) $
- do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids
+ do { (env1, ids1) <- mapAccumLM (simplJoinBndr mult res_ty) env ids
; seqIds ids1 `seq` return env1 }
---------------
simplJoinBndr :: Mult -> OutType
-> SimplEnv -> InBndr
- -> (SimplEnv, OutBndr)
+ -> SimplM (SimplEnv, OutBndr)
simplJoinBndr mult res_ty env id
= subst_id_bndr env id (adjustJoinPointType mult res_ty)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -70,7 +70,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Monad ( mapAccumLM, liftIO, MonadFix (mfix) )
+import GHC.Utils.Monad ( mapAccumLM, liftIO )
import GHC.Utils.Logger
import GHC.Utils.Misc
@@ -84,14 +84,11 @@ import GHC.Types.Var.Env
import GHC.Types.Unique.FM
import Control.Exception (bracket_)
-import GHC.Core.Subst (substIdInfo, clone_id_hack, substExpr, extendSubstWithVar)
-import GHC.Data.OrdList
import GHC.Types.Unique.Set
-import Data.Functor
-import GHC.Types.Unique.Supply
import Data.Traversable (for)
import qualified Data.IntMap as IM
import qualified Data.Set as Set
+import GHC.Types.Var.Set
{-
The guts of the simplifier is in this module, but the driver loop for
@@ -227,87 +224,37 @@ too small to show up in benchmarks.
************************************************************************
-}
-type SimplR = (SimplFloats, SimplEnv, SimplCount)
-type ResimplEnv = (Bool, SimplEnv, UniqSet Var)
-
--- | Add the 'Var' to the in-scope set: as a side effect,
--- and remove any existing substitutions for it
-extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs cvs) v
- = Subst (in_scope `extendInScopeSet` v)
- (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
+type SimplR = (SimplFloats, (SimplEnv, VarSet), SimplCount)
+type ResimplEnv = (Bool, SimplEnv)
-- TODO rename
-simplScc :: ResimplEnv -> [SimplR] -> [InBind] -> SimplM (SimplFloats, SimplEnv)
-simplScc (should_trace, env0, our_binders) deps b = {-# SCC simplScc #-} do
+simplScc :: ResimplEnv -> [SimplR] -> [InBind] -> SimplM (SimplFloats, SimplEnv, VarSet)
+simplScc (should_trace, env0) deps b = {-# SCC simplScc #-} do
let traceM | should_trace
&& False
= pprTraceM
| otherwise = \_ _ -> pure ()
- let (_floats0, envs0, _scs) = unzip3 $ deps
+ let (_floats0, envs0, _scs) = unzip3 deps
traceM "simplScc:start:(#deps,binders)" $ ppr (length deps, bindersOfBinds b)
-- when (any (> 1) check) $ pprPanic "simplScc" $ ppr (floats0, b)
let
- !inscope = {-# SCC in_scope #-} foldr unionInScope (seInScope env0) (seInScope <$> envs0)
+ !inscope = {-# SCC in_scope #-} foldl' extendInScopeSetSet (seInScope env0) (snd <$> envs0)
- these_binds = bindersOfBinds b
- inscope_less_ours = foldl' delInScopeSet inscope these_binds
no_collisions x y = plusUFM_C f x y where
-- f x y = pprPanic "collision" $ ppr (x,y)
f x _ = x
env1 = env0 { seInScope = inscope
- , seIdSubst = foldr no_collisions emptyUFM (seIdSubst <$> envs0)
+ , seIdSubst = foldr no_collisions emptyUFM (seIdSubst . fst <$> envs0)
}
traceM "simplScc:env1:" $ ppr env1
(floats1, env2) <- simpl_binds env1 b
traceM "simplScc:simpl_bind:(floats1,env1)" $ ppr (floats1,env2)
-- pprTraceM "simplScc2" $ ppr b
+ let all_new_vars = unionVarSets (mkVarSet (bindersOfBinds (getTopFloatBinds floats1)) : (map snd envs0))
-
-
- -- Do something to rename local binders to avoid name clashes.
- -- When we are simplifying we create the uniques for local bindings which are floated using
- -- uniqAway. The values of these uniques is computed from the InScopeSet, in parralel the InScopeSet doesn't
- -- contain all the top-level floated bindings so you can get name clashes.
- -- Therefore a bit of hacky way to deal with this is to find all the local ids which have a unique from uniqAway and
- -- replace them with a properly fresh unique from the unique supply. (Which is unique globally)
- (subst, !new_binds) <- getUniqueSupplyM <&> \us -> initUs_ us . mfix $ \ ~(subst_rec,_) -> let
- go_id :: Subst -> Id -> UniqSM (Subst, Id)
- go_id s i = do
- u <- getUniqueM
- pure $ case () of
- _ | i `elementOfUniqSet` our_binders -> let
- j = maybeModifyIdInfo (substIdInfo True subst_rec i (idInfo i)) i
- in (extendInScope s j, j)
- -- | is_local bndr = subst_id_bndr acc_env bndr (flip setVarUnique u)
- | isLocalId i -> let
- (new_subst, new_bndr) = clone_id_hack True subst_rec s (i, u)
- in (extendSubstWithVar new_subst i new_bndr, new_bndr)
- | otherwise -> (extendInScope s i, i)
- go acc_subst bind = case bind of
- NonRec i rhs -> do
- (new_subst, new_id) <- go_id acc_subst i
- pure (new_subst, NonRec new_id $ substExpr subst_rec rhs)
- Rec bs -> do
- let f s (i,rhs) = do
- (ns,ni) <- go_id s i
- pure (ns, (ni, substExpr subst_rec rhs))
- (new_subst, bs1) <- mapAccumLM f acc_subst bs
- pure (new_subst, Rec bs1)
- in mapAccumLM go (mkEmptySubst inscope_less_ours) $ getTopFloatBinds $ floats1
-
- let !floats2 = case sfLetFloats floats1 of
- LetFloats _ ff -> let
- lf = LetFloats (toOL new_binds) ff
- in SimplFloats lf (sfJoinFloats floats1) (getSubstInScope subst)
-
- traceM "simplScc:substSimplFloats:(subst_rec,subst1,floats2)" $ ppr (subst,floats2)
-
- -- TODO check (seIdSubst env2) doesn't have any stale ids
-
- pure (floats2, setInScopeFromF env2 floats2)
+ pure (floats1, env2, all_new_vars)
-- | Quotient a core program graph by creating regular sized groups in topological order. The result is a new
-- quotiented graph with groups of the specified size.
@@ -354,21 +301,19 @@ simplTopBinds group_size env0 in_binds --(binds0, g)
-- It's rather as if the top-level binders were imported.
-- See note [Glomming] in "GHC.Core.Opt.OccurAnal".
-- See Note [Bangs in the Simplifier]
- ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds (concatMap snd binds0))
+ ; let !env1 = env0 { seInScope = mkInScopeSet (mkUniqSet (bindersOfBinds (concatMap snd binds0))) }
; res <- SM' $ \te sc -> do
case te_simpl_threads (st_config te) of
1 -> unSM (simpl_binds env1 (map snd (fst in_binds))) te sc
_ -> do
- -- Get from InScopeSet
- let my_binds = mkUniqSet [lookupRecBndr env1 x | x <- bindersOfBinds (concatMap snd binds0)]
-- Create a result variable for each binding group
env_m_vars <- liftIO $ M.fromList <$> (sequence [(k,) <$> newEmptyMVar | (k,_) <- binds0])
-- Control the amount of parrelism with a semaphore
sem <- newQSem (te_simpl_threads $ st_config te)
let zero_sc = zeroSimplCount' $ hasDetailedCounts sc
let work :: [IO ()]
- work = map (mk_work sem (False, env1, my_binds) env_m_vars te zero_sc) grouped_binds
+ work = map (mk_work sem (False, env1) env_m_vars te zero_sc) grouped_binds
-- Spawn each group into a separate thread
mapM_ forkIO work
@@ -391,8 +336,8 @@ simplTopBinds group_size env0 in_binds --(binds0, g)
(binds0, g) = simple_group_binds group_size in_binds
grouped_binds = binds0
combine_envs env0 envs =
- env0 { seInScope = foldr unionInScope (seInScope env0) (map seInScope envs)
- , seIdSubst = foldr plusUFM (seIdSubst env0) (map seIdSubst envs) }
+ env0 { seInScope = foldl' extendInScopeSetSet (seInScope env0) (map snd envs)
+ , seIdSubst = foldr plusUFM (seIdSubst env0) (map (seIdSubst . fst) envs) }
mk_work sem env1 deps te sc0 (k, b) = do
rs <- for [x | di <- Set.toList (Set.fromList (g M.! k)), di /= k, Just x <- [M.lookup di deps]] readMVar
@@ -401,9 +346,9 @@ simplTopBinds group_size env0 in_binds --(binds0, g)
-- Wait for a semaphore slot
bracket_ (waitQSem sem) (signalQSem sem) $ do
-- Simplify the group
- ((f,e),sc) <- unSM (simplScc env1 rs b) te sc0
+ ((f,e, new_vars),sc) <- unSM (simplScc env1 rs b) te sc0
-- Put the result into the result variable
- putMVar my_var (f, e, sc)
+ putMVar my_var (f, (e, new_vars), sc)
-- We need to track the zapped top-level binders, because
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -752,7 +752,7 @@ add_info env old_bndr top_level new_rhs new_bndr
old_unfolding = realUnfoldingInfo old_info
new_unfolding | isStableUnfolding old_unfolding
- = substUnfolding False subst old_unfolding
+ = substUnfolding subst old_unfolding
| otherwise
= unfolding_from_rhs
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -34,8 +34,6 @@ module GHC.Core.Subst (
substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr,
cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
- clone_id_hack
-
) where
import GHC.Prelude
@@ -378,7 +376,7 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
-- The lazy-set is because we're in a loop here, with
-- rec_subst, when dealing with a mutually-recursive group
new_id = maybeModifyIdInfo mb_new_info id2
- mb_new_info = substIdInfo False rec_subst id2 (idInfo id2)
+ mb_new_info = substIdInfo rec_subst id2 (idInfo id2)
-- NB: unfolding info may be zapped
-- Extend the substitution if the unique has changed
@@ -431,22 +429,19 @@ cloneRecIdBndrs subst us ids
-- Just like substIdBndr, except that it always makes a new unique
-- It is given the unique to use
-- Discards non-Stable unfoldings
-clone_id_hack :: Bool -> Subst -- Substitution for the IdInfo
+clone_id :: Subst -- Substitution for the IdInfo
-> Subst -> (Id, Unique) -- Substitution and Id to transform
-> (Subst, Id) -- Transformed pair
-clone_id_hack hack rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
+clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
= (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
where
id1 = setVarUnique old_id uniq
id2 = substIdType subst id1
- new_id = maybeModifyIdInfo (substIdInfo hack rec_subst id2 (idInfo old_id)) id2
+ new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
(new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
| otherwise = (extendVarEnv idvs old_id (Var new_id), cvs)
-clone_id :: Subst -> Subst -> (Id, Unique) -> (Subst, Id)
-clone_id = clone_id_hack False
-
{-
************************************************************************
* *
@@ -479,11 +474,11 @@ substIdType subst@(Subst _ _ tv_env cv_env) id
------------------
-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
-- Discards unfoldings, unless they are Stable
-substIdInfo :: Bool -> Subst -> Id -> IdInfo -> Maybe IdInfo
-substIdInfo hack subst new_id info
+substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
+substIdInfo subst new_id info
| nothing_to_do = Nothing
| otherwise = Just (info `setRuleInfo` substRuleInfo subst new_id old_rules
- `setUnfoldingInfo` substUnfolding hack subst old_unf)
+ `setUnfoldingInfo` substUnfolding subst old_unf)
where
old_rules = ruleInfo info
old_unf = realUnfoldingInfo info
@@ -494,26 +489,23 @@ substIdInfo hack subst new_id info
-- NB: substUnfolding /discards/ any unfolding without
-- without a Stable source. This is usually what we want,
-- but it may be a bit unexpected
-substUnfolding, substUnfoldingSC :: Bool -> Subst -> Unfolding -> Unfolding
+substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
-- Seq'ing on the returned Unfolding is enough to cause
-- all the substitutions to happen completely
-substUnfoldingSC hack subst unf -- Short-cut version
+substUnfoldingSC subst unf -- Short-cut version
| isEmptySubst subst = unf
- | otherwise = substUnfolding hack subst unf
+ | otherwise = substUnfolding subst unf
-substUnfolding _ subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
= df { df_bndrs = bndrs', df_args = args' }
where
(subst',bndrs') = substBndrs subst bndrs
args' = map (substExpr subst') args
--- MP: These is a hack here atm because we rename local bindings after simplication is finished and need
--- to reflect these changes into the stable unfoldings.
-substUnfolding hack subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
+substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain stable unfoldings
| not (isStableSource src) -- Zap an unstable unfolding, to save substitution work
- && not hack
= NoUnfolding
| otherwise -- But keep a stable one!
= seqExpr new_tmpl `seq`
@@ -521,7 +513,7 @@ substUnfolding hack subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
where
new_tmpl = substExpr subst tmpl
-substUnfolding _ _ unf = unf -- NoUnfolding, OtherCon
+substUnfolding _ unf = unf -- NoUnfolding, OtherCon
------------------
substIdOcc :: Subst -> Id -> Id
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -2342,12 +2342,12 @@ normSplitTyConApp_maybe _ _ = Nothing
extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
-extendInScopeSetBind in_scope binds
- = foldBindersOfBindStrict extendInScopeSet in_scope binds
+extendInScopeSetBind (InScope in_scope) binds
+ = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds
extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet
-extendInScopeSetBndrs in_scope binds
- = foldBindersOfBindsStrict extendInScopeSet in_scope binds
+extendInScopeSetBndrs (InScope in_scope) binds
+ = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds
mkInScopeSetBndrs :: [CoreBind] -> InScopeSet
mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -25,7 +25,6 @@ module GHC.Types.Var.Env (
elemVarEnvByKey,
filterVarEnv, restrictVarEnv,
partitionVarEnv,
- delInScopeSet,
-- * Deterministic Var environments (maps)
DVarEnv, DIdEnv, DTyVarEnv,
@@ -52,9 +51,9 @@ module GHC.Types.Var.Env (
InScopeSet(..),
-- ** Operations on InScopeSets
- emptyInScopeSet, mkInScopeSet, mkInScopeSetList,
+ emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
- getInScopeVars, lookupInScope,
+ getInScopeVars, lookupInScope, lookupInScope_Directly,
unionInScope, elemInScopeSet, uniqAway,
varSetInScope,
unsafeGetFreshLocalUnique,
@@ -109,10 +108,7 @@ import GHC.Utils.Outputable
--
-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides
-- the motivation for this abstraction.
--- The InScopeSet is a pair of (Var, Int) to track how many times variables in the
--- InScopeSet have been updated, so that if we union two InScopeSets together we know
--- to choose the updated variables.
-newtype InScopeSet = InScope (VarEnv (Var, Int))
+newtype InScopeSet = InScope VarSet
-- Note [Lookups in in-scope set]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We store a VarSet here, but we use this for lookups rather than just
@@ -139,64 +135,57 @@ newtype InScopeSet = InScope (VarEnv (Var, Int))
instance Outputable InScopeSet where
ppr (InScope s) =
text "InScope" <+>
- braces (fsep (map (\(v, i) -> ppr (Var.varName v, i)) (nonDetEltsUFM s)))
+ braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s)))
-- It's OK to use nonDetEltsUniqSet here because it's
-- only for pretty printing
-- In-scope sets get big, and with -dppr-debug
-- the output is overwhelming
emptyInScopeSet :: InScopeSet
-emptyInScopeSet = InScope emptyUFM
+emptyInScopeSet = InScope emptyVarSet
getInScopeVars :: InScopeSet -> VarSet
-getInScopeVars (InScope vs) = unsafeUFMToUniqSet (mapUFM fst vs)
+getInScopeVars (InScope vs) = vs
mkInScopeSet :: VarSet -> InScopeSet
-mkInScopeSet in_scope = InScope (mapVarEnv (,0) (getUniqSet in_scope))
+mkInScopeSet in_scope = InScope in_scope
mkInScopeSetList :: [Var] -> InScopeSet
-mkInScopeSetList vs = mkInScopeSet (mkVarSet vs)
+mkInScopeSetList vs = InScope (mkVarSet vs)
extendInScopeSet :: InScopeSet -> Var -> InScopeSet
extendInScopeSet (InScope in_scope) v
- = InScope ((extendVarEnv_C (\(_, n) (v, _) -> (v, n + 1)) in_scope v (v, 0)))
+ = InScope (extendVarSet in_scope v)
extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
-extendInScopeSetList in_scope vs
- = foldl' extendInScopeSet in_scope vs
+extendInScopeSetList (InScope in_scope) vs
+ = InScope $ foldl' extendVarSet in_scope vs
extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet
-extendInScopeSetSet in_scope vs
- = foldl' extendInScopeSet in_scope (nonDetEltsUniqSet vs)
+extendInScopeSetSet (InScope in_scope) vs
+ = InScope (in_scope `unionVarSet` vs)
--- Deleting from inscope never makes sense as things never just go out of scope
delInScopeSet :: InScopeSet -> Var -> InScopeSet
-delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarEnv` v)
+delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v)
elemInScopeSet :: Var -> InScopeSet -> Bool
-elemInScopeSet v (InScope in_scope) = v `elemVarEnv` in_scope
+elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope
-- | Look up a variable the 'InScopeSet'. This lets you map from
-- the variable's identity (unique) to its full value.
lookupInScope :: InScopeSet -> Var -> Maybe Var
-lookupInScope (InScope in_scope) v = fst <$> lookupUFM in_scope v
+lookupInScope (InScope in_scope) v = lookupVarSet in_scope v
-{-
lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
lookupInScope_Directly (InScope in_scope) uniq
- = fst <$> lookupUFM_Directly in_scope uniq
- -}
+ = lookupVarSet_Directly in_scope uniq
unionInScope :: InScopeSet -> InScopeSet -> InScopeSet
unionInScope (InScope s1) (InScope s2)
- = InScope (plusVarEnv_C comb s1 s2)
- where
- comb (l, n1) (r, n2)
- | n1 >= n2 = (l, n1)
- | otherwise = (r, n2)
+ = InScope (s1 `unionVarSet` s2)
varSetInScope :: VarSet -> InScopeSet -> Bool
-varSetInScope vars (InScope s1) = all (flip elemVarEnv s1) (nonDetEltsUniqSet vars)
+varSetInScope vars (InScope s1) = vars `subVarSet` s1
{-
Note [Local uniques]
@@ -238,7 +227,7 @@ uniqAway' in_scope var
-- introduce non-unique 'Unique's this way. See Note [Local uniques].
unsafeGetFreshLocalUnique :: InScopeSet -> Unique
unsafeGetFreshLocalUnique (InScope set)
- | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap set)
+ | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)
, let uniq' = mkLocalUnique uniq
, not $ uniq' `ltUnique` minLocalUnique
= incrUnique uniq'
=====================================
hadrian/cabal.project
=====================================
@@ -7,5 +7,3 @@ index-state: 2022-09-10T18:46:55Z
-- and the Cabal takes nearly twice as long to build with -O1. See #16817.
package Cabal
optimization: False
-
-allow-newer: base
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a9069be5af7b11b7b058df93b889d92def24465...87b78878746dd92733eda00a1129e4a3ab9beb53
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a9069be5af7b11b7b058df93b889d92def24465...87b78878746dd92733eda00a1129e4a3ab9beb53
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/20221117/cade05d7/attachment-0001.html>
More information about the ghc-commits
mailing list