packages feed

structures 0.1 → 0.2

raw patch · 10 files changed

+553/−167 lines, 10 filesdep ~containersdep ~contravariantdep ~free

Dependency ranges changed: containers, contravariant, free, transformers, vector-algorithms

Files

− .ghci 
@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
CHANGELOG.markdown view
@@ -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
benchmarks/inserts.hs view
@@ -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   ]
src/Data/Vector/Bit.hs view
@@ -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
src/Data/Vector/Map.hs view
@@ -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 <ekmett@gmail.com> -- 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 -- <http://supertech.csail.mit.edu/papers/sbtree.pdf "Cache-Oblivious Streaming B-Trees">,--- 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 #-}--}
+ src/Data/Vector/Map/Deamortized.hs view
@@ -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 <ekmett@gmail.com>+-- 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+-- <http://supertech.csail.mit.edu/papers/sbtree.pdf "Cache-Oblivious Streaming B-Trees">,+-- 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 #-}
+ src/Data/Vector/Map/Ephemeral.hs view
@@ -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 <ekmett@gmail.com>+-- 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+-- <http://supertech.csail.mit.edu/papers/sbtree.pdf "Cache-Oblivious Streaming B-Trees">.+--+-- 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
src/Data/Vector/Set.hs view
@@ -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)
src/Data/Vector/Slow.hs view
@@ -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
structures.cabal view
@@ -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