diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,10 @@ +0.2 +--- +* `Data.Vector.Map` now has asymptotics that are fully deamortized. +* `Data.Vector.Map.Ephemeral` provides a cache-oblivious lookahead array that doesn't deamortize. + On the plus side it can be 2-4x faster than `Data.Vector.Map`. + On the downside, using anything but the most recent version can dramaticlly affect the asymptotics of your program. + 0.1 --- * Repository initialized diff --git a/benchmarks/inserts.hs b/benchmarks/inserts.hs --- a/benchmarks/inserts.hs +++ b/benchmarks/inserts.hs @@ -4,7 +4,10 @@ import Data.Foldable as F import Data.Map as M import Data.HashMap.Strict as H -import Data.Vector.Map as V +import Data.Vector.Map.Ephemeral as V +import Data.Vector.Map.Persistent as P +import Data.Vector.Map.Tuned as T +import Data.Vector.Map as O import Control.DeepSeq import Control.Monad.Random import Control.Monad @@ -12,13 +15,28 @@ import Criterion.Main instance NFData (V.Map k v) +instance NFData (O.Map k v) +instance NFData (P.Map k v) +instance NFData (T.Map k v) +buildP :: Int -> P.Map Int Int +buildP n = F.foldl' (flip (join P.insert)) P.empty $ take n $ randoms (mkStdGen 1) + +buildT :: Int -> T.Map Int Int +buildT n = F.foldl' (flip (join T.insert)) T.empty $ take n $ randoms (mkStdGen 1) + buildV :: Int -> V.Map Int Int buildV n = F.foldl' (flip (join V.insert)) V.empty $ take n $ randoms (mkStdGen 1) fromListV :: Int -> V.Map Int Int fromListV n = V.fromList $ Prelude.map (\x -> (x,x)) $ take n $ randoms (mkStdGen 1) +buildO :: Int -> O.Map Int Int +buildO n = F.foldl' (flip (join O.insert)) O.empty $ take n $ randoms (mkStdGen 1) + +fromListO :: Int -> O.Map Int Int +fromListO n = O.fromList $ Prelude.map (\x -> (x,x)) $ take n $ randoms (mkStdGen 1) + buildM :: Int -> M.Map Int Int buildM n = F.foldl' (flip (join M.insert)) M.empty $ take n $ randoms (mkStdGen 1) @@ -27,16 +45,22 @@ main :: IO () main = defaultMainWith defaultConfig { cfgSamples = ljust 10 } (return ()) - [ bench "COLA insert 10k" $ nf buildV 10000 - , bench "COLA fromList 10k" $ nf fromListV 10000 - , bench "Data.Map insert 10k" $ nf buildM 10000 - , bench "Data.HashMap insert 10k" $ nf buildH 10000 - , bench "COLA insert 100k" $ nf buildV 100000 - , bench "COLA fromList 100k" $ nf fromListV 100000 - , bench "Data.Map insert 100k" $ nf buildM 100000 - , bench "Data.HashMap insert 100k" $ nf buildH 100000 - , bench "COLA insert 1m" $ nf buildV 1000000 - , bench "COLA fromList 1m" $ nf fromListV 1000000 - , bench "Data.Map insert 1m" $ nf buildM 1000000 - , bench "Data.HashMap insert 1m" $ nf buildH 1000000 + [ bench "Ephemeral insert 10k" $ nf buildV 10000 + , bench "Persistent insert 10k" $ nf buildP 10000 + , bench "Tuned insert 10k" $ nf buildT 10000 + , bench "Data.Map insert 10k" $ nf buildM 10000 + , bench "Data.HashMap insert 10k" $ nf buildH 10000 + , bench "WC insert 10k" $ nf buildO 10000 + , bench "Ephemeral insert 100k" $ nf buildV 100000 + , bench "Persistent insert 100k" $ nf buildP 100000 + , bench "Tuned insert 100k" $ nf buildT 100000 + , bench "Data.Map insert 100k" $ nf buildM 100000 + , bench "Data.HashMap insert 100k" $ nf buildH 100000 + , bench "Worstcase insert 100k" $ nf buildO 100000 + , bench "Ephemeral insert 1m" $ nf buildV 1000000 + , bench "Persistent insert 1m" $ nf buildP 1000000 + , bench "Tuned insert 1m" $ nf buildT 1000000 + , bench "Data.Map insert 1m" $ nf buildM 1000000 + , bench "Data.HashMap insert 1m" $ nf buildH 1000000 + , bench "Overmars insert 1m" $ nf buildO 1000000 ] diff --git a/src/Data/Vector/Bit.hs b/src/Data/Vector/Bit.hs --- a/src/Data/Vector/Bit.hs +++ b/src/Data/Vector/Bit.hs @@ -21,7 +21,6 @@ , size , singleton , empty - , access -- * Vectors of Bits , UM.MVector(MV_Bit) , U.Vector(V_Bit) @@ -145,9 +144,12 @@ size (BitVector n _ _) = n {-# INLINE size #-} -access :: Int -> BitVector -> Bool -access i (BitVector n as _) = 0 <= i && i < n && getBit (as U.! i) -{-# INLINE access #-} +type instance Index BitVector = Int + +{- +instance (Functor f, Contravariant f) => Contains f BitVector where + contains i f (BitVector n as _) = coerce $ L.indexed f i (0 <= i && i < n && getBit (as U.! i)) +-} -- | Construct a 'BitVector' with a single element. singleton :: Bool -> BitVector diff --git a/src/Data/Vector/Map.hs b/src/Data/Vector/Map.hs --- a/src/Data/Vector/Map.hs +++ b/src/Data/Vector/Map.hs @@ -12,9 +12,12 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2013 Edward Kmett +-- Copyright : (C) 2013-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental @@ -23,7 +26,7 @@ -- This module provides a 'Vector'-based 'Map' that is loosely based on the -- Cache Oblivious Lookahead Array (COLA) by Bender et al. from -- , --- but with inserts deamortized using a technique from Overmars and van Leeuwen. +-- but with inserts converted from ephemerally amortized to persisently amortized using a technique from Overmars and van Leeuwen. -- -- Currently this 'Map' is implemented in an insert-only fashion. Deletions are left to future work -- or to another derived structure in case they prove expensive. @@ -41,7 +44,7 @@ -- of the COLA. ----------------------------------------------------------------------------- module Data.Vector.Map - ( Map(..) + ( Map , empty , null , singleton @@ -50,171 +53,98 @@ , fromList ) where -import Control.Monad.ST.Unsafe as Unsafe -import Control.Monad.ST.Class -import Control.Monad.Trans.Iter import Data.Bits +import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.Vector.Array +import Data.Vector.Fusion.Stream.Monadic (Stream(..)) +import qualified Data.Vector.Fusion.Stream.Monadic as Stream +import Data.Vector.Fusion.Util +import qualified Data.Map as Map +import qualified Data.Vector.Map.Fusion as Fusion import qualified Data.Vector.Generic as G -import qualified Data.Vector.Generic.Mutable as GM -import Data.Vector.Slow as Slow import Prelude hiding (null, lookup) -import System.IO.Unsafe as Unsafe -#define BOUNDS_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Bounds) - -- | This Map is implemented as an insert-only Cache Oblivious Lookahead Array (COLA) with amortized complexity bounds -- that are equal to those of a B-Tree, except for an extra log factor slowdown on lookups due to the lack of fractional --- cascading. +-- cascading. It uses a traditional Data.Map as a nursery. -data Chunk k a = Chunk !(Array k) !(Array a) +data Map k a = Map !(Map.Map k a) !(LA k a) -data Map k a +_THRESHOLD :: Int +_THRESHOLD = 10 + +data LA k a = M0 - | M1 !(Array k) !(Array a) - | M2 !(Array k) !(Array a) - !(Array k) !(Array a) !(Partial (Chunk k a)) !(Map k a) - | M3 !(Array k) !(Array a) - !(Array k) !(Array a) - !(Array k) !(Array a) !(Partial (Chunk k a)) !(Map k a) + | M1 !(Chunk k a) + | M2 !(Chunk k a) !(Chunk k a) (Chunk k a) !(LA k a) -- merged chunk is deliberately lazy + | M3 !(Chunk k a) !(Chunk k a) !(Chunk k a) (Chunk k a) !(LA k a) -deriving instance (Show (Arr v v), Show (Arr k k)) => Show (Map k v) -deriving instance (Show (Arr v v), Show (Arr k k)) => Show (Chunk k v) +data Chunk k a = Chunk !(Array k) !(Array a) --- | /O(1)/. Identify if a 'Map' is the 'empty' 'Map'. +deriving instance (Show (Arr k k), Show (Arr a a)) => Show (Chunk k a) +deriving instance (Show (Arr k k), Show (Arr a a)) => Show (LA k a) + +#if __GLASGOW_HASKELL__ >= 708 +type role LA nominal nominal +#endif + +-- | /O(1)/. Identify if a 'LA' is the 'empty' 'LA'. null :: Map k v -> Bool -null M0 = True -null _ = False +null (Map m M0) = Map.null m +null _ = False {-# INLINE null #-} --- | /O(1)/ The 'empty' 'Map'. +-- | /O(1)/ The 'empty' 'LA'. empty :: Map k v -empty = M0 +empty = Map Map.empty M0 {-# INLINE empty #-} --- | /O(1)/ Construct a 'Map' from a single key/value pair. +-- | /O(1)/ Construct a 'LA' from a single key/value pair. singleton :: (Arrayed k, Arrayed v) => k -> v -> Map k v -singleton k v = M1 (G.singleton k) (G.singleton v) +singleton k v = Map (Map.singleton k v) M0 {-# INLINE singleton #-} -- | /O(log^2 N)/ worst-case. Lookup an element. lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v -lookup !k m0 = go m0 where - {-# INLINE go #-} - go M0 = Nothing - go (M1 ka va) = lookup1 k ka va Nothing - go (M2 ka va kb vb _ m) = lookup1 k ka va $ lookup1 k kb vb $ go m - go (M3 ka va kb vb kc vc _ m) = lookup1 k ka va $ lookup1 k kb vb $ lookup1 k kc vc $ go m +lookup !k (Map m0 la) = case Map.lookup k m0 of + Nothing -> go la + mv -> mv + where + go M0 = Nothing + go (M1 as) = lookup1 k as Nothing + go (M2 as bs _ m) = lookup1 k as $ lookup1 k bs $ go m + go (M3 as bs cs _ m) = lookup1 k as $ lookup1 k bs $ lookup1 k cs $ go m {-# INLINE lookup #-} -lookup1 :: (Ord k, Arrayed k, Arrayed v) => k -> Array k -> Array v -> Maybe v -> Maybe v -lookup1 k ks vs r +lookup1 :: (Ord k, Arrayed k, Arrayed v) => k -> Chunk k v -> Maybe v -> Maybe v +lookup1 k (Chunk ks vs) r | j <- search (\i -> ks G.! i >= k) 0 (G.length ks - 1) , ks G.! j == k = Just $ vs G.! j | otherwise = r {-# INLINE lookup1 #-} --- | O((log N)\/B) worst-case loads for each cache. Insert an element. -insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v -insert k0 v0 s0 = go (G.singleton k0) (G.singleton v0) s0 where - go ka a M0 = M1 ka a - go ka a (M1 kb b) = M2 ka a kb b (merge ka a kb b) M0 - go ka a (M2 kb b kc c mbc xs) = M3 ka a kb b kc c (step mbc) (steps xs) - go ka a (M3 kb b _ _ _ _ mcd xs) = case mcd of - Stop (Chunk kcd cd) -> M2 ka a kb b (merge ka a kb b) (go kcd cd xs) - _ -> error "insert: stop Step" - - steps (M2 kx x ky y mxy xs) = M2 kx x ky y (step mxy) (steps xs) - steps (M3 kx x ky y kz z myz xs) = M3 kx x ky y kz z (step myz) (steps xs) - steps m = m -{-# INLINE insert #-} - -step :: Partial a -> Partial a -step (Stop _) = error "insert: step Stop" -step (Step m) = m -{-# INLINE step #-} - -merge :: forall k a. (Ord k, Arrayed k, Arrayed a) => Array k -> Array a -> Array k -> Array a -> Partial (Chunk k a) -merge ka va kb vb = step (walkDupableST mergeST) where - mergeST :: forall s. IterST s (Chunk k a) - mergeST = do - let - !la = G.length ka - !lb = G.length kb - kc <- liftST $ GM.unsafeNew (la + lb) - vc <- liftST $ GM.unsafeNew (la + lb) - let - goL :: Int -> Int -> IterST s () - goL !i !j -- left exhausted - | j >= lb = return () - | !k <- i + j = do - liftST $ do - kj <- G.unsafeIndexM kb j - GM.unsafeWrite kc k kj - vj <- G.unsafeIndexM vb j - GM.unsafeWrite vc k vj - delay $ goL i (j+1) - - goR :: Int -> Int -> IterST s () - goR !i !j -- right exhausted - | i >= la = return () - | !k <- i + j = do - liftST $ do - ki <- G.unsafeIndexM ka i - GM.unsafeWrite kc k ki - vi <- G.unsafeIndexM va i - GM.unsafeWrite vc k vi - delay $ goR (i+1) j +zips :: (Arrayed k, Arrayed v) => Chunk k v -> Stream Id (k, v) +zips (Chunk ks vs) = Stream.zip (G.stream ks) (G.stream vs) +{-# INLINE zips #-} - go :: Int -> Int -> IterST s () - go !i !j - | i >= la = goL i j - | j >= lb = goR i j - | !k <- i + j = do - ki <- liftST $ G.unsafeIndexM ka i - kj <- liftST $ G.unsafeIndexM kb j - case compare ki kj of - LT -> do - liftST $ do - vi <- G.unsafeIndexM va i - GM.unsafeWrite kc k ki - GM.unsafeWrite vc k vi - delay $ go (i+1) j - EQ -> do - liftST $ do - vi <- G.unsafeIndexM va i - GM.unsafeWrite kc k ki - GM.unsafeWrite vc k vi - delay $ go (i+1) (i+j) - GT -> do - liftST $ do - vj <- G.unsafeIndexM vb j - GM.unsafeWrite kc k kj - GM.unsafeWrite vc k vj - delay $ go i (j+1) - go 0 0 - liftST $ do - fkc <- G.unsafeFreeze kc - fvc <- G.unsafeFreeze vc - return $ Chunk fkc fvc +merge :: (Ord k, Arrayed k, Arrayed v) => Chunk k v -> Chunk k v -> Chunk k v +merge as bs = case G.unstream $ zips as `Fusion.merge` zips bs of + V_Pair _ ks vs -> Chunk ks vs {-# INLINE merge #-} -walkDupableST :: (forall s. IterST s a) -> Partial a -walkDupableST m0 = go m0 where - go (IterT m) = - case Unsafe.unsafeDupablePerformIO $ - Unsafe.unsafeSTToIO m of - Left a -> Stop a - Right n -> Step (go n) - -{- -merge :: (Ord k, Arrayed k, Arrayed a) => Array k -> Array a -> Array k -> Array a -> Partial (Chunk k a) -merge km m kn n = step $ walkDupableST $ do - V_Pair _ ks vs <- Slow.unstreamM $ Slow.streamST $ Fusion.merge (zips km m) (zips kn n) - return $ Chunk ks vs -{-# INLINE merge #-} --} +-- | O((log N)\/B) amortized loads for each cache. Insert an element. +insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v +insert k0 v0 (Map m0 xs0) + | n0 <= _THRESHOLD = Map (Map.insert k0 v0 m0) xs0 + | otherwise = Map Map.empty $ inserts (Chunk (G.fromListN n0 (Map.keys m0)) (G.fromListN n0 (Foldable.toList m0))) xs0 + where + n0 = Map.size m0 + inserts as M0 = M1 as + inserts as (M1 bs) = M2 as bs (merge as bs) M0 + inserts as (M2 bs cs bcs xs) = M3 as bs cs bcs xs + inserts as (M3 bs _ _ cds xs) = cds `seq` M2 as bs (merge as bs) (inserts cds xs) +{-# INLINE insert #-} fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs @@ -232,9 +162,3 @@ where hml = h - l m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6 {-# INLINE search #-} - -{- -zips :: (G.Vector v a, G.Vector u b) => v a -> u b -> Stream Id (a, b) -zips va ub = Stream.zip (G.stream va) (G.stream ub) -{-# INLINE zips #-} --} diff --git a/src/Data/Vector/Map/Deamortized.hs b/src/Data/Vector/Map/Deamortized.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Map/Deamortized.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2013-2014 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- This module provides a 'Vector'-based 'Map' that is loosely based on the +-- Cache Oblivious Lookahead Array (COLA) by Bender et al. from +-- , +-- but with inserts deamortized by using a varant of a technique from Overmars and van Leeuwen. +-- +-- Currently this 'Map' is implemented in an insert-only fashion. Deletions are left to future work +-- or to another derived structure in case they prove expensive. +-- +-- Currently, we also do not use fractional cascading, as it affects the constant factors badly enough +-- to not pay for itself at the scales we are interested in. The naive /O(log^2 n)/ lookup +-- consistently outperforms the alternative. +-- +-- Compared to the venerable @Data.Map@, this data structure currently consumes more memory, but it +-- provides a more limited palette of operations with different asymptotics (~10x faster inserts at a million entries) +-- and enables us to utilize contiguous storage. +-- +-- /NB:/ when used with boxed data this structure may hold onto references to old versions +-- of things for many updates to come until sufficient operations have happened to merge them out +-- of the COLA. +----------------------------------------------------------------------------- +module Data.Vector.Map.Deamortized + ( Map + , empty + , null + , singleton + , lookup + , insert + , fromList + ) where + +import Control.Applicative hiding (empty) +import Data.Bits +import Data.Foldable as Foldable +import qualified Data.List as List +import Data.Vector.Array +import qualified Data.Map.Strict as Map +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as GM +import GHC.Prim (RealWorld) +import Prelude hiding (null, lookup) +import System.IO.Unsafe as Unsafe + +-- | How many items is it worth batching up in the Nursery? +_THRESHOLD :: Int +_THRESHOLD = 1000 + +-- | This Map is implemented as an insert-only Cache Oblivious Lookahead Array (COLA) with amortized complexity bounds +-- that are equal to those of a B-Tree, except for an extra log factor slowdown on lookups due to the lack of fractional +-- cascading. It uses a traditional Data.Map as a nursery. + +data Map k a = Map !(Map.Map k a) !(LA k a) + +-- | Cache-Oblivious Lookahead Array internals +data LA k a + = M0 + | M1 !(Array k) !(Array a) + | M2 !(Array k) !(Array a) + !(Array k) !(Array a) + {-# UNPACK #-} !Int {-# UNPACK #-} !Int + !(MArray RealWorld k) !(MArray RealWorld a) + !(LA k a) + | M3 !(Array k) !(Array a) + !(Array k) !(Array a) + !(Array k) !(Array a) + {-# UNPACK #-} !Int {-# UNPACK #-} !Int + !(MArray RealWorld k) !(MArray RealWorld a) + !(LA k a) + +#if __GLASGOW_HASKELL__ >= 708 +type role Map nominal nominal +#endif + +instance (Show (Arr v v), Show (Arr k k)) => Show (LA k v) where + showsPrec _ M0 = showString "M0" + showsPrec d (M1 ka a) = showParen (d > 10) $ + showString "M1 " . showsPrec 11 ka . showChar ' ' . showsPrec 11 a + showsPrec d (M2 ka a kb b ra rb _ _ xs) = showParen (d > 10) $ + showString "M2 " . + showsPrec 11 ka . showChar ' ' . showsPrec 11 a . showChar ' ' . + showsPrec 11 kb . showChar ' ' . showsPrec 11 b . showChar ' ' . + showsPrec 11 ra . showChar ' ' . showsPrec 11 rb . showString " _ _ " . + showsPrec 11 xs + showsPrec d (M3 ka a kb b kc c rb rc _ _ xs) = showParen (d > 10) $ + showString "M3 " . + showsPrec 11 ka . showChar ' ' . showsPrec 11 a . showChar ' ' . + showsPrec 11 kb . showChar ' ' . showsPrec 11 b . showChar ' ' . + showsPrec 11 kc . showChar ' ' . showsPrec 11 c . showChar ' ' . + showsPrec 11 rb . showChar ' ' . showsPrec 11 rc . showString " _ _ " . + showsPrec 11 xs + +instance (Show (Arr v v), Show (Arr k k), Show k, Show v) => Show (Map k v) where + showsPrec d (Map n l) = showParen (d > 10) $ + showString "Map " . showsPrec 11 n . showChar ' ' . showsPrec 11 l + +-- | /O(1)/. Identify if a 'Map' is the 'empty' 'Map'. +null :: Map k v -> Bool +null (Map n M0) = Map.null n +null _ = False +{-# INLINE null #-} + +-- | /O(1)/ The 'empty' 'Map'. +empty :: Map k v +empty = Map Map.empty M0 +{-# INLINE empty #-} + +-- | /O(1)/ Construct a 'Map' from a single key/value pair. +singleton :: (Arrayed k, Arrayed v) => k -> v -> Map k v +singleton k v = Map (Map.singleton k v) M0 +{-# INLINE singleton #-} + +-- | /O(log^2 N)/ worst-case. Lookup an element. +lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v +lookup !k (Map m0 la) = case Map.lookup k m0 of + Nothing -> go la + mv -> mv + where + {-# INLINE go #-} + go M0 = Nothing + go (M1 ka va) = lookup1 k ka va Nothing + go (M2 ka va kb vb _ _ _ _ m) = lookup1 k ka va $ lookup1 k kb vb $ go m + go (M3 ka va kb vb kc vc _ _ _ _ m) = lookup1 k ka va $ lookup1 k kb vb $ lookup1 k kc vc $ go m +{-# INLINE lookup #-} + +lookup1 :: (Ord k, Arrayed k, Arrayed v) => k -> Array k -> Array v -> Maybe v -> Maybe v +lookup1 k ks vs r + | j <- search (\i -> ks G.! i >= k) 0 (G.length ks - 1) + , ks G.! j == k = Just $ vs G.! j + | otherwise = r +{-# INLINE lookup1 #-} + +-- | O((log N)\/B) worst-case loads for each cache. Insert an element. +insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v +insert k0 v0 (Map m0 xs0) + | n0 <= _THRESHOLD = Map (Map.insert k0 v0 m0) xs0 + | otherwise = Map Map.empty $ unsafeDupablePerformIO $ inserts (G.fromListN n0 (Map.keys m0)) (G.fromListN n0 (Foldable.toList m0)) xs0 + where + n0 = Map.size m0 + inserts ka a M0 = return $ M1 ka a + inserts ka a (M1 kb b) = do + let n = G.length ka + G.length kb + kab <- GM.basicUnsafeNew n + ab <- GM.basicUnsafeNew n + (ra,rb) <- steps ka a kb b 0 0 kab ab + return $ M2 ka a kb b ra rb kab ab M0 + inserts ka a (M2 kb b kc c rb rc kbc bc xs) = do + (rb',rc') <- steps kb b kc c rb rc kbc bc + M3 ka a kb b kc c rb' rc' kbc bc <$> stepTail xs + inserts ka a (M3 kb b _ _ _ _ _ _ kcd cd xs) = do + let n = G.length ka + G.length kb + kab <- GM.basicUnsafeNew n + ab <- GM.basicUnsafeNew n + (ra,rb) <- steps ka a kb b 0 0 kab ab + kcd' <- G.unsafeFreeze kcd + cd' <- G.unsafeFreeze cd + M2 ka a kb b ra rb kab ab <$> inserts kcd' cd' xs + + stepTail (M2 kx x ky y rx ry kxy xy xs) = do + (rx',ry') <- steps kx x ky y rx ry kxy xy + M2 kx x ky y rx' ry' kxy xy <$> stepTail xs + stepTail (M3 kx x ky y kz z ry rz kyz yz xs) = do + (ry',rz') <- steps ky y kz z ry rz kyz yz + M3 kx x ky y kz z ry' rz' kyz yz <$> stepTail xs + stepTail m = return m +{-# INLINE insert #-} + +steps :: (Ord k, Arrayed k, Arrayed v) => Array k -> Array v -> Array k -> Array v -> Int -> Int -> MArray RealWorld k -> MArray RealWorld v -> IO (Int, Int) +steps ka a kb b ra0 rb0 kab ab = go ra0 rb0 where + n = min (ra0 + rb0 + _THRESHOLD) (GM.length kab) + na = G.length ka + nb = G.length kb + go !ra !rb + | r >= n = return (ra, rb) + | ra == na = do + k <- G.basicUnsafeIndexM kb rb + v <- G.basicUnsafeIndexM b rb + GM.basicUnsafeWrite kab r k + GM.basicUnsafeWrite ab r v + go ra (rb + 1) + | rb == nb = do + k <- G.basicUnsafeIndexM ka ra + v <- G.basicUnsafeIndexM a ra + GM.basicUnsafeWrite kab r k + GM.basicUnsafeWrite ab r v + go (ra + 1) rb + | otherwise = do + k1 <- G.basicUnsafeIndexM ka ra + k2 <- G.basicUnsafeIndexM kb rb + case compare k1 k2 of + LT -> do + v <- G.basicUnsafeIndexM a ra + GM.basicUnsafeWrite kab r k1 + GM.basicUnsafeWrite ab r v + go (ra + 1) rb + EQ -> do -- collision, overwrite with newer value + v <- G.basicUnsafeIndexM a ra + GM.basicUnsafeWrite kab r k1 + GM.basicUnsafeWrite ab r v + go (ra + 1) (rb + 1) + GT -> do + v <- G.basicUnsafeIndexM b rb + GM.basicUnsafeWrite kab r k2 + GM.basicUnsafeWrite ab r v + go ra (rb + 1) + where r = ra + rb + +fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v +fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs +{-# INLINE fromList #-} + +-- | Offset binary search +-- +-- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@ +search :: (Int -> Bool) -> Int -> Int -> Int +search p = go where + go l h + | l == h = l + | p m = go l m + | otherwise = go (m+1) h + where hml = h - l + m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6 +{-# INLINE search #-} diff --git a/src/Data/Vector/Map/Ephemeral.hs b/src/Data/Vector/Map/Ephemeral.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Map/Ephemeral.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2013-2014 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- This module provides a 'Vector'-based 'Map' that is loosely based on the +-- Cache Oblivious Lookahead Array (COLA) by Bender et al. from +-- . +-- +-- Currently this 'Map' is implemented in an insert-only fashion. Deletions are left to future work +-- or to another derived structure in case they prove expensive. +-- +-- Unlike the COLA, this version merely provides amortized complexity bounds as this permits us to +-- provide a fully functional API. However, even those asymptotics are only guaranteed if you do not +-- modify the \"old\" versions of the 'Map'. If you do, then while correctness is preserved, the +-- asymptotic analysis becomes inaccurate. +-- +-- Reading from \"old\" versions of the 'Map' does not affect the asymptotic analysis and is fine. +-- +-- Fractional cascading was originally replaced with the use of a hierarchical bloom filter per level containing +-- the elements for that level, with the false positive rate tuned to balance the lookup cost against +-- the costs of the cache misses for a false positive at that depth. This avoids the need to collect +-- forwarding pointers from the next level, reducing pressure on the cache dramatically, while providing +-- the same asymptotic complexity. +-- +-- With either of these two techniques when used ephemerally, this 'Map' had asymptotic performance equal to that +-- of a B-Tree tuned to the parameters of your caches with requiring such parameter tuning. +-- +-- However, the constants were still bad enough that the naive /O(log^2 n)/ version of the COLA actually wins +-- at lookups in benchmarks at the scale this data structure is interesting, say around a few million entries, +-- by a factor of 10x! Consequently, we're currently not even Bloom filtering. +-- +-- Compared to the venerable @Data.Map@, this data structure currently consumes more memory, but it +-- provides a more limited palette of operations with different asymptotics (~10x faster inserts at a million entries) +-- and enables us to utilize contiguous storage. +-- +-- /NB:/ when used with boxed data this structure may hold onto references to old versions +-- of things for many updates to come until sufficient operations have happened to merge them out +-- of the COLA. +-- +-- TODO: track actual percentage of occupancy for each vector compared to the source vector it was based on. +-- This would permit 'split' and other operations that trim a 'Map' to properly reason about space usage by +-- borrowing the 1/3rd occupancy rule from a Stratified Doubling Array. +----------------------------------------------------------------------------- +module Data.Vector.Map.Ephemeral + ( Map(..) + , empty + , null + , singleton + , lookup + , insert + , fromList + , shape + ) where + +import Data.Bits +import qualified Data.List as List +import Data.Vector.Array +import Data.Vector.Fusion.Stream.Monadic (Stream(..)) +import qualified Data.Vector.Fusion.Stream.Monadic as Stream +import Data.Vector.Fusion.Util +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Map.Fusion as Fusion +import Prelude hiding (null, lookup) + +#define BOUNDS_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Bounds) + +-- | This Map is implemented as an insert-only Cache Oblivious Lookahead Array (COLA) with amortized complexity bounds +-- that are equal to those of a B-Tree when it is used ephemerally, using Bloom filters to replace the fractional +-- cascade. +data Map k v + = Nil + | One !k v !(Map k v) + | Map !Int !(Array k) !(Array v) !(Map k v) + +deriving instance (Show (Arr v v), Show (Arr k k), Show k, Show v) => Show (Map k v) +deriving instance (Read (Arr v v), Read (Arr k k), Read k, Read v) => Read (Map k v) + +-- | /O(1)/. Identify if a 'Map' is the 'empty' 'Map'. +null :: Map k v -> Bool +null Nil = True +null _ = False +{-# INLINE null #-} + +-- | /O(1)/ The 'empty' 'Map'. +empty :: Map k v +empty = Nil +{-# INLINE empty #-} + +-- | /O(1)/ Construct a 'Map' from a single key/value pair. +singleton :: Arrayed v => k -> v -> Map k v +singleton k v = v `vseq` One k v Nil +{-# INLINE singleton #-} + +-- | /O(log^2 N)/ persistently amortized, /O(N)/ worst case. Lookup an element. +lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v +lookup !k m0 = go m0 where + {-# INLINE go #-} + go Nil = Nothing + go (One i a m) + | k == i = Just a + | otherwise = go m + go (Map n ks vs m) + | j <- search (\i -> ks G.! i >= k) 0 (n-1) + , ks G.! j == k = Just $ vs G.! j + | otherwise = go m +{-# INLINE lookup #-} + +threshold :: Int -> Int -> Bool +threshold n1 n2 = n1 > unsafeShiftR n2 1 +{-# INLINE threshold #-} + +-- force a value as much as it would be forced by inserting it into an Array +vseq :: forall a b. Arrayed a => a -> b -> b +vseq a b = G.elemseq (undefined :: Array a) a b +{-# INLINE vseq #-} + +-- | O((log N)\/B) ephemerally amortized loads for each cache, O(N\/B) worst case. Insert an element. +insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v +insert !k v (Map n1 ks1 vs1 (Map n2 ks2 vs2 m)) + | threshold n1 n2 = insert2 k v ks1 vs1 ks2 vs2 m +insert !ka va (One kb vb (One kc vc m)) = case G.unstream $ Fusion.insert ka va rest of + V_Pair n ks vs -> Map n ks vs m + where + rest = case compare kb kc of + LT -> Stream.fromListN 2 [(kb,vb),(kc,vc)] + EQ -> Stream.fromListN 1 [(kb,vb)] + GT -> Stream.fromListN 2 [(kc,vc),(kb,vb)] +insert k v m = v `vseq` One k v m +{-# INLINABLE insert #-} + +insert2 :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Array k -> Array v -> Array k -> Array v -> Map k v -> Map k v +insert2 k v ks1 vs1 ks2 vs2 m = case G.unstream $ Fusion.insert k v (zips ks1 vs1) `Fusion.merge` zips ks2 vs2 of + V_Pair n ks3 vs3 -> Map n ks3 vs3 m +{-# INLINE insert2 #-} + +fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v +fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs +{-# INLINE fromList #-} + +-- | Offset binary search +-- +-- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@ +search :: (Int -> Bool) -> Int -> Int -> Int +search p = go where + go l h + | l == h = l + | p m = go l m + | otherwise = go (m+1) h + where hml = h - l + m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6 +{-# INLINE search #-} + +zips :: (G.Vector v a, G.Vector u b) => v a -> u b -> Stream Id (a, b) +zips va ub = Stream.zip (G.stream va) (G.stream ub) +{-# INLINE zips #-} + +-- * Debugging + +shape :: Map k v -> [Int] +shape Nil = [] +shape (One _ _ m) = 1 : shape m +shape (Map n _ _ m) = n : shape m diff --git a/src/Data/Vector/Set.hs b/src/Data/Vector/Set.hs --- a/src/Data/Vector/Set.hs +++ b/src/Data/Vector/Set.hs @@ -14,8 +14,8 @@ data Set a = S0 - | S1 !(Array a) - | S2 !(Array a) !(Array a) !(Partial (Array a)) !(Set a) + | S1 !(Array a) + | S2 !(Array a) !(Array a) !(Partial (Array a)) !(Set a) | S3 !(Array a) !(Array a) !(Array a) !(Partial (Array a)) !(Set a) deriving instance Show (Array a) => Show (Set a) diff --git a/src/Data/Vector/Slow.hs b/src/Data/Vector/Slow.hs --- a/src/Data/Vector/Slow.hs +++ b/src/Data/Vector/Slow.hs @@ -20,7 +20,7 @@ import Control.Monad.ST import Control.Monad.ST.Class import Control.Monad.ST.Unsafe as Unsafe -import Control.Monad.Trans.Iter +import Control.Monad.Trans.Iter hiding (foldM) import qualified Data.Vector.Fusion.Stream.Monadic as M import qualified Data.Vector.Fusion.Stream.Size as SS import Data.Vector.Internal.Check as Ck diff --git a/structures.cabal b/structures.cabal --- a/structures.cabal +++ b/structures.cabal @@ -1,6 +1,6 @@ name: structures category: Data, Structures -version: 0.1 +version: 0.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -14,7 +14,6 @@ synopsis: "Advanced" Data Structures extra-source-files: - .ghci .travis.yml .gitignore .vim.custom @@ -65,9 +64,10 @@ library build-depends: base >= 4 && < 5, - contravariant >= 0.4.2 && < 1, + containers >= 0.5 && < 0.6, + contravariant >= 0.4.2 && < 2, deepseq >= 1.1 && < 1.4, - free >= 4.3 && < 5, + free >= 4.6.1 && < 5, ghc, ghc-prim, hashable >= 1.2.1 && < 1.3, @@ -77,9 +77,9 @@ parallel >= 3.2 && < 3.3, primitive >= 0.5 && < 0.6, semigroups >= 0.9 && < 1, - transformers >= 0.3 && < 0.4, + transformers >= 0.3 && < 0.5, vector >= 0.10 && < 0.11, - vector-algorithms >= 0.5 && < 0.6 + vector-algorithms >= 0.5 && < 0.7 hs-source-dirs: src @@ -91,6 +91,8 @@ Data.Vector.Bloom.Util Data.Vector.Heap Data.Vector.Map + Data.Vector.Map.Deamortized + Data.Vector.Map.Ephemeral Data.Vector.Map.Fusion Data.Vector.Set Data.Vector.Set.Fusion @@ -211,6 +213,7 @@ main-is: maps.hs ghc-options: -Wall hs-source-dirs: benchmarks + buildable: False if flag(optimized) ghc-options: -O2 @@ -236,6 +239,7 @@ main-is: lookups.hs ghc-options: -Wall hs-source-dirs: benchmarks + buildable: False if flag(optimized) ghc-options: -O2