compact-map 2008.11.8 → 2008.11.9
raw patch · 7 files changed
+217/−261 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Data.CompactMap: instance Show Range
+ Data.CompactMap: deleteFindMin :: (Binary k, Binary a) => Map k a -> ((k, a), Map k a)
+ Data.CompactMap: deleteMin :: (Binary k, Binary a) => Map k a -> Map k a
+ Data.CompactMap: findMax :: (Binary k, Binary a) => Map k a -> (k, a)
+ Data.CompactMap: findMin :: (Binary k, Binary a) => Map k a -> (k, a)
Files
- compact-map.cabal +7/−3
- src/Data/CompactMap.hs +139/−40
- src/Data/CompactMap/Buffer.hs +14/−17
- src/Data/CompactMap/Fetch.hs +34/−24
- src/Data/CompactMap/Index.hs +21/−23
- src/Data/CompactMap/MemoryMap.hs +0/−104
- src/Data/CompactMap/Types.hs +2/−50
compact-map.cabal view
@@ -1,24 +1,28 @@ Name: compact-map-Version: 2008.11.8+Version: 2008.11.9 Author: David Himmelstrup <lemmih@gmail.com> Maintainer: David Himmelstrup <lemmih@gmail.com> Copyright: 2008 David Himmelstrup <lemmih@gmail.com> Build-Type: Simple Build-Depends: base, bytestring, binary, array, containers ghc-prof-options: -auto-all+ghc-options: -fwarn-unused-imports Exposed-Modules: Data.CompactMap Other-Modules: Data.CompactMap.Types Data.CompactMap.Index Data.CompactMap.Buffer- Data.CompactMap.MemoryMap Data.CompactMap.Fetch Hs-Source-Dirs: src Extensions: CPP License: BSD3 License-file: LICENSE-Tested-with: GHC ==6.8.3+Tested-with: GHC ==6.8.3, GHC ==6.10.1 Category: Data Synopsis: Compact Data.Map implementation using Data.Binary Description: This library attempts to provide a memory efficient alternative to Data.Map.+ .+ Test coverage can be found here: <http://darcs.haskell.org/~lemmih/compact-map/tests/hpc_index.html>+ .+ Benchmarks can be found here: <http://darcs.haskell.org/~lemmih/compact-map/benchmarks/>
src/Data/CompactMap.hs view
@@ -140,15 +140,15 @@ , findIndex , elemAt , updateAt- , deleteAt+ , deleteAt-} -- * Min\/Max , findMin , findMax , deleteMin- , deleteMax+-- , deleteMax , deleteFindMin- , deleteFindMax- , updateMin+-- , deleteFindMax+{- , updateMin , updateMax , updateMinWithKey , updateMaxWithKey@@ -178,7 +178,7 @@ import Text.Read hiding (get) import Control.Monad import qualified Data.CompactMap.Index as Index-import qualified Data.CompactMap.Types as Types+import Data.CompactMap.Types as Types import qualified Data.Array.IArray as IArray import qualified Data.Set as Set @@ -188,16 +188,21 @@ import Prelude hiding (null,lookup,map,filter) import qualified Prelude -data Range = Range Int Int deriving Show+import System.Mem.Weak +data Range = Range Int Int+ -- | A Map from keys @k@ to values @a@. data Map k a = Empty | Existing - { index :: !(MVar Types.Index)+ { index :: !(MVar Index) , uniq :: {-# UNPACK #-} !(IORef Int) , range :: ![Range] , mapSize :: {-# UNPACK #-} !Int- } deriving (Typeable)+ }+#if !defined(HPC)+ deriving (Typeable)+#endif {-------------------------------------------------------------------- Instances@@ -239,16 +244,16 @@ Nothing -> return () Just val -> do let key = unsafePerformIO $ Index.getKeyFromPointer ptr put (key,val)- let x = unsafePerformIO $ do withMVar index Index.touchIndex - return ()- x `seq` return ()+ unsafePerformIO $+ do withMVar index Index.touchIndex+ return $ return () get = do n <- get ls <- replicateM n get unsafePerformIO $ do idx <- Index.newIndex- forM_ ls $ \(k,v) -> do keyCursor <- Index.newKeyCursor (Types.indexBuffer idx) (Lazy.fromChunks [k])+ forM_ ls $ \(k,v) -> do keyCursor <- Index.newKeyCursor (indexBuffer idx) (Lazy.fromChunks [k]) Index.insertLargestKeyCursor idx keyCursor- dataCursor <- Index.newDataCursor (Types.indexBuffer idx) 0 (Just (Lazy.fromChunks [v]))+ dataCursor <- Index.newDataCursor (indexBuffer idx) 0 (Just (Lazy.fromChunks [v])) Index.pushNewDataCursor keyCursor dataCursor --Index.insertBS idx (decodeStrict k :: k) 0 (Just (Lazy.fromChunks [v])) uniq <- newIORef 1@@ -321,7 +326,7 @@ -- An example of using @lookup@: -- -- > import Prelude hiding (lookup)--- > import Data.Map+-- > import Data.CompactMap -- > -- > employeeDept = fromList([("John","Sales"), ("Bob","IT")]) -- > deptCountry = fromList([("IT","USA"), ("Sales","France")])@@ -346,9 +351,10 @@ lookup k Existing{index=index,range=range} = unsafePerformIO $ withMVar index $ \idx -> do ls <- Index.lookupList idx k- return $ case findValue range ls of- Nothing -> Nothing- Just bs -> Just (decodeStrict bs)+ case findValue range ls of+ Nothing -> return Nothing+ Just bs -> do mkWeak bs index Nothing+ return $ Just (decodeStrict bs) -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns -- the value at key @k@ or returns default value @def@@@ -432,7 +438,7 @@ Nothing -> x Just old -> f kx x (decodeStrict old) newSize = if isJust oldVal then mapSize else mapSize + 1- dataCursor <- Index.newDataCursor (Types.indexBuffer idx) u (Just $ encode newVal)+ dataCursor <- Index.newDataCursor (indexBuffer idx) u (Just $ encode newVal) Index.pushNewDataCursor keyCursor dataCursor return $ Existing{index=index,uniq=uniq,range=addToRange u range,mapSize=newSize} @@ -459,12 +465,14 @@ modifyIORef uniq succ keyCursor <- Index.insertKey idx k ls <- Index.getDataFromPointer keyCursor- let oldVal = fmap decodeStrict $ findValue range ls+ let oldValBS = findValue range ls+ oldVal = fmap decodeStrict oldValBS newVal = case oldVal of Nothing -> a Just old -> f k a old newSize = if isJust oldVal then mapSize else mapSize + 1- dataCursor <- Index.newDataCursor (Types.indexBuffer idx) u (Just $ encode newVal)+ case oldValBS of Just val -> mkWeak val index Nothing>>return(); Nothing -> return ()+ dataCursor <- Index.newDataCursor (indexBuffer idx) u (Just $ encode newVal) Index.pushNewDataCursor keyCursor dataCursor return $ (oldVal, Existing{index=index,uniq=uniq,range=addToRange u range,mapSize=newSize}) @@ -546,16 +554,18 @@ updateLookupWithKey f k m@Existing{index=index,uniq=uniq,range=range,mapSize=mapSize} = unsafePerformIO $ withMVar index $ \idx -> do ls <- Index.lookupList idx k- case fmap decodeStrict $ findValue range ls of+ case findValue range ls of Nothing -> return (Nothing, m)- Just val -> do let newVal = f k val- u <- readIORef uniq- modifyIORef uniq succ- Index.insert idx k u newVal- let newSize = case isJust newVal of- False -> mapSize-1- True -> mapSize- return (newVal `mplus` Just val, Existing{index=index,uniq=uniq,range=addToRange u range,mapSize=newSize})+ Just valBS -> do let val = decodeStrict valBS+ newVal = f k val+ mkWeak valBS index Nothing+ u <- readIORef uniq+ modifyIORef uniq succ+ Index.insert idx k u newVal+ let newSize = case isJust newVal of+ False -> mapSize-1+ True -> mapSize+ return (newVal `mplus` Just val, Existing{index=index,uniq=uniq,range=addToRange u range,mapSize=newSize}) -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.@@ -751,10 +761,10 @@ do idx <- Index.newIndex let loop n _ | n `seq` False = undefined loop n [] = return n- loop n ((k,v):rs)+ loop n ((k,v):rs) | k `seq` v `seq` True = do keyCursor <- Index.insertKey idx k oldData <- Index.peekKeyCursorData keyCursor- newData <- Index.newDataCursor (Types.indexBuffer idx) 0 (Just (encode v))+ newData <- Index.newDataCursor (indexBuffer idx) 0 (Just (encode v)) Index.pushNewDataCursor keyCursor newData loop (if oldData==nullPtr then n+1 else n) rs size <- loop 0 ls@@ -788,7 +798,7 @@ let newVal = case oldData of ((_,Just old):_) -> f k v (decodeStrict old) _ -> v- newData <- Index.newDataCursor (Types.indexBuffer idx) 0 (Just (encode newVal))+ newData <- Index.newDataCursor (indexBuffer idx) 0 (Just (encode newVal)) Index.pushNewDataCursor keyCursor newData loop (if Prelude.null oldData then n+1 else n) rs size <- loop 0 ls@@ -806,17 +816,18 @@ toList Existing{index=index,range=range} = unsafePerformIO $ do keys <- withMVar index $ Index.listKeyPointers- let loop [] = withMVar index Index.touchIndex >> return []+ let loop [] = return [] -- withMVar index Index.touchIndex >> return [] loop (keyCursor:xs) = unsafeInterleaveIO $- do ls <- Index.getDataFromPointer keyCursor+ do mkWeak keyCursor index Nothing+ ls <- Index.getDataFromPointer keyCursor case findValue range ls of Nothing -> loop xs Just bs -> do key <- Index.getKeyFromPointer keyCursor- let ckey = Strict.copy key- cbs = Strict.copy bs- let pair = (decodeStrict ckey, decodeStrict cbs)- ckey `seq` cbs `seq` liftM (pair:) (loop xs)+ mkWeak bs index Nothing+ mkWeak key index Nothing+ let pair = (decodeStrict key, decodeStrict bs)+ liftM (pair:) (loop xs) loop (IArray.elems keys) @@ -884,7 +895,7 @@ = unsafePerformIO $ do idx <- Index.newIndex n <- foldM (\s (k,v) -> do keyCursor <- Index.insertLargestKey idx k- dataCursor <- Index.newDataCursor (Types.indexBuffer idx) 0 (Just $ encode v)+ dataCursor <- Index.newDataCursor (indexBuffer idx) 0 (Just $ encode v) Index.pushNewDataCursor keyCursor dataCursor return $! s+1) 0 ls index <- newMVar idx@@ -978,7 +989,7 @@ Left v' -> (idxL,encode v',s1+1,s2) Right v' -> (idxR,encode v',s1,s2+1) keyCursor <- Index.insertLargestKey idx k- dataCursor <- Index.newDataCursor (Types.indexBuffer idx) 0 (Just v')+ dataCursor <- Index.newDataCursor (indexBuffer idx) 0 (Just v') Index.pushNewDataCursor keyCursor dataCursor return $! (s1',s2')) (0,0) (toList m) indexL <- newMVar idxL@@ -987,6 +998,94 @@ uniqR <- newIORef 1 return $ (Existing{index=indexL,uniq=uniqR,range=addToRange 0 [],mapSize=s1} ,Existing{index=indexR,uniq=uniqL,range=addToRange 0 [],mapSize=s2})+++-- | /O(log n)/. The minimal key of the map. Calls 'error' is the map is empty.+--+-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > findMin empty Error: empty map has no minimal element+findMin :: (Binary k, Binary a) => Map k a -> (k,a)+findMin m = case m of+ Empty -> err+ Existing{index=index,range=range} ->+ unsafePerformIO $ withMVar index $ \idx ->+ do mbMin <- findMinKey idx range+ case mbMin of+ Nothing -> err+ Just (keyCursor,val)+ -> do key <- Index.getKeyFromPointer keyCursor+ mkWeak key index Nothing+ mkWeak val index Nothing+ return (decodeStrict key, decodeStrict val)+ where err = error "Map.findMin: empty map has no minimal element"++-- | /O(log n)/. The maximal key of the map. Calls 'error' is the map is empty.+--+-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")+-- > findMax empty Error: empty map has no maximal element+findMax :: (Binary k, Binary a) => Map k a -> (k,a)+findMax m = case m of+ Empty -> err+ Existing{index=index,range=range} ->+ unsafePerformIO $ withMVar index $ \idx ->+ do mbMin <- findMaxKey idx range+ case mbMin of+ Nothing -> err+ Just (keyCursor,val)+ -> do key <- Index.getKeyFromPointer keyCursor+ mkWeak key index Nothing+ mkWeak val index Nothing+ return (decodeStrict key, decodeStrict val)+ where err = error "Map.findMax: empty map has no maximal element"++-- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.+--+-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]+-- > deleteMin empty == empty+deleteMin :: (Binary k, Binary a) => Map k a -> Map k a+deleteMin = snd . deleteFindMin++-- | /O(log n)/. Delete and find the minimal element.+--+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) +-- > deleteFindMin empty == (Error: can not return the minimal element of an empty map,empty)+deleteFindMin :: (Binary k, Binary a) => Map k a -> ((k,a), Map k a)+deleteFindMin m+ = case m of+ Empty -> (deleteFindMinErr, Empty)+ Existing{index=index,uniq=uniq,range=range,mapSize=mapSize}+ -> unsafePerformIO $ withMVar index $ \idx ->+ do mbMin <- findMinKey idx range+ case mbMin of+ Nothing -> return (deleteFindMinErr, Empty)+ Just (keyCursor,val)+ -> do u <- readIORef uniq+ modifyIORef uniq succ+ dataCursor <- Index.newDataCursor (indexBuffer idx) u Nothing+ Index.pushNewDataCursor keyCursor dataCursor+ key <- Index.getKeyFromPointer keyCursor+ mkWeak key index Nothing+ mkWeak val index Nothing+ return $ ((decodeStrict key,decodeStrict val),Existing{index=index,uniq=uniq,range=addToRange u range,mapSize=mapSize-1})+ where deleteFindMinErr = error "Data.CompactMap.deleteFindMin: can not return the minimal element of an empty map"++findMinKey = findCornerKey Index.extractLeft Index.extractRight+findMaxKey = findCornerKey Index.extractRight Index.extractLeft+findCornerKey left right (Index orig buffer) range+ = do s <- Index.getSize orig+ if s == 0+ then return Nothing+ else do let loop ptr | ptr == nullPtr = return Nothing+ loop ptr = do res <- loop =<< left ptr+ case res of+ Just val -> return $ Just val+ Nothing -> do keyCursor <- Index.extractElemIdx ptr+ ls <- Index.getDataFromPointer keyCursor+ case findValue range ls of+ Just val -> return $ Just (keyCursor, val)+ _ -> loop =<< right ptr+ loop orig+ {-------------------------------------------------------------------- Utilities
src/Data/CompactMap/Buffer.hs view
@@ -1,25 +1,25 @@-{-# OPTIONS -fglasgow-exts -fbang-patterns #-}-module Data.CompactMap.Buffer where+{-# LANGUAGE BangPatterns #-}+module Data.CompactMap.Buffer+ ( newBuffer+ , withBytes+ , touchBuffer+ ) where -import Foreign (Ptr,Storable(..),plusPtr, castPtr) -import Data.CompactMap.MemoryMap import Data.CompactMap.Types -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr, castForeignPtr)-import Foreign.Concurrent+import Foreign (Ptr, plusPtr, castPtr)+import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, castForeignPtr) import Data.IORef-+import GHC.ForeignPtr (mallocPlainForeignPtrBytes) newBuffer :: Int -> IO Buffer newBuffer initSize- = do aligned <- alignSize initSize- dataPtr <- mmap aligned [Read,Write] [Anonymous,Private,NoReserve]- fptr <- newIORef =<< newForeignPtr dataPtr (munmap dataPtr initSize)+ = do fptr <- newIORef =<< mallocPlainForeignPtrBytes initSize old <- newIORef [] posRef <- newFastMutInt 0- size <- newFastMutInt aligned+ size <- newFastMutInt initSize return $ Buffer{ bufferData = fptr , bufferOld = old , bufferPos = posRef@@ -35,15 +35,12 @@ withForeignPtr (castForeignPtr oldPtr) $ \ptr -> fn $! (ptr `plusPtr` currentPos) else do let minSize = max bytesNeeded currentSize newSize = minSize + minSize `div` 4 -- Add 25% to the buffer.- aligned <- alignSize newSize- --putStrLn $ "Expanding from " ++ show currentSize ++ " to " ++ show aligned- !newPtr <- mmap aligned [Read,Write] [Anonymous,Private,NoReserve]- fptr <- newForeignPtr newPtr (munmap newPtr aligned)+ fptr <- mallocPlainForeignPtrBytes newSize writeIORef bufferData fptr modifyIORef bufferOld (oldPtr:) writeFastMutInt bufferPos bytesNeeded- writeFastMutInt bufferSize aligned- fn $! (castPtr newPtr)+ writeFastMutInt bufferSize newSize -- aligned+ withForeignPtr fptr $ fn . castPtr touchBuffer :: Buffer -> IO () touchBuffer buffer
src/Data/CompactMap/Fetch.hs view
@@ -1,54 +1,64 @@-{-# OPTIONS -fglasgow-exts -fbang-patterns #-}-module Data.CompactMap.Fetch where+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE BangPatterns #-}+module Data.CompactMap.Fetch+ ( getElement+ , extractElement+ , extractElementBS+ , extractElementInt+ ) where -import Data.CompactMap.Types-import Data.CompactMap.Buffer- import Foreign import GHC.Ptr -import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LBS +import Data.Bits import Data.Binary --import Data.BinaryLinear sizeOfInt :: Int sizeOfInt = sizeOf (0::Int) -{-# INLINE [2] getElement #-}+{-# INLINE getElement #-} getElement :: (Binary a) => Ptr () -> IO a getElement ptr = do size <- peek (castPtr ptr) :: IO Int extractElement (ptr `plusPtr` (sizeOfInt * 1)) size +{-# INLINE [2] extractElement #-} extractElement :: Binary a => Ptr () -> Int -> IO a extractElement !ptr !size--- = return $! decode (castPtr ptr)- = do bs <- B.unsafePackCStringLen (castPtr ptr, size)+ = do !bs <- B.unsafePackCStringLen (castPtr ptr, size) return $! decode (LBS.fromChunks [bs]) +{-# RULES "extractElement/Int" extractElement = extractElementInt #-}+extractElementInt :: Ptr () -> Int -> IO Int+extractElementInt !ptr !size+ = do !bs <- B.unsafePackCStringLen (castPtr ptr, size)+ let !x = decode (LBS.fromChunks [bs]) :: Int+ b1 <- fmap fromIntegral (peek (ptr `plusPtr` (0)) :: IO Word8)+ b2 <- fmap fromIntegral (peek (ptr `plusPtr` (1)) :: IO Word8)+ b3 <- fmap fromIntegral (peek (ptr `plusPtr` (2)) :: IO Word8)+ b4 <- fmap fromIntegral (peek (ptr `plusPtr` (3)) :: IO Word8)+ b5 <- fmap fromIntegral (peek (ptr `plusPtr` (4)) :: IO Word8)+ b6 <- fmap fromIntegral (peek (ptr `plusPtr` (5)) :: IO Word8)+ b7 <- fmap fromIntegral (peek (ptr `plusPtr` (6)) :: IO Word8)+ b8 <- fmap fromIntegral (peek (ptr `plusPtr` (7)) :: IO Word8)+ return $ b1 `shiftL` 56 .|.+ b2 `shiftL` 48 .|.+ b3 `shiftL` 40 .|.+ b4 `shiftL` 32 .|.+ b5 `shiftL` 24 .|.+ b6 `shiftL` 16 .|.+ b7 `shiftL` 8 .|.+ b8 `shiftL` 0+ {-# RULES "extractElement/ByteString" extractElement = extractElementBS #-} extractElementBS :: Ptr () -> Int -> IO B.ByteString extractElementBS ptr !size = let n = sizeOf (0::Int) Ptr addr# = ptr `plusPtr` n in B.unsafePackAddressLen (size-n) addr#-{--extractRawString :: DiskSet RawString -> Int -> IO RawString-extractRawString !(DiskSet {tPosition=pos, tData=dat}) !n- = do posPtr <- bufferPtr pos- datPtr <- bufferPtr dat- (from, size) <- getElemDimensions posPtr n- let n = sizeOf (0::Int)- return $! RawString (size-n) (castPtr datPtr `plusPtr` (n+from))--}-{--{-# RULES "extractElement/RawString" extractElement = extractElementRaw #-}-extractElementRaw :: Ptr () -> Int -> IO RawString-extractElementRaw ptr size = let n = sizeOf (0::Int)- in return $! RawString (size-n) (castPtr ptr `plusPtr` n)--}
src/Data/CompactMap/Index.hs view
@@ -3,18 +3,12 @@ module Data.CompactMap.Index where import Foreign hiding (rotateL,rotateR)-import Foreign.C (CStringLen) import Foreign.Storable import Control.Monad-import System.Exit-import GHC.Exts import Data.Maybe-import Text.Printf-import Data.Int-import Numeric import System.IO.Unsafe -import Data.Array.IArray+--import Data.Array.IArray import Data.Array.IO import Data.Array.Unboxed @@ -29,7 +23,7 @@ import Data.CompactMap.Types import Data.CompactMap.Fetch -import GHC.Exts (addr2Int#)+import GHC.Exts (addr2Int#, Ptr(..), Int(..)) import Prelude hiding (Either(..)) @@ -321,7 +315,7 @@ getReverseElements = getAllElements (\idx left right -> right . (idx:) . left) -} -newIndex = do buffer <- newBuffer 0+newIndex = do buffer <- newBuffer 512 withBytes buffer indexItemSize $ \ptr -> ptr `seq` do poke ptr (IndexItem nullPtr (intToPtr 0) nullPtr nullPtr nullPtr) return $ Index ptr buffer@@ -402,7 +396,7 @@ isValid testSet idx putStrLn "Index is valid" -}-+{- verify prev !pos | pos == nullPtr = return () verify prev !pos = do !top <- extractTop pos@@ -415,7 +409,7 @@ unless (top==prev) $ putStrLn "Top fail" verify pos left verify pos right-+-} balanceTree !pos | pos==nullPtr = return () balanceTree !pos = do balance pos@@ -442,14 +436,14 @@ | otherwise -> return () rotateL pos left right- = do !sizeLY <- getSize left- !sizeRY <- getSize right+ = do !sizeLY <- getSize =<< extractLeft right+ !sizeRY <- getSize =<< extractRight right if sizeLY < ratio * sizeRY then singleL pos else doubleL pos rotateR pos left right- = do !sizeLY <- getSize left- !sizeRY <- getSize right+ = do !sizeLY <- getSize =<< extractLeft left+ !sizeRY <- getSize =<< extractRight left if sizeRY < ratio * sizeLY then singleR pos else doubleR pos singleL pos@@ -480,29 +474,33 @@ = do IndexItem kTop kSize kElemIdx p1 k2 <- peek pos IndexItem k2Top k2Size k2ElemIdx k3 p4 <- peek k2 IndexItem k3Top k3Size k3ElemIdx p2 p3 <- peek k3+-- putStrLn "doubleL" !p2Size <- getSize p2 !p3Size <- getSize p3 let p1Size = ptrToInt kSize - ptrToInt k2Size - 1 p4Size = ptrToInt k2Size - ptrToInt k3Size - 1 poke pos (IndexItem kTop kSize k3ElemIdx k3 k2) -- kSize hasn't changed poke k2 (IndexItem k2Top (intToPtr $ p3Size+p4Size+1) k2ElemIdx p3 p4) -- k2ElemIdx and p4 hasn't changed- poke k3 (IndexItem k3Top (intToPtr $ p1Size+p2Size+1) kElemIdx p1 p2)--- recalcSize ptr k2 p3 p4--- recalcSize ptr k3 p1 p2+ poke k3 (IndexItem k2Top (intToPtr $ p1Size+p2Size+1) kElemIdx p1 p2)+ putTop p1 k3+ putTop k3 pos+ putTop p3 k2 doubleR pos = do IndexItem kTop kSize kElemIdx k2 p4 <- peek pos IndexItem k2Top k2Size k2ElemIdx p1 k3 <- peek k2 IndexItem k3Top k3Size k3ElemIdx p2 p3 <- peek k3+-- putStrLn "doubleR" !p2Size <- getSize p2 !p3Size <- getSize p3 let p1Size = ptrToInt k2Size - ptrToInt k3Size - 1 p4Size = ptrToInt kSize - ptrToInt k2Size - 1- poke pos (IndexItem kTop kSize k3ElemIdx k3 k2) -- kSize hasn't changed- poke k2 (IndexItem k2Top (intToPtr $ p1Size+p2Size+1) k2ElemIdx p1 p2) -- k2ElemIdx and p1 hasn't changed.- poke k3 (IndexItem k3Top (intToPtr $ p3Size+p4Size+1) kElemIdx p3 p4)--- recalcSize ptr k2 p1 p2--- recalcSize ptr k3 p3 p4+ poke pos (IndexItem kTop kSize k3ElemIdx k2 k3) -- kSize hasn't changed+ poke k2 (IndexItem pos (intToPtr $ p1Size+p2Size+1) k2ElemIdx p1 p2) -- k2ElemIdx and p1 hasn't changed.+ poke k3 (IndexItem pos (intToPtr $ p3Size+p4Size+1) kElemIdx p3 p4)+ putTop k3 pos+ putTop p2 k2+ putTop p4 k3 {- recalcSize ptr !pos !left !right
− src/Data/CompactMap/MemoryMap.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# OPTIONS -fasm #-}-module Data.CompactMap.MemoryMap- ( Protection(..)- , Flag(..)- , mmap- , alignSize- , mremap- , munmap--- , mprotect- , getPageSize- ) where--import Control.Monad-import GHC.IOBase-import Foreign.C-import Foreign-import Data.Bits-import Numeric-import Data.List-import Data.Char--foreign import ccall unsafe "mmap" c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> CInt -> IO (Ptr a)-foreign import ccall unsafe "munmap" c_munmap :: Ptr a -> CSize -> IO CInt-foreign import ccall unsafe "mremap" c_mremap :: Ptr a -> CSize -> CSize -> CInt -> IO (Ptr a)---foreign import ccall unsafe "mprotect" c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt--foreign import ccall unsafe "getpagesize" c_getpagesize :: IO CInt--getPageSize :: IO Int-getPageSize = liftM fromIntegral c_getpagesize--{--failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)-failWhenNULL name f = do- addr <- f- if addr == nullPtr- then ioError (IOError Nothing ResourceExhausted name - "out of memory" Nothing)- else return addr--}--data Protection- = Execute- | Read- | Write--protToBit Read = 0x1-protToBit Write = 0x2-protToBit Execute = 0x4--data Flag- = Fixed- | Shared- | Private- | Anonymous- | NoReserve--flagToBit Fixed = 0x10-flagToBit Shared = 0x01-flagToBit Private = 0x02-flagToBit Anonymous = 0x20-flagToBit NoReserve = 0x04000--errPtr :: Ptr a-errPtr = nullPtr `plusPtr` (-1)-{--mprotect :: Ptr a -> Int -> [Protection] -> IO ()-mprotect ptr size flags- = let cprot = foldr (.|.) 0 (map protToBit flags)- in do throwErrnoIf (== -1) "mprotect" (c_mprotect ptr (fromIntegral size) cprot)- return ()--}-mmap :: Int -> [Protection] -> [Flag] -> IO (Ptr a)-mmap size prot flags- = do let cprot = foldr (.|.) 0 (map protToBit prot)- cflags = foldr (.|.) 0 (map flagToBit flags)- throwErrnoIf (== errPtr) "mmap" (c_mmap nullPtr (fromIntegral size) cprot cflags (-1) 0)--alignSize :: Int -> IO Int-alignSize size- = do page <- getPageSize- return $ if size <= 0 then page- else (size `div` page) * page + if size `mod` page == 0 then 0 else page--mremap :: Ptr a -> Int -> Int -> IO (Ptr a)-mremap ptr oldSize newSize- = throwErrnoIf (== errPtr) "mremap" (c_mremap ptr (fromIntegral oldSize) (fromIntegral newSize) 1)--munmap :: Ptr a -> Int -> IO ()-munmap ptr size- = throwErrnoIfMinus1_ "munmap" $ c_munmap ptr (fromIntegral size)-{--showSize :: Int -> String-showSize n'- = loop sizes (fromIntegral n')- where loop [] n = showFFloat (Just 0) (n::Float) " bytes"- loop ((s,p):xs) n | n >= s = showFFloat (Just 2) (n/s) p- | otherwise = loop xs n- sizes = [ (giga, " GiB")- , (mega, " MiB")- , (kilo, " KiB")]--}-
src/Data/CompactMap/Types.hs view
@@ -1,26 +1,13 @@-{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fbang-patterns #-}+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE UndecidableInstances, BangPatterns #-} module Data.CompactMap.Types where import Control.Monad import Foreign import Foreign.Storable-import Foreign.C ---import Data.Generics hiding ((:+:),GT)-import Data.Char-import Data.Int-import Data.Binary-import Data.Binary.Put---import Data.Binary.Get (getInthost)-import Data.ByteString.Internal (memcmp,inlinePerformIO)-import qualified Data.ByteString.Unsafe as B----import qualified Data.CompactString as C---import qualified Data.CompactString.Unsafe as C- import GHC.IOBase hiding (Buffer) import GHC.Exts-import GHC.Int data Buffer = Buffer { bufferData :: {-# UNPACK #-} !(IORef (ForeignPtr ()))@@ -43,41 +30,6 @@ case writeIntArray# arr 0# i s of { s -> (# s, () #) } --{--newtype OptInt = OptInt Int deriving (Eq,Ord,Enum,Typeable,Num,Show)-instance Binary OptInt where- {-# INLINE put #-}- put (OptInt i) = putInthost i- {-# INLINE get #-}- get = liftM OptInt getInthost--}-{--data RawString = RawString {-# UNPACK #-} !Int {-# UNPACK #-} !(Ptr CChar)-instance Binary RawString where- put (RawString len ptr) = error "put not defined" -- putCString (ptr,len)- get = error "get not defined" {-do bs <- get- return $! RawString (B.length bs) (unsafePerformIO $ B.unsafeUseAsCString bs return) -}-instance Ord RawString where- {-# INLINE compare #-}- compare (RawString len1 ptr1) (RawString len2 ptr2)- = inlinePerformIO $- do n <- memcmp (castPtr $ ptr1) (castPtr ptr2) (fromIntegral $ min len1 len2)- return $! case n `compare` 0 of- EQ -> compare len1 len2- x -> x-instance Show RawString where- show (RawString len ptr) = show (unsafePerformIO $ B.unsafePackCStringLen (ptr,len))-instance Eq RawString where- a == b = compare a b == EQ--}-{--instance C.Encoding a => Binary (C.CompactString a) where- {-# INLINE put #-}- put = put . C.toByteString- {-# INLINE get #-}- get = fmap C.unsafeFromByteString get--} data KeyCursor data DataCursor