diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index 2ac463acd..ad17c5146 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -46,7 +46,8 @@ main = do , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m , bench "fromList" $ whnf M.fromList elems , bench "fromAscList" $ whnf M.fromAscList elems - , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems + , bench "fromAscList:fusion" $ + whnf (\n -> M.fromAscList [(i,()) | i <- [1..n]]) bound , bench "minView" $ whnf (maybe 0 (\((k,v), m) -> k+v+M.size m) . M.minViewWithKey) (M.fromList $ zip [1..10] [1..10]) , bench "spanAntitone" $ whnf (M.spanAntitone ( x * 2 + 1) keys) values elems_mixed = zip mixedKeys values -------------------------------------------------------- - keys = [1..2^12] + bound = 2^12 + keys = [1..bound] keys' = fmap (+ 1000000) keys - keys'' = fmap (* 2) [1..2^12] + keys'' = fmap (* 2) [1..bound] mixedKeys = interleave keys keys' - values = [1..2^12] - key_mid = 2^11 + values = [1..bound] + key_mid = bound `div` 2 -------------------------------------------------------- sum k v1 v2 = k + v1 + v2 consPair k v xs = (k, v) : xs diff --git a/containers-tests/benchmarks/IntSet.hs b/containers-tests/benchmarks/IntSet.hs index d47680c01..4c6f30f47 100644 --- a/containers-tests/benchmarks/IntSet.hs +++ b/containers-tests/benchmarks/IntSet.hs @@ -41,8 +41,11 @@ main = do , bench "fromList" $ whnf IS.fromList elems , bench "fromRange" $ whnf IS.fromRange (1,bound) , bench "fromRange:small" $ whnf IS.fromRange (-1,0) - , bench "fromAscList" $ whnf IS.fromAscList elems - , bench "fromDistinctAscList" $ whnf IS.fromDistinctAscList elems + , bench "fromAscList" $ whnf fromAscListNoinline elems + , bench "fromAscList:fusion" $ whnf (\n -> IS.fromAscList [1..n]) bound + , bench "fromAscList:sparse" $ whnf fromAscListNoinline elems_sparse + , bench "fromAscList:sparse:fusion" $ + whnf (\n -> IS.fromAscList (map (*64) [1..n])) bound , bench "disjoint:false" $ whnf (IS.disjoint s) s_even , bench "disjoint:true" $ whnf (IS.disjoint s_odd) s_even , bench "null.intersection:false" $ whnf (IS.null. IS.intersection s) s_even @@ -81,6 +84,11 @@ ins xs s0 = foldl' (\s a -> IS.insert a s) s0 xs del :: [Int] -> IS.IntSet -> IS.IntSet del xs s0 = foldl' (\s k -> IS.delete k s) s0 xs +-- NOINLINE to work around an issue where the inlined function doesn't get +-- optimized (see GHC #25878). +fromAscListNoinline :: [Int] -> IS.IntSet +fromAscListNoinline = IS.fromAscList +{-# NOINLINE fromAscListNoinline #-} -- | Automata contain just the transitions diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index adb8795aa..c56567023 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -29,6 +29,7 @@ import qualified Prelude (map, filter) import Data.List (nub,sort) import qualified Data.List as List +import qualified Data.List.NonEmpty as NE import qualified Data.IntSet as IntSet import Test.Tasty import Test.Tasty.HUnit @@ -157,7 +158,6 @@ main = defaultMain $ testGroup "intmap-properties" , testProperty "mergeWithKey model" prop_mergeWithKeyModel , testProperty "merge valid" prop_merge_valid , testProperty "mergeA effects" prop_mergeA_effects - , testProperty "fromAscList" prop_ordered , testProperty "fromList then toList" prop_list , testProperty "toDescList" prop_descList , testProperty "toAscList+toDescList" prop_ascDescList @@ -248,6 +248,10 @@ main = defaultMain $ testGroup "intmap-properties" , testProperty "mapKeysWith" prop_mapKeysWith , testProperty "mapKeysMonotonic" prop_mapKeysMonotonic , testProperty "compare" prop_compare + , testProperty "fromAscList" prop_fromAscList + , testProperty "fromAscListWith" prop_fromAscListWith + , testProperty "fromAscListWithKey" prop_fromAscListWithKey + , testProperty "fromDistinctAscList" prop_fromDistinctAscList ] {-------------------------------------------------------------------- @@ -1402,12 +1406,6 @@ prop_mergeA_effects xs ys ---------------------------------------------------------------- -prop_ordered :: Property -prop_ordered - = forAll (choose (5,100)) $ \n -> - let xs = [(x,()) | x <- [0..n::Int]] - in fromAscList xs == fromList xs - prop_list :: [Int] -> Bool prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])]) @@ -1984,3 +1982,38 @@ prop_mapKeysMonotonic (Positive a) b m = prop_compare :: IntMap OrdA -> IntMap OrdA -> Property prop_compare m1 m2 = compare m1 m2 === compare (toList m1) (toList m2) + +prop_fromAscList :: [(Int, A)] -> Property +prop_fromAscList kxs = + valid t .&&. + t === fromList sortedKxs + where + sortedKxs = List.sortBy (comparing fst) kxs + t = fromAscList sortedKxs + +prop_fromAscListWith :: Fun (A, A) A -> [(Int, A)] -> Property +prop_fromAscListWith f kxs = + valid t .&&. + t === fromListWith (applyFun2 f) sortedKxs + where + sortedKxs = List.sortBy (comparing fst) kxs + t = fromAscListWith (applyFun2 f) sortedKxs + +prop_fromAscListWithKey :: Fun (Int, A, A) A -> [(Int, A)] -> Property +prop_fromAscListWithKey f kxs = + valid t .&&. + t === fromListWithKey (applyFun3 f) sortedKxs + where + sortedKxs = List.sortBy (comparing fst) kxs + t = fromAscListWithKey (applyFun3 f) sortedKxs + +prop_fromDistinctAscList :: [(Int, A)] -> Property +prop_fromDistinctAscList kxs = + valid t .&&. + toList t === nubSortedKxs + where + nubSortedKxs = + List.map NE.head $ + NE.groupBy ((==) `on` fst) $ + List.sortBy (comparing fst) kxs + t = fromDistinctAscList nubSortedKxs diff --git a/containers-tests/tests/intset-properties.hs b/containers-tests/tests/intset-properties.hs index a9f0f3688..0e3c455f3 100644 --- a/containers-tests/tests/intset-properties.hs +++ b/containers-tests/tests/intset-properties.hs @@ -46,7 +46,6 @@ main = defaultMain $ testGroup "intset-properties" , testProperty "prop_difference" prop_difference , testProperty "prop_intersection" prop_intersection , testProperty "prop_symmetricDifference" prop_symmetricDifference - , testProperty "prop_Ordered" prop_Ordered , testProperty "prop_List" prop_List , testProperty "prop_DescList" prop_DescList , testProperty "prop_AscDescList" prop_AscDescList @@ -90,6 +89,8 @@ main = defaultMain $ testGroup "intset-properties" , testProperty "delete" prop_delete , testProperty "deleteMin" prop_deleteMin , testProperty "deleteMax" prop_deleteMax + , testProperty "fromAscList" prop_fromAscList + , testProperty "fromDistinctAscList" prop_fromDistinctAscList ] ---------------------------------------------------------------- @@ -281,10 +282,6 @@ prop_disjoint a b = a `disjoint` b == null (a `intersection` b) {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} -prop_Ordered - = forAll (choose (5,100)) $ \n -> - let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]] - in fromAscList xs == fromList xs prop_List :: [Int] -> Bool prop_List xs @@ -521,3 +518,20 @@ prop_deleteMin s = toList (deleteMin s) === if null s then [] else tail (toList prop_deleteMax :: IntSet -> Property prop_deleteMax s = toList (deleteMax s) === if null s then [] else init (toList s) + +prop_fromAscList :: [Int] -> Property +prop_fromAscList xs = + valid t .&&. + toList t === nubSortedXs + where + sortedXs = sort xs + nubSortedXs = List.map NE.head $ NE.group sortedXs + t = fromAscList sortedXs + +prop_fromDistinctAscList :: [Int] -> Property +prop_fromDistinctAscList xs = + valid t .&&. + toList t === nubSortedXs + where + nubSortedXs = List.map NE.head $ NE.group $ sort xs + t = fromDistinctAscList nubSortedXs diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index f8ef5600d..7ca95f625 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -290,6 +290,10 @@ module Data.IntMap.Internal ( , bin , binCheckLeft , binCheckRight + , MonoState(..) + , Stack(..) + , ascLinkTop + , ascLinkAll -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict" , mapWhenMissing @@ -3385,8 +3389,8 @@ fromListWithKey f xs -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscList :: [(Key,a)] -> IntMap a -fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) -{-# NOINLINE fromAscList #-} +fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs +{-# INLINE fromAscList #-} -- Inline for list fusion -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -3400,8 +3404,8 @@ fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) -- Also see the performance note on 'fromListWith'. fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) -{-# NOINLINE fromAscListWith #-} +fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs +{-# INLINE fromAscListWith #-} -- Inline for list fusion -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -3415,86 +3419,66 @@ fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) -- -- Also see the performance note on 'fromListWith'. +-- See Note [fromAscList implementation] fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWithKey f = fromMonoListWithKey Nondistinct f -{-# NOINLINE fromAscListWithKey #-} +fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next MSNada xs) + where + next s (!ky, y) = case s of + MSNada -> MSPush ky y Nada + MSPush kx x stk + | kx == ky -> MSPush ky (f ky y x) stk + | otherwise -> let m = branchMask kx ky + in MSPush ky y (ascLinkTop stk kx (Tip kx x) m) +{-# INLINE fromAscListWithKey #-} -- Inline for list fusion -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. -- --- __Warning__: This function should be used only if the keys are in --- strictly increasing order. This precondition is not checked. Use 'fromList' --- if the precondition may not hold. --- --- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] - -fromDistinctAscList :: [(Key,a)] -> IntMap a -fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) -{-# NOINLINE fromDistinctAscList #-} - --- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys --- and a combining function. +-- @fromDistinctAscList = 'fromAscList'@ -- --- The precise conditions under which this function works are subtle: --- For any branch mask, keys with the same prefix w.r.t. the branch --- mask must occur consecutively in the list. +-- See warning on 'fromAscList'. -- --- Also see the performance note on 'fromListWith'. - -fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromMonoListWithKey distinct f = go - where - go [] = Nil - go ((kx,vx) : zs1) = addAll' kx vx zs1 - - -- `addAll'` collects all keys equal to `kx` into a single value, - -- and then proceeds with `addAll`. - addAll' !kx vx [] - = Tip kx vx - addAll' !kx vx ((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = let v = f kx vy vx in addAll' ky v zs - -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs' - - -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` - -- `addAll` consumes the rest of the list, adding to the tree `tx` - addAll !_kx !tx [] - = tx - addAll !kx !tx ((ky,vy) : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty kx tx) zs' - - -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. - addMany' !_m !kx vx [] - = Inserted (Tip kx vx) [] - addMany' !m !kx vx zs0@((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = let v = f kx vy vx in addMany' m ky v zs - -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs) - | mask kx m /= mask ky m - = Inserted (Tip kx vx) zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs' - - -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. - addMany !_m !_kx tx [] - = Inserted tx [] - addMany !m !kx tx zs0@((ky,vy) : zs) - | mask kx m /= mask ky m - = Inserted tx zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty kx tx) zs' -{-# INLINE fromMonoListWithKey #-} - -data Inserted a = Inserted !(IntMap a) ![(Key,a)] - -data Distinct = Distinct | Nondistinct +-- This definition exists for backwards compatibility. It offers no advantage +-- over @fromAscList@. +fromDistinctAscList :: [(Key,a)] -> IntMap a +-- Note: There is nothing we can optimize compared to fromAscList. +-- The adjacent key equals check (kx == ky) might seem unnecessary for +-- fromDistinctAscList, but it guards branchMask which has undefined behavior +-- under that case. We could error on kx == ky instead, but that isn't any +-- better. +fromDistinctAscList = fromAscList +{-# INLINE fromDistinctAscList #-} -- Inline for list fusion + +data Stack a + = Nada + | Push {-# UNPACK #-} !Int !(IntMap a) !(Stack a) + +data MonoState a + = MSNada + | MSPush {-# UNPACK #-} !Key a !(Stack a) + +ascLinkTop :: Stack a -> Int -> IntMap a -> Int -> Stack a +ascLinkTop stk !rk r !rm = case stk of + Nada -> Push rm r stk + Push m l stk' + | i2w m < i2w rm -> let p = Prefix (mask rk m .|. m) + in ascLinkTop stk' rk (Bin p l r) rm + | otherwise -> Push rm r stk + +ascLinkAll :: MonoState a -> IntMap a +ascLinkAll s = case s of + MSNada -> Nil + MSPush kx x stk -> ascLinkStack stk kx (Tip kx x) +{-# INLINABLE ascLinkAll #-} + +ascLinkStack :: Stack a -> Int -> IntMap a -> IntMap a +ascLinkStack stk !rk r = case stk of + Nada -> r + Push m l stk' + | signBranch p -> Bin p r l + | otherwise -> ascLinkStack stk' rk (Bin p l r) + where + p = Prefix (mask rk m .|. m) {-------------------------------------------------------------------- Eq @@ -3884,3 +3868,33 @@ withEmpty bars = " ":bars -- * This is similar to the Map merge complexity, which is O(m log (n/m)). -- * When m is a small constant the term simplifies to O(min(n, W)), which is -- just the complexity we expect for single operations like insert and delete. + +-- Note [fromAscList implementation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- fromAscList is an implementation that builds up the result bottom-up +-- in linear time. It maintains a state (MonoState) that gets updated with +-- key-value pairs from the input list one at a time. The state contains the +-- last key-value pair, and a stack of pending trees. +-- +-- For a new key-value pair, the branchMask with the previous key is computed. +-- This represents the depth of the lowest common ancestor that the tree with +-- the previous key, say tl, and the tree with the new key, tr, must have in +-- the final result. Since the keys are in ascending order we expect no more +-- keys in tl, and we can build it by moving up the stack and linking trees. We +-- know when to stop by the branchMask value. We must not link higher than that +-- depth, otherwise instead of tl we will build the parent of tl prematurely +-- before tr is ready. Once the linking is done, tl will be at the top of the +-- stack. +-- +-- We also store the branchMask of a tree with its future right sibling in the +-- stack. This is an optimization, benchmarks show that this is faster than +-- recomputing the branchMask values when linking trees. +-- +-- In the end, we link all the trees remaining in the stack. There is a small +-- catch: negative keys appear in the input before non-negative keys (if they +-- both appear), but the tree with negative keys and the tree with non-negative +-- keys must be the right and left child of the root respectively. So we check +-- for this and link them accordingly. +-- +-- The implementation is defined as a foldl' over the input list, which makes +-- it a good consumer in list fusion. diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 4beb84a6f..2a5078522 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -232,7 +232,7 @@ import Prelude () import Data.Bits import qualified Data.IntMap.Internal as L import Data.IntSet.Internal.IntTreeCommons - (Key, Prefix(..), nomatch, left, signBranch, mask, branchMask) + (Key, Prefix(..), nomatch, left, signBranch, branchMask) import Data.IntMap.Internal ( IntMap (..) , bin @@ -240,7 +240,10 @@ import Data.IntMap.Internal , binCheckRight , link , linkKey - , linkWithMask + , MonoState(..) + , Stack(..) + , ascLinkTop + , ascLinkAll , (\\) , (!) @@ -1119,8 +1122,8 @@ fromListWithKey f xs -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscList :: [(Key,a)] -> IntMap a -fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) -{-# NOINLINE fromAscList #-} +fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs +{-# INLINE fromAscList #-} -- Inline for list fusion -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -1134,8 +1137,8 @@ fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) -- Also see the performance note on 'fromListWith'. fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) -{-# NOINLINE fromAscListWith #-} +fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs +{-# INLINE fromAscListWith #-} -- Inline for list fusion -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -1148,89 +1151,29 @@ fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) -- -- Also see the performance note on 'fromListWith'. +-- See Note [fromAscList implementation] in Data.IntMap.Internal. fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWithKey f = fromMonoListWithKey Nondistinct f -{-# NOINLINE fromAscListWithKey #-} +fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next MSNada xs) + where + next s (!ky, y) = case s of + MSNada -> msPush' ky y Nada + MSPush kx x stk + | kx == ky -> msPush' ky (f ky y x) stk + | otherwise -> let m = branchMask kx ky + in msPush' ky y (ascLinkTop stk kx (Tip kx x) m) + msPush' ky !y = MSPush ky y +{-# INLINE fromAscListWithKey #-} -- Inline for list fusion -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. -- --- __Warning__: This function should be used only if the keys are in --- strictly increasing order. This precondition is not checked. Use 'fromList' --- if the precondition may not hold. +-- @fromDistinctAscList = 'fromAscList'@ -- --- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] - -fromDistinctAscList :: [(Key,a)] -> IntMap a -fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) -{-# NOINLINE fromDistinctAscList #-} - --- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys --- and a combining function. +-- See warning on 'fromAscList'. -- --- The precise conditions under which this function works are subtle: --- For any branch mask, keys with the same prefix w.r.t. the branch --- mask must occur consecutively in the list. --- --- Also see the performance note on 'fromListWith'. - -fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromMonoListWithKey distinct f = go - where - go [] = Nil - go ((kx,vx) : zs1) = addAll' kx vx zs1 - - -- `addAll'` collects all keys equal to `kx` into a single value, - -- and then proceeds with `addAll`. - -- - -- We want to have the same strictness as fromListWithKey, which is achieved - -- with the bang on vx. - addAll' !kx !vx [] - = Tip kx vx - addAll' !kx !vx ((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = addAll' ky (f kx vy vx) zs - -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs' - - -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` - -- `addAll` consumes the rest of the list, adding to the tree `tx` - addAll !_kx !tx [] - = tx - addAll !kx !tx ((ky,vy) : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty kx tx) zs' - - -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. - -- - -- We want to have the same strictness as fromListWithKey, which is achieved - -- with the bang on vx. - addMany' !_m !kx !vx [] - = Inserted (Tip kx vx) [] - addMany' !m !kx !vx zs0@((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = addMany' m ky (f kx vy vx) zs - -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs) - | mask kx m /= mask ky m - = Inserted (Tip kx vx) zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs' - - -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. - addMany !_m !_kx tx [] - = Inserted tx [] - addMany !m !kx tx zs0@((ky,vy) : zs) - | mask kx m /= mask ky m - = Inserted tx zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty kx tx) zs' -{-# INLINE fromMonoListWithKey #-} - -data Inserted a = Inserted !(IntMap a) ![(Key,a)] - -data Distinct = Distinct | Nondistinct +-- This definition exists for backwards compatibility. It offers no advantage +-- over @fromAscList@. +fromDistinctAscList :: [(Key,a)] -> IntMap a +-- See Note on Data.IntMap.Internal.fromDistinctAscList. +fromDistinctAscList = fromAscList +{-# INLINE fromDistinctAscList #-} -- Inline for list fusion diff --git a/containers/src/Data/IntSet/Internal.hs b/containers/src/Data/IntSet/Internal.hs index 4521b6ebc..86168019f 100644 --- a/containers/src/Data/IntSet/Internal.hs +++ b/containers/src/Data/IntSet/Internal.hs @@ -1403,78 +1403,65 @@ fromRange (lx,rx) -- __Warning__: This function should be used only if the elements are in -- non-decreasing order. This precondition is not checked. Use 'fromList' if the -- precondition may not hold. + +-- See Note [fromAscList implementation] in Data.IntMap.Internal. fromAscList :: [Key] -> IntSet -fromAscList = fromMonoList -{-# NOINLINE fromAscList #-} +fromAscList xs = ascLinkAll (Foldable.foldl' next MSNada xs) + where + next s !ky = case s of + MSNada -> MSPush py bmy Nada + MSPush px bmx stk + | px == py -> MSPush py (bmx .|. bmy) stk + | otherwise -> let m = branchMask px py + in MSPush py bmy (ascLinkTop stk px (Tip px bmx) m) + where + py = prefixOf ky + bmy = bitmapOf ky +{-# INLINE fromAscList #-} -- Inline for list fusion -- | \(O(n)\). Build a set from an ascending list of distinct elements. -- --- __Warning__: This function should be used only if the elements are in --- strictly increasing order. This precondition is not checked. Use 'fromList' --- if the precondition may not hold. +-- @fromDistinctAscList = 'fromAscList'@ +-- +-- See warning on 'fromAscList'. +-- +-- This definition exists for backwards compatibility. It offers no advantage +-- over @fromAscList@. fromDistinctAscList :: [Key] -> IntSet +-- See note on Data.IntMap.Internal.fromDisinctAscList. fromDistinctAscList = fromAscList -{-# INLINE fromDistinctAscList #-} - --- | \(O(n)\). Build a set from a monotonic list of elements. --- --- The precise conditions under which this function works are subtle: --- For any branch mask, keys with the same prefix w.r.t. the branch --- mask must occur consecutively in the list. -fromMonoList :: [Key] -> IntSet -fromMonoList [] = Nil -fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1 - where - -- `addAll'` collects all keys with the prefix `px` into a single - -- bitmap, and then proceeds with `addAll`. - addAll' !px !bm [] - = Tip px bm - addAll' !px !bm (ky : zs) - | px == prefixOf ky - = addAll' px (bm .|. bitmapOf ky) zs - -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs) - | py <- prefixOf ky - , m <- branchMask px py - , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs - = addAll px (linkWithMask m py ty px (Tip px bm)) zs' - - -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx` - -- `addAll` consumes the rest of the list, adding to the tree `tx` - addAll !_px !tx [] - = tx - addAll !px !tx (ky : zs) - | py <- prefixOf ky - , m <- branchMask px py - , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs - = addAll px (linkWithMask m py ty px tx) zs' - - -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. - addMany' !_m !px !bm [] - = Inserted (Tip px bm) [] - addMany' !m !px !bm zs0@(ky : zs) - | px == prefixOf ky - = addMany' m px (bm .|. bitmapOf ky) zs - -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs) - | mask px m /= mask ky m - = Inserted (Tip (prefixOf px) bm) zs0 - | py <- prefixOf ky - , mxy <- branchMask px py - , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs - = addMany m px (linkWithMask mxy py ty px (Tip px bm)) zs' - - -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`. - addMany !_m !_px tx [] - = Inserted tx [] - addMany !m !px tx zs0@(ky : zs) - | mask px m /= mask ky m - = Inserted tx zs0 - | py <- prefixOf ky - , mxy <- branchMask px py - , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs - = addMany m px (linkWithMask mxy py ty px tx) zs' -{-# INLINE fromMonoList #-} - -data Inserted = Inserted !IntSet ![Key] +{-# INLINE fromDistinctAscList #-} -- Inline for list fusion + +data Stack + = Nada + | Push {-# UNPACK #-} !Int !IntSet !Stack + +data MonoState + = MSNada + | MSPush {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap !Stack + +ascLinkTop :: Stack -> Int -> IntSet -> Int -> Stack +ascLinkTop stk !rk r !rm = case stk of + Nada -> Push rm r stk + Push m l stk' + | i2w m < i2w rm -> let p = Prefix (mask rk m .|. m) + in ascLinkTop stk' rk (Bin p l r) rm + | otherwise -> Push rm r stk + +ascLinkAll :: MonoState -> IntSet +ascLinkAll s = case s of + MSNada -> Nil + MSPush px bmx stk -> ascLinkStack stk px (Tip px bmx) +{-# INLINABLE ascLinkAll #-} + +ascLinkStack :: Stack -> Int -> IntSet -> IntSet +ascLinkStack stk !rk r = case stk of + Nada -> r + Push m l stk' + | signBranch p -> Bin p r l + | otherwise -> ascLinkStack stk' rk (Bin p l r) + where + p = Prefix (mask rk m .|. m) {-------------------------------------------------------------------- Eq