Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/Types/Unique/DFM.hs
    ... ... @@ -14,6 +14,9 @@ See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ o
    14 14 
     is not deterministic.
    15 15 
     -}
    16 16
    17 
    +{-# LANGUAGE MagicHash #-}
    18 
    +{-# LANGUAGE UnboxedTuples #-}
    19 
    +
    17 20 
     {-# OPTIONS_GHC -Wall #-}
    18 21
    19 22 
     module GHC.Types.Unique.DFM (
    ... ... @@ -79,6 +82,9 @@ import Data.Functor.Classes (Eq1 (..))
    79 82 
     import Data.List (sortBy)
    80 83 
     import Data.Function (on)
    81 84 
     import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
    85 
    +import GHC.Data.SmallArray
    86 
    +import GHC.Exts (State#)
    87 
    +import GHC.ST (ST(..), runST)
    82 88 
     import Unsafe.Coerce
    83 89 
     import qualified GHC.Data.Word64Set as W
    84 90
    ... ... @@ -92,9 +98,10 @@ import qualified GHC.Data.Word64Set as W
    92 98 
     -- order then `udfmToList` returns them in deterministic order.
    93 99 
     --
    94 100 
     -- There is an implementation cost: each element is given a serial number
    95 
    --- as it is added, and `udfmToList` sorts its result by this serial
    96 
    --- number. So you should only use `UniqDFM` if you need the deterministic
    101 
    +-- as it is added, and functions like `udfmToList` or `eltsUDFM` order their
    102 
    +-- results by this serial number (see
    103 
    +-- Note [Cost of deterministic iteration]). So you should only use `UniqDFM`
    104 
    +-- if you need the deterministic property.
    97 105 
     --
    98 106 
     -- `foldUDFM` also preserves determinism.
    99 107 
     --
    ... ... @@ -112,13 +119,17 @@ import qualified GHC.Data.Word64Set as W
    112 119 
     --
    113 120 
     -- An alternative would be to have
    114 121 
     --
    115 
    ---   data UniqDFM ele = UDFM (M.IntMap ele) [ele]
    122 
    +--   data UniqDFM ele = UDFM (Word64Map ele) [ele]
    116 123 
     --
    117 124 
     -- where the list determines the order. This makes deletion tricky as we'd
    118 125 
     -- only accumulate elements in that list, but makes merging easier as you
    119 126 
     -- can just merge both structures independently.
    120 127 
     -- Deletion can probably be done in amortized fashion when the size of the
    121 128 
     -- list is twice the size of the set.
    129 
    +--
    130 
    +--   data UniqDFM ele = UDFM (Word64Map ele) [Unique]
    131 
    +--
    132 
    +-- may also be worth considering. Compare Dhall.Map in the dhall package.
    122 133
    123 134 
     -- | A type of values tagged with insertion time
    124 135 
     data TaggedVal val =
    ... ... @@ -153,11 +164,15 @@ data UniqDFM key ele =
    153 164 
                                     -- time. See Note [Overflow on plusUDFM]
    154 165 
       deriving (Data, Functor)
    155 166
    156 
    --- | Deterministic, in O(n log n).
    167 
    +-- | Deterministic.
    168 
    +--
    169 
    +-- See Note [Cost of deterministic iteration].
    157 170 
     instance Foldable (UniqDFM key) where
    158 171 
       foldr = foldUDFM
    159 172
    160 
    --- | Deterministic, in O(n log n).
    173 
    +-- | Deterministic.
    174 
    +--
    175 
    +-- See Note [Cost of deterministic iteration].
    161 176 
     instance Traversable (UniqDFM key) where
    162 177 
       traverse f = fmap listToUDFM_Directly
    163 178 
                  . traverse (\(u,a) -> (u,) <$> f a)
    ... ... @@ -310,13 +325,20 @@ elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
    310 325 
     elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
    311 326
    312 327 
     -- | Performs a deterministic fold over the UniqDFM.
    313 
    --- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
    328 
    +--
    329 
    +-- O(n) in the common case, with an O(n log n) fallback.
    330 
    +--
    331 
    +-- Don't use this to access the first element or to check for emptiness,
    332 
    +-- as this already incurs most of the cost of returning the full list.
    333 
    +-- See Note [Cost of deterministic iteration].
    314 334 
     foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
    315 335 
     {-# INLINE foldUDFM #-}
    316 336 
     -- This INLINE prevents a regression in !10568
    317 337 
     foldUDFM k z m = foldr k z (eltsUDFM m)
    318 338
    319 
    --- | Like 'foldUDFM' but the function also receives a key
    339 
    +-- | Like 'foldUDFM' but the function also receives a key.
    340 
    +--
    341 
    +-- See Note [Cost of deterministic iteration].
    320 342 
     foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a
    321 343 
     {-# INLINE foldWithKeyUDFM #-}
    322 344 
     -- This INLINE was copied from foldUDFM
    ... ... @@ -331,14 +353,90 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m
    331 353 
       where
    332 354 
         k' acc (TaggedVal v _) = k v acc
    333 355
    356 
    +-- Note [Cost of deterministic iteration]
    357 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    358 
    +-- Deterministic iteration orders elements by insertion tag, and any such
    359 
    +-- ordering must inspect every element's tag before it can emit the first
    360 
    +-- element. So even the head of the result costs a full traversal of the map
    361 
    +-- plus the allocation of an O(n)-sized array -- or, on the fallback path,
    362 
    +-- O(n log n) cons cells (see Note [Sorting a UDFM]). Laziness in the result
    363 
    +-- list only avoids allocating for elements that are never demanded; it does
    364 
    +-- not make the iteration incremental. #27459 shows this cost biting in
    365 
    +-- consumers that demanded only the head.
    366 
    +--
    367 
    +-- So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM;
    368 
    +-- for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and
    369 
    +-- if you don't need the deterministic order at all, use the nonDet functions.
    370 
    +
    371 
    +-- | Deterministic, in order of insertion.
    372 
    +--
    373 
    +-- See Notes [Sorting a UDFM] and [Cost of deterministic iteration].
    334 374 
     eltsUDFM :: UniqDFM key elt -> [elt]
    335 375 
     {-# INLINE eltsUDFM #-}
    336 376 
     -- The INLINE makes it a good producer (from the map)
    337 
    -eltsUDFM (UDFM m _i) = map taggedFst (sort_it m)
    377 
    +eltsUDFM (UDFM m i)
    378 
    +  | n <= 1            = map taggedFst (M.elems m)
    379 
    +  | usePlacement n i  = placementSort i (M.elems m)
    380 
    +  | otherwise         = map taggedFst (sort_it m)
    381 
    +  where n = M.size m
    338 382
    339 383 
     sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt]
    340 384 
     sort_it m = sortBy (compare `on` taggedSnd) (M.elems m)
    341 385
    386 
    +
    387 
    +-- Note [Sorting a UDFM]
    388 
    +-- ~~~~~~~~~~~~~~~~~~~~~
    389 
    +-- Deterministic iteration must order elements by insertion tag. Instead of a
    390 
    +-- comparison sort -- the list mergesort behind sortBy allocates ~n*log n cons
    391 
    +-- cells -- we exploit the invariant that in (UDFM m i) all tags are distinct
    392 
    +-- Ints in [0, i): allocate an array of size i, write each element at
    393 
    +-- @index = tag@, freeze, and read out in index order. That's O(i) work (which
    394 
    +-- subsumes the O(n) fill, since distinct tags force n <= i), no comparisons,
    395 
    +-- and the readout is lazy, so consumers that demand only a prefix pay almost
    396 
    +-- nothing beyond the fill (but the fill itself is unavoidable; see
    397 
    +-- Note [Cost of deterministic iteration]).
    398 
    +--
    399 
    +-- Holes: slots whose tag never occurs keep the initial sentinel, a TaggedVal
    400 
    +-- with tag -1. Real tags are non-negative, so the readout skips on tag < 0;
    401 
    +-- the sentinel's value field is never touched (it is unsafeCoerced ()).
    402 
    +--
    403 
    +-- This sorting method loses when i is much larger than n: i never shrinks
    404 
    +-- (overwrites keep bumping it, delete/filter shrink n but not i). We compute
    405 
    +-- n = M.size m (O(n), cheap next to either sort) and fall back to the
    406 
    +-- mergesort when i > 4 * n. Maps built by plain insertion -- the common
    407 
    +-- case -- have i == n. The guard also caps the fast path's O(i) at O(n).
    408 
    +
    409 
    +usePlacement :: Int -> Int -> Bool
    410 
    +usePlacement n i = i <= 4 * n
    411 
    +
    412 
    +-- | Order a list of 'TaggedVal's by tag, by placing each at array index =
    413 
    +-- its tag.
    414 
    +--
    415 
    +-- The tags must be distinct and in @[0, i)@.
    416 
    +-- See Note [Sorting a UDFM].
    417 
    +placementSort :: forall r. Int -> [TaggedVal r] -> [r]
    418 
    +placementSort i tvs = runST (ST (\s0 ->
    419 
    +  case newSmallArray i hole s0 of
    420 
    +    (# s1, marr #) -> case fill marr tvs s1 of
    421 
    +      s2 -> case unsafeFreezeSmallArray marr s2 of
    422 
    +        (# s3, arr #) -> (# s3, readout arr 0 #)))
    423 
    +  where
    424 
    +    hole :: TaggedVal r
    425 
    +    hole = TaggedVal (unsafeCoerce ()) (-1)
    426 
    +
    427 
    +    fill :: SmallMutableArray s (TaggedVal r) -> [TaggedVal r] -> State# s -> State# s
    428 
    +    fill _    []          s = s
    429 
    +    fill marr (tv : tvs') s =
    430 
    +      case writeSmallArray marr (taggedSnd tv) tv s of
    431 
    +        s' -> fill marr tvs' s'
    432 
    +
    433 
    +    readout :: SmallArray (TaggedVal r) -> Int -> [r]
    434 
    +    readout arr j
    435 
    +      | j >= i    = []
    436 
    +      | t < 0     = readout arr (j + 1)
    437 
    +      | otherwise = v : readout arr (j + 1)
    438 
    +      where TaggedVal v t = indexSmallArray arr j
    439 
    +
    342 440 
     filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
    343 441 
     filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
    344 442
    ... ... @@ -356,11 +454,25 @@ udfmRestrictKeysSet (UDFM val_set i) set =
    356 454 
       in UDFM (M.restrictKeys val_set key_set) i
    357 455
    358 456 
     -- | Converts `UniqDFM` to a list, with elements in deterministic order.
    359 
    --- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
    457 
    +--
    458 
    +-- O(n) in the common case, with an O(n log n) fallback.
    459 
    +--
    460 
    +-- Don't use this to access the first element or to check for emptiness,
    461 
    +-- as this already incurs most of the cost of returning the full list.
    462 
    +-- See Note [Cost of deterministic iteration].
    360 463 
     udfmToList :: UniqDFM key elt -> [(Unique, elt)]
    361 
    -udfmToList (UDFM m _i) =
    362 
    -  [ (mkUniqueGrimily k, taggedFst v)
    363 
    -  | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
    464 
    +udfmToList (UDFM m i)
    465 
    +  | n <= 1           = [ (mkUniqueGrimily k, taggedFst v) | (k, v) <- M.toList m ]
    466 
    +    -- Unlike eltsUDFM, this allocates a fresh TaggedVal + pair per element
    467 
    +    -- before the sort. If it ever matters, a parallel Word64 array of
    468 
    +    -- keys filled in the same pass would avoid the eager boxes.
    469 
    +  | usePlacement n i = placementSort i
    470 
    +      (M.foldrWithKey (\k tv rest ->
    471 
    +         TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv) : rest) [] m)
    472 
    +  | otherwise =
    473 
    +      [ (mkUniqueGrimily k, taggedFst v)
    474 
    +      | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
    475 
    +  where n = M.size m
    364 476
    365 477 
     -- Determines whether two 'UniqDFM's contain the same keys.
    366 478 
     equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help