diff --git a/System/IO/MMap.hs b/System/IO/MMap.hs --- a/System/IO/MMap.hs +++ b/System/IO/MMap.hs @@ -2,8 +2,8 @@ -- | -- Module : System.IO.MMap -- Copyright : (c) Gracjan Polak 2009 --- License : BSD-style --- +-- License : BSD-style +-- -- Stability : experimental -- Portability : portable -- @@ -36,23 +36,21 @@ where import System.IO () -import Foreign.Ptr (Ptr,FunPtr,nullPtr,plusPtr,minusPtr,castPtr) +import Foreign.Ptr (Ptr,FunPtr,nullPtr,plusPtr,castPtr) import Foreign.C.Types (CInt(..),CLLong(..),CSize(..)) -import Foreign.C.String (CString(..),withCString) -import Foreign.ForeignPtr (ForeignPtr,withForeignPtr,finalizeForeignPtr,newForeignPtr,newForeignPtrEnv,newForeignPtr_) -import Foreign.Storable( poke ) -import Foreign.Marshal.Alloc( malloc, mallocBytes, free ) +import Foreign.C.String (CString,withCString) +import Foreign.ForeignPtr (ForeignPtr,withForeignPtr,finalizeForeignPtr,newForeignPtr,newForeignPtrEnv) import Foreign.C.Error -import qualified Foreign.Concurrent( newForeignPtr ) import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Internal as BS (fromForeignPtr) import Data.Int (Int64) -import Control.Monad (when,liftM) -import Control.Exception +import Control.Monad (when) +import qualified Control.Exception as E (bracketOnError, bracket, finally) import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Lazy as BSL (ByteString,fromChunks) +import Prelude hiding (length) -import Debug.Trace +--import Debug.Trace -- TODO: -- - support native characters (Unicode) in FilePath @@ -167,17 +165,17 @@ deriving (Eq,Ord,Enum,Show,Read) sanitizeFileRegion :: (Integral a,Bounded a) => String -> ForeignPtr () -> Mode -> Maybe (Int64,a) -> IO (Int64,a) -sanitizeFileRegion filepath handle ReadWriteEx (Just region@(offset,length)) = - withForeignPtr handle $ \handle -> do +sanitizeFileRegion filepath handle' ReadWriteEx (Just region@(offset,length)) = + withForeignPtr handle' $ \handle -> do longsize <- c_system_io_file_size handle let needsize = fromIntegral (offset + fromIntegral length) - when (longsize < needsize) - ((throwErrnoPathIfMinus1 "extend file size" filepath $ + when (longsize < needsize) + ((throwErrnoPathIfMinus1 "extend file size" filepath $ c_system_io_extend_file_size handle needsize) >> return ()) - return region -sanitizeFileRegion filepath handle ReadWriteEx _ + return region +sanitizeFileRegion _filepath _handle ReadWriteEx _ = error "sanitizeRegion given ReadWriteEx with no region, please check earlier for this" -sanitizeFileRegion filepath handle mode region = withForeignPtr handle $ \handle -> do +sanitizeFileRegion filepath handle' mode region = withForeignPtr handle' $ \handle -> do longsize <- c_system_io_file_size handle >>= \x -> return (fromIntegral x) let Just (_,sizetype) = region (offset,size) <- case region of @@ -196,7 +194,7 @@ return (offset,size) checkModeRegion :: FilePath -> Mode -> Maybe a -> IO () -checkModeRegion filepath ReadWriteEx Nothing = +checkModeRegion filepath ReadWriteEx Nothing = ioError (errnoToIOError "mmap ReadWriteEx must have explicit region" eINVAL Nothing (Just filepath)) checkModeRegion _ _ _ = return () @@ -216,7 +214,7 @@ -- -- Use @munmapFilePtr ptr rawsize@ to unmap memory. -- --- Memory mapped files will behave as if they were read lazily +-- Memory mapped files will behave as if they were read lazily -- pages from the file will be loaded into memory on demand. -- @@ -226,16 +224,16 @@ -> IO (Ptr a,Int,Int,Int) -- ^ (ptr,rawsize,offset,size) mmapFilePtr filepath mode offsetsize = do checkModeRegion filepath mode offsetsize - bracket (mmapFileOpen filepath mode) + E.bracket (mmapFileOpen filepath mode) (finalizeForeignPtr) mmap where - mmap handle = do - (offset,size) <- sanitizeFileRegion filepath handle mode offsetsize + mmap handle' = do + (offset,size) <- sanitizeFileRegion filepath handle' mode offsetsize let align = offset `mod` fromIntegral c_system_io_granularity let offsetraw = offset - align let sizeraw = size + fromIntegral align - ptr <- withForeignPtr handle $ \handle -> - c_system_io_mmap_mmap handle (fromIntegral $ fromEnum mode) + ptr <- withForeignPtr handle' $ \handle -> + c_system_io_mmap_mmap handle (fromIntegral $ fromEnum mode) (fromIntegral offsetraw) (fromIntegral sizeraw) when (ptr == nullPtr) $ throwErrnoPath ("mmap of '" ++ filepath ++ "' failed") filepath @@ -254,14 +252,14 @@ mmapWithFilePtr filepath mode offsetsize action = do checkModeRegion filepath mode offsetsize (ptr,rawsize,offset,size) <- mmapFilePtr filepath mode offsetsize - result <- action (ptr `plusPtr` offset,size) `finally` munmapFilePtr ptr rawsize + result <- action (ptr `plusPtr` offset,size) `E.finally` munmapFilePtr ptr rawsize return result -- | Maps region of file and returns it as 'ForeignPtr'. See 'mmapFilePtr' for details. mmapFileForeignPtr :: FilePath -- ^ name of file to map -> Mode -- ^ access mode -> Maybe (Int64,Int) -- ^ range to map, maps whole file if Nothing - -> IO (ForeignPtr a,Int,Int) -- ^ foreign pointer to beginning of raw region, + -> IO (ForeignPtr a,Int,Int) -- ^ foreign pointer to beginning of raw region, -- offset to your data and size of your data mmapFileForeignPtr filepath mode range = do checkModeRegion filepath mode range @@ -280,42 +278,54 @@ let bytestring = BS.fromForeignPtr foreignptr offset size return bytestring --- | The 'mmapFileForeignPtrLazy' function maps a file or device into memory, --- returning a list of tuples with the same meaning as in function --- 'mmapFileForeignPtr'. +-- | The 'mmapFileForeignPtrLazy' function maps a file or device into +-- memory, returning a list of tuples with the same meaning as in +-- function 'mmapFileForeignPtr'. -- +-- Chunks are really mapped into memory at the first inspection of a +-- chunk. They are kept in memory while they are referenced, garbage +-- collector takes care of the later. +-- mmapFileForeignPtrLazy :: FilePath -- ^ name of file to mmap -> Mode -- ^ access mode -> Maybe (Int64,Int64) -- ^ range to map, maps whole file if Nothing -> IO [(ForeignPtr a,Int,Int)] -- ^ (ptr,offset,size) mmapFileForeignPtrLazy filepath mode offsetsize = do checkModeRegion filepath mode offsetsize - bracketOnError (mmapFileOpen filepath mode) + E.bracketOnError (mmapFileOpen filepath mode) (finalizeForeignPtr) mmap where mmap handle = do (offset,size) <- sanitizeFileRegion filepath handle mode offsetsize - return $ map (mapChunk handle) (chunks offset size) - -- FIXME: might be we need NOINLINE pragma here, investigate later - mapChunk handle (offset,size) = unsafePerformIO $ - withForeignPtr handle $ \handle -> do - let align = offset `mod` fromIntegral c_system_io_granularity - offsetraw = offset - align - sizeraw = size + fromIntegral align - ptr <- c_system_io_mmap_mmap handle (fromIntegral $ fromEnum mode) - (fromIntegral offsetraw) (fromIntegral sizeraw) - when (ptr == nullPtr) $ - throwErrnoPath ("lazy mmap of '" ++ filepath ++ - "' chunk(" ++ show offset ++ "," ++ show size ++") failed") filepath - let rawsizeptr = castIntToPtr sizeraw - foreignptr <- newForeignPtrEnv c_system_io_mmap_munmap_funptr rawsizeptr ptr - return (foreignptr,fromIntegral offset,size) + return $ map (mmapFileForeignPtrLazyChunk filepath mode handle) (chunks offset size) + +{-# NOINLINE mmapFileForeignPtrLazyChunk #-} +mmapFileForeignPtrLazyChunk :: FilePath + -> Mode + -> ForeignPtr () + -> (Int64, Int) + -> (ForeignPtr a, Int, Int) +mmapFileForeignPtrLazyChunk filepath mode handle' (offset,size) = unsafePerformIO $ + withForeignPtr handle' $ \handle -> do + let align = offset `mod` fromIntegral c_system_io_granularity + offsetraw = offset - align + sizeraw = size + fromIntegral align + ptr <- c_system_io_mmap_mmap handle (fromIntegral $ fromEnum mode) + (fromIntegral offsetraw) (fromIntegral sizeraw) + when (ptr == nullPtr) $ + throwErrnoPath ("lazy mmap of '" ++ filepath ++ + "' chunk(" ++ show offset ++ "," ++ show size ++") failed") filepath + let rawsizeptr = castIntToPtr sizeraw + foreignptr <- newForeignPtrEnv c_system_io_mmap_munmap_funptr rawsizeptr ptr + return (foreignptr,fromIntegral offset,size) + chunks :: Int64 -> Int64 -> [(Int64,Int)] -chunks offset 0 = [] +chunks _offset 0 = [] chunks offset size | size <= fromIntegral chunkSize = [(offset,fromIntegral size)] - | otherwise = let offset2 = ((offset + chunkSize + chunkSize - 1) `div` chunkSize) * chunkSize + | otherwise = let offset2 = ((offset + chunkSizeLong * 2 - 1) `div` chunkSizeLong) * chunkSizeLong size2 = offset2 - offset + chunkSizeLong = fromIntegral chunkSize in (offset,fromIntegral size2) : chunks offset2 (size-size2) -- | Maps region of file and returns it as 'BSL.ByteString'. File is @@ -337,20 +347,20 @@ -> IO () munmapFilePtr ptr rawsize = c_system_io_mmap_munmap (castIntToPtr rawsize) ptr -chunkSize :: Num a => a -chunkSize = fromIntegral $ (128*1024 `div` c_system_io_granularity) * c_system_io_granularity +chunkSize :: Int +chunkSize = (128*1024 `div` fromIntegral c_system_io_granularity) * fromIntegral c_system_io_granularity mmapFileOpen :: FilePath -> Mode -> IO (ForeignPtr ()) -mmapFileOpen filepath mode = do - ptr <- withCString filepath $ \filepath -> +mmapFileOpen filepath' mode = do + ptr <- withCString filepath' $ \filepath -> c_system_io_mmap_file_open filepath (fromIntegral $ fromEnum mode) when (ptr == nullPtr) $ - throwErrnoPath ("opening of '" ++ filepath ++ "' failed") filepath + throwErrnoPath ("opening of '" ++ filepath' ++ "' failed") filepath' handle <- newForeignPtr c_system_io_mmap_file_close ptr return handle -castPtrToInt :: Ptr a -> Int -castPtrToInt ptr = ptr `minusPtr` nullPtr +--castPtrToInt :: Ptr a -> Int +--castPtrToInt ptr = ptr `minusPtr` nullPtr castIntToPtr :: Int -> Ptr a castIntToPtr int = nullPtr `plusPtr` int diff --git a/mmap.cabal b/mmap.cabal --- a/mmap.cabal +++ b/mmap.cabal @@ -1,5 +1,5 @@ Name: mmap -Version: 0.5.8 +Version: 0.5.9 Stability: stable License: BSD3 License-File: LICENSE @@ -32,6 +32,7 @@ Exposed-modules: System.IO.MMap Hs-source-dirs: . Include-dirs: cbits + GHC-options: -Wall if os(mingw32) C-sources: cbits/win32.c else diff --git a/tests/mmaptest.hs b/tests/mmaptest.hs --- a/tests/mmaptest.hs +++ b/tests/mmaptest.hs @@ -14,15 +14,16 @@ import Control.Concurrent import Test.HUnit import System.Directory -import Foreign.C.Types (CInt,CLLong) +import Foreign.C.Types (CInt(..),CLLong) import Control.Monad import System.IO import Data.Int +import Control.Exception as E #ifdef WINDOWS import qualified System.Win32.File as W #endif -ignoreExceptions doit = (doit >> return ()) `catch` (\e -> return ()) +ignoreExceptions doit = (doit >> return ()) `E.catch` (\(e :: IOError) -> return ()) foreign import ccall unsafe "HsMmap.h system_io_mmap_counters" c_system_io_counters :: IO CInt @@ -76,18 +77,15 @@ test_no_permission_readonly = do let filename = "test_nopermission.bin" - ignoreExceptions $ setPermissions filename (Permissions {readable = True, - writable = True, - executable = True, - searchable = True}) + ignoreExceptions $ setPermissions filename (setOwnerReadable True . + setOwnerWritable True . + setOwnerExecutable True . + setOwnerSearchable True $ emptyPermissions) BSC.writeFile filename content - setPermissions filename (Permissions {readable = False, - writable = False, - executable = False, - searchable = False}) - Permissions {readable = readable} <- getPermissions filename - -- no way to clear read flag under Windows, skip the test - if not readable + setPermissions filename (emptyPermissions) + permissions <- getPermissions filename + -- no way to clear read flag under Windows, skip the test + if not (readable permissions) then ignoreExceptions $ do mmapFileByteString filename Nothing assertFailure "Should throw exception" @@ -162,7 +160,7 @@ BSC.writeFile filename content mmapWithFilePtr filename ReadWriteEx (Just (4,5000)) $ \(ptr,size) -> do size @?= 5000 - bs <- BSC.packCStringLen (castPtr ptr,size) + bs <- BSC.packCStringLen (castPtr ptr,size) bs @?= BSC.take 5000 (BSC.drop 4 (content `BSC.append` BSC.replicate 10000 '\0')) test_delete_while_mmapped = do @@ -170,7 +168,7 @@ BSC.writeFile filename content mmapWithFilePtr filename ReadOnly Nothing $ \(ptr,size) -> do removeFileDelayed filename - bs <- BSC.packCStringLen (castPtr ptr,size) + bs <- BSC.packCStringLen (castPtr ptr,size) bs @?= content v <- doesFileExist filename False @=? v @@ -190,7 +188,7 @@ mmapFileForeignPtrLazy filename ReadWriteEx (Just (0,threegb)) System.Mem.performGC threadDelay 1000 - size <- withFile filename ReadMode hFileSize + size <- withFile filename ReadMode hFileSize size @?= fromIntegral threegb test_create_offset_plus_size_readwriteex = do @@ -198,7 +196,7 @@ ignoreExceptions $ removeFile filename mmapWithFilePtr filename ReadWriteEx (Just (4,5000)) $ \(ptr,size) -> do size @?= 5000 - bs <- BSC.packCStringLen (castPtr ptr,size) + bs <- BSC.packCStringLen (castPtr ptr,size) bs @?= BSC.replicate 5000 '\0' test_create_readwriteex_no_way = do @@ -220,7 +218,7 @@ test_change_two_places = do let filename = "test_normalAB.bin" BSC.writeFile filename content - mmapWithFilePtr filename ReadWrite Nothing $ \(ptr1,size1) -> + mmapWithFilePtr filename ReadWrite Nothing $ \(ptr1,size1) -> do -- this should change one common memory let v1 = 0x41414141::Int32 @@ -229,13 +227,13 @@ v2 @?= v1 bs2 <- mmapFileByteString filename Nothing size1 @?= BSC.length bs2 - bs1 <- BSC.packCStringLen (castPtr ptr1,size1) + bs1 <- BSC.packCStringLen (castPtr ptr1,size1) bs1 @?= bs2 test_change_read_write = do let filename = "test_normalAC.bin" BSC.writeFile filename content - mmapWithFilePtr filename ReadWrite Nothing $ \(ptr1,size1) -> + mmapWithFilePtr filename ReadWrite Nothing $ \(ptr1,size1) -> do poke (castPtr ptr1) (0x41414141::Int32) bs3 <- BSC.readFile filename @@ -244,7 +242,7 @@ test_writecopy = do let filename = "test_normalAD.bin" BSC.writeFile filename content - mmapWithFilePtr filename WriteCopy Nothing $ \(ptr1,size1) -> + mmapWithFilePtr filename WriteCopy Nothing $ \(ptr1,size1) -> do poke (castPtr ptr1) (0x41414141::Int32) -- change should NOT be reflected in file on disk @@ -257,46 +255,46 @@ counters <- c_system_io_counters return (counters @?= 0) -alltests = [ "Normal read only mmap" ~: +alltests = [ "Normal read only mmap" ~: test_normal_readonly - , "Normal read only mmap lazy" ~: + , "Normal read only mmap lazy" ~: test_normal_readonly_lazy - , "Zero length file mmap" ~: + , "Zero length file mmap" ~: test_normal_readonly_zero_length - , "File does not exist" ~: + , "File does not exist" ~: test_non_existing_readonly - , "No permission to read file" ~: + , "No permission to read file" ~: test_no_permission_readonly - , "Signal error when negative offset given" ~: + , "Signal error when negative offset given" ~: test_normal_negative_offset_readonly , "Signal error when negative size given" ~: test_normal_negative_size_readonly - , "Test if we can cut part of file" ~: + , "Test if we can cut part of file" ~: test_normal_offset_size_readonly - , "Test if we can cut zero length part of file" ~: + , "Test if we can cut zero length part of file" ~: test_normal_offset_size_zero_readonly - , "Test if we can cut zero length part of file lazy" ~: + , "Test if we can cut zero length part of file lazy" ~: test_normal_offset_size_zero_readonly_lazy - , "Should throw error if mmaping readonly beyond end of file" ~: + , "Should throw error if mmaping readonly beyond end of file" ~: test_normal_offset_beyond_eof_readonly - , "Should throw error if mmaping readonly beyond end of file lazy" ~: + , "Should throw error if mmaping readonly beyond end of file lazy" ~: test_normal_offset_beyond_eof_readonly_lazy - , "Should throw error if mmaping readonly with size beyond end of file" ~: + , "Should throw error if mmaping readonly with size beyond end of file" ~: test_normal_offset_plus_size_beyond_eof_readonly - , "Should throw error if mmaping readonly with size beyond end of file lazy" ~: + , "Should throw error if mmaping readonly with size beyond end of file lazy" ~: test_normal_offset_plus_size_beyond_eof_readonly_lazy - , "Should ReadWriteEx mmap existing file and resize" ~: + , "Should ReadWriteEx mmap existing file and resize" ~: test_normal_offset_plus_size_beyond_eof_readwriteex , "Should ReadWriteEx mmap new file and resize" ~: test_create_offset_plus_size_readwriteex , "ReadWriteEx must have range specified" ~: test_create_nothing_readwriteex_should_throw , "Report error in file creation" ~: - test_create_readwriteex_no_way + test_create_readwriteex_no_way , "ReadWriteEx in lazy mode should set file size even if not touching" ~: test_readwriteex_lazy_make_dont_touch , "Remove file while mmaped" ~: - test_delete_while_mmapped + test_delete_while_mmapped , "MMap byte string many times" ~: test_normal_readonly_many_times , "Mmap common memory" ~: @@ -307,7 +305,7 @@ test_writecopy --, "ReadWriteEx in lazy should extend file beyond 3GB when mapped in" ~: - -- Test_readwriteex_lazy_make_a_touch + -- Test_readwriteex_lazy_make_a_touch -- insert tests above this line , "Counters should be zero" ~: test_counters_zero @@ -344,4 +342,3 @@ threadDelay 10000 -} -