Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC Commits: cb32b775 by Simon Jakobi at 2026-07-09T19:31:05+02:00 WIP: UDFM: fold foldUDFM directly over the placement array foldUDFM was foldr k z (eltsUDFM m); on the non-empty path eltsUDFM calls the out-of-line elts_nonempty, which returns a real list, so every non-singleton fold materialised the sorted [elt] before consuming it. Make placementSort emit its readout as a build, and route foldUDFM's non-empty case through an out-of-line fold_elts_nonempty that does foldr k z (placementSort ...). placementSort's INLINE lets foldr/build fuse once inside the worker, so the combiner is threaded straight into the array readout with no intermediate list -- and without inlining the sort machinery into every consumer. eltsUDFM's list-producing path is unchanged (the unfused build reduces to cons/nil). See Note [Sorting a UDFM]. Assisted-by: Claude Opus 4.8 - - - - - 26f30aa1 by Simon Jakobi at 2026-07-09T19:31:11+02:00 UDFM: use a static sentinel for placement-sort holes placementSort seeds the array with a sentinel (tag -1) in slots that no element's tag ever hits. TaggedVal's value field is strict, so the sentinel needs a value in WHNF. Borrowing one from the map via findMin allocates a thunk per call that also retains the whole source map until the holes are read. Use `unsafeCoerce ()` instead: () is a static, already-evaluated nullary constructor, so the sentinel is a single shared top-level value -- no per-call allocation and it retains nothing. The value is never read (the readout skips tag < 0) and r is always a lifted, boxed type, so this is safe; see Note [Sorting a UDFM]. Measured (perf+no_profiled_libs, 80 compiler perf tests): bytes allocated drops slightly on every affected test versus the findMin sentinel, with no residency change. Assisted-by: Claude Opus 4.8 - - - - - 1 changed file: - compiler/GHC/Types/Unique/DFM.hs Changes: ===================================== compiler/GHC/Types/Unique/DFM.hs ===================================== @@ -347,8 +347,21 @@ elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m -- See Note [Cost of deterministic iteration]. foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a {-# INLINE foldUDFM #-} --- This INLINE prevents a regression in !10568 -foldUDFM k z m = foldr k z (eltsUDFM m) +-- The INLINE prevents a regression in !10568 and, together with the placement +-- sort's build form, lets the non-empty path fold directly over the sorted +-- readout with no intermediate list. See Note [Sorting a UDFM]. +foldUDFM k z (UDFM m ub) + -- n <= 1: any order is trivially tag order, so fold straight over the map + | M.compareSize m 1 /= GT = M.foldr (k . taggedFst) z m + | otherwise = fold_elts_nonempty k z m ub + +-- Precondition: m is non-empty. Out of line (like elts_nonempty) so foldUDFM's +-- consumers don't inline the sort machinery; but placementSort's build fuses +-- with the foldr here, so the placement path folds without building a list. +fold_elts_nonempty :: (elt -> a -> a) -> a -> M.Word64Map (TaggedVal elt) -> Int -> a +fold_elts_nonempty k z m ub + | usePlacement m ub = foldr k z (placementSort ub (\_ tv -> tv) m) + | otherwise = foldr k z (map taggedFst (sort_it m)) -- | Like 'foldUDFM' but the function also receives a key. -- @@ -420,13 +433,29 @@ O(ub) -- with no comparisons. The readout is lazy, so consumers that demand only a prefix pay almost nothing beyond the fill (but the fill itself is unavoidable; see Note [Cost of deterministic iteration]). +placementSort emits the readout as a 'build', so foldr/build fusion applies. +An eltsUDFM consumer materialises the list (build reduces to cons/nil); a +foldUDFM consumer instead has its combiner threaded straight into the readout, +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. -The sentinel's value field is never read, but something must fill it: not a -panic thunk -- TaggedVal's strict value field would force it as soon as the -readout inspects a hole's tag -- so we borrow the value of an arbitrary map -element. (Safe: the callers' guards send maps of size < 2 down a different -path, so the map is never empty here.) +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. 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 @@ -453,19 +482,15 @@ placementSort :: forall e r. Int -> (M.Key -> TaggedVal e -> TaggedVal r) -> M.Word64Map (TaggedVal e) -> [r] -{-# INLINE placementSort #-} -- specializes mk into the fill loop -placementSort ub mk m = runST (ST (\s0 -> - case newSmallArray ub hole s0 of - (# s1, marr #) -> case fill marr s1 of - (# s2, () #) -> case unsafeFreezeSmallArray marr s2 of - (# s3, arr #) -> (# s3, readout arr 0 #))) +{-# INLINE placementSort #-} -- specializes mk into the fill loop; makes the + -- readout a good producer that fuses with a + -- 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 real value of type r -- borrow one from - -- the map. See Note [Sorting a UDFM]. + -- 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]. hole :: TaggedVal r - hole = case M.findMin m of - (k, tv) -> TaggedVal (taggedFst (mk k tv)) (-1) + hole = TaggedVal (unsafeCoerce ()) (-1) fill :: SmallMutableArray s (TaggedVal r) -> State# s -> (# State# s, () #) fill marr s = case M.traverseWithKey_ write m of ST st -> st s @@ -473,12 +498,22 @@ placementSort ub mk m = runST (ST (\s0 -> write k tv = ST (\s' -> (# writeSmallArray marr (taggedSnd tv) (mk k tv) s', () #)) - readout :: SmallArray (TaggedVal r) -> Int -> [r] - readout arr j - | j >= ub = [] - | t < 0 = readout arr (j + 1) - | otherwise = v : readout arr (j + 1) - where TaggedVal v t = indexSmallArray arr j + -- Written as a build so that foldr/build fusion lets a consuming fold + -- (foldUDFM) apply its combiner during readout, with no cons cells. + -- Unfused (eltsUDFM), build reduces to cons/nil and yields the list. + gen :: forall b. (r -> b -> b) -> b -> b + gen cons nil = runST (ST (\s0 -> + case newSmallArray ub hole s0 of + (# s1, marr #) -> case fill marr s1 of + (# s2, () #) -> case unsafeFreezeSmallArray marr s2 of + (# s3, arr #) -> (# s3, readout arr 0 #))) + where + 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 filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/966e260a14667b5f21f73088356e88e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/966e260a14667b5f21f73088356e88e... You're receiving this email because of your account on gitlab.haskell.org.