Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC Commits: a70e4b42 by Simon Jakobi at 2026-07-10T00:34:01+02:00 UDFM: represent placement-sort holes with a TaggedHole constructor The placement sort in eltsUDFM/udfmToList/foldUDFM seeds gap slots of its SmallArray with a sentinel. Previously that sentinel was `TaggedVal (unsafeCoerce ()) (-1)`, relying on () having the same boxed representation as the element type. Replace it with a proper nullary constructor, TaggedHole, so the readout distinguishes gaps by constructor instead of a tag < 0 test, and no unsafe coercion is needed. The accessors taggedFst/taggedSnd panic on TaggedHole, since it must never be stored in a map. Compiler allocation is neutral (T13719 +0.01%, T17836 -0.14%; both within noise). See Note [Sorting a UDFM]. Assisted-by: Claude Opus 4.8 - - - - - 1 changed file: - compiler/GHC/Types/Unique/DFM.hs Changes: ===================================== compiler/GHC/Types/Unique/DFM.hs ===================================== @@ -74,6 +74,7 @@ import GHC.Prelude import GHC.Types.Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily ) import GHC.Utils.Outputable +import GHC.Utils.Panic (panic) import qualified GHC.Data.Word64Map.Strict as MS import qualified GHC.Data.Word64Map as M @@ -135,19 +136,24 @@ import qualified GHC.Data.Word64Set as W -- | A type of values carrying an insertion tag data TaggedVal val = - TaggedVal - !val - {-# UNPACK #-} !Int -- ^ insertion tag + TaggedVal + !val + {-# UNPACK #-} !Int -- ^ insertion tag + | TaggedHole -- ^ placement-sort gap sentinel; never stored in a map. + -- See Note [Sorting a UDFM]. deriving stock (Data, Functor, Foldable, Traversable) taggedFst :: TaggedVal val -> val taggedFst (TaggedVal v _) = v +taggedFst TaggedHole = panic "taggedFst: TaggedHole" taggedSnd :: TaggedVal val -> Int taggedSnd (TaggedVal _ i) = i +taggedSnd TaggedHole = panic "taggedSnd: TaggedHole" instance Eq val => Eq (TaggedVal val) where (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 + _ == _ = panic "TaggedVal (==): TaggedHole" -- | Type of unique deterministic finite maps -- @@ -207,7 +213,7 @@ addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_Directly (UDFM m i) u v = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where - tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i + tf new old = TaggedVal (taggedFst new) (taggedSnd old) -- Keep the old tag, but insert the new value -- This means that udfmToList typically returns elements -- in the order of insertion, rather than the reverse @@ -224,8 +230,8 @@ addToUDFM_C_Directly addToUDFM_C_Directly f (UDFM m i) u v = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where - tf (TaggedVal new_v _) (TaggedVal old_v old_i) - = TaggedVal (f old_v new_v) old_i + tf new old + = TaggedVal (f (taggedFst old) (taggedFst new)) (taggedSnd old) -- Flip the arguments, because M.insertWith uses (new->old->result) -- but f needs (old->new->result) -- Like addToUDFM_Directly, keep the old tag @@ -378,7 +384,7 @@ foldWithKeyUDFM k z m = foldr (uncurry k) z (udfmToList m) nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m where - k' acc (TaggedVal v _) = k v acc + k' acc tv = k (taggedFst tv) acc {- Note [Cost of deterministic iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -440,22 +446,13 @@ folding the sorted elements with no intermediate list. foldUDFM is INLINE and dispatches through the out-of-line fold_elts_nonempty, where the fusion happens once -- so the fold is list-free without inlining the sort into every consumer. -Holes: slots whose tag never occurs keep the initial sentinel, a TaggedVal -with tag -1. Real tags are non-negative, so the readout skips on tag < 0 and -never reads the sentinel's value field. But that field is strict, so the -sentinel still needs a value in WHNF: a panic thunk is out (it would be forced --- and crash -- the moment the readout inspects a hole's tag). We use -@unsafeCoerce ()@: () is a static, already-evaluated nullary constructor, so -the sentinel is one shared top-level value -- no per-call allocation, and it -retains nothing. - -The unsafeCoerce is safe here because r is always a lifted, boxed (pointer) -type -- it comes from the map's elements -- so a pointer to () has the right -representation. The GC only ever traces that pointer (() is a valid closure); -the value is never evaluated or used as an r, since the readout takes values -only from filled slots. Borrowing a real element instead would also type-check -but costs a per-call thunk that retains the whole source map until the holes -are read. +Holes: slots whose tag never occurs keep the initial sentinel, the nullary +constructor TaggedHole. The readout distinguishes it from a real TaggedVal by +constructor, so it never touches a filled element's value in a hole slot. +TaggedHole is static (a nullary constructor is a single shared closure), so +newSmallArray fills every slot with the same pointer -- no per-call allocation, +nothing retained. TaggedHole must never be stored in a map; the accessors +(taggedFst, taggedSnd) panic on it to catch any invariant violation. This sorting method loses when ub is much larger than n = M.size m: ub never shrinks (overwrites keep bumping it, delete/filter shrink n but not ub). We @@ -487,10 +484,10 @@ placementSort :: forall e r. Int -- consuming fold. See Note [Sorting a UDFM]. placementSort ub mk m = build gen where - -- The tag -1 marks unfilled slots; the value field is never read, but it - -- is strict, so it needs a WHNF value of type r. See Note [Sorting a UDFM]. + -- Unfilled slots hold the TaggedHole sentinel; the readout skips it. + -- See Note [Sorting a UDFM]. hole :: TaggedVal r - hole = TaggedVal (unsafeCoerce ()) (-1) + hole = TaggedHole fill :: SmallMutableArray s (TaggedVal r) -> State# s -> (# State# s, () #) fill marr s = case M.traverseWithKey_ write m of ST st -> st s @@ -511,17 +508,17 @@ placementSort ub mk m = build gen readout :: SmallArray (TaggedVal r) -> Int -> b readout arr j | j >= ub = nil - | t < 0 = readout arr (j + 1) - | otherwise = cons v (readout arr (j + 1)) - where TaggedVal v t = indexSmallArray arr j + | otherwise = case indexSmallArray arr j of + TaggedHole -> readout arr (j + 1) + TaggedVal v _ -> cons v (readout arr (j + 1)) filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt -filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i +filterUDFM p (UDFM m i) = UDFM (M.filter (p . taggedFst) m) i filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i where - p' k (TaggedVal v _) = p (mkUniqueGrimily k) v + p' k tv = p (mkUniqueGrimily k) (taggedFst tv) udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i @@ -645,7 +642,7 @@ alterUDFM f (UDFM m i) k = UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) where alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) + alterf (Just tv) = inject $ f (Just (taggedFst tv)) inject Nothing = Nothing inject (Just v) = Just $ TaggedVal v i @@ -664,7 +661,7 @@ upsertUDFM f (UDFM m i) k = UDFM (MS.upsert upsertf (getKey $ getUnique k) m) (i + 1) where upsertf Nothing = TaggedVal (f Nothing) i - upsertf (Just (TaggedVal v _)) = TaggedVal (f (Just v)) i + upsertf (Just tv) = TaggedVal (f (Just (taggedFst tv))) i -- | The expression (@'alterUDFM_L' f map k@) alters value @x@ at @k@, or absence -- thereof and returns the new element at @k@ if there is any. @@ -687,7 +684,7 @@ alterUDFM_L f (UDFM m i) k = where alterf :: Maybe (TaggedVal elt) -> (Maybe (TaggedVal elt)) alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) + alterf (Just tv) = inject $ f (Just (taggedFst tv)) inject Nothing = Nothing inject (Just v) = Just $ TaggedVal v i View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a70e4b4285630695aecc61665101c047... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a70e4b4285630695aecc61665101c047... You're receiving this email because of your account on gitlab.haskell.org.