GitLab

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