diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrew Martin (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Martin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/impure-containers.cabal b/impure-containers.cabal new file mode 100644 --- /dev/null +++ b/impure-containers.cabal @@ -0,0 +1,65 @@ +name: impure-containers +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/andrewthad/impure-containers#readme +license: BSD3 +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2016 Andrew Martin +category: web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Lib + Data.HashMap.Mutable.Basic + -- Data.Heap.Mutable.ModelA + -- Data.Heap.Mutable.ModelB + Data.Heap.Mutable.ModelC + Data.Heap.Mutable.ModelD + -- Data.Vector.Unique + Data.Graph.Immutable + Data.Graph.Immutable.Tagged + other-modules: + Data.HashMap.Mutable.Internal.Array + Data.HashMap.Mutable.Internal.CacheLine + Data.HashMap.Mutable.Internal.CheapPseudoRandomBitStream + Data.HashMap.Mutable.Internal.IntArray + Data.HashMap.Mutable.Internal.Linear.Bucket + Data.HashMap.Mutable.Internal.UnsafeTricks + Data.HashMap.Mutable.Internal.Utils + build-depends: + base >= 4.7 && < 5 + , hashable + , primitive + , vector + , liquidhaskell + , vector-th-unbox + , containers + , ghc-prim + default-language: Haskell2010 + +test-suite impure-containers-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base + , impure-containers + , containers + , test-framework + , test-framework-quickcheck2 + , QuickCheck + , HUnit + , test-framework-hunit + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/andrewthad/impure-containers diff --git a/src/Data/Graph/Immutable.hs b/src/Data/Graph/Immutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Immutable.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Data.Graph.Immutable where + +import Data.Graph.Immutable.Tagged + +data SomeGraph e v = forall g. SomeGraph { getSomeGraph :: Graph g e v } + + diff --git a/src/Data/Graph/Immutable/Tagged.hs b/src/Data/Graph/Immutable/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Immutable/Tagged.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} + +module Data.Graph.Immutable.Tagged where + +import Control.Monad.Primitive +import Data.Vector (Vector) +import Data.Vector.Mutable (MVector) +import Control.Monad +import Data.Word +import Control.Monad.ST (runST) +import qualified Data.Heap.Mutable.ModelD as Heap +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU + +newtype Vertex g = Vertex { getVertex :: Int } +newtype Vertices g v = Vertices { getVertices :: Vector v } + deriving (Functor) + +data Edge g = Edge + { edgeVertexA :: !Int + , edgeVertexB :: !Int + } + +-- | The neighbor vertices and neighbor edges must have +-- equal length. +data Graph g e v = Graph + { graphVertices :: !(Vector v) + , graphOutboundNeighborVertices :: !(Vector (U.Vector Int)) + , graphOutboundNeighborEdges :: !(Vector (Vector e)) + -- , graphEdges :: Int -> Int -> Maybe e + } deriving (Functor) + +-- instance Functor (Graph g e) where +-- fmap f g = g { graphVertices = Vector.map (graphVertices g) } + +-- visited,allowed,notAllowed :: Word8 +-- visited = 2 +-- allowed = 1 +-- notAllowed = 0 + +-- | This is a generalization of Dijkstra\'s algorithm. +breadthFirstBy :: (Ord s, Monoid s) + => (v -> v -> s -> e -> s) + -> Vertex g + -> Graph g e v + -> Vertices g s +breadthFirstBy f v0 g@(Graph vertices outNeighbors outEdges) = runST $ do + let vertexCount = V.length vertices + newVertices <- MV.new vertexCount + MV.set newVertices mempty + visited <- MU.new vertexCount + MU.set visited False + heap <- Heap.new vertexCount + Heap.unsafePush mempty (getVertex v0) heap + let keepGoing = do + m <- Heap.pop heap + case m of + Nothing -> return () + Just (s,vertexIx) -> do + MU.write visited vertexIx True + MV.write newVertices vertexIx s + let neighborVertices = outNeighbors V.! vertexIx + neighborEdges = outEdges V.! vertexIx + v1 = vertices V.! vertexIx + runInsert neighborIx neighborVertexIx = do + let edgeVal = neighborEdges V.! neighborIx + v2 = vertices V.! neighborVertexIx + alreadyVisited <- MU.read visited neighborVertexIx + if alreadyVisited + then return () + else Heap.push (f v1 v2 s edgeVal) neighborVertexIx heap + U.imapM_ runInsert neighborVertices + keepGoing + keepGoing + newVerticesFrozen <- V.freeze newVertices + return (Vertices newVerticesFrozen) + -- return (g {graphVertices = newVerticesFrozen}) + +lookupVertex :: Eq v => v -> Graph g e v -> Maybe (Vertex g) +lookupVertex val g = fmap Vertex (V.elemIndex val (graphVertices g)) + +traverseNeighbors_ :: Applicative m + => (e -> Vertex g -> v -> m a) + -> Vertex g + -> Graph g e v + -> m () +traverseNeighbors_ f (Vertex x) g = + let allVertices = graphVertices g + vertices = graphOutboundNeighborVertices g V.! x + edges = graphOutboundNeighborEdges g V.! x + numNeighbors = U.length vertices + go !i = if i < numNeighbors + then let vertexNum = vertices U.! i + vertexVal = allVertices V.! vertexNum + edgeVal = edges V.! i + in f edgeVal (Vertex vertexNum) vertexVal *> go (i + 1) + else pure () + in go 0 + +-- lookupEdge :: Vertex g -> Vertex g -> Graph g e v -> Maybe (Edge g) +-- lookupEdge (Vertex x) (Vertex y) g = + +mutableIForM_ :: PrimMonad m => MVector (PrimState m) a -> (Int -> a -> m b) -> m () +mutableIForM_ m f = forM_ (take (MV.length m) (enumFrom 0)) $ \i -> do + a <- MV.read m i + f i a + +mutableIFoldM' :: PrimMonad m => (a -> Int -> b -> m a) -> a -> MVector (PrimState m) b -> m a +mutableIFoldM' f x m = go 0 x where + len = MV.length m + go !i !a = if i < len + then do + b <- MV.read m i + aNext <- f a i b + go (i + 1) aNext + else return x + diff --git a/src/Data/HashMap/Mutable/Basic.hs b/src/Data/HashMap/Mutable/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Basic.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module Data.HashMap.Mutable.Basic + ( HashTable + , new + , newSized + , delete + , lookup + , insert + , mapM_ + , foldM + , computeOverhead + ) where + + +------------------------------------------------------------------------------ +import Control.Exception (assert) +import Control.Monad hiding (foldM, mapM_) +import Control.Monad.ST (ST) +import Control.Monad.Primitive (PrimMonad,PrimState,unsafePrimToPrim) +import Data.Bits +import Data.Hashable (Hashable) +import qualified Data.Hashable as H +import Data.Maybe +import Data.Monoid +import qualified Data.Primitive.ByteArray as A +import Data.Primitive.MutVar (MutVar,readMutVar,writeMutVar,newMutVar) +import Data.STRef +import GHC.Exts +import Prelude hiding (lookup, mapM_, read) +------------------------------------------------------------------------------ +import Data.HashMap.Mutable.Internal.Array +import Data.HashMap.Mutable.Internal.CacheLine +import Data.HashMap.Mutable.Internal.IntArray (Elem) +import qualified Data.HashMap.Mutable.Internal.IntArray as U +import Data.HashMap.Mutable.Internal.Utils + + +------------------------------------------------------------------------------ +-- | An open addressing hash table using linear probing. +newtype HashTable s k v = HT (MutVar s (HashTable_ s k v)) + +type SizeRefs s = A.MutableByteArray s + +intSz :: Int +intSz = (finiteBitSize (0::Int) `div` 8) + +readLoad :: PrimMonad m => SizeRefs (PrimState m) -> m Int +readLoad = flip A.readByteArray 0 + +writeLoad :: PrimMonad m => SizeRefs (PrimState m) -> Int -> m () +writeLoad = flip A.writeByteArray 0 + +readDelLoad :: PrimMonad m => SizeRefs (PrimState m) -> m Int +readDelLoad = flip A.readByteArray 1 + +writeDelLoad :: PrimMonad m => SizeRefs (PrimState m) -> Int -> m () +writeDelLoad = flip A.writeByteArray 1 + +newSizeRefs :: PrimMonad m => m (SizeRefs (PrimState m)) +newSizeRefs = do + let asz = 2 * intSz + a <- A.newAlignedPinnedByteArray asz intSz + A.fillByteArray a 0 asz 0 + return a + + +data HashTable_ s k v = HashTable + { _size :: {-# UNPACK #-} !Int + , _load :: !(SizeRefs s) -- ^ 2-element array, stores how many entries + -- and deleted entries are in the table. + , _hashes :: !(U.IntArray s) + , _keys :: {-# UNPACK #-} !(MutableArray s k) + , _values :: {-# UNPACK #-} !(MutableArray s v) + } + + +------------------------------------------------------------------------------ +instance Show (HashTable s k v) where + show _ = "" + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:new". +new :: PrimMonad m => m (HashTable (PrimState m) k v) +new = newSized 1 +{-# INLINE new #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:newSized". +newSized :: PrimMonad m => Int -> m (HashTable (PrimState m) k v) +newSized n = do + debug $ "entering: newSized " ++ show n + let m = nextBestPrime $ ceiling (fromIntegral n / maxLoad) + ht <- newSizedReal m + newRef ht +{-# INLINE newSized #-} + + +------------------------------------------------------------------------------ +newSizedReal :: PrimMonad m => Int -> m (HashTable_ (PrimState m) k v) +newSizedReal m = do + -- make sure the hash array is a multiple of cache-line sized so we can + -- always search a whole cache line at once + let m' = ((m + numElemsInCacheLine - 1) `div` numElemsInCacheLine) + * numElemsInCacheLine + h <- U.newArray m' + k <- newArray m undefined + v <- newArray m undefined + ld <- newSizeRefs + return $! HashTable m ld h k v + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:delete". +delete :: (PrimMonad m, Hashable k, Eq k) => + (HashTable (PrimState m) k v) + -> k + -> m () +delete htRef k = do + debug $ "entered: delete: hash=" ++ show h + ht <- readRef htRef + _ <- delete' ht True k h + return () + where + !h = hash k +{-# INLINE delete #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:lookup". +lookup :: (PrimMonad m, Eq k, Hashable k) => (HashTable (PrimState m) k v) -> k -> m (Maybe v) +lookup htRef !k = do + ht <- readRef htRef + lookup' ht + where + lookup' (HashTable sz _ hashes keys values) = do + let !b = whichBucket h sz + debug $ "lookup h=" ++ show h ++ " sz=" ++ show sz ++ " b=" ++ show b + go b 0 sz + + where + !h = hash k + !he = hashToElem h + + go !b !start !end = {-# SCC "lookup/go" #-} do + debug $ concat [ "lookup'/go: " + , show b + , "/" + , show start + , "/" + , show end + ] + idx <- forwardSearch2 hashes b end he emptyMarker + debug $ "forwardSearch2 returned " ++ show idx + if (idx < 0 || idx < start || idx >= end) + then return Nothing + else do + h0 <- U.readArray hashes idx + debug $ "h0 was " ++ show h0 + + if recordIsEmpty h0 + then do + debug $ "record empty, returning Nothing" + return Nothing + else do + k' <- readArray keys idx + if k == k' + then do + debug $ "value found at " ++ show idx + v <- readArray values idx + return $! Just v + else do + debug $ "value not found, recursing" + if idx < b + then go (idx + 1) (idx + 1) b + else go (idx + 1) start end +{-# INLINE lookup #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:insert". +insert :: (PrimMonad m, Eq k, Hashable k) => + (HashTable (PrimState m) k v) + -> k + -> v + -> m () +insert htRef !k !v = do + ht <- readRef htRef + !ht' <- insert' ht + writeRef htRef ht' + + where + insert' ht = do + debug "insert': calling delete'" + b <- delete' ht False k h + + debug $ concat [ "insert': writing h=" + , show h + , " he=" + , show he + , " b=" + , show b + ] + U.writeArray hashes b he + writeArray keys b k + writeArray values b v + + checkOverflow ht + + where + !h = hash k + !he = hashToElem h + hashes = _hashes ht + keys = _keys ht + values = _values ht +{-# INLINE insert #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:foldM". +foldM :: PrimMonad m => (a -> (k,v) -> m a) -> a -> HashTable (PrimState m) k v -> m a +foldM f seed0 htRef = readRef htRef >>= work + where + work (HashTable sz _ hashes keys values) = go 0 seed0 + where + go !i !seed | i >= sz = return seed + | otherwise = do + h <- U.readArray hashes i + if recordIsEmpty h || recordIsDeleted h + then go (i+1) seed + else do + k <- readArray keys i + v <- readArray values i + !seed' <- f seed (k, v) + go (i+1) seed' + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:mapM_". +mapM_ :: PrimMonad m => ((k,v) -> m b) -> HashTable (PrimState m) k v -> m () +mapM_ f htRef = readRef htRef >>= work + where + work (HashTable sz _ hashes keys values) = go 0 + where + go !i | i >= sz = return () + | otherwise = do + h <- U.readArray hashes i + if recordIsEmpty h || recordIsDeleted h + then go (i+1) + else do + k <- readArray keys i + v <- readArray values i + _ <- f (k, v) + go (i+1) + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:computeOverhead". +computeOverhead :: PrimMonad m => HashTable (PrimState m) k v -> m Double +computeOverhead htRef = readRef htRef >>= work + where + work (HashTable sz' loadRef _ _ _) = do + !ld <- readLoad loadRef + let k = fromIntegral ld / sz + return $ constOverhead/sz + (2 + 2*ws*(1-k)) / (k * ws) + where + ws = fromIntegral $! finiteBitSize (0::Int) `div` 8 + sz = fromIntegral sz' + -- Change these if you change the representation + constOverhead = 14 + + +------------------------------ +-- Private functions follow -- +------------------------------ + + +------------------------------------------------------------------------------ +{-# INLINE insertRecord #-} +insertRecord :: PrimMonad m + => Int + -> U.IntArray (PrimState m) + -> MutableArray (PrimState m) k + -> MutableArray (PrimState m) v + -> Int + -> k + -> v + -> m () +insertRecord !sz !hashes !keys !values !h !key !value = do + let !b = whichBucket h sz + debug $ "insertRecord sz=" ++ show sz ++ " h=" ++ show h ++ " b=" ++ show b + probe b + + where + he = hashToElem h + + probe !i = {-# SCC "insertRecord/probe" #-} do + !idx <- forwardSearch2 hashes i sz emptyMarker deletedMarker + debug $ "forwardSearch2 returned " ++ show idx + assert (idx >= 0) $ do + U.writeArray hashes idx he + writeArray keys idx key + writeArray values idx value + + +------------------------------------------------------------------------------ +checkOverflow :: (PrimMonad m, Eq k, Hashable k) => + (HashTable_ (PrimState m) k v) + -> m (HashTable_ (PrimState m) k v) +checkOverflow ht@(HashTable sz ldRef _ _ _) = do + !ld <- readLoad ldRef + let !ld' = ld + 1 + writeLoad ldRef ld' + !dl <- readDelLoad ldRef + + debug $ concat [ "checkOverflow: sz=" + , show sz + , " entries=" + , show ld + , " deleted=" + , show dl ] + + if fromIntegral (ld + dl) / fromIntegral sz > maxLoad + then if dl > ld `div` 2 + then rehashAll ht sz + else growTable ht + else return ht + + +------------------------------------------------------------------------------ +rehashAll :: (Hashable k, PrimMonad m) => HashTable_ (PrimState m) k v -> Int -> m (HashTable_ (PrimState m) k v) +rehashAll (HashTable sz loadRef hashes keys values) sz' = do + debug $ "rehashing: old size " ++ show sz ++ ", new size " ++ show sz' + ht' <- newSizedReal sz' + let (HashTable _ loadRef' newHashes newKeys newValues) = ht' + readLoad loadRef >>= writeLoad loadRef' + rehash newHashes newKeys newValues + return ht' + + where + rehash newHashes newKeys newValues = go 0 + where + go !i | i >= sz = return () + | otherwise = {-# SCC "growTable/rehash" #-} do + h0 <- U.readArray hashes i + when (not (recordIsEmpty h0 || recordIsDeleted h0)) $ do + k <- readArray keys i + v <- readArray values i + insertRecord sz' newHashes newKeys newValues + (hash k) k v + go $ i+1 + + +------------------------------------------------------------------------------ +growTable :: (Hashable k, PrimMonad m) => HashTable_ (PrimState m) k v -> m (HashTable_ (PrimState m) k v) +growTable ht@(HashTable sz _ _ _ _) = do + let !sz' = bumpSize maxLoad sz + rehashAll ht sz' + + +------------------------------------------------------------------------------ +-- Helper data structure for delete' +data Slot = Slot { + _slot :: {-# UNPACK #-} !Int + , _wasDeleted :: {-# UNPACK #-} !Int -- we use Int because Bool won't + -- unpack + } + deriving (Show) + + +------------------------------------------------------------------------------ +instance Monoid Slot where + mempty = Slot maxBound 0 + (Slot x1 b1) `mappend` (Slot x2 b2) = + if x1 == maxBound then Slot x2 b2 else Slot x1 b1 + + +------------------------------------------------------------------------------ +-- Returns the slot in the array where it would be safe to write the given key. +delete' :: (PrimMonad m, Hashable k, Eq k) => + (HashTable_ (PrimState m) k v) + -> Bool + -> k + -> Int + -> m Int +delete' (HashTable sz loadRef hashes keys values) clearOut k h = do + debug $ "delete': h=" ++ show h ++ " he=" ++ show he + ++ " sz=" ++ show sz ++ " b0=" ++ show b0 + pair@(found, slot) <- go mempty b0 False + debug $ "go returned " ++ show pair + + let !b' = _slot slot + + when found $ bump loadRef (-1) + + -- bump the delRef lower if we're writing over a deleted marker + when (not clearOut && _wasDeleted slot == 1) $ bumpDel loadRef (-1) + return b' + + where + he = hashToElem h + bump ref i = do + !ld <- readLoad ref + writeLoad ref $! ld + i + bumpDel ref i = do + !ld <- readDelLoad ref + writeDelLoad ref $! ld + i + + !b0 = whichBucket h sz + + haveWrapped !(Slot fp _) !b = if fp == maxBound + then False + else b <= fp + + -- arguments: + + -- * fp maintains the slot in the array where it would be safe to + -- write the given key + -- * b search the buckets array starting at this index. + -- * wrap True if we've wrapped around, False otherwise + + go !fp !b !wrap = do + debug $ concat [ "go: fp=" + , show fp + , " b=" + , show b + , ", wrap=" + , show wrap + , ", he=" + , show he + , ", emptyMarker=" + , show emptyMarker + , ", deletedMarker=" + , show deletedMarker ] + + !idx <- forwardSearch3 hashes b sz he emptyMarker deletedMarker + debug $ "forwardSearch3 returned " ++ show idx ++ " with sz=" ++ show sz ++ ", b=" ++ show b + + if wrap && idx >= b0 + -- we wrapped around in the search and didn't find our hash code; + -- this means that the table is full of deleted elements. Just return + -- the first place we'd be allowed to insert. + -- + -- TODO: if we get in this situation we should probably just rehash + -- the table, because every insert is going to be O(n). + then return $! + (False, fp `mappend` (Slot (error "impossible") 0)) + else do + -- because the table isn't full, we know that there must be either + -- an empty or a deleted marker somewhere in the table. Assert this + -- here. + assert (idx >= 0) $ return () + h0 <- U.readArray hashes idx + debug $ "h0 was " ++ show h0 + + if recordIsEmpty h0 + then do + let pl = fp `mappend` (Slot idx 0) + debug $ "empty, returning " ++ show pl + return (False, pl) + else do + let !wrap' = haveWrapped fp idx + if recordIsDeleted h0 + then do + let pl = fp `mappend` (Slot idx 1) + debug $ "deleted, cont with pl=" ++ show pl + go pl (idx + 1) wrap' + else + if he == h0 + then do + debug $ "found he == h0 == " ++ show h0 + k' <- readArray keys idx + if k == k' + then do + let samePlace = _slot fp == idx + debug $ "found at " ++ show idx + debug $ "clearout=" ++ show clearOut + debug $ "sp? " ++ show samePlace + -- "clearOut" is set if we intend to write a new + -- element into the slot. If we're doing an update + -- and we found the old key, instead of writing + -- "deleted" and then re-writing the new element + -- there, we can just write the new element. This + -- only works if we were planning on writing the + -- new element here. + when (clearOut || not samePlace) $ do + bumpDel loadRef 1 + U.writeArray hashes idx deletedMarker + writeArray keys idx undefined + writeArray values idx undefined + return (True, fp `mappend` (Slot idx 0)) + else go fp (idx + 1) wrap' + else go fp (idx + 1) wrap' + +------------------------------------------------------------------------------ +maxLoad :: Double +maxLoad = 0.82 + + +------------------------------------------------------------------------------ +emptyMarker :: Elem +emptyMarker = 0 + +------------------------------------------------------------------------------ +deletedMarker :: Elem +deletedMarker = 1 + + +------------------------------------------------------------------------------ +{-# INLINE recordIsEmpty #-} +recordIsEmpty :: Elem -> Bool +recordIsEmpty = (== emptyMarker) + + +------------------------------------------------------------------------------ +{-# INLINE recordIsDeleted #-} +recordIsDeleted :: Elem -> Bool +recordIsDeleted = (== deletedMarker) + + +------------------------------------------------------------------------------ +{-# INLINE hash #-} +hash :: (Hashable k) => k -> Int +hash = H.hash + + +------------------------------------------------------------------------------ +{-# INLINE hashToElem #-} +hashToElem :: Int -> Elem +hashToElem !h = out + where + !(I# lo#) = h .&. U.elemMask + + !m# = maskw# lo# 0# `or#` maskw# lo# 1# + !nm# = not# m# + + !r# = ((int2Word# 2#) `and#` m#) `or#` (int2Word# lo# `and#` nm#) + !out = U.primWordToElem r# + + +------------------------------------------------------------------------------ +newRef :: PrimMonad m => HashTable_ (PrimState m) k v -> m (HashTable (PrimState m) k v) +newRef = liftM HT . newMutVar +{-# INLINE newRef #-} + +writeRef :: PrimMonad m => HashTable (PrimState m) k v -> HashTable_ (PrimState m) k v -> m () +writeRef (HT ref) ht = writeMutVar ref ht +{-# INLINE writeRef #-} + +readRef :: PrimMonad m => HashTable (PrimState m) k v -> m (HashTable_ (PrimState m) k v) +readRef (HT ref) = readMutVar ref +{-# INLINE readRef #-} + + +------------------------------------------------------------------------------ +{-# INLINE debug #-} +debug :: PrimMonad m => String -> m () +#ifdef DEBUG +debug s = unsafePrimToPrim (putStrLn s) +#else +debug _ = return () +#endif diff --git a/src/Data/HashMap/Mutable/Internal/Array.hs b/src/Data/HashMap/Mutable/Internal/Array.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Internal/Array.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} + +module Data.HashMap.Mutable.Internal.Array + ( MutableArray + , newArray + , readArray + , writeArray + ) where + + +import Control.Monad.ST +import Control.Monad.Primitive (PrimMonad,PrimState) + +#ifdef BOUNDS_CHECKING +import qualified Data.Vector.Mutable as M +import Data.Vector.Mutable (MVector) +#else +import qualified Data.Primitive.Array as M +import Data.Primitive.Array (MutableArray) +#endif + + +#ifdef BOUNDS_CHECKING + +type MutableArray s a = MVector s a + +newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) +newArray = M.replicate + +readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a +readArray = M.read + +writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () +writeArray = M.write + +#else + +newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) +newArray = M.newArray + +readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a +readArray = M.readArray + +writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () +writeArray = M.writeArray + +#endif diff --git a/src/Data/HashMap/Mutable/Internal/CacheLine.hs b/src/Data/HashMap/Mutable/Internal/CacheLine.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Internal/CacheLine.hs @@ -0,0 +1,826 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} + +module Data.HashMap.Mutable.Internal.CacheLine + ( cacheLineSearch + , cacheLineSearch2 + , cacheLineSearch3 + , forwardSearch2 + , forwardSearch3 + , isCacheLineAligned + , advanceByCacheLineSize + , prefetchRead + , prefetchWrite + , bl_abs# + , sign# + , mask# + , maskw# + ) where + +import Control.Monad +import Control.Monad.ST (ST) +import Control.Monad.Primitive (PrimMonad,PrimState,unsafePrimToPrim) + +import Data.HashMap.Mutable.Internal.IntArray (Elem, IntArray) +import qualified Data.HashMap.Mutable.Internal.IntArray as M + +#ifndef NO_C_SEARCH +import Foreign.C.Types +#else +import Data.Bits +import Data.Int +import qualified Data.Vector.Unboxed as U +import GHC.Int +#endif + +import Data.HashMap.Mutable.Internal.Utils +import GHC.Exts + +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Exts (isTrue#) +#else +isTrue# :: Bool -> Bool +isTrue# = id +#endif + +{-# INLINE prefetchRead #-} +{-# INLINE prefetchWrite #-} +prefetchRead :: PrimMonad m => IntArray (PrimState m) -> Int -> m () +prefetchWrite :: PrimMonad m => IntArray (PrimState m) -> Int -> m () + +#ifndef NO_C_SEARCH +foreign import ccall unsafe "line_search" + c_lineSearch :: Ptr a -> CInt -> CUShort -> IO CInt + +foreign import ccall unsafe "line_search_2" + c_lineSearch_2 :: Ptr a -> CInt -> CUShort -> CUShort -> IO CInt + +foreign import ccall unsafe "line_search_3" + c_lineSearch_3 :: Ptr a -> CInt -> CUShort -> CUShort -> CUShort -> IO CInt + +foreign import ccall unsafe "forward_search_2" + c_forwardSearch_2 :: Ptr a -> CInt -> CInt -> CUShort -> CUShort -> IO CInt + +foreign import ccall unsafe "forward_search_3" + c_forwardSearch_3 :: Ptr a -> CInt -> CInt -> CUShort -> CUShort -> CUShort + -> IO CInt + +foreign import ccall unsafe "prefetch_cacheline_read" + prefetchCacheLine_read :: Ptr a -> CInt -> IO () + +foreign import ccall unsafe "prefetch_cacheline_write" + prefetchCacheLine_write :: Ptr a -> CInt -> IO () + + +fI :: (Num b, Integral a) => a -> b +fI = fromIntegral + +prefetchRead a i = unsafePrimToPrim $ prefetchCacheLine_read v x + where + v = M.toPtr a + x = fI i + +prefetchWrite a i = unsafePrimToPrim $ prefetchCacheLine_write v x + where + v = M.toPtr a + x = fI i + + +{-# INLINE forwardSearch2 #-} +forwardSearch2 :: PrimMonad m => IntArray (PrimState m) -> Int -> Int -> Elem -> Elem -> m Int +forwardSearch2 !vec !start !end !x1 !x2 = + liftM fromEnum $! unsafePrimToPrim c + where + c = c_forwardSearch_2 (M.toPtr vec) (fI start) (fI end) (fI x1) (fI x2) + + +{-# INLINE forwardSearch3 #-} +forwardSearch3 :: PrimMonad m => IntArray (PrimState m) -> Int -> Int -> Elem -> Elem -> Elem -> m Int +forwardSearch3 !vec !start !end !x1 !x2 !x3 = + liftM fromEnum $! unsafePrimToPrim c + where + c = c_forwardSearch_3 (M.toPtr vec) (fI start) (fI end) + (fI x1) (fI x2) (fI x3) + + +{-# INLINE lineSearch #-} +lineSearch :: PrimMonad m => IntArray (PrimState m) -> Int -> Elem -> m Int +lineSearch !vec !start !value = + liftM fromEnum $! unsafePrimToPrim c + where + c = c_lineSearch (M.toPtr vec) (fI start) (fI value) + + +{-# INLINE lineSearch2 #-} +lineSearch2 :: PrimMonad m => IntArray (PrimState m) -> Int -> Elem -> Elem -> m Int +lineSearch2 !vec !start !x1 !x2 = + liftM fromEnum $! unsafePrimToPrim c + where + c = c_lineSearch_2 (M.toPtr vec) (fI start) (fI x1) (fI x2) + + +{-# INLINE lineSearch3 #-} +lineSearch3 :: PrimMonad m => IntArray (PrimState m) -> Int -> Elem -> Elem -> Elem -> m Int +lineSearch3 !vec !start !x1 !x2 !x3 = + liftM fromEnum $! unsafePrimToPrim c + where + c = c_lineSearch_3 (M.toPtr vec) (fI start) (fI x1) (fI x2) (fI x3) +#endif + +{-# INLINE advanceByCacheLineSize #-} +advanceByCacheLineSize :: Int -> Int -> Int +advanceByCacheLineSize !(I# start0#) !(I# vecSize#) = out + where + !(I# clm#) = cacheLineIntMask + !clmm# = not# (int2Word# clm#) + !start# = word2Int# (clmm# `and#` int2Word# start0#) + !(I# nw#) = numElemsInCacheLine + !start'# = start# +# nw# + !s# = sign# (vecSize# -# start'# -# 1#) + !m# = not# (int2Word# s#) + !r# = int2Word# start'# `and#` m# + !out = I# (word2Int# r#) + + +{-# INLINE isCacheLineAligned #-} +isCacheLineAligned :: Int -> Bool +isCacheLineAligned (I# x#) = isTrue# (r# ==# 0#) + where + !(I# m#) = cacheLineIntMask + !mw# = int2Word# m# + !w# = int2Word# x# + !r# = word2Int# (mw# `and#` w#) + + +{-# INLINE sign# #-} +-- | Returns 0 if x is positive, -1 otherwise +sign# :: Int# -> Int# +sign# !x# = x# `uncheckedIShiftRA#` wordSizeMinus1# + where + !(I# wordSizeMinus1#) = wordSize-1 + + +{-# INLINE bl_abs# #-} +-- | Abs of an integer, branchless +bl_abs# :: Int# -> Int# +bl_abs# !x# = word2Int# r# + where + !m# = sign# x# + !r# = (int2Word# (m# +# x#)) `xor#` int2Word# m# + + +{-# INLINE mask# #-} +-- | Returns 0xfff..fff (aka -1) if a# == b#, 0 otherwise. +mask# :: Int# -> Int# -> Int# +mask# !a# !b# = dest# + where + !d# = a# -# b# + !r# = bl_abs# d# -# 1# + !dest# = sign# r# + + +{- note: this code should be: + +mask# :: Int# -> Int# -> Int# +mask# !a# !b# = let !(I# z#) = fromEnum (a# ==# b#) + !q# = negateInt# z# + in q# + +but GHC doesn't properly optimize this as straight-line code at the moment. + +-} + + +{-# INLINE maskw# #-} +maskw# :: Int# -> Int# -> Word# +maskw# !a# !b# = int2Word# (mask# a# b#) + + +#ifdef NO_C_SEARCH +prefetchRead _ _ = return () +prefetchWrite _ _ = return () + +{-# INLINE forwardSearch2 #-} +forwardSearch2 :: PrimMonad m => IntArray (PrimState m) -> Int -> Int -> Elem -> Elem -> m Int +forwardSearch2 !vec !start !end !x1 !x2 = go start end False + where + go !i !e !b = + if i >= e then + if b then return (-1) else go 0 start True + else do + h <- M.readArray vec i + if h == x1 || h == x2 + then return i + else go (i+1) e b + + +{-# INLINE forwardSearch3 #-} +forwardSearch3 :: PrimMonad m => IntArray (PrimState m) -> Int -> Int -> Elem -> Elem -> Elem -> m Int +forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start end False + where + go !i !e !b = + if i >= e then + if b then return (-1) else go 0 start True + else do + h <- M.readArray vec i + if h == x1 || h == x2 || h == x3 + then return i + else go (i+1) e b + + +deBruijnBitPositions :: U.Vector Int8 +deBruijnBitPositions = + U.fromList [ + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 + ] + + +{-# INLINE firstBitSet# #-} +-- only works with 32-bit values -- ok for us here +firstBitSet# :: Int# -> Int# +firstBitSet# i# = word2Int# ((or# zeroCase# posw#)) + where + !zeroCase# = int2Word# (mask# 0# i#) + !w# = int2Word# i# + !iLowest# = word2Int# (and# w# (int2Word# (negateInt# i#))) + !idxW# = uncheckedShiftRL# + (narrow32Word# (timesWord# (int2Word# iLowest#) + (int2Word# 0x077CB531#))) + 27# + !idx = I# (word2Int# idxW#) + !(I8# pos8#) = U.unsafeIndex deBruijnBitPositions idx + !posw# = int2Word# pos8# + +#endif + + +#ifdef NO_C_SEARCH +lineResult# :: Word# -- ^ mask + -> Int -- ^ start value + -> Int +lineResult# bitmask# (I# start#) = I# (word2Int# rv#) + where + !p# = firstBitSet# (word2Int# bitmask#) + !mm# = maskw# p# (-1#) + !nmm# = not# mm# + !rv# = mm# `or#` (nmm# `and#` (int2Word# (start# +# p#))) +{-# INLINE lineResult# #-} + + +-- Required: unlike in C search, required that the start index is +-- cache-line-aligned and array has at least 32 elements after the start index +lineSearch :: IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +lineSearch !vec !start !elem1 = do + let !(I# v1#) = fromIntegral elem1 + + !(I# x1#) <- liftM fromIntegral $ M.readArray vec start + let !p1# = (and# (maskw# x1# v1#) (int2Word# 0x1#)) + + !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1 + let !p2# = or# p1# (and# (maskw# x2# v1#) (int2Word# 0x2#)) + + !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2 + let !p3# = or# p2# (and# (maskw# x3# v1#) (int2Word# 0x4#)) + + !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3 + let !p4# = or# p3# (and# (maskw# x4# v1#) (int2Word# 0x8#)) + + !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4 + let !p5# = or# p4# (and# (maskw# x5# v1#) (int2Word# 0x10#)) + + !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5 + let !p6# = or# p5# (and# (maskw# x6# v1#) (int2Word# 0x20#)) + + !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6 + let !p7# = or# p6# (and# (maskw# x7# v1#) (int2Word# 0x40#)) + + !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7 + let !p8# = or# p7# (and# (maskw# x8# v1#) (int2Word# 0x80#)) + + !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8 + let !p9# = or# p8# (and# (maskw# x9# v1#) (int2Word# 0x100#)) + + !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9 + let !p10# = or# p9# (and# (maskw# x10# v1#) (int2Word# 0x200#)) + + !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10 + let !p11# = or# p10# (and# (maskw# x11# v1#) (int2Word# 0x400#)) + + !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11 + let !p12# = or# p11# (and# (maskw# x12# v1#) (int2Word# 0x800#)) + + !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12 + let !p13# = or# p12# (and# (maskw# x13# v1#) (int2Word# 0x1000#)) + + !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13 + let !p14# = or# p13# (and# (maskw# x14# v1#) (int2Word# 0x2000#)) + + !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14 + let !p15# = or# p14# (and# (maskw# x15# v1#) (int2Word# 0x4000#)) + + !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15 + let !p16# = or# p15# (and# (maskw# x16# v1#) (int2Word# 0x8000#)) + + !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16 + let !p17# = or# p16# (and# (maskw# x17# v1#) (int2Word# 0x10000#)) + + !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17 + let !p18# = or# p17# (and# (maskw# x18# v1#) (int2Word# 0x20000#)) + + !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18 + let !p19# = or# p18# (and# (maskw# x19# v1#) (int2Word# 0x40000#)) + + !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19 + let !p20# = or# p19# (and# (maskw# x20# v1#) (int2Word# 0x80000#)) + + !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20 + let !p21# = or# p20# (and# (maskw# x21# v1#) (int2Word# 0x100000#)) + + !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21 + let !p22# = or# p21# (and# (maskw# x22# v1#) (int2Word# 0x200000#)) + + !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22 + let !p23# = or# p22# (and# (maskw# x23# v1#) (int2Word# 0x400000#)) + + !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23 + let !p24# = or# p23# (and# (maskw# x24# v1#) (int2Word# 0x800000#)) + + !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24 + let !p25# = or# p24# (and# (maskw# x25# v1#) (int2Word# 0x1000000#)) + + !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25 + let !p26# = or# p25# (and# (maskw# x26# v1#) (int2Word# 0x2000000#)) + + !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26 + let !p27# = or# p26# (and# (maskw# x27# v1#) (int2Word# 0x4000000#)) + + !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27 + let !p28# = or# p27# (and# (maskw# x28# v1#) (int2Word# 0x8000000#)) + + !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28 + let !p29# = or# p28# (and# (maskw# x29# v1#) (int2Word# 0x10000000#)) + + !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29 + let !p30# = or# p29# (and# (maskw# x30# v1#) (int2Word# 0x20000000#)) + + !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30 + let !p31# = or# p30# (and# (maskw# x31# v1#) (int2Word# 0x40000000#)) + + !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31 + let !p32# = or# p31# (and# (maskw# x32# v1#) (int2Word# 0x80000000#)) + + return $! lineResult# p32# start + + +-- Required: unlike in C search, required that the start index is +-- cache-line-aligned and array has at least 32 elements after the start index +lineSearch2 :: IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ second value to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +lineSearch2 !vec !start !elem1 !elem2 = do + let !(I# v1#) = fromIntegral elem1 + let !(I# v2#) = fromIntegral elem2 + + !(I# x1#) <- liftM fromIntegral $ M.readArray vec start + let !p1# = (and# (int2Word# 0x1#) + (or# (maskw# x1# v1#) (maskw# x1# v2#))) + !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1 + let !p2# = or# p1# (and# (int2Word# 0x2#) + (or# (maskw# x2# v1#) (maskw# x2# v2#))) + !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2 + let !p3# = or# p2# (and# (int2Word# 0x4#) + (or# (maskw# x3# v1#) (maskw# x3# v2#))) + !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3 + let !p4# = or# p3# (and# (int2Word# 0x8#) + (or# (maskw# x4# v1#) (maskw# x4# v2#))) + !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4 + let !p5# = or# p4# (and# (int2Word# 0x10#) + (or# (maskw# x5# v1#) (maskw# x5# v2#))) + !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5 + let !p6# = or# p5# (and# (int2Word# 0x20#) + (or# (maskw# x6# v1#) (maskw# x6# v2#))) + !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6 + let !p7# = or# p6# (and# (int2Word# 0x40#) + (or# (maskw# x7# v1#) (maskw# x7# v2#))) + !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7 + let !p8# = or# p7# (and# (int2Word# 0x80#) + (or# (maskw# x8# v1#) (maskw# x8# v2#))) + !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8 + let !p9# = or# p8# (and# (int2Word# 0x100#) + (or# (maskw# x9# v1#) (maskw# x9# v2#))) + !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9 + let !p10# = or# p9# (and# (int2Word# 0x200#) + (or# (maskw# x10# v1#) (maskw# x10# v2#))) + !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10 + let !p11# = or# p10# (and# (int2Word# 0x400#) + (or# (maskw# x11# v1#) (maskw# x11# v2#))) + !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11 + let !p12# = or# p11# (and# (int2Word# 0x800#) + (or# (maskw# x12# v1#) (maskw# x12# v2#))) + !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12 + let !p13# = or# p12# (and# (int2Word# 0x1000#) + (or# (maskw# x13# v1#) (maskw# x13# v2#))) + !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13 + let !p14# = or# p13# (and# (int2Word# 0x2000#) + (or# (maskw# x14# v1#) (maskw# x14# v2#))) + !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14 + let !p15# = or# p14# (and# (int2Word# 0x4000#) + (or# (maskw# x15# v1#) (maskw# x15# v2#))) + !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15 + let !p16# = or# p15# (and# (int2Word# 0x8000#) + (or# (maskw# x16# v1#) (maskw# x16# v2#))) + !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16 + let !p17# = or# p16# (and# (int2Word# 0x10000#) + (or# (maskw# x17# v1#) (maskw# x17# v2#))) + !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17 + let !p18# = or# p17# (and# (int2Word# 0x20000#) + (or# (maskw# x18# v1#) (maskw# x18# v2#))) + !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18 + let !p19# = or# p18# (and# (int2Word# 0x40000#) + (or# (maskw# x19# v1#) (maskw# x19# v2#))) + !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19 + let !p20# = or# p19# (and# (int2Word# 0x80000#) + (or# (maskw# x20# v1#) (maskw# x20# v2#))) + !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20 + let !p21# = or# p20# (and# (int2Word# 0x100000#) + (or# (maskw# x21# v1#) (maskw# x21# v2#))) + !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21 + let !p22# = or# p21# (and# (int2Word# 0x200000#) + (or# (maskw# x22# v1#) (maskw# x22# v2#))) + !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22 + let !p23# = or# p22# (and# (int2Word# 0x400000#) + (or# (maskw# x23# v1#) (maskw# x23# v2#))) + !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23 + let !p24# = or# p23# (and# (int2Word# 0x800000#) + (or# (maskw# x24# v1#) (maskw# x24# v2#))) + !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24 + let !p25# = or# p24# (and# (int2Word# 0x1000000#) + (or# (maskw# x25# v1#) (maskw# x25# v2#))) + !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25 + let !p26# = or# p25# (and# (int2Word# 0x2000000#) + (or# (maskw# x26# v1#) (maskw# x26# v2#))) + !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26 + let !p27# = or# p26# (and# (int2Word# 0x4000000#) + (or# (maskw# x27# v1#) (maskw# x27# v2#))) + !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27 + let !p28# = or# p27# (and# (int2Word# 0x8000000#) + (or# (maskw# x28# v1#) (maskw# x28# v2#))) + !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28 + let !p29# = or# p28# (and# (int2Word# 0x10000000#) + (or# (maskw# x29# v1#) (maskw# x29# v2#))) + !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29 + let !p30# = or# p29# (and# (int2Word# 0x20000000#) + (or# (maskw# x30# v1#) (maskw# x30# v2#))) + !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30 + let !p31# = or# p30# (and# (int2Word# 0x40000000#) + (or# (maskw# x31# v1#) (maskw# x31# v2#))) + !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31 + let !p32# = or# p31# (and# (int2Word# 0x80000000#) + (or# (maskw# x32# v1#) (maskw# x32# v2#))) + + return $! lineResult# p32# start + + +-- Required: unlike in C search, required that the start index is +-- cache-line-aligned and array has at least 32 elements after the start index +lineSearch3 :: IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ second value to search for + -> Elem -- ^ third value to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +lineSearch3 !vec !start !elem1 !elem2 !elem3 = do + let !(I# v1#) = fromIntegral elem1 + let !(I# v2#) = fromIntegral elem2 + let !(I# v3#) = fromIntegral elem3 + + !(I# x1#) <- liftM fromIntegral $ M.readArray vec start + let !p1# = (and# (int2Word# 0x1#) + (or# (maskw# x1# v1#) + (or# (maskw# x1# v2#) (maskw# x1# v3#)))) + + !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1 + let !p2# = or# p1# (and# (int2Word# 0x2#) + (or# (maskw# x2# v1#) + (or# (maskw# x2# v2#) (maskw# x2# v3#)))) + + !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2 + let !p3# = or# p2# (and# (int2Word# 0x4#) + (or# (maskw# x3# v1#) + (or# (maskw# x3# v2#) (maskw# x3# v3#)))) + + !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3 + let !p4# = or# p3# (and# (int2Word# 0x8#) + (or# (maskw# x4# v1#) + (or# (maskw# x4# v2#) (maskw# x4# v3#)))) + + !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4 + let !p5# = or# p4# (and# (int2Word# 0x10#) + (or# (maskw# x5# v1#) + (or# (maskw# x5# v2#) (maskw# x5# v3#)))) + + !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5 + let !p6# = or# p5# (and# (int2Word# 0x20#) + (or# (maskw# x6# v1#) + (or# (maskw# x6# v2#) (maskw# x6# v3#)))) + + !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6 + let !p7# = or# p6# (and# (int2Word# 0x40#) + (or# (maskw# x7# v1#) + (or# (maskw# x7# v2#) (maskw# x7# v3#)))) + + !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7 + let !p8# = or# p7# (and# (int2Word# 0x80#) + (or# (maskw# x8# v1#) + (or# (maskw# x8# v2#) (maskw# x8# v3#)))) + + !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8 + let !p9# = or# p8# (and# (int2Word# 0x100#) + (or# (maskw# x9# v1#) + (or# (maskw# x9# v2#) (maskw# x9# v3#)))) + + !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9 + let !p10# = or# p9# (and# (int2Word# 0x200#) + (or# (maskw# x10# v1#) + (or# (maskw# x10# v2#) (maskw# x10# v3#)))) + + !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10 + let !p11# = or# p10# (and# (int2Word# 0x400#) + (or# (maskw# x11# v1#) + (or# (maskw# x11# v2#) (maskw# x11# v3#)))) + + !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11 + let !p12# = or# p11# (and# (int2Word# 0x800#) + (or# (maskw# x12# v1#) + (or# (maskw# x12# v2#) (maskw# x12# v3#)))) + + !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12 + let !p13# = or# p12# (and# (int2Word# 0x1000#) + (or# (maskw# x13# v1#) + (or# (maskw# x13# v2#) (maskw# x13# v3#)))) + + !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13 + let !p14# = or# p13# (and# (int2Word# 0x2000#) + (or# (maskw# x14# v1#) + (or# (maskw# x14# v2#) (maskw# x14# v3#)))) + + !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14 + let !p15# = or# p14# (and# (int2Word# 0x4000#) + (or# (maskw# x15# v1#) + (or# (maskw# x15# v2#) (maskw# x15# v3#)))) + + !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15 + let !p16# = or# p15# (and# (int2Word# 0x8000#) + (or# (maskw# x16# v1#) + (or# (maskw# x16# v2#) (maskw# x16# v3#)))) + + !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16 + let !p17# = or# p16# (and# (int2Word# 0x10000#) + (or# (maskw# x17# v1#) + (or# (maskw# x17# v2#) (maskw# x17# v3#)))) + + !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17 + let !p18# = or# p17# (and# (int2Word# 0x20000#) + (or# (maskw# x18# v1#) + (or# (maskw# x18# v2#) (maskw# x18# v3#)))) + + !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18 + let !p19# = or# p18# (and# (int2Word# 0x40000#) + (or# (maskw# x19# v1#) + (or# (maskw# x19# v2#) (maskw# x19# v3#)))) + + !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19 + let !p20# = or# p19# (and# (int2Word# 0x80000#) + (or# (maskw# x20# v1#) + (or# (maskw# x20# v2#) (maskw# x20# v3#)))) + + !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20 + let !p21# = or# p20# (and# (int2Word# 0x100000#) + (or# (maskw# x21# v1#) + (or# (maskw# x21# v2#) (maskw# x21# v3#)))) + + !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21 + let !p22# = or# p21# (and# (int2Word# 0x200000#) + (or# (maskw# x22# v1#) + (or# (maskw# x22# v2#) (maskw# x22# v3#)))) + + !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22 + let !p23# = or# p22# (and# (int2Word# 0x400000#) + (or# (maskw# x23# v1#) + (or# (maskw# x23# v2#) (maskw# x23# v3#)))) + + !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23 + let !p24# = or# p23# (and# (int2Word# 0x800000#) + (or# (maskw# x24# v1#) + (or# (maskw# x24# v2#) (maskw# x24# v3#)))) + + !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24 + let !p25# = or# p24# (and# (int2Word# 0x1000000#) + (or# (maskw# x25# v1#) + (or# (maskw# x25# v2#) (maskw# x25# v3#)))) + + !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25 + let !p26# = or# p25# (and# (int2Word# 0x2000000#) + (or# (maskw# x26# v1#) + (or# (maskw# x26# v2#) (maskw# x26# v3#)))) + + !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26 + let !p27# = or# p26# (and# (int2Word# 0x4000000#) + (or# (maskw# x27# v1#) + (or# (maskw# x27# v2#) (maskw# x27# v3#)))) + + !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27 + let !p28# = or# p27# (and# (int2Word# 0x8000000#) + (or# (maskw# x28# v1#) + (or# (maskw# x28# v2#) (maskw# x28# v3#)))) + + !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28 + let !p29# = or# p28# (and# (int2Word# 0x10000000#) + (or# (maskw# x29# v1#) + (or# (maskw# x29# v2#) (maskw# x29# v3#)))) + + !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29 + let !p30# = or# p29# (and# (int2Word# 0x20000000#) + (or# (maskw# x30# v1#) + (or# (maskw# x30# v2#) (maskw# x30# v3#)))) + + !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30 + let !p31# = or# p30# (and# (int2Word# 0x40000000#) + (or# (maskw# x31# v1#) + (or# (maskw# x31# v2#) (maskw# x31# v3#)))) + + !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31 + let !p32# = or# p31# (and# (int2Word# 0x80000000#) + (or# (maskw# x32# v1#) + (or# (maskw# x32# v2#) (maskw# x32# v3#)))) + + return $! lineResult# p32# start + + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for a given int value. The number of +-- things to search for must be at most the number of things remaining in the +-- vector. +naiveSearch :: IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Int -- ^ number of things to search + -> Elem -- ^ value to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +naiveSearch !vec !start !nThings !value = go start + where + !doneIdx = start + nThings + + go !i | i >= doneIdx = return (-1) + | otherwise = do + x <- M.readArray vec i + if x == value then return i else go (i+1) +{-# INLINE naiveSearch #-} + + +------------------------------------------------------------------------------ +naiveSearch2 :: IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Int -- ^ number of things to search + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +naiveSearch2 !vec !start !nThings !value1 !value2 = go start + where + !doneIdx = start + nThings + + go !i | i >= doneIdx = return (-1) + | otherwise = do + x <- M.readArray vec i + if x == value1 || x == value2 then return i else go (i+1) +{-# INLINE naiveSearch2 #-} + + +------------------------------------------------------------------------------ +naiveSearch3 :: IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Int -- ^ number of things to search + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> Elem -- ^ value 3 to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +naiveSearch3 !vec !start !nThings !value1 !value2 !value3 = go start + where + !doneIdx = start + nThings + + go !i | i >= doneIdx = return (-1) + | otherwise = do + x <- M.readArray vec i + if x == value1 || x == value2 || x == value3 + then return i + else go (i+1) +{-# INLINE naiveSearch3 #-} + +-- end #if NO_C_SEARCH +#endif + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for a given int value, cache-line aligned. +-- If the start index is cache-line aligned, and there is more than a +-- cache-line's room between the start index and the end of the vector, we will +-- search the cache-line all at once using an efficient branchless +-- bit-twiddling technique. Otherwise, we will use a typical loop. +-- +cacheLineSearch :: PrimMonad m + => IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +cacheLineSearch !vec !start !value = do +#ifdef NO_C_SEARCH + let !vlen = M.length vec + let !st1 = vlen - start + let !nvlen = numElemsInCacheLine - st1 + let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask + let st2 = adv - start + + + if nvlen > 0 || not (isCacheLineAligned start) + then naiveSearch vec start (min st1 st2) value + else lineSearch vec start value +#else + lineSearch vec start value +#endif +{-# INLINE cacheLineSearch #-} + + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for one of two given int values, +-- cache-line aligned. If the start index is cache-line aligned, and there is +-- more than a cache-line's room between the start index and the end of the +-- vector, we will search the cache-line all at once using an efficient +-- branchless bit-twiddling technique. Otherwise, we will use a typical loop. +-- +cacheLineSearch2 :: PrimMonad m + => IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +cacheLineSearch2 !vec !start !value !value2 = do +#ifdef NO_C_SEARCH + let !vlen = M.length vec + let !st1 = vlen - start + let !nvlen = numElemsInCacheLine - st1 + let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask + let st2 = adv - start + + if nvlen > 0 || not (isCacheLineAligned start) + then naiveSearch2 vec start (min st1 st2) value value2 + else lineSearch2 vec start value value2 +#else + lineSearch2 vec start value value2 +#endif +{-# INLINE cacheLineSearch2 #-} + + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for one of three given int values, +-- cache-line aligned. If the start index is cache-line aligned, and there is +-- more than a cache-line's room between the start index and the end of the +-- vector, we will search the cache-line all at once using an efficient +-- branchless bit-twiddling technique. Otherwise, we will use a typical loop. +-- +cacheLineSearch3 :: PrimMonad m + => IntArray (PrimState m) -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> Elem -- ^ value 3 to search for + -> m Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +cacheLineSearch3 !vec !start !value !value2 !value3 = do +#ifdef NO_C_SEARCH + let !vlen = M.length vec + let !st1 = vlen - start + let !nvlen = numElemsInCacheLine - st1 + let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask + let st2 = adv - start + + if nvlen > 0 || not (isCacheLineAligned start) + then naiveSearch3 vec start (min st1 st2) value value2 value3 + else lineSearch3 vec start value value2 value3 +#else + lineSearch3 vec start value value2 value3 +#endif +{-# INLINE cacheLineSearch3 #-} diff --git a/src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs b/src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.HashMap.Mutable.Internal.CheapPseudoRandomBitStream + ( BitStream + , newBitStream + , getNextBit + , getNBits + ) where + +import Control.Applicative +import Control.Monad.ST +import Data.Bits ((.&.)) +import Data.STRef +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V +import Data.Word (Word, Word32, Word64) + +import Data.HashMap.Mutable.Internal.Utils + + +------------------------------------------------------------------------------ +-- Chosen by fair dice roll. Guaranteed random. More importantly, there are an +-- equal number of 0 and 1 bits in both of these vectors. +random32s :: Vector Word32 +random32s = V.fromList [ 0xe293c315 + , 0x82e2ff62 + , 0xcb1ef9ae + , 0x78850172 + , 0x551ee1ce + , 0x59d6bfd1 + , 0xb717ec44 + , 0xe7a3024e + , 0x02bb8976 + , 0x87e2f94f + , 0xfa156372 + , 0xe1325b17 + , 0xe005642a + , 0xc8d02eb3 + , 0xe90c0a87 + , 0x4cb9e6e2 + ] + + +------------------------------------------------------------------------------ +random64s :: Vector Word64 +random64s = V.fromList [ 0x62ef447e007e8732 + , 0x149d6acb499feef8 + , 0xca7725f9b404fbf8 + , 0x4b5dfad194e626a9 + , 0x6d76f2868359491b + , 0x6b2284e3645dcc87 + , 0x5b89b485013eaa16 + , 0x6e2d4308250c435b + , 0xc31e641a659e0013 + , 0xe237b85e9dc7276d + , 0x0b3bb7fa40d94f3f + , 0x4da446874d4ca023 + , 0x69240623fedbd26b + , 0x76fb6810dcf894d3 + , 0xa0da4e0ce57c8ea7 + , 0xeb76b84453dc3873 + ] + + +------------------------------------------------------------------------------ +numRandoms :: Int +numRandoms = 16 + + +------------------------------------------------------------------------------ +randoms :: Vector Word +randoms | wordSize == 32 = V.map fromIntegral random32s + | otherwise = V.map fromIntegral random64s + + +------------------------------------------------------------------------------ +data BitStream s = BitStream { + _curRandom :: !(STRef s Word) + , _bitsLeft :: !(STRef s Int ) + , _randomPos :: !(STRef s Int ) + } + + +------------------------------------------------------------------------------ +newBitStream :: ST s (BitStream s) +newBitStream = + unwrapMonad $ + BitStream <$> (WrapMonad $ newSTRef $ V.unsafeIndex randoms 0) + <*> (WrapMonad $ newSTRef wordSize) + <*> (WrapMonad $ newSTRef 1) + + +------------------------------------------------------------------------------ +getNextBit :: BitStream s -> ST s Word +getNextBit = getNBits 1 + + +------------------------------------------------------------------------------ +getNBits :: Int -> BitStream s -> ST s Word +getNBits nbits (BitStream crRef blRef rpRef) = do + !bl <- readSTRef blRef + if bl < nbits + then newWord + else nextBits bl + + where + newWord = do + !rp <- readSTRef rpRef + let r = V.unsafeIndex randoms rp + writeSTRef blRef $! wordSize - nbits + writeSTRef rpRef $! if rp == (numRandoms-1) then 0 else rp + 1 + extractBits r + + extractBits r = do + let !b = r .&. ((1 `shiftL` nbits) - 1) + writeSTRef crRef $! (r `shiftRL` nbits) + return b + + nextBits bl = do + !r <- readSTRef crRef + writeSTRef blRef $! bl - nbits + extractBits r diff --git a/src/Data/HashMap/Mutable/Internal/IntArray.hs b/src/Data/HashMap/Mutable/Internal/IntArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Internal/IntArray.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module Data.HashMap.Mutable.Internal.IntArray + ( IntArray + , Elem + , elemMask + , primWordToElem + , elemToInt + , elemToInt# + , newArray + , readArray + , writeArray + , length + , toPtr + ) where + +------------------------------------------------------------------------------ +import Control.Monad.ST +import Control.Monad.Primitive (PrimMonad,PrimState) +import Data.Bits +import qualified Data.Primitive.ByteArray as A +import Data.Primitive.Types (Addr (..)) +import GHC.Exts +import GHC.Word +import Prelude hiding (length) +------------------------------------------------------------------------------ + + +#ifdef BOUNDS_CHECKING +#define BOUNDS_MSG(sz,i) concat [ "[", __FILE__, ":", \ + show (__LINE__ :: Int), \ + "] bounds check exceeded: ", \ + "size was ", show (sz), " i was ", show (i) ] + +#define BOUNDS_CHECK(arr,i) let sz = (A.sizeofMutableByteArray (arr) \ + `div` wordSizeInBytes) in \ + if (i) < 0 || (i) >= sz \ + then error (BOUNDS_MSG(sz,(i))) \ + else return () +#else +#define BOUNDS_CHECK(arr,i) +#endif + + +------------------------------------------------------------------------------ +newtype IntArray s = IA (A.MutableByteArray s) +type Elem = Word16 + + +------------------------------------------------------------------------------ +primWordToElem :: Word# -> Elem +primWordToElem = W16# + + +------------------------------------------------------------------------------ +elemToInt :: Elem -> Int +elemToInt e = let !i# = elemToInt# e + in (I# i#) + + +------------------------------------------------------------------------------ +elemToInt# :: Elem -> Int# +elemToInt# (W16# w#) = word2Int# w# + + +------------------------------------------------------------------------------ +elemMask :: Int +elemMask = 0xffff + + +------------------------------------------------------------------------------ +wordSizeInBytes :: Int +wordSizeInBytes = finiteBitSize (0::Elem) `div` 8 + + +------------------------------------------------------------------------------ +-- | Cache line size, in bytes +cacheLineSize :: Int +cacheLineSize = 64 + + +------------------------------------------------------------------------------ +newArray :: PrimMonad m => Int -> m (IntArray (PrimState m)) +newArray n = do + let !sz = n * wordSizeInBytes + !arr <- A.newAlignedPinnedByteArray sz cacheLineSize + A.fillByteArray arr 0 sz 0 + return $! IA arr + + +------------------------------------------------------------------------------ +readArray :: PrimMonad m => IntArray (PrimState m) -> Int -> m Elem +readArray (IA a) idx = do + BOUNDS_CHECK(a,idx) + A.readByteArray a idx + + +------------------------------------------------------------------------------ +writeArray :: PrimMonad m => IntArray (PrimState m) -> Int -> Elem -> m () +writeArray (IA a) idx val = do + BOUNDS_CHECK(a,idx) + A.writeByteArray a idx val + + +------------------------------------------------------------------------------ +length :: IntArray s -> Int +length (IA a) = A.sizeofMutableByteArray a `div` wordSizeInBytes + + +------------------------------------------------------------------------------ +toPtr :: IntArray s -> Ptr a +toPtr (IA a) = Ptr a# + where + !(Addr !a#) = A.mutableByteArrayContents a diff --git a/src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs b/src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module Data.HashMap.Mutable.Internal.Linear.Bucket +( Bucket, + newBucketArray, + newBucketSize, + emptyWithSize, + growBucketTo, + snoc, + size, + lookup, + delete, + toList, + fromList, + mapM_, + foldM, + expandBucketArray, + expandArray, + nelemsAndOverheadInWords, + bucketSplitSize +) where + + +------------------------------------------------------------------------------ +import Control.Monad hiding (foldM, mapM_) +import qualified Control.Monad +import Control.Monad.ST (ST) +#ifdef DEBUG +import Data.HashMap.Mutable.Internal.Utils (unsafeIOToST) +#endif +import Data.HashMap.Mutable.Internal.Array +import Data.Maybe (fromMaybe) +import Data.STRef +import Prelude hiding (lookup, mapM_) +------------------------------------------------------------------------------ +import Data.HashMap.Mutable.Internal.UnsafeTricks + + +#ifdef DEBUG +import System.IO +#endif + + +type Bucket s k v = Key (Bucket_ s k v) + +------------------------------------------------------------------------------ +data Bucket_ s k v = Bucket { _bucketSize :: {-# UNPACK #-} !Int + , _highwater :: {-# UNPACK #-} !(STRef s Int) + , _keys :: {-# UNPACK #-} !(MutableArray s k) + , _values :: {-# UNPACK #-} !(MutableArray s v) + } + + +------------------------------------------------------------------------------ +bucketSplitSize :: Int +bucketSplitSize = 16 + + +------------------------------------------------------------------------------ +newBucketArray :: Int -> ST s (MutableArray s (Bucket s k v)) +newBucketArray k = newArray k emptyRecord + +------------------------------------------------------------------------------ +nelemsAndOverheadInWords :: Bucket s k v -> ST s (Int,Int) +nelemsAndOverheadInWords bKey = do + if (not $ keyIsEmpty bKey) + then do + !hw <- readSTRef hwRef + let !w = sz - hw + return (hw, constOverhead + 2*w) + else + return (0, 0) + + where + constOverhead = 8 + b = fromKey bKey + sz = _bucketSize b + hwRef = _highwater b + + +------------------------------------------------------------------------------ +emptyWithSize :: Int -> ST s (Bucket s k v) +emptyWithSize !sz = do + !keys <- newArray sz undefined + !values <- newArray sz undefined + !ref <- newSTRef 0 + + return $ toKey $ Bucket sz ref keys values + + +------------------------------------------------------------------------------ +newBucketSize :: Int +newBucketSize = 4 + + +------------------------------------------------------------------------------ +expandArray :: a -- ^ default value + -> Int -- ^ new size + -> Int -- ^ number of elements to copy + -> MutableArray s a -- ^ old array + -> ST s (MutableArray s a) +expandArray def !sz !hw !arr = do + newArr <- newArray sz def + cp newArr + + where + cp !newArr = go 0 + where + go !i + | i >= hw = return newArr + | otherwise = do + readArray arr i >>= writeArray newArr i + go (i+1) + + +------------------------------------------------------------------------------ +expandBucketArray :: Int + -> Int + -> MutableArray s (Bucket s k v) + -> ST s (MutableArray s (Bucket s k v)) +expandBucketArray = expandArray emptyRecord + + +------------------------------------------------------------------------------ +growBucketTo :: Int -> Bucket s k v -> ST s (Bucket s k v) +growBucketTo !sz bk | keyIsEmpty bk = emptyWithSize sz + | otherwise = do + if osz >= sz + then return bk + else do + hw <- readSTRef hwRef + k' <- expandArray undefined sz hw keys + v' <- expandArray undefined sz hw values + return $ toKey $ Bucket sz hwRef k' v' + + where + bucket = fromKey bk + osz = _bucketSize bucket + hwRef = _highwater bucket + keys = _keys bucket + values = _values bucket + + +------------------------------------------------------------------------------ +{-# INLINE snoc #-} +-- Just return == new bucket object +snoc :: Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v)) +snoc bucket | keyIsEmpty bucket = mkNew + | otherwise = snoc' (fromKey bucket) + where + mkNew !k !v = do + debug "Bucket.snoc: mkNew" + keys <- newArray newBucketSize undefined + values <- newArray newBucketSize undefined + + writeArray keys 0 k + writeArray values 0 v + ref <- newSTRef 1 + return (1, Just $ toKey $ Bucket newBucketSize ref keys values) + + snoc' (Bucket bsz hwRef keys values) !k !v = + readSTRef hwRef >>= check + where + check !hw + | hw < bsz = bump hw + | otherwise = spill hw + + bump hw = do + debug $ "Bucket.snoc: bumping hw, bsz=" ++ show bsz ++ ", hw=" + ++ show hw + + writeArray keys hw k + writeArray values hw v + let !hw' = hw + 1 + writeSTRef hwRef hw' + debug "Bucket.snoc: finished" + return (hw', Nothing) + + doublingThreshold = bucketSplitSize `div` 2 + growFactor = 1.5 :: Double + newSize z | z == 0 = newBucketSize + | z < doublingThreshold = z * 2 + | otherwise = ceiling $ growFactor * fromIntegral z + + spill !hw = do + let sz = newSize bsz + debug $ "Bucket.snoc: spilling, old size=" ++ show bsz ++ ", new size=" + ++ show sz + + bk <- growBucketTo sz bucket + + debug "Bucket.snoc: spill finished, snoccing element" + let (Bucket _ hwRef' keys' values') = fromKey bk + + let !hw' = hw+1 + writeArray keys' hw k + writeArray values' hw v + writeSTRef hwRef' hw' + + return (hw', Just bk) + + + +------------------------------------------------------------------------------ +{-# INLINE size #-} +size :: Bucket s k v -> ST s Int +size b | keyIsEmpty b = return 0 + | otherwise = readSTRef $ _highwater $ fromKey b + + +------------------------------------------------------------------------------ +-- note: search in reverse order! We prefer recently snoc'd keys. +lookup :: (Eq k) => Bucket s k v -> k -> ST s (Maybe v) +lookup bucketKey !k | keyIsEmpty bucketKey = return Nothing + | otherwise = lookup' $ fromKey bucketKey + where + lookup' (Bucket _ hwRef keys values) = do + hw <- readSTRef hwRef + go (hw-1) + where + go !i + | i < 0 = return Nothing + | otherwise = do + k' <- readArray keys i + if k == k' + then do + !v <- readArray values i + return $! Just v + else go (i-1) + + +------------------------------------------------------------------------------ +{-# INLINE toList #-} +toList :: Bucket s k v -> ST s [(k,v)] +toList bucketKey | keyIsEmpty bucketKey = return [] + | otherwise = toList' $ fromKey bucketKey + where + toList' (Bucket _ hwRef keys values) = do + hw <- readSTRef hwRef + go [] hw 0 + where + go !l !hw !i | i >= hw = return l + | otherwise = do + k <- readArray keys i + v <- readArray values i + go ((k,v):l) hw $ i+1 + + +------------------------------------------------------------------------------ +-- fromList needs to reverse the input in order to make fromList . toList == id +{-# INLINE fromList #-} +fromList :: [(k,v)] -> ST s (Bucket s k v) +fromList l = Control.Monad.foldM f emptyRecord (reverse l) + where + f bucket (k,v) = do + (_,m) <- snoc bucket k v + return $ fromMaybe bucket m + +------------------------------------------------------------------------------ +delete :: (Eq k) => Bucket s k v -> k -> ST s Bool +delete bucketKey !k | keyIsEmpty bucketKey = do + debug $ "Bucket.delete: empty bucket" + return False + | otherwise = do + debug "Bucket.delete: start" + del $ fromKey bucketKey + where + del (Bucket sz hwRef keys values) = do + hw <- readSTRef hwRef + debug $ "Bucket.delete: hw=" ++ show hw ++ ", sz=" ++ show sz + go hw $ hw - 1 + + where + go !hw !i | i < 0 = return False + | otherwise = do + k' <- readArray keys i + if k == k' + then do + debug $ "found entry to delete at " ++ show i + move (hw-1) i keys + move (hw-1) i values + let !hw' = hw-1 + writeSTRef hwRef hw' + return True + else go hw (i-1) + + +------------------------------------------------------------------------------ +{-# INLINE mapM_ #-} +mapM_ :: ((k,v) -> ST s a) -> Bucket s k v -> ST s () +mapM_ f bucketKey + | keyIsEmpty bucketKey = do + debug $ "Bucket.mapM_: bucket was empty" + return () + | otherwise = doMap $ fromKey bucketKey + where + doMap (Bucket sz hwRef keys values) = do + hw <- readSTRef hwRef + debug $ "Bucket.mapM_: hw was " ++ show hw ++ ", sz was " ++ show sz + go hw 0 + where + go !hw !i | i >= hw = return () + | otherwise = do + k <- readArray keys i + v <- readArray values i + _ <- f (k,v) + go hw $ i+1 + + +------------------------------------------------------------------------------ +{-# INLINE foldM #-} +foldM :: (a -> (k,v) -> ST s a) -> a -> Bucket s k v -> ST s a +foldM f !seed0 bucketKey + | keyIsEmpty bucketKey = return seed0 + | otherwise = doMap $ fromKey bucketKey + where + doMap (Bucket _ hwRef keys values) = do + hw <- readSTRef hwRef + go hw seed0 0 + where + go !hw !seed !i | i >= hw = return seed + | otherwise = do + k <- readArray keys i + v <- readArray values i + seed' <- f seed (k,v) + go hw seed' (i+1) + + +------------------------------------------------------------------------------ +-- move i into j +move :: Int -> Int -> MutableArray s a -> ST s () +move i j arr | i == j = do + debug $ "move " ++ show i ++ " into " ++ show j + return () + | otherwise = do + debug $ "move " ++ show i ++ " into " ++ show j + readArray arr i >>= writeArray arr j + + + +{-# INLINE debug #-} +debug :: String -> ST s () + +#ifdef DEBUG +debug s = unsafeIOToST $ do + putStrLn s + hFlush stdout +#else +#ifdef TESTSUITE +debug !s = do + let !_ = length s + return $! () +#else +debug _ = return () +#endif +#endif + diff --git a/src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs b/src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +#ifdef UNSAFETRICKS +{-# LANGUAGE MagicHash #-} +#endif + +module Data.HashMap.Mutable.Internal.UnsafeTricks + ( Key + , toKey + , fromKey + , emptyRecord + , deletedRecord + , keyIsEmpty + , keyIsDeleted + , writeDeletedElement + , makeEmptyVector + ) where + +import Control.Monad.Primitive +import Data.Vector.Mutable (MVector) +import qualified Data.Vector.Mutable as M +#ifdef UNSAFETRICKS +import GHC.Exts +import Unsafe.Coerce + +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Exts (isTrue#) +#else +isTrue# :: Bool -> Bool +isTrue# = id +#endif + +#endif + + +------------------------------------------------------------------------------ +#ifdef UNSAFETRICKS +type Key a = Any + +#else +data Key a = Key !a + | EmptyElement + | DeletedElement + deriving (Show) +#endif + + +------------------------------------------------------------------------------ +-- Type signatures +emptyRecord :: Key a +deletedRecord :: Key a +keyIsEmpty :: Key a -> Bool +keyIsDeleted :: Key a -> Bool +makeEmptyVector :: PrimMonad m => Int -> m (MVector (PrimState m) (Key a)) +writeDeletedElement :: PrimMonad m => + MVector (PrimState m) (Key a) -> Int -> m () +toKey :: a -> Key a +fromKey :: Key a -> a + + +#ifdef UNSAFETRICKS +data TombStone = EmptyElement + | DeletedElement + +{-# NOINLINE emptyRecord #-} +emptyRecord = unsafeCoerce EmptyElement + +{-# NOINLINE deletedRecord #-} +deletedRecord = unsafeCoerce DeletedElement + +{-# INLINE keyIsEmpty #-} +keyIsEmpty a = isTrue# (x# ==# 1#) + where + !x# = reallyUnsafePtrEquality# a emptyRecord + +{-# INLINE keyIsDeleted #-} +keyIsDeleted a = isTrue# (x# ==# 1#) + where + !x# = reallyUnsafePtrEquality# a deletedRecord + +{-# INLINE toKey #-} +toKey = unsafeCoerce + +{-# INLINE fromKey #-} +fromKey = unsafeCoerce + +#else + +emptyRecord = EmptyElement + +deletedRecord = DeletedElement + +keyIsEmpty EmptyElement = True +keyIsEmpty _ = False + +keyIsDeleted DeletedElement = True +keyIsDeleted _ = False + +toKey = Key + +fromKey (Key x) = x +fromKey _ = error "impossible" + +#endif + + +------------------------------------------------------------------------------ +{-# INLINE makeEmptyVector #-} +makeEmptyVector m = M.replicate m emptyRecord + +------------------------------------------------------------------------------ +{-# INLINE writeDeletedElement #-} +writeDeletedElement v i = M.unsafeWrite v i deletedRecord diff --git a/src/Data/HashMap/Mutable/Internal/Utils.hs b/src/Data/HashMap/Mutable/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Mutable/Internal/Utils.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module Data.HashMap.Mutable.Internal.Utils + ( whichBucket + , nextBestPrime + , bumpSize + , shiftL + , shiftRL + , iShiftL + , iShiftRL + , nextHighestPowerOf2 + , log2 + , highestBitMask + , wordSize + , cacheLineSize + , numElemsInCacheLine + , cacheLineIntMask + , cacheLineIntBits + , forceSameType + , unsafeIOToST + ) where + +import Data.Bits hiding (shiftL) +import Data.HashMap.Mutable.Internal.IntArray (Elem) +import Data.Vector (Vector) +import qualified Data.Vector as V +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import qualified Data.Bits +import Data.Word +#endif + +#if MIN_VERSION_base(4,4,0) +import Control.Monad.ST.Unsafe (unsafeIOToST) +#else +import Control.Monad.ST (unsafeIOToST) +#endif + +------------------------------------------------------------------------------ +wordSize :: Int +wordSize = bitSize (0::Int) + + +cacheLineSize :: Int +cacheLineSize = 64 + + +numElemsInCacheLine :: Int +numElemsInCacheLine = z + where + !z = cacheLineSize `div` (bitSize (0::Elem) `div` 8) + + +-- | What you have to mask an integer index by to tell if it's +-- cacheline-aligned +cacheLineIntMask :: Int +cacheLineIntMask = z + where + !z = numElemsInCacheLine - 1 + + +cacheLineIntBits :: Int +cacheLineIntBits = log2 $ toEnum numElemsInCacheLine + + +------------------------------------------------------------------------------ +{-# INLINE whichBucket #-} +whichBucket :: Int -> Int -> Int +whichBucket !h !sz = o + where + !o = h `mod` sz + + +------------------------------------------------------------------------------ +binarySearch :: (Ord e) => Vector e -> e -> Int +binarySearch = binarySearchBy compare +{-# INLINE binarySearch #-} + + +------------------------------------------------------------------------------ +binarySearchBy :: (e -> e -> Ordering) + -> Vector e + -> e + -> Int +binarySearchBy cmp vec e = binarySearchByBounds cmp vec e 0 (V.length vec) +{-# INLINE binarySearchBy #-} + + +------------------------------------------------------------------------------ +binarySearchByBounds :: (e -> e -> Ordering) + -> Vector e + -> e + -> Int + -> Int + -> Int +binarySearchByBounds cmp vec e = loop + where + loop !l !u + | u <= l = l + | otherwise = let e' = V.unsafeIndex vec k + in case cmp e' e of + LT -> loop (k+1) u + EQ -> k + GT -> loop l k + where k = (u + l) `shiftR` 1 +{-# INLINE binarySearchByBounds #-} + + +------------------------------------------------------------------------------ +primeSizes :: Vector Integer +primeSizes = V.fromList [ 19 + , 31 + , 37 + , 43 + , 47 + , 53 + , 61 + , 67 + , 79 + , 89 + , 97 + , 107 + , 113 + , 127 + , 137 + , 149 + , 157 + , 167 + , 181 + , 193 + , 211 + , 233 + , 257 + , 281 + , 307 + , 331 + , 353 + , 389 + , 409 + , 421 + , 443 + , 467 + , 503 + , 523 + , 563 + , 593 + , 631 + , 653 + , 673 + , 701 + , 733 + , 769 + , 811 + , 877 + , 937 + , 1039 + , 1117 + , 1229 + , 1367 + , 1543 + , 1637 + , 1747 + , 1873 + , 2003 + , 2153 + , 2311 + , 2503 + , 2777 + , 3079 + , 3343 + , 3697 + , 5281 + , 6151 + , 7411 + , 9901 + , 12289 + , 18397 + , 24593 + , 34651 + , 49157 + , 66569 + , 73009 + , 98317 + , 118081 + , 151051 + , 196613 + , 246011 + , 393241 + , 600011 + , 786433 + , 1050013 + , 1572869 + , 2203657 + , 3145739 + , 4000813 + , 6291469 + , 7801379 + , 10004947 + , 12582917 + , 19004989 + , 22752641 + , 25165843 + , 39351667 + , 50331653 + , 69004951 + , 83004629 + , 100663319 + , 133004881 + , 173850851 + , 201326611 + , 293954587 + , 402653189 + , 550001761 + , 702952391 + , 805306457 + , 1102951999 + , 1402951337 + , 1610612741 + , 1902802801 + , 2147483647 + , 3002954501 + , 3902954959 + , 4294967291 + , 5002902979 + , 6402754181 + , 8589934583 + , 17179869143 + , 34359738337 + , 68719476731 + , 137438953447 + , 274877906899 ] + + +------------------------------------------------------------------------------ +nextBestPrime :: Int -> Int +nextBestPrime x = fromEnum yi + where + xi = toEnum x + idx = binarySearch primeSizes xi + yi = V.unsafeIndex primeSizes idx + + +------------------------------------------------------------------------------ +bumpSize :: Double -> Int -> Int +bumpSize !maxLoad !s = nextBestPrime $! ceiling (fromIntegral s / maxLoad) + + +------------------------------------------------------------------------------ +shiftL :: Word -> Int -> Word +shiftRL :: Word -> Int -> Word +iShiftL :: Int -> Int -> Int +iShiftRL :: Int -> Int -> Int +#if __GLASGOW_HASKELL__ +{-------------------------------------------------------------------- + GHC: use unboxing to get @shiftRL@ inlined. +--------------------------------------------------------------------} +{-# INLINE shiftL #-} +shiftL (W# x) (I# i) + = W# (shiftL# x i) + +{-# INLINE shiftRL #-} +shiftRL (W# x) (I# i) + = W# (shiftRL# x i) + +{-# INLINE iShiftL #-} +iShiftL (I# x) (I# i) + = I# (iShiftL# x i) + +{-# INLINE iShiftRL #-} +iShiftRL (I# x) (I# i) + = I# (iShiftRL# x i) + +#else +shiftL x i = Data.Bits.shiftL x i +shiftRL x i = shiftR x i +iShiftL x i = shiftL x i +iShiftRL x i = shiftRL x i +#endif + + +------------------------------------------------------------------------------ +{-# INLINE nextHighestPowerOf2 #-} +nextHighestPowerOf2 :: Word -> Word +nextHighestPowerOf2 w = highestBitMask (w-1) + 1 + + +------------------------------------------------------------------------------ +log2 :: Word -> Int +log2 w = go (nextHighestPowerOf2 w) 0 + where + go 0 !i = i-1 + go !n !i = go (shiftRL n 1) (i+1) + + +------------------------------------------------------------------------------ +{-# INLINE highestBitMask #-} +highestBitMask :: Word -> Word +highestBitMask !x0 = case (x0 .|. shiftRL x0 1) of + x1 -> case (x1 .|. shiftRL x1 2) of + x2 -> case (x2 .|. shiftRL x2 4) of + x3 -> case (x3 .|. shiftRL x3 8) of + x4 -> case (x4 .|. shiftRL x4 16) of + x5 -> x5 .|. shiftRL x5 32 + + +------------------------------------------------------------------------------ +forceSameType :: Monad m => a -> a -> m () +forceSameType _ _ = return () +{-# INLINE forceSameType #-} diff --git a/src/Data/Heap/Mutable/ModelC.hs b/src/Data/Heap/Mutable/ModelC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Heap/Mutable/ModelC.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides a variant of a mutable binary min heap that is used elsewhere to implement +-- Dijkstra\'s algorithm. It is unlikely that there are other uses for this specific +-- implementation. The binary heap in this module uses the standard array-as-binary-heap +-- approach where the 0-index item in the array is unused, the 1-index item is the +-- root, and the @n@ element has its left child at @2n@ and its right child at @2n + 1@. +-- The following additions (which are uncommon) have been made: +-- +-- * This heap only supports 'Int' elements but is polymorphic in the priority data type. +-- * When the heap is initialized, it is given an 'Int'. This represents and exclusive upper bound +-- on the allowed elements. For example, if you pass 40, then you can only push 0 through 39 as +-- elements. +-- * Most of the functions in this module take an extra 'Int' (right after the 'RawHeap' argument). +-- This 'Int' tells us the number of items currently in the heap. In some cases, this argument +-- is not even used, but it is present so that LiquidHaskell can provide extra bound-checking assurances. +-- For example, if we initialize the heap with @new 90@, and then push three elements, we do not +-- want to be able to read the 83rd element in the 'rawHeapPriorities' and 'rawHeapElements' +-- arrays. Even though the this index is technically in bounds, the element stored there is not +-- actually in the heap. Many places where this bounding number is passed around to a function +-- should be eliminated by the inliner and do not affect runtime performance. The @ModelD@ module +-- provides a much more usable heap implementation where the currenty heap size is stored in a 'MutVar'. +-- It is not implemented as a 'MutVar' in here because LiquidHaskell cannot (to my knowledge) +-- use mutable values for meaningful proofs. +-- * This heap implements decrease-key as a part of 'push'. If you push an already existing element +-- onto the heap, the priority of the existing one and the priority of the one you are attempting +-- to push will be combined with the 'Monoid' instance. (Note: this could definitely be weakened +-- to 'Semigroup'). At the moment, only bubble up is attempted after this operation, so if this +-- causing the priority to increas, the heap becomes invalid (but not in a way that causes +-- segfaults). +-- +-- As a result of the third constraint, the 'Monoid' instance and 'Ord' instance of the priority type +-- must obey these additional laws: +-- +-- > mappend a b ≤ a +-- > mappend a b ≤ b +-- > mempty ≥ c +-- +-- In more colloquial terms, the monoidal append of two priorities must be less than or equal +-- to the smaller of the two. Additionally, 'mempty' must be the largest priority. + +module Data.Heap.Mutable.ModelC where + +import Control.Monad +import Control.Monad.Primitive +import Data.Primitive.MutVar +import Data.Primitive.Types (sizeOf#) +import GHC.Types (Int(..)) +import Data.Vector (Vector,MVector) +import Data.Bits (unsafeShiftL,unsafeShiftR) +import Data.Word +import Data.Coerce +import Data.Vector.Unboxed (Unbox) +import Data.Primitive.Array +import Data.Primitive.ByteArray +import Debug.Trace +import qualified Data.Primitive.Array as A +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU + + +{-@ type Positive = {n:Int | n > 0} @-} + +{-@ data RawHeap s p = RawHeap + { rawHeapBound :: Nat + , rawHeapPriorities :: (MutableArray s p) + , rawHeapElements :: (MutableByteArray s) + , rawHeapInvertedIndex :: (MutableByteArray s) + } +@-} +data RawHeap s p = RawHeap + { rawHeapBound :: !Int -- ^ This bound is exclusive + , rawHeapPriorities :: !(MutableArray s p) -- ^ Binary tree of priorities + , rawHeapElements :: !(MutableByteArray s) -- ^ Binary tree of elements + , rawHeapInvertedIndex :: !(MutableByteArray s) -- ^ Lookup binary tree index by element, used for increase and decrease priority + } + +{-@ assume readHeapPriority :: PrimMonad m + => h:RawHeap (PrimState m) p -> bound:{bound:Nat | bound <= rawHeapBound h} + -> ix:{v:Nat | v > 0 && v <= bound } -> m p @-} +readHeapPriority :: PrimMonad m => RawHeap (PrimState m) p -> Int -> Int -> m p +readHeapPriority (RawHeap _ priorities _ _) _ ix = readArray priorities ix + +{-@ assume readHeapElement :: PrimMonad m => h:RawHeap (PrimState m) p + -> bound:{bound:Nat | bound <= rawHeapBound h} + -> ix:{v:Positive | v <= bound } + -> m {e:Nat | e < rawHeapBound h} @-} +readHeapElement :: PrimMonad m => RawHeap (PrimState m) p -> Int -> Int -> m Int +readHeapElement (RawHeap _ _ elements _) _ ix = readByteArray elements ix + +{-@ assume writeHeapPriority :: PrimMonad m + => h:RawHeap (PrimState m) p -> bound:{bound:Nat | bound <= rawHeapBound h} + -> ix:{v:Nat | v > 0 && v <= bound } -> p -> m () @-} +writeHeapPriority :: PrimMonad m => RawHeap (PrimState m) p -> Int -> Int -> p -> m () +writeHeapPriority (RawHeap _ priorities _ _) _ = writeArray priorities + +{-@ assume writeHeapElement :: PrimMonad m + => h:RawHeap (PrimState m) p + -> bound:{bound:Nat | bound <= rawHeapBound h} + -> ix:{v:Positive | v <= bound } + -> e:{v:Nat | v < rawHeapBound h } + -> m () @-} +writeHeapElement :: PrimMonad m => RawHeap (PrimState m) p -> Int -> Int -> Int -> m () +writeHeapElement (RawHeap _ _ elements _) _ = writeByteArray elements + +{-@ assume readHeapInvertedIndex :: PrimMonad m + => h:RawHeap (PrimState m) p + -> bound:{bound:Nat | bound <= rawHeapBound h } + -> ix:{v:Nat | v < rawHeapBound h } + -> m {x:Positive|x < bound} +@-} +readHeapInvertedIndex :: PrimMonad m => RawHeap (PrimState m) p -> Int -> Int -> m Int +readHeapInvertedIndex (RawHeap _ _ _ invIndex) _ ix = readByteArray invIndex ix + +{-@ assume writeHeapInvertedIndex :: PrimMonad m + => h:RawHeap (PrimState m) p + -> bound:{bound:Nat | bound <= rawHeapBound h } + -> e:{v:Nat | v < rawHeapBound h } + -> ix:{v:Nat | v <= bound } + -> m () +@-} +writeHeapInvertedIndex :: PrimMonad m => RawHeap (PrimState m) p -> Int -> Int -> Int -> m () +writeHeapInvertedIndex (RawHeap _ _ _ invIndex) _ = writeByteArray invIndex + +{-@ swapHeap :: (Ord p, Monoid p, PrimMonad m) + => h:RawHeap (PrimState m) p + -> bound:{bound:Nat | bound <= rawHeapBound h} + -> ix1:{ix1:Positive | ix1 <= bound} + -> ix2:{ix2:Positive | ix2 <= bound} + -> m () @-} +swapHeap :: PrimMonad m => RawHeap (PrimState m) p -> Int -> Int -> Int -> m () +swapHeap h bound ix1 ix2 = do + a <- readHeapElement h bound ix1 + b <- readHeapElement h bound ix2 + writeHeapElement h bound ix1 b + writeHeapElement h bound ix2 a + c <- readHeapPriority h bound ix1 + d <- readHeapPriority h bound ix2 + writeHeapPriority h bound ix1 d + writeHeapPriority h bound ix2 c + writeHeapInvertedIndex h bound a ix2 + writeHeapInvertedIndex h bound b ix1 + +{-@ pop :: (PrimMonad m, Ord p) + => h:RawHeap (PrimState m) p + -> bound:{bound:Nat | bound <= rawHeapBound h} + -> m ({k:Nat | if bound = 0 then k = 0 else k = bound - 1},Maybe (p,Int)) +@-} +pop :: (PrimMonad m, Ord p) => RawHeap (PrimState m) p -> Int -> m (Int,Maybe (p,Int)) +pop h currentSize = if currentSize > 0 + then do + let newSize = currentSize - 1 + priority <- readHeapPriority h currentSize 1 + element <- readHeapElement h currentSize 1 + writeHeapInvertedIndex h currentSize element 0 + if (newSize > 0) + then do + lastPriority <- readHeapPriority h currentSize currentSize + lastElement <- readHeapElement h currentSize currentSize + writeHeapPriority h currentSize 1 lastPriority + writeHeapElement h currentSize 1 lastElement + writeHeapInvertedIndex h newSize lastElement 1 + bubbleDown h newSize + else return () + return (newSize, Just (priority,element)) + else return (currentSize,Nothing) + +{-@ bubbleDown :: (Ord p, PrimMonad m) + => h:RawHeap (PrimState m) p + -> bound:{bound:Positive | bound <= rawHeapBound h} + -> m () +@-} +bubbleDown :: forall p m. (Ord p, PrimMonad m) + => RawHeap (PrimState m) p + -> Int + -> m () +bubbleDown h currentSizeX = go currentSizeX 1 where + {-@ go :: bnd:{bnd:Positive | bnd <= rawHeapBound h} -> ix:Positive -> m () / [bnd - ix] @-} + go :: Int -> Int -> m () + go !currentSize !ix = do + let leftChildIx = ix + ix + rightChildIx = leftChildIx + 1 + if rightChildIx > currentSize + then if leftChildIx == currentSize + then do + let childIx = leftChildIx + myPriority <- readHeapPriority h currentSize ix + childPriority <- readHeapPriority h currentSize childIx + if childPriority < myPriority + then do + myElement <- readHeapElement h currentSize ix + childElement <- readHeapElement h currentSize childIx + swapHeap h currentSize ix childIx + -- go childIx -- not needed here bc we know there will not be further children + else return () + else return () + else do + myPriority <- readHeapPriority h currentSize ix + leftChildPriority <- readHeapPriority h currentSize leftChildIx + rightChildPriority <- readHeapPriority h currentSize rightChildIx + let (childIx,childPriority) = if leftChildPriority < rightChildPriority + then (leftChildIx,leftChildPriority) + else (rightChildIx,rightChildPriority) + if childPriority < myPriority + then do + myElement <- readHeapElement h currentSize ix + childElement <- readHeapElement h currentSize childIx + swapHeap h currentSize ix childIx + go currentSize childIx + else return () + +{-@ unsafePush :: (Ord p, Monoid p, PrimMonad m) + => p -> e:Nat -> oldSize:Nat + -> {h:RawHeap (PrimState m) p | e < rawHeapBound h && oldSize <= rawHeapBound h} + -> m {newSize:Nat | newSize > 0} @-} +unsafePush :: forall m p k. (Ord p, Monoid p, PrimMonad m) + => p -> Int -> Int -> RawHeap (PrimState m) p -> m Int +unsafePush priority element currentSize h@(RawHeap bound _ _ _) = do + existingElemIndex <- readHeapInvertedIndex h currentSize element + if existingElemIndex == 0 + then if currentSize < rawHeapBound h + then do + let newSize = currentSize + 1 + appendElem priority element newSize h + return newSize + else error "unsafePush: This cannot ever happen (2)" + else if currentSize > 0 + then do + combineElem priority element currentSize existingElemIndex h + return currentSize + else error "unsafePush: This cannot ever happen (1)" + +{-@ appendElem :: (Ord p, Monoid p, PrimMonad m) + => p -> e:Nat -> newSize:{newSize:Nat|newSize > 0} + -> {h:RawHeap (PrimState m) p | e < rawHeapBound h && newSize <= rawHeapBound h} + -> m () @-} +appendElem :: (Ord p, PrimMonad m) + => p -> Int -> Int -> RawHeap (PrimState m) p -> m () +appendElem priority element currentSize h = do + writeHeapPriority h currentSize currentSize priority + writeHeapElement h currentSize currentSize element + writeHeapInvertedIndex h currentSize element currentSize + bubbleUp currentSize currentSize h + +{-@ combineElem :: (Ord p, Monoid p, PrimMonad m) + => p -> e:Nat -> sz:Positive -> ix:{ix:Positive | ix <= sz} + -> {h:RawHeap (PrimState m) p | e < rawHeapBound h && sz <= rawHeapBound h} + -> m () @-} +combineElem :: (Monoid p, Ord p, PrimMonad m) + => p -> Int -> Int -> Int -> RawHeap (PrimState m) p -> m () +combineElem priority element currentSize existingIndex h = do + existingPriority <- readHeapPriority h currentSize existingIndex + let newPriority = mappend priority existingPriority + writeHeapPriority h currentSize existingIndex newPriority + bubbleUp currentSize existingIndex h + +{-@ bubbleUp :: (Ord p, PrimMonad m) + => sz:Positive + -> ix:{ix:Positive|ix <= sz} + -> {h:RawHeap (PrimState m) p | sz <= rawHeapBound h} + -> m () @-} +bubbleUp :: (Ord p, PrimMonad m) + => Int + -> Int + -> RawHeap (PrimState m) p + -> m () +bubbleUp currentSize startIx h = go startIx where + go !ix = do + let parentIx = ix `div` 2 -- getParentIndex ix, make this more efficient, use shifting + if parentIx > 0 + then do + myPriority <- readHeapPriority h currentSize ix + parentPriority <- readHeapPriority h currentSize parentIx + if myPriority < parentPriority + then do + swapHeap h currentSize ix parentIx + go parentIx + else return () + else return () + +{-@ new :: (PrimMonad m, Monoid p) => bound:Nat + -> m ({n:Int| n = 0},{h:RawHeap (PrimState m) p | rawHeapBound h = bound}) @-} +new :: (PrimMonad m, Monoid p) => Int -> m (Int,RawHeap (PrimState m) p) +new bound = do + let boundPlusOne = bound + 1 + priorities <- newArray boundPlusOne mempty + elements <- newByteArray (boundPlusOne * (I# (sizeOf# (undefined :: Int)))) + invertedIndex <- newByteArray (bound * (I# (sizeOf# (undefined :: Int)))) + setByteArray invertedIndex 0 bound (0 :: Int) + return (0,RawHeap bound priorities elements invertedIndex) + diff --git a/src/Data/Heap/Mutable/ModelD.hs b/src/Data/Heap/Mutable/ModelD.hs new file mode 100644 --- /dev/null +++ b/src/Data/Heap/Mutable/ModelD.hs @@ -0,0 +1,62 @@ +module Data.Heap.Mutable.ModelD where + +import qualified Data.Heap.Mutable.ModelC as I +import Debug.Trace +import Data.Primitive.MutVar +import Control.Monad.Primitive +import Control.Monad + +data Heap s p = Heap + { heapRaw :: !(I.RawHeap s p) + , heapCurrentSize :: !(MutVar s Int) + } + +new :: (PrimMonad m, Monoid p) + => Int -- ^ Maximum element + -> m (Heap (PrimState m) p) +new i = if i < 0 + then error "mutable heap new: size must be positive" + else do + (sz,h) <- I.new i + currentSize <- newMutVar 0 + return (Heap h currentSize) + +-- | Does not check to see if the provided element is within +-- the bounds accepted by the 'Heap'. +unsafePush :: (Ord p, Monoid p, PrimMonad m) + => p -- ^ Priority + -> Int -- ^ Element + -> Heap (PrimState m) p -- ^ Heap + -> m () +unsafePush priority element (Heap raw currentSize) = do + oldSize <- readMutVar currentSize + newSize <- I.unsafePush priority element oldSize raw + writeMutVar currentSize newSize + +push :: (Ord p, Monoid p, PrimMonad m) + => p -- ^ Priority + -> Int -- ^ Element + -> Heap (PrimState m) p -- ^ Heap + -> m () +push priority element h@(Heap raw _) = if element < I.rawHeapBound raw + then unsafePush priority element h + else error "mutable heap push: element too big" + +pushList :: (Ord p, PrimMonad m, Monoid p) => [(p, Int)] -> Heap (PrimState m) p -> m () +pushList xs h = forM_ xs $ \(p,e) -> push p e h + +popAll :: (Ord p, PrimMonad m) => Heap (PrimState m) p -> m [(p,Int)] +popAll h = do + m <- pop h + case m of + Nothing -> return [] + Just r -> (r:) <$> popAll h + +pop :: (PrimMonad m, Ord p) => Heap (PrimState m) p -> m (Maybe (p,Int)) +pop (Heap raw currentSize) = do + oldSize <- readMutVar currentSize + (newSize,m) <- I.pop raw oldSize + writeMutVar currentSize newSize + return m + + diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Main (main) where + +import Test.QuickCheck (Gen, Arbitrary(..), choose, shrinkIntegral) +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion,(@?=)) +import Data.Coerce + +import Data.Word +import Data.Function (on) +import Data.List (groupBy) +import Control.Monad +import Control.Monad.ST +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map +import Debug.Trace + +import qualified Data.Heap.Mutable.ModelD as HeapD + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ testGroup "Heaps" + [ testProperty "Model D Push No Crash" multipush + , testProperty "Model D Push Pop" heapPushPop + , testProperty "Model D List" heapMatchesList + ] + ] + +testElements :: Int +testElements = 15 + +newtype Min = Min { getMin :: Word32 } + deriving (Show,Read,Eq,Ord) + +instance Arbitrary Min where + arbitrary = fmap Min (choose (0,20)) + shrink (Min a) = fmap Min $ filter (>= 0) $ shrinkIntegral a + +instance Monoid Min where + mempty = Min 0 + mappend (Min a) (Min b) = Min (min a b) + +newtype MyElement = MyElement { getMyElement :: Int } + deriving (Show,Read,Eq,Ord) + +instance Arbitrary MyElement where + arbitrary = fmap MyElement (choose (0,fromIntegral testElements - 1)) + shrink (MyElement a) = fmap MyElement $ filter (>= 0) $ shrinkIntegral a -- fmap MyElement (enumFromTo 0 (a - 1)) + +multipush :: [(Min,MyElement)] -> Bool +multipush xs = runST $ do + h <- trace "Running Test" (HeapD.new testElements) + HeapD.pushList (coerce xs :: [(Min,Int)]) h + return True + +heapPushPop :: [(Min,MyElement)] -> Bool +heapPushPop xs = + let res = runST $ do + h <- HeapD.new testElements + forM xs $ \(c,MyElement i) -> do + HeapD.push c i h + HeapD.pop h + in sequence res == coerce (Just xs) + +heapMatchesList :: [(Min,MyElement)] -> Bool +heapMatchesList xs' = + let xs = coerce xs' :: [(Min,Int)] + xsSet = fmap (\(p,e) -> (e,p)) xs + ys = Map.fromListWith mappend xsSet + listRes = Map.toList $ Map.fromListWith Set.union $ map (\(e,p) -> (p,Set.singleton e)) (Map.toList ys) + heapRes = runST $ do + h <- HeapD.new testElements + HeapD.pushList xs h + HeapD.popAll h + heapResSet = map (\pairs@((p,_) : _) -> (p,Set.fromList $ map snd pairs)) + $ groupBy (on (==) fst) heapRes + in heapResSet == listRes +