diff --git a/compact-map.cabal b/compact-map.cabal --- a/compact-map.cabal +++ b/compact-map.cabal @@ -1,24 +1,28 @@ Name: compact-map -Version: 2008.11.8 +Version: 2008.11.9 Author: David Himmelstrup Maintainer: David Himmelstrup Copyright: 2008 David Himmelstrup 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: + . + Benchmarks can be found here: diff --git a/src/Data/CompactMap.hs b/src/Data/CompactMap.hs --- a/src/Data/CompactMap.hs +++ b/src/Data/CompactMap.hs @@ -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 diff --git a/src/Data/CompactMap/Buffer.hs b/src/Data/CompactMap/Buffer.hs --- a/src/Data/CompactMap/Buffer.hs +++ b/src/Data/CompactMap/Buffer.hs @@ -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 diff --git a/src/Data/CompactMap/Fetch.hs b/src/Data/CompactMap/Fetch.hs --- a/src/Data/CompactMap/Fetch.hs +++ b/src/Data/CompactMap/Fetch.hs @@ -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) --} diff --git a/src/Data/CompactMap/Index.hs b/src/Data/CompactMap/Index.hs --- a/src/Data/CompactMap/Index.hs +++ b/src/Data/CompactMap/Index.hs @@ -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 diff --git a/src/Data/CompactMap/MemoryMap.hs b/src/Data/CompactMap/MemoryMap.hs deleted file mode 100644 --- a/src/Data/CompactMap/MemoryMap.hs +++ /dev/null @@ -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")] --} - diff --git a/src/Data/CompactMap/Types.hs b/src/Data/CompactMap/Types.hs --- a/src/Data/CompactMap/Types.hs +++ b/src/Data/CompactMap/Types.hs @@ -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