[Git][ghc/ghc][wip/mixed-uniqfm] 2 commits: Fix for #24102
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Thu Oct 19 16:09:45 UTC 2023
Sebastian Graf pushed to branch wip/mixed-uniqfm at Glasgow Haskell Compiler / GHC
Commits:
aef078bb by Sebastian Graf at 2023-10-19T18:08:51+02:00
Fix for #24102
- - - - -
064c9ef1 by Sebastian Graf at 2023-10-19T18:09:32+02:00
Consequently hide mixed unique sets behind a newtype
- - - - -
5 changed files:
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/Graph/UnVar.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
Changes:
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -643,13 +643,19 @@ cpeBind top_lvl env (Rec pairs)
where
(bndrs, rhss) = unzip pairs
- -- Flatten all the floats, and the current
- -- group into a single giant Rec
+ -- Flatten all the floats, and the current
+ -- group into a single giant Rec
add_float (Float bind bound _) prs2
- | bound /= CaseBound = case bind of
+ | bound /= CaseBound
+ || all (definitelyLiftedType . idType) (bindersOf bind)
+ -- The latter check is hit in -O0 (i.e., flavours quick, devel2)
+ -- for dictionary args which haven't been floated out yet, #24102.
+ -- They are preferably CaseBound, but since they are lifted we may
+ -- just as well put them in the Rec, in contrast to lifted bindings.
+ = case bind of
NonRec x e -> (x,e) : prs2
Rec prs1 -> prs1 ++ prs2
- add_float f _ = pprPanic "cpeBind" (ppr f)
+ add_float f _ = pprPanic "cpeBind" (ppr f)
---------------
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
=====================================
compiler/GHC/Data/Graph/UnVar.hs
=====================================
@@ -31,7 +31,7 @@ module GHC.Data.Graph.UnVar
import GHC.Prelude
-import GHC.Types.Unique.FM( UniqFM, ufmToSet_Directly, getMixedKey, getUnmixedUnique )
+import GHC.Types.Unique.FM
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Types.Unique
@@ -44,7 +44,10 @@ import qualified GHC.Data.Word64Set as S
-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
-- Therefore, use a Word64Set directly (which is likely also a bit more efficient).
--- Set of uniques, i.e. for adjacent nodes
+-- Set of mixed unique keys, i.e. for adjacent nodes
+-- This could very well be backed by a UniqFMKeySet! But that would require
+-- moving a lot of functions to GHC.Types.Unique.FM, because we definitely
+-- don't want to expose the newtype constructor of UniqFMKeySet.
newtype UnVarSet = UnVarSet S.Word64Set
deriving Eq
@@ -52,7 +55,7 @@ k :: Var -> Word64
k v = getMixedKey (getUnique v)
domUFMUnVarSet :: UniqFM key elt -> UnVarSet
-domUFMUnVarSet ae = UnVarSet $ ufmToSet_Directly ae
+domUFMUnVarSet ae = UnVarSet $ ufmksToMixedSet $ ufmToSet_Directly ae
emptyUnVarSet :: UnVarSet
emptyUnVarSet = UnVarSet S.empty
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -151,11 +151,9 @@ import GHC.Runtime.Loader
import GHC.Rename.Names
import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
-import GHC.Types.Unique
+import GHC.Types.Unique.FM (UniqFMKeySet, emptyUniqFMKeySet, mkUniqFMKeySet, unionUniqFMKeySet)
import GHC.Iface.Errors.Types
-import qualified GHC.Data.Word64Set as W
-
-- -----------------------------------------------------------------------------
-- Loading the program
@@ -2812,7 +2810,7 @@ Before a module is compiled, we use this set to restrict the HUG to the visible
modules only, avoiding this tricky space leak.
Efficiency of the ModuleNameSet is of utmost importance, because a union occurs for
-each edge in the module graph. To achieve this, the set is represented directly as an IntSet,
+each edge in the module graph. To achieve this, the set is represented directly as a UniqFMKeySet,
which provides suitable performance – even using a UniqSet (which is backed by an IntMap) is
too slow. The crucial test of performance here is the time taken to a do a no-op build in --make mode.
@@ -2821,12 +2819,11 @@ See test "jspace" for an example which used to trigger this problem.
-}
-- See Note [ModuleNameSet, efficiency and space leaks]
-type ModuleNameSet = M.Map UnitId W.Word64Set
+type ModuleNameSet = M.Map UnitId UniqFMKeySet
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet uid mn s =
- let k = (getKey $ getUnique $ mn)
- in M.insertWith (W.union) uid (W.singleton k) s
+ M.insertWith unionUniqFMKeySet uid (mkUniqFMKeySet [mn]) s
-- | Wait for some dependencies to finish and then read from the given MVar.
wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
@@ -2837,7 +2834,7 @@ wait_deps_hug hug_var deps = do
let -- Restrict to things which are in the transitive closure to avoid retaining
-- reference to loop modules which have already been compiled by other threads.
-- See Note [ModuleNameSet, efficiency and space leaks]
- !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe W.empty $ M.lookup uid module_deps)
+ !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe emptyUniqFMKeySet $ M.lookup uid module_deps)
in hme { homeUnitEnv_hpt = new }
return (unitEnv_mapWithKey pruneHomeUnitEnv hug, module_deps)
@@ -2852,7 +2849,7 @@ wait_deps (x:xs) = do
Nothing -> return (hmis, new_deps)
Just hmi -> return (hmi:hmis, new_deps)
where
- unionModuleNameSet = M.unionWith W.union
+ unionModuleNameSet = M.unionWith unionUniqFMKeySet
-- Executing the pipelines
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -80,9 +80,8 @@ import Data.Data
import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
-import GHC.Types.Unique.FM (UniqFM, getMixedKey, getUnmixedUnique, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
+import GHC.Types.Unique.FM
import Unsafe.Coerce
-import qualified GHC.Data.Word64Set as W
-- Note [Deterministic UniqFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -325,10 +324,9 @@ filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i
udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt
udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i
-udfmRestrictKeysSet :: UniqDFM key elt -> W.Word64Set -> UniqDFM key elt
+udfmRestrictKeysSet :: UniqDFM key elt -> UniqFMKeySet -> UniqDFM key elt
udfmRestrictKeysSet (UDFM val_set i) set =
- let key_set = set
- in UDFM (M.restrictKeys val_set key_set) i
+ UDFM (M.restrictKeys val_set (ufmksToMixedSet set)) i
-- | Converts `UniqDFM` to a list, with elements in deterministic order.
-- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
@@ -353,7 +351,7 @@ intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i
-- a subset of elements from the left set, so `i` is a good upper bound.
udfmIntersectUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1
-udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i
+udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToMixedIntMap y)) i
-- M.intersection is left biased, that means the result will only have
-- a subset of elements from the left set, so `i` is a good upper bound.
@@ -361,7 +359,7 @@ disjointUDFM :: UniqDFM key elt -> UniqDFM key elt -> Bool
disjointUDFM (UDFM x _i) (UDFM y _j) = M.disjoint x y
disjointUdfmUfm :: UniqDFM key elt -> UniqFM key elt2 -> Bool
-disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToIntMap y)
+disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToMixedIntMap y)
minusUDFM :: UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1
minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i
@@ -369,12 +367,12 @@ minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i
-- bound.
udfmMinusUFM :: UniqDFM key elt1 -> UniqFM key elt2 -> UniqDFM key elt1
-udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i
+udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToMixedIntMap y)) i
-- M.difference returns a subset of a left set, so `i` is a good upper
-- bound.
ufmMinusUDFM :: UniqFM key elt1 -> UniqDFM key elt2 -> UniqFM key elt1
-ufmMinusUDFM x (UDFM y _i) = unsafeIntMapToUFM (M.difference (ufmToIntMap x) y)
+ufmMinusUDFM x (UDFM y _i) = mixedIntMapToUFM (M.difference (ufmToMixedIntMap x) y)
-- | Partition UniqDFM into two UniqDFMs according to the predicate
partitionUDFM :: (elt -> Bool) -> UniqDFM key elt -> (UniqDFM key elt, UniqDFM key elt)
@@ -388,7 +386,7 @@ delListFromUDFM = foldl' delFromUDFM
-- | This allows for lossy conversion from UniqDFM to UniqFM
udfmToUfm :: UniqDFM key elt -> UniqFM key elt
-udfmToUfm (UDFM m _i) = unsafeIntMapToUFM (M.map taggedFst m)
+udfmToUfm (UDFM m _i) = mixedIntMapToUFM (M.map taggedFst m)
listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM key elt
listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -33,9 +33,13 @@ module GHC.Types.Unique.FM (
-- * Unique-keyed mappings
UniqFM, -- abstract type
NonDetUniqFM(..), -- wrapper for opting into nondeterminism
+ UniqFMKeySet, -- A Word64Set with keys that are mixed the same way as UniqFM's
getMixedKey,
getUnmixedUnique,
+ -- ** Manipulating UniqFMKeySets
+ emptyUniqFMKeySet, mkUniqFMKeySet, unionUniqFMKeySet,
+
-- ** Manipulating those mappings
emptyUFM,
unitUFM,
@@ -83,8 +87,8 @@ module GHC.Types.Unique.FM (
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
nonDetEltsUFM, nonDetKeysUFM,
- ufmToSet_Directly,
- nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM,
+ ufmToSet_Directly, ufmksToMixedSet,
+ nonDetUFMToList, ufmToMixedIntMap, mixedIntMapToUFM,
unsafeCastUFMKey,
pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM
) where
@@ -103,10 +107,6 @@ import Data.Functor.Classes (Eq1 (..))
import Data.Bits
import Data.Coerce
--- for UNIQUE_TAG_BITS. @mix@ will silently fail if this isn't included and
--- you'll get panics.
-#include "Unique.h"
-
-- | A finite map from @uniques@ of one type to
-- elements in another type.
--
@@ -122,6 +122,10 @@ newtype UniqFM key ele = UFM (M.Word64Map ele)
-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism.
type role UniqFM representational representational -- Don't allow coerces over the key
+-- | The result of `ufmToSet_Directly`: A very dense `S.Word64Set` the keys of
+-- which are mixed exactly like the keys of the `UniqFM` from whence it came.
+newtype UniqFMKeySet = UFMKS S.Word64Set
+
-- | https://gist.github.com/degski/6e2069d6035ae04d5d6f64981c995ec2
mix :: MS.Key -> MS.Key -> MS.Key
{-# INLINE mix #-}
@@ -129,7 +133,7 @@ mix k = fromIntegral . f . g . f . g . f . fromIntegral
where
f y = (y `shiftR` s) `xor` y
g z = z * k
- s = finiteBitSize k `shiftR` 1 -- 32 for 64 bit, 16 for 32 bit
+ s = finiteBitSize k `shiftR` 1
kFORWARD, kBACKWARD :: MS.Key
-- These are like "encryption" and "decryption" keys to mix
@@ -149,6 +153,15 @@ getUnmixedUnique :: MS.Key -> Unique
{-# INLINE getUnmixedUnique #-}
getUnmixedUnique = mkUniqueGrimily . dec
+emptyUniqFMKeySet :: UniqFMKeySet
+emptyUniqFMKeySet = UFMKS S.empty
+
+mkUniqFMKeySet :: Uniquable k => [k] -> UniqFMKeySet
+mkUniqFMKeySet us = UFMKS (S.fromList (map (getMixedKey . getUnique) us))
+
+unionUniqFMKeySet :: UniqFMKeySet -> UniqFMKeySet -> UniqFMKeySet
+unionUniqFMKeySet (UFMKS s1) (UFMKS s2) = UFMKS (S.union s1 s2)
+
emptyUFM :: UniqFM key elt
emptyUFM = UFM M.empty
@@ -374,7 +387,7 @@ plusUFMList :: [UniqFM key elt] -> UniqFM key elt
plusUFMList = foldl' plusUFM emptyUFM
plusUFMListWith :: (elt -> elt -> elt) -> [UniqFM key elt] -> UniqFM key elt
-plusUFMListWith f xs = unsafeIntMapToUFM $ M.unionsWith f (map ufmToIntMap xs)
+plusUFMListWith f xs = mixedIntMapToUFM $ M.unionsWith f (map ufmToMixedIntMap xs)
sequenceUFMList :: forall key elt. [UniqFM key elt] -> UniqFM key [elt]
sequenceUFMList = foldr (plusUFM_CD2 cons) emptyUFM
@@ -471,8 +484,8 @@ lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt
lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getMixedKey u) m
-- | NB: This provides a set of keys with with `getMixedKey`!
-ufmToSet_Directly :: UniqFM key elt -> S.Word64Set
-ufmToSet_Directly (UFM m) = M.keysSet m
+ufmToSet_Directly :: UniqFM key elt -> UniqFMKeySet
+ufmToSet_Directly (UFM m) = UFMKS (M.keysSet m)
anyUFM :: (elt -> Bool) -> UniqFM key elt -> Bool
anyUFM p (UFM m) = M.foldr ((||) . p) False m
@@ -546,11 +559,20 @@ instance forall key. Foldable (NonDetUniqFM key) where
instance forall key. Traversable (NonDetUniqFM key) where
traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m
-ufmToIntMap :: UniqFM key elt -> M.Word64Map elt
-ufmToIntMap (UFM m) = m
+-- | Interpret a `UniqFMKeySet` as a `Word64Set`, where the Unique keys can be
+-- recovered by applying `getUnmixedUnique` to the keys.
+ufmksToMixedSet :: UniqFMKeySet -> S.Word64Set
+ufmksToMixedSet (UFMKS s) = s
+
+-- | Interpret a `UniqFM` as a `Word64Map`, where the Unique keys can be
+-- recovered by applying `getUnmixedUnique` to the keys.
+ufmToMixedIntMap :: UniqFM key elt -> M.Word64Map elt
+ufmToMixedIntMap (UFM m) = m
-unsafeIntMapToUFM :: M.Word64Map elt -> UniqFM key elt
-unsafeIntMapToUFM = UFM
+-- | Interpret a `Word64Map` as a `UniqFM`, where the Unique keys of the
+-- `Word64Map` can be recovered by applying `getUnmixedUnique` to the keys.
+mixedIntMapToUFM :: M.Word64Map elt -> UniqFM key elt
+mixedIntMapToUFM = UFM
-- | Cast the key domain of a UniqFM.
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e122c96e692ef7be3138b1be0afc478825265bd...064c9ef12005314ebb6b3806f8c1fae9f98bbd13
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e122c96e692ef7be3138b1be0afc478825265bd...064c9ef12005314ebb6b3806f8c1fae9f98bbd13
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/20231019/259be0fd/attachment-0001.html>
More information about the ghc-commits
mailing list