[Git][ghc/ghc][wip/sjakobi/nondetfolds] Delete some evidence bindings more efficiently
Simon Jakobi
gitlab at gitlab.haskell.org
Tue Mar 31 01:03:18 UTC 2020
Simon Jakobi pushed to branch wip/sjakobi/nondetfolds at Glasgow Haskell Compiler / GHC
Commits:
fa1d67f1 by Simon Jakobi at 2020-03-31T03:02:51+02:00
Delete some evidence bindings more efficiently
(needs refactoring)
- - - - -
6 changed files:
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Set.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/typecheck/TcEvidence.hs
- compiler/typecheck/TcSimplify.hs
Changes:
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -50,7 +50,7 @@ module GHC.Types.Unique.DFM (
equalKeysUDFM,
minusUDFM,
listToUDFM,
- udfmMinusUFM,
+ udfmMinusUFM, ufmMinusUDFM,
partitionUDFM,
anyUDFM, allUDFM,
pprUniqDFM, pprUDFM,
@@ -73,7 +73,7 @@ import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
import qualified Data.Semigroup as Semi
-import GHC.Types.Unique.FM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)
+import GHC.Types.Unique.FM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap, intMapToUFM)
-- Note [Deterministic UniqFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -343,6 +343,9 @@ udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i
-- M.difference returns a subset of a left set, so `i` is a good upper
-- bound.
+ufmMinusUDFM :: UniqFM elt1 -> UniqDFM elt2 -> UniqFM elt1
+ufmMinusUDFM x (UDFM y _i) = intMapToUFM (M.difference (ufmToIntMap x) y)
+
-- | Partition UniqDFM into two UniqDFMs according to the predicate
partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt)
partitionUDFM p (UDFM m i) =
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -67,7 +67,7 @@ module GHC.Types.Unique.FM (
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
nonDetEltsUFM, eltsUFM, nonDetKeysUFM,
ufmToSet_Directly,
- nonDetUFMToList, ufmToIntMap,
+ nonDetUFMToList, ufmToIntMap, intMapToUFM,
pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM
) where
@@ -359,6 +359,9 @@ instance Traversable NonDetUniqFM where
ufmToIntMap :: UniqFM elt -> M.IntMap elt
ufmToIntMap (UFM m) = m
+intMapToUFM :: M.IntMap elt -> UniqFM elt
+intMapToUFM = UFM
+
-- Determines whether two 'UniqFM's contain the same keys.
equalKeysUFM :: UniqFM a -> UniqFM b -> Bool
equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2
=====================================
compiler/GHC/Types/Unique/Set.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Types.Unique.Set (
delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,
delListFromUniqSet_Directly,
unionUniqSets, unionManyUniqSets,
- minusUniqSet, uniqSetMinusUFM,
+ minusUniqSet, uniqSetMinusUFM, uniqSetMinusUDFM,
intersectUniqSets,
restrictUniqSetToUFM,
uniqSetAny, uniqSetAll,
@@ -48,6 +48,7 @@ module GHC.Types.Unique.Set (
import GhcPrelude
+import GHC.Types.Unique.DFM
import GHC.Types.Unique.FM
import GHC.Types.Unique
import Data.Coerce
@@ -111,6 +112,9 @@ restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)
uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a
uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)
+uniqSetMinusUDFM :: UniqSet a -> UniqDFM b -> UniqSet a
+uniqSetMinusUDFM (UniqSet s) t = UniqSet (ufmMinusUDFM s t)
+
elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet a (UniqSet s) = elemUFM a s
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -33,7 +33,7 @@ module GHC.Types.Var.Env (
extendDVarEnv, extendDVarEnv_C,
extendDVarEnvList,
lookupDVarEnv, elemDVarEnv,
- isEmptyDVarEnv, foldDVarEnv,
+ isEmptyDVarEnv, foldDVarEnv, nonDetStrictFoldDVarEnv,
mapDVarEnv, filterDVarEnv,
modifyDVarEnv,
alterDVarEnv,
@@ -583,6 +583,9 @@ lookupDVarEnv = lookupUDFM
foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b
foldDVarEnv = foldUDFM
+nonDetStrictFoldDVarEnv :: (b -> a -> b) -> b -> DVarEnv a -> b
+nonDetStrictFoldDVarEnv = nonDetStrictFoldUDFM
+
mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b
mapDVarEnv = mapUDFM
=====================================
compiler/typecheck/TcEvidence.hs
=====================================
@@ -15,7 +15,9 @@ module TcEvidence (
-- * Evidence bindings
TcEvBinds(..), EvBindsVar(..),
EvBindMap(..), emptyEvBindMap, extendEvBinds,
- lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
+ lookupEvBind, evBindMapBinds,
+ foldEvBindMap, nonDetStrictFoldEvBindMap,
+ filterEvBindMap,
isEmptyEvBindMap,
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
evBindVar, isCoEvBindsVar,
@@ -496,6 +498,9 @@ evBindMapBinds = foldEvBindMap consBag emptyBag
foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a
foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs)
+nonDetStrictFoldEvBindMap :: (a -> EvBind -> a) -> a -> EvBindMap -> a
+nonDetStrictFoldEvBindMap k z bs = nonDetStrictFoldDVarEnv k z (ev_bind_varenv bs)
+
filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap
filterEvBindMap k (EvBindMap { ev_bind_varenv = env })
= EvBindMap { ev_bind_varenv = filterDVarEnv k env }
=====================================
compiler/typecheck/TcSimplify.hs
=====================================
@@ -1862,11 +1862,11 @@ neededEvVars implic@(Implic { ic_given = givens
; tcvs <- TcS.getTcEvTyCoVars ev_binds_var
; let seeds1 = foldr add_implic_seeds old_needs implics
- seeds2 = foldEvBindMap add_wanted seeds1 ev_binds
+ seeds2 = foldEvBindMap add_wanted seeds1 ev_binds -- TODO
seeds3 = seeds2 `unionVarSet` tcvs
need_inner = findNeededEvVars ev_binds seeds3
live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds
- need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds
+ need_outer = varSetMinusEvBindMap need_inner live_ev_binds
`delVarSetList` givens
; TcS.setTcEvBindsMap ev_binds_var live_ev_binds
@@ -1890,8 +1890,8 @@ neededEvVars implic@(Implic { ic_given = givens
| is_given = ev_var `elemVarSet` needed
| otherwise = True -- Keep all wanted bindings
- del_ev_bndr :: EvBind -> VarSet -> VarSet
- del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v
+ varSetMinusEvBindMap :: VarSet -> EvBindMap -> VarSet
+ varSetMinusEvBindMap vs ebm = uniqSetMinusUDFM vs (ev_bind_varenv ebm)
add_wanted :: EvBind -> VarSet -> VarSet
add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs
@@ -2381,7 +2381,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
seed_skols = mkVarSet skols `unionVarSet`
mkVarSet given_ids `unionVarSet`
foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
- foldEvBindMap add_one_bind emptyVarSet binds
+ foldEvBindMap add_one_bind emptyVarSet binds -- TODO
-- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
-- Include the EvIds of any non-floating constraints
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa1d67f121cf813dfd7b3e155b8b301e5f9eaeff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa1d67f121cf813dfd7b3e155b8b301e5f9eaeff
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/20200330/48dc1dfb/attachment-0001.html>
More information about the ghc-commits
mailing list