impure-containers (empty) → 0.1.0.0
raw patch · 17 files changed
+3143/−0 lines, 17 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, containers, ghc-prim, hashable, impure-containers, liquidhaskell, primitive, test-framework, test-framework-hunit, test-framework-quickcheck2, vector, vector-th-unbox
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- impure-containers.cabal +65/−0
- src/Data/Graph/Immutable.hs +9/−0
- src/Data/Graph/Immutable/Tagged.hs +120/−0
- src/Data/HashMap/Mutable/Basic.hs +574/−0
- src/Data/HashMap/Mutable/Internal/Array.hs +47/−0
- src/Data/HashMap/Mutable/Internal/CacheLine.hs +826/−0
- src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs +122/−0
- src/Data/HashMap/Mutable/Internal/IntArray.hs +116/−0
- src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs +358/−0
- src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs +113/−0
- src/Data/HashMap/Mutable/Internal/Utils.hs +312/−0
- src/Data/Heap/Mutable/ModelC.hs +296/−0
- src/Data/Heap/Mutable/ModelD.hs +62/−0
- src/Lib.hs +6/−0
- test/Spec.hs +85/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ impure-containers.cabal view
@@ -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
+ src/Data/Graph/Immutable.hs view
@@ -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 }++
+ src/Data/Graph/Immutable/Tagged.hs view
@@ -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+
+ src/Data/HashMap/Mutable/Basic.hs view
@@ -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 _ = "<HashTable>"+++------------------------------------------------------------------------------+-- | 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
+ src/Data/HashMap/Mutable/Internal/Array.hs view
@@ -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
+ src/Data/HashMap/Mutable/Internal/CacheLine.hs view
@@ -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 #-}
+ src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs view
@@ -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
+ src/Data/HashMap/Mutable/Internal/IntArray.hs view
@@ -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
+ src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs view
@@ -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+
+ src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs view
@@ -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
+ src/Data/HashMap/Mutable/Internal/Utils.hs view
@@ -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 #-}
+ src/Data/Heap/Mutable/ModelC.hs view
@@ -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)+
+ src/Data/Heap/Mutable/ModelD.hs view
@@ -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++
+ src/Lib.hs view
@@ -0,0 +1,6 @@+module Lib+ ( someFunc+ ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ test/Spec.hs view
@@ -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+