[Git][ghc/ghc][wip/cfuneqcan-refactor] 4 commits: Improve some comments
Richard Eisenberg
gitlab at gitlab.haskell.org
Wed Nov 11 17:54:10 UTC 2020
Richard Eisenberg pushed to branch wip/cfuneqcan-refactor at Glasgow Haskell Compiler / GHC
Commits:
57b64775 by Richard Eisenberg at 2020-11-11T08:56:13-05:00
Improve some comments
- - - - -
150897ed by Richard Eisenberg at 2020-11-11T11:36:19-05:00
Checkpoint before adding filterTM
- - - - -
65bd0608 by Richard Eisenberg at 2020-11-11T12:52:41-05:00
remove stale givens from famapp-cache
- - - - -
ef747932 by Richard Eisenberg at 2020-11-11T12:53:42-05:00
Remove unused parameter
- - - - -
10 changed files:
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Map.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/TyCon/Env.hs
- compiler/GHC/Data/TrieMap.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/Tc/Solver/Flatten.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Types/Unique/DFM.hs
Changes:
=====================================
compiler/GHC/Cmm/Dataflow/Label.hs
=====================================
@@ -141,6 +141,7 @@ instance TrieMap LabelMap where
alterTM k f m = mapAlter f k m
foldTM k m z = mapFoldr k z m
mapTM f m = mapMap f m
+ filterTM f m = mapFilter f m
-----------------------------------------------------------------------------
-- FactBase
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -80,7 +80,7 @@ module GHC.Core.Coercion (
-- ** Free variables
tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,
tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,
- coercionSize,
+ coercionSize, anyFreeVarsOfCo,
-- ** Substitution
CvSubstEnv, emptyCvSubstEnv,
=====================================
compiler/GHC/Core/Map.hs
=====================================
@@ -116,6 +116,7 @@ instance TrieMap CoreMap where
alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
foldTM k (CoreMap m) = foldTM k m
mapTM f (CoreMap m) = CoreMap (mapTM f m)
+ filterTM f (CoreMap m) = CoreMap (filterTM f m)
-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a at . The extended
-- key makes it suitable for recursive traversal, since it can track binders,
@@ -197,6 +198,7 @@ instance TrieMap CoreMapX where
alterTM = xtE
foldTM = fdE
mapTM = mapE
+ filterTM = ftE
--------------------------
mapE :: (a->b) -> CoreMapX a -> CoreMapX b
@@ -213,6 +215,20 @@ mapE f (CM { cm_var = cvar, cm_lit = clit
, cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
, cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
+ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a
+ftE f (CM { cm_var = cvar, cm_lit = clit
+ , cm_co = cco, cm_type = ctype
+ , cm_cast = ccast , cm_app = capp
+ , cm_lam = clam, cm_letn = cletn
+ , cm_letr = cletr, cm_case = ccase
+ , cm_ecase = cecase, cm_tick = ctick })
+ = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit
+ , cm_co = filterTM f cco, cm_type = filterTM f ctype
+ , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp
+ , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn
+ , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase
+ , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }
+
--------------------------
lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
lookupCoreMap cm e = lookupTM e cm
@@ -330,6 +346,7 @@ instance TrieMap AltMap where
alterTM = xtA emptyCME
foldTM = fdA
mapTM = mapA
+ filterTM = ftA
instance Eq (DeBruijn CoreAlt) where
D env1 a1 == D env2 a2 = go a1 a2 where
@@ -348,6 +365,12 @@ mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
, am_data = mapTM (mapTM f) adata
, am_lit = mapTM (mapTM f) alit }
+ftA :: (a->Bool) -> AltMap a -> AltMap a
+ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
+ = AM { am_deflt = filterTM f adeflt
+ , am_data = mapTM (filterTM f) adata
+ , am_lit = mapTM (filterTM f) alit }
+
lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs)
lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs)
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -90,6 +90,7 @@ instance TrieMap CoercionMap where
alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)
foldTM k (CoercionMap m) = foldTM k m
mapTM f (CoercionMap m) = CoercionMap (mapTM f m)
+ filterTM f (CoercionMap m) = CoercionMap (filterTM f m)
type CoercionMapG = GenMap CoercionMapX
newtype CoercionMapX a = CoercionMapX (TypeMapX a)
@@ -101,6 +102,7 @@ instance TrieMap CoercionMapX where
alterTM = xtC
foldTM f (CoercionMapX core_tm) = foldTM f core_tm
mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm)
+ filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)
instance Eq (DeBruijn Coercion) where
D env1 co1 == D env2 co2
@@ -176,6 +178,7 @@ instance TrieMap TypeMapX where
alterTM = xtT
foldTM = fdT
mapTM = mapT
+ filterTM = filterT
instance Eq (DeBruijn Type) where
env_t@(D env t) == env_t'@(D env' t')
@@ -289,6 +292,18 @@ fdT k m = foldTM k (tm_var m)
. foldTyLit k (tm_tylit m)
. foldMaybe k (tm_coerce m)
+filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a
+filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon
+ , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit
+ , tm_coerce = tcoerce })
+ = TM { tm_var = filterTM f tvar
+ , tm_app = mapTM (filterTM f) tapp
+ , tm_tycon = filterTM f ttycon
+ , tm_funty = mapTM (mapTM (filterTM f)) tfunty
+ , tm_forall = mapTM (filterTM f) tforall
+ , tm_tylit = filterTM f tlit
+ , tm_coerce = filterMaybe f tcoerce }
+
------------------------
data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
, tlm_string :: UniqFM FastString a
@@ -301,6 +316,7 @@ instance TrieMap TyLitMap where
alterTM = xtTyLit
foldTM = foldTyLit
mapTM = mapTyLit
+ filterTM = filterTyLit
emptyTyLitMap :: TyLitMap a
emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM }
@@ -325,6 +341,10 @@ foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
foldTyLit l m = flip (foldUFM l) (tlm_string m)
. flip (Map.foldr l) (tlm_number m)
+filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a
+filterTyLit f (TLM { tlm_number = tn, tlm_string = ts })
+ = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts }
+
-------------------------------------------------
-- | @TypeMap a@ is a map from 'Type' to @a at . If you are a client, this
-- is the type you want. The keys in this map may have different kinds.
@@ -348,6 +368,7 @@ instance TrieMap TypeMap where
alterTM k f m = xtTT (deBruijnize k) f m
foldTM k (TypeMap m) = foldTM (foldTM k) m
mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)
+ filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m)
foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap k z m = foldTM k m z
@@ -388,6 +409,7 @@ instance TrieMap LooseTypeMap where
alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)
foldTM f (LooseTypeMap m) = foldTM f m
mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)
+ filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)
{-
************************************************************************
@@ -462,6 +484,7 @@ instance TrieMap BndrMap where
alterTM = xtBndr emptyCME
foldTM = fdBndrMap
mapTM = mapBndrMap
+ filterTM = ftBndrMap
mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b
mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)
@@ -483,6 +506,8 @@ xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a
xtBndr env v xt (BndrMap tymap) =
BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))
+ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a
+ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm)
--------- Variable occurrence -------------
data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable
@@ -495,6 +520,7 @@ instance TrieMap VarMap where
alterTM = xtVar emptyCME
foldTM = fdVar
mapTM = mapVar
+ filterTM = ftVar
mapVar :: (a->b) -> VarMap a -> VarMap b
mapVar f (VM { vm_bvar = bv, vm_fvar = fv })
@@ -520,6 +546,10 @@ lkDFreeVar var env = lookupDVarEnv env var
xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a
xtDFreeVar v f m = alterDVarEnv f m v
+ftVar :: (a -> Bool) -> VarMap a -> VarMap a
+ftVar f (VM { vm_bvar = bv, vm_fvar = fv })
+ = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv }
+
-------------------------------------------------
lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a
lkDNamed n env = lookupDNameEnv env (getName n)
=====================================
compiler/GHC/Core/TyCon/Env.hs
=====================================
@@ -29,7 +29,7 @@ module GHC.Core.TyCon.Env (
emptyDTyConEnv, isEmptyDTyConEnv,
lookupDTyConEnv,
delFromDTyConEnv, filterDTyConEnv,
- mapDTyConEnv,
+ mapDTyConEnv, mapMaybeDTyConEnv,
adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv
) where
@@ -131,6 +131,9 @@ filterDTyConEnv = filterUDFM
mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b
mapDTyConEnv = mapUDFM
+mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b
+mapMaybeDTyConEnv = mapMaybeUDFM
+
adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a
adjustDTyConEnv = adjustUDFM
=====================================
compiler/GHC/Data/TrieMap.hs
=====================================
@@ -16,11 +16,11 @@ module GHC.Data.TrieMap(
-- * Maps over 'Literal's
LiteralMap,
-- * 'TrieMap' class
- TrieMap(..), insertTM, deleteTM, foldMapTM,
+ TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,
-- * Things helpful for adding additional Instances.
(>.>), (|>), (|>>), XT,
- foldMaybe,
+ foldMaybe, filterMaybe,
-- * Map for leaf compression
GenMap,
lkG, xtG, mapG, fdG,
@@ -72,6 +72,7 @@ class TrieMap m where
lookupTM :: forall b. Key m -> m b -> Maybe b
alterTM :: forall b. Key m -> XT b -> m b -> m b
mapTM :: (a->b) -> m a -> m b
+ filterTM :: (a -> Bool) -> m a -> m a
foldTM :: (a -> b -> b) -> m a -> b -> b
-- The unusual argument order here makes
@@ -87,6 +88,10 @@ deleteTM k m = alterTM k (\_ -> Nothing) m
foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r
foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty
+-- This looks inefficient.
+isEmptyTM :: TrieMap m => m a -> Bool
+isEmptyTM m = foldTM (\ _ _ -> False) m True
+
----------------------
-- Recall that
-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
@@ -126,6 +131,7 @@ instance TrieMap IntMap.IntMap where
alterTM = xtInt
foldTM k m z = IntMap.foldr k z m
mapTM f m = IntMap.map f m
+ filterTM f m = IntMap.filter f m
xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
xtInt k f m = IntMap.alter f k m
@@ -137,6 +143,7 @@ instance Ord k => TrieMap (Map.Map k) where
alterTM k f m = Map.alter f k m
foldTM k m z = Map.foldr k z m
mapTM f m = Map.map f m
+ filterTM f m = Map.filter f m
{-
@@ -213,6 +220,7 @@ instance forall key. Uniquable key => TrieMap (UniqDFM key) where
alterTM k f m = alterUDFM f m k
foldTM k m z = foldUDFM k z m
mapTM f m = mapUDFM f m
+ filterTM f m = filterUDFM f m
{-
************************************************************************
@@ -234,6 +242,7 @@ instance TrieMap m => TrieMap (MaybeMap m) where
alterTM = xtMaybe alterTM
foldTM = fdMaybe
mapTM = mapMb
+ filterTM = ftMaybe
instance TrieMap m => Foldable (MaybeMap m) where
foldMap = foldMapTM
@@ -256,6 +265,19 @@ fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b
fdMaybe k m = foldMaybe k (mm_nothing m)
. foldTM k (mm_just m)
+ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a
+ftMaybe f (MM { mm_nothing = mn, mm_just = mj })
+ = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj }
+
+foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
+foldMaybe _ Nothing b = b
+foldMaybe k (Just a) b = k a b
+
+filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
+filterMaybe _ Nothing = Nothing
+filterMaybe f input@(Just x) | f x = input
+ | otherwise = Nothing
+
{-
************************************************************************
* *
@@ -275,6 +297,7 @@ instance TrieMap m => TrieMap (ListMap m) where
alterTM = xtList alterTM
foldTM = fdList
mapTM = mapList
+ filterTM = ftList
instance TrieMap m => Foldable (ListMap m) where
foldMap = foldMapTM
@@ -301,9 +324,9 @@ fdList :: forall m a b. TrieMap m
fdList k m = foldMaybe k (lm_nil m)
. foldTM (fdList k) (lm_cons m)
-foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
-foldMaybe _ Nothing b = b
-foldMaybe k (Just a) b = k a b
+ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
+ftList f (LM { lm_nil = mnil, lm_cons = mcons })
+ = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons }
{-
************************************************************************
@@ -365,6 +388,7 @@ instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
alterTM = xtG
foldTM = fdG
mapTM = mapG
+ filterTM = ftG
instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where
foldMap = foldMapTM
@@ -417,3 +441,13 @@ fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b
fdG _ EmptyMap = \z -> z
fdG k (SingletonMap _ v) = \z -> k v z
fdG k (MultiMap m) = foldTM k m
+
+{-# INLINEABLE ftG #-}
+ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a
+ftG _ EmptyMap = EmptyMap
+ftG f input@(SingletonMap _ v)
+ | f v = input
+ | otherwise = EmptyMap
+ftG f (MultiMap m) = MultiMap (filterTM f m)
+ -- we don't have enough information to reconstruct the key to make
+ -- a SingletonMap
=====================================
compiler/GHC/Stg/CSE.hs
=====================================
@@ -130,6 +130,8 @@ instance TrieMap StgArgMap where
foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
+ filterTM f (SAM {sam_var = varm, sam_lit = litm}) =
+ SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }
newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
@@ -141,6 +143,7 @@ instance TrieMap ConAppMap where
m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
foldTM k = un_cam >.> foldTM (foldTM k)
mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM
+ filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM
-----------------
-- The CSE Env --
=====================================
compiler/GHC/Tc/Solver/Flatten.hs
=====================================
@@ -364,17 +364,18 @@ faster. This doesn't seem quite worth it, yet.
Note [flatten_exact_fam_app_fully performance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Once we've got a flat rhs, we extend the flat-cache to record
+Once we've got a flat rhs, we extend the famapp-cache to record
the result. Doing so can save lots of work when the same redex shows up more
than once. Note that we record the link from the redex all the way to its
-*final* value, not just the single step reduction. Interestingly, adding to the
-flat-cache for the first reduction *doubles* the allocations
-for the T9872a test. However, using the flat-cache in
-the later reduction is a similar gain. I (Richard E) don't currently
-(Dec '14 nor Nov '20) have any knowledge as to *why* these facts are true.
-Perhaps the first use of the flat-cache doesn't add much, because we didn't
-need to reduce in the arguments (and instance lookup is similar to cache
-lookup).
+*final* value, not just the single step reduction.
+
+If we can reduce the family application right away (the first call
+to try_to_reduce), we do *not* add to the cache. There are two possibilities
+here: 1) we just read the result from the cache, or 2) we used one type
+family instance. In either case, recording the result in the cache doesn't
+save much effort the next time around. And adding to the cache here is
+actually disastrous: it more than doubles the allocations for T9872a. So
+we skip adding to the cache here.
-}
{-# INLINE flatten_args_tc #-}
@@ -765,7 +766,6 @@ flatten_fam_app tc tys -- Can be over-saturated
; flatten_app_ty_args xi1 co1 tys_rest }
-- the [TcType] exactly saturate the TyCon
--- See Note [flatten_exact_fam_app_fully performance]
flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
flatten_exact_fam_app_fully tc tys
= do { checkStackDepth (mkTyConApp tc tys)
@@ -773,6 +773,8 @@ flatten_exact_fam_app_fully tc tys
-- Step 1. Try to reduce without reducing arguments first.
; result1 <- try_to_reduce tc tys
; case result1 of
+ -- Don't use `finish`;
+ -- See Note [flatten_exact_fam_app_fully performance]
{ Just (co, xi) -> do { (xi2, co2) <- bumpDepth $ flatten_one xi
; return (xi2, co2 `mkTcTransCo` co) }
; Nothing ->
@@ -815,7 +817,8 @@ flatten_exact_fam_app_fully tc tys
do { result3 <- try_to_reduce tc xis
; case result3 of
Just (co, xi) -> finish (homogenise xi co)
- Nothing -> return (homogenise reduced (mkTcReflCo role reduced))
+ Nothing -> -- we have made no progress at all
+ return (homogenise reduced (mkTcReflCo role reduced))
where
reduced = mkTyConApp tc xis }}}}}
where
@@ -836,8 +839,7 @@ flatten_exact_fam_app_fully tc tys
-- Returned coercion is output ~r input, where r is the role in the FlatM monad
try_to_reduce :: TyCon -> [TcType] -> FlatM (Maybe (TcCoercion, TcType))
try_to_reduce tc tys
- = do { flavour <- getFlavour
- ; result <- liftTcS $ firstJustsM [ lookupFamAppCache flavour tc tys
+ = do { result <- liftTcS $ firstJustsM [ lookupFamAppCache tc tys
, matchFam tc tys ]
; downgrade result }
where
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -404,20 +404,14 @@ data InertSet
-- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical
, inert_famapp_cache :: FunEqMap (TcCoercion, TcType)
- -- If F tys :-> (co, rhs, flav),
- -- then co :: rhs ~ F tys
- -- all evidence is from instances or Givens
- -- (We have no way of "kicking out" from the cache, so putting
- -- wanteds here means we can end up solving a Wanted with itself. Bad)
- --
- -- Some entries in the cache might have arisen from Wanteds, and
- -- so this should be used only for rewriting Wanteds.
- --
-- Just a hash-cons cache for use when reducing family applications
-- only
--
- -- Only nominal equalities end up in here (along with
- -- top-level instances)
+ -- If F tys :-> (co, rhs, flav),
+ -- then co :: rhs ~N F tys
+ -- all evidence is from instances or Givens; no coercion holes here
+ -- (We have no way of "kicking out" from the cache, so putting
+ -- wanteds here means we can end up solving a Wanted with itself. Bad)
, inert_solved_dicts :: DictMap CtEvidence
-- All Wanteds, of form ev :: C t1 .. tn
@@ -1600,6 +1594,20 @@ kickOutRewritable new_fr new_lhs ics
; unless (n_kicked == 0) $
do { updWorkListTcS (appendWorkList kicked_out)
+
+ -- The famapp-cache contains Given evidence from the inert set.
+ -- If we're kicking out Givens, we need to remove this evidence
+ -- from the cache, too.
+ ; let kicked_given_ev_vars =
+ [ ev_var | ct <- wl_eqs kicked_out
+ , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]
+ ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&
+ -- if this isn't true, no use looking through the constraints
+ not (null kicked_given_ev_vars)) $
+ do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"
+ (ppr kicked_given_ev_vars)
+ ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }
+
; csTraceTcS $
hang (text "Kick out, lhs =" <+> ppr new_lhs)
2 (vcat [ text "n-kicked =" <+> int n_kicked
@@ -2387,17 +2395,6 @@ lookupFamAppInert fam_tc tys
= Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)
| otherwise = Nothing
-lookupFamAppCache :: CtFlavour -> TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
-lookupFamAppCache _ fam_tc tys
- = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts
- ; case findFunEq famapp_cache fam_tc tys of
- result@(Just (co, ty)) ->
- do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)
- , ppr ty
- , ppr co ])
- ; return result }
- Nothing -> return Nothing }
-
lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
-- Is this exact predicate type cached in the solved or canonicals of the InertSet?
lookupInInerts loc pty
@@ -2423,6 +2420,40 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
Just ev -> Just ev
_ -> Nothing
+---------------------------
+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
+lookupFamAppCache fam_tc tys
+ = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts
+ ; case findFunEq famapp_cache fam_tc tys of
+ result@(Just (co, ty)) ->
+ do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)
+ , ppr ty
+ , ppr co ])
+ ; return result }
+ Nothing -> return Nothing }
+
+extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()
+-- NB: co :: rhs ~ F tys, to match expectations of flattener
+extendFamAppCache tc xi_args stuff@(_, ty)
+ = do { dflags <- getDynFlags
+ ; when (gopt Opt_FamAppCache dflags) $
+ do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args
+ , ppr ty ])
+ -- 'co' can be bottom, in the case of derived items
+ ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->
+ is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }
+
+-- Remove entries from the cache whose evidence mentions variables in the
+-- supplied set
+dropFromFamAppCache :: VarSet -> TcS ()
+dropFromFamAppCache varset
+ = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts
+ ; let filtered = filterTcAppMap check famapp_cache
+ ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }
+ where
+ check :: (TcCoercion, TcType) -> Bool
+ check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)
+
{- *********************************************************************
* *
Irreds
@@ -2494,18 +2525,15 @@ alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc
alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))
-filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
-filterTcAppMap f m
- = mapDTyConEnv do_tm m
+filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a
+filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m
where
- do_tm tm = foldTM insert_mb tm emptyTM
- insert_mb ct tm
- | f ct = insertTM tys ct tm
- | otherwise = tm
- where
- tys = case ct of
- CDictCan { cc_tyargs = tys } -> tys
- _ -> pprPanic "filterTcAppMap" (ppr ct)
+ one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
+ one_tycon tm
+ | isEmptyTM filtered_tm = Nothing
+ | otherwise = Just filtered_tm
+ where
+ filtered_tm = filterTM f tm
tcAppMapToBag :: TcAppMap a -> Bag a
tcAppMapToBag m = foldTcAppMap consBag m emptyBag
@@ -3218,17 +3246,6 @@ zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar
zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
----------------------------
-extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()
--- NB: co :: rhs ~ F tys, to match expectations of flattener
-extendFamAppCache tc xi_args stuff@(_, ty)
- = do { dflags <- getDynFlags
- ; when (gopt Opt_FamAppCache dflags) $
- do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args
- , ppr ty ])
- -- 'co' can be bottom, in the case of derived items
- ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->
- is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }
-
pprKicked :: Int -> SDoc
pprKicked 0 = empty
pprKicked n = parens (int n <+> text "kicked out")
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -15,8 +15,12 @@ is not deterministic.
-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}
@@ -38,6 +42,7 @@ module GHC.Types.Unique.DFM (
adjustUDFM_Directly,
alterUDFM,
mapUDFM,
+ mapMaybeUDFM,
plusUDFM,
plusUDFM_C,
lookupUDFM, lookupUDFM_Directly,
@@ -121,7 +126,7 @@ data TaggedVal val =
TaggedVal
val
{-# UNPACK #-} !Int -- ^ insertion time
- deriving (Data, Functor)
+ deriving stock (Data, Functor, Foldable, Traversable)
taggedFst :: TaggedVal val -> val
taggedFst (TaggedVal v _) = v
@@ -399,6 +404,10 @@ alterUDFM f (UDFM m i) k =
mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i
+mapMaybeUDFM :: forall elt1 elt2 key.
+ (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
+mapMaybeUDFM f (UDFM m i) = UDFM (M.mapMaybe (traverse f) m) i
+
anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool
anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cf1819f586e5abae39ca19430ad9d0f1fcb94d4...ef7479323a85c965b50fb2dfd71f537872cedab1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cf1819f586e5abae39ca19430ad9d0f1fcb94d4...ef7479323a85c965b50fb2dfd71f537872cedab1
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/20201111/28f84ef4/attachment-0001.html>
More information about the ghc-commits
mailing list