diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/System/IO/MMap.hs b/System/IO/MMap.hs --- a/System/IO/MMap.hs +++ b/System/IO/MMap.hs @@ -1,391 +1,391 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} --- | --- Module : System.IO.MMap --- Copyright : (c) Gracjan Polak 2009 --- License : BSD-style --- --- Stability : experimental --- Portability : portable --- --- This library provides a wrapper to mmap(2) or MapViewOfFile, --- allowing files or devices to be lazily loaded into memory as strict --- or lazy ByteStrings, ForeignPtrs or plain Ptrs, using the virtual --- memory subsystem to do on-demand loading. Modifications are also --- supported. - - -module System.IO.MMap -( - -- $mmap_intro - - -- * Mapping mode - Mode(..), - - -- * Memory mapped files strict interface - mmapFilePtr, - mmapWithFilePtr, - mmapFileForeignPtr, - mmapFileByteString, - - munmapFilePtr, - - -- * Memory mapped files lazy interface - mmapFileForeignPtrLazy, - mmapFileByteStringLazy -) -where - -import System.IO () -import Foreign.Ptr (Ptr,FunPtr,nullPtr,plusPtr,minusPtr,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.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 qualified Data.ByteString as BS (ByteString) -import qualified Data.ByteString.Lazy as BSL (ByteString,fromChunks) - -import Debug.Trace - --- TODO: --- - support native characters (Unicode) in FilePath --- - support externally given HANDLEs and FDs --- - support data commit --- - support memory region resize - --- $mmap_intro --- --- This module is an interface to @mmap(2)@ system call under POSIX --- (Unix, Linux, Mac OS X) and @CreateFileMapping@, @MapViewOfFile@ under --- Windows. --- --- We can consider mmap as lazy IO pushed into the virtual memory --- subsystem. --- --- It is only safe to mmap a file if you know you are the sole --- user. Otherwise referential transparency may be or may be not --- compromised. Sadly semantics differ much between operating systems. --- --- In case of IO errors all function use 'throwErrno' or 'throwErrnoPath'. --- --- In case of 'ForeignPtr' or 'BS.ByteString' functions the storage --- manager is used to free the mapped memory. When the garbage --- collector notices there are no further references to the mapped --- memory, a call to @munmap@ is made. It is not necessary to do this --- yourself. In tight memory situations it may be profitable to use --- 'System.Mem.performGC' or 'finalizeForeignPtr' to force an unmap --- action. You can also use 'mmapWithFilePtr' that uses scope based --- resource allocation. --- --- To free resources returned as Ptr use 'munmapFilePtr'. --- --- For modes 'ReadOnly', 'ReadWrite' and 'WriteCopy' file must exist --- before mapping it into memory. It also needs to have correct --- permissions for reading and/or writing (depending on mode). In --- 'ReadWriteEx' the file will be created with default permissions if --- it does not exist. --- --- If mode is 'ReadWrite', 'ReadWriteEx' or 'WriteCopy' the returned --- memory region may be written to with 'Foreign.Storable.poke' and --- friends. In 'WriteCopy' mode changes will not be written to disk. --- It is an error to modify mapped memory in 'ReadOnly' mode. If is --- undefined if and how changes from external changes affect your --- mmapped regions, they may reflect in your memory or may not and --- this note applies equally to all modes. --- --- Range specified may be 'Nothing', in this case whole file will be --- mapped. Otherwise range should be 'Just (offset,size)' where --- offsets is the beginning byte of file region to map and size tells --- mapping length. There are no alignment requirements. Returned Ptr or --- ForeignPtr will be aligned to page size boundary and you'll be --- given offset to your data. Both @offset@ and @size@ must be --- nonnegative. Sum @offset + size@ should not be greater than file --- length, except in 'ReadWriteEx' mode when file will be extended to --- cover whole range. We do allow @size@ to be 0 and we do mmap files --- of 0 length. If your offset is 0 you are guaranteed to receive page --- aligned pointer back. You are required to give explicit range in --- case of 'ReadWriteEx' even if the file exists. --- --- File extension in 'ReadWriteEx' mode seems to use sparse files --- whenever supported by oprating system and therefore returns --- immediatelly as postpones real block allocation for later. --- --- For more details about mmap and its consequences see: --- --- * --- --- * --- --- * --- --- Questions and Answers --- --- * Q: What happens if somebody writes to my mmapped file? A: --- Undefined. System is free to not synchronize write system call and --- mmap so nothing is sure. So this might be reflected in your memory --- or not. This applies even in 'WriteCopy' mode. --- --- * Q: What happens if I map 'ReadWrite' and change memory? A: After --- some time in will be written to disk. It is unspecified when this --- happens. --- --- * Q: What if somebody removes my file? A: Undefined. File with --- mmapped region is treated by system as open file. Removing such --- file works the same way as removing open file and different systems --- have different ideas what to do in such case. --- --- * Q: Why can't I open my file for writting after mmaping it? A: --- File needs to be unmapped first. Either make sure you don't --- reference memory mapped regions and force garbage collection (this --- is hard to do) or better yet use mmaping with explicit memory --- management. --- --- * Q: Can I map region after end of file? A: You need to use --- 'ReadWriteEx' mode. --- - - --- | Mode of mapping. Four cases are supported. -data Mode = ReadOnly -- ^ file is mapped read-only, file must - -- exist - | ReadWrite -- ^ file is mapped read-write, file must - -- exist - | WriteCopy -- ^ file is mapped read-write, but changes - -- aren't propagated to disk, file must exist - | ReadWriteEx -- ^ file is mapped read-write, if file does - -- not exist it will be created with default - -- permissions, region parameter specifies - -- size, if file size is lower it will be - -- extended with zeros - 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 - longsize <- c_system_io_file_size handle - let needsize = fromIntegral (offset + fromIntegral length) - when (longsize < needsize) - ((throwErrnoPathIfMinus1 "extend file size" filepath $ - c_system_io_extend_file_size handle needsize) >> return ()) - 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 - longsize <- c_system_io_file_size handle >>= \x -> return (fromIntegral x) - let Just (_,sizetype) = region - (offset,size) <- case region of - Just (offset,size) -> do - when (size<0) $ - ioError (errnoToIOError "mmap negative size reguested" eINVAL Nothing (Just filepath)) - when (offset<0) $ - ioError (errnoToIOError "mmap negative offset reguested" eINVAL Nothing (Just filepath)) - when (mode/=ReadWriteEx && (longsize do - when (longsize > fromIntegral (maxBound `asTypeOf` sizetype)) $ - ioError (errnoToIOError "mmap requested size is greater then maxBound" eINVAL Nothing (Just filepath)) - return (0,fromIntegral longsize) - return (offset,size) - -checkModeRegion :: FilePath -> Mode -> Maybe a -> IO () -checkModeRegion filepath ReadWriteEx Nothing = - ioError (errnoToIOError "mmap ReadWriteEx must have explicit region" eINVAL Nothing (Just filepath)) -checkModeRegion _ _ _ = return () - --- | The 'mmapFilePtr' function maps a file or device into memory, --- returning a tuple @(ptr,rawsize,offset,size)@ where: --- --- * @ptr@ is pointer to mmapped region --- --- * @rawsize@ is length (in bytes) of mapped data, rawsize might be --- greater than size because of alignment --- --- * @offset@ tell where your data lives: @plusPtr ptr offset@ --- --- * @size@ your data length (in bytes) --- --- If 'mmapFilePtr' fails for some reason, a 'throwErrno' is used. --- --- Use @munmapFilePtr ptr rawsize@ to unmap memory. --- --- Memory mapped files will behave as if they were read lazily --- pages from the file will be loaded into memory on demand. --- - -mmapFilePtr :: FilePath -- ^ name of file to mmap - -> Mode -- ^ access mode - -> Maybe (Int64,Int) -- ^ range to map, maps whole file if Nothing - -> IO (Ptr a,Int,Int,Int) -- ^ (ptr,rawsize,offset,size) -mmapFilePtr filepath mode offsetsize = do - checkModeRegion filepath mode offsetsize - bracket (mmapFileOpen filepath mode) - (finalizeForeignPtr) mmap - where - 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) - (fromIntegral offsetraw) (fromIntegral sizeraw) - when (ptr == nullPtr) $ - throwErrnoPath ("mmap of '" ++ filepath ++ "' failed") filepath - return (castPtr ptr,sizeraw,fromIntegral align,size) - --- | Memory map region of file using autounmap semantics. See --- 'mmapFilePtr' for description of parameters. The @action@ will be --- executed with tuple @(ptr,size)@ as single argument. This is the --- pointer to mapped data already adjusted and size of requested --- region. Return value is that of action. -mmapWithFilePtr :: FilePath -- ^ name of file to mmap - -> Mode -- ^ access mode - -> Maybe (Int64,Int) -- ^ range to map, maps whole file if Nothing - -> ((Ptr (),Int) -> IO a) -- ^ action to run - -> IO a -- ^ result of action -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 - 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, - -- offset to your data and size of your data -mmapFileForeignPtr filepath mode range = do - checkModeRegion filepath mode range - (rawptr,rawsize,offset,size) <- mmapFilePtr filepath mode range - let rawsizeptr = castIntToPtr rawsize - foreignptr <- newForeignPtrEnv c_system_io_mmap_munmap_funptr rawsizeptr rawptr - return (foreignptr,offset,size) - --- | Maps region of file and returns it as 'BS.ByteString'. File is --- mapped in in 'ReadOnly' mode. See 'mmapFilePtr' for details. -mmapFileByteString :: FilePath -- ^ name of file to map - -> Maybe (Int64,Int) -- ^ range to map, maps whole file if Nothing - -> IO BS.ByteString -- ^ bytestring with file contents -mmapFileByteString filepath range = do - (foreignptr,offset,size) <- mmapFileForeignPtr filepath ReadOnly range - 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'. --- -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) - (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) - -chunks :: Int64 -> Int64 -> [(Int64,Int)] -chunks offset 0 = [] -chunks offset size | size <= fromIntegral chunkSize = [(offset,fromIntegral size)] - | otherwise = let offset2 = ((offset + chunkSize + chunkSize - 1) `div` chunkSize) * chunkSize - size2 = offset2 - offset - in (offset,fromIntegral size2) : chunks offset2 (size-size2) - --- | Maps region of file and returns it as 'BSL.ByteString'. File is --- mapped in in 'ReadOnly' mode. See 'mmapFileForeignPtrLazy' for --- details. -mmapFileByteStringLazy :: FilePath -- ^ name of file to map - -> Maybe (Int64,Int64) -- ^ range to map, maps whole file if Nothing - -> IO BSL.ByteString -- ^ bytestring with file content -mmapFileByteStringLazy filepath offsetsize = do - list <- mmapFileForeignPtrLazy filepath ReadOnly offsetsize - return (BSL.fromChunks (map turn list)) - where - turn (foreignptr,offset,size) = BS.fromForeignPtr foreignptr offset size - --- | Unmaps memory region. As parameters use values marked as ptr and --- rawsize in description of 'mmapFilePtr'. -munmapFilePtr :: Ptr a -- ^ pointer - -> Int -- ^ rawsize - -> 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 - -mmapFileOpen :: FilePath -> Mode -> IO (ForeignPtr ()) -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 - handle <- newForeignPtr c_system_io_mmap_file_close ptr - return handle - -castPtrToInt :: Ptr a -> Int -castPtrToInt ptr = ptr `minusPtr` nullPtr - -castIntToPtr :: Int -> Ptr a -castIntToPtr int = nullPtr `plusPtr` int - - --- | Should open file given as CString in mode given as CInt -foreign import ccall unsafe "HsMmap.h system_io_mmap_file_open" - c_system_io_mmap_file_open :: CString -- ^ file path, system encoding - -> CInt -- ^ mode as 0, 1, 2, fromEnum - -> IO (Ptr ()) -- ^ file handle returned, nullPtr on error (and errno set) --- | Used in finalizers, to close handle -foreign import ccall unsafe "HsMmap.h &system_io_mmap_file_close" - c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ()) - --- | Mmemory maps file from handle, using mode, starting offset and size -foreign import ccall unsafe "HsMmap.h system_io_mmap_mmap" - c_system_io_mmap_mmap :: Ptr () -- ^ handle from c_system_io_mmap_file_open - -> CInt -- ^ mode - -> CLLong -- ^ starting offset, must be nonegative - -> CSize -- ^ length, must be greater than zero - -> IO (Ptr a) -- ^ starting pointer to byte data, nullPtr on error (plus errno set) --- | Used in finalizers -foreign import ccall unsafe "HsMmap.h &system_io_mmap_munmap" - c_system_io_mmap_munmap_funptr :: FunPtr(Ptr () -> Ptr a -> IO ()) --- | Unmap region of memory. Size must be the same as returned by --- mmap. If size is zero, does nothing (treats pointer as invalid) -foreign import ccall unsafe "HsMmap.h system_io_mmap_munmap" - c_system_io_mmap_munmap :: Ptr () -> Ptr a -> IO () --- | Get file size in system specific manner -foreign import ccall unsafe "HsMmap.h system_io_mmap_file_size" - c_system_io_file_size :: Ptr () -> IO CLLong --- | Set file size in system specific manner. It is guaranteed to be called --- only with new size being at least current size. -foreign import ccall unsafe "HsMmap.h system_io_mmap_extend_file_size" - c_system_io_extend_file_size :: Ptr () -> CLLong -> IO CInt --- | Memory mapping granularity. -foreign import ccall unsafe "HsMmap.h system_io_mmap_granularity" - c_system_io_granularity :: CInt +{-# LANGUAGE ForeignFunctionInterface, CPP #-} +-- | +-- Module : System.IO.MMap +-- Copyright : (c) Gracjan Polak 2009 +-- License : BSD-style +-- +-- Stability : experimental +-- Portability : portable +-- +-- This library provides a wrapper to mmap(2) or MapViewOfFile, +-- allowing files or devices to be lazily loaded into memory as strict +-- or lazy ByteStrings, ForeignPtrs or plain Ptrs, using the virtual +-- memory subsystem to do on-demand loading. Modifications are also +-- supported. + + +module System.IO.MMap +( + -- $mmap_intro + + -- * Mapping mode + Mode(..), + + -- * Memory mapped files strict interface + mmapFilePtr, + mmapWithFilePtr, + mmapFileForeignPtr, + mmapFileByteString, + + munmapFilePtr, + + -- * Memory mapped files lazy interface + mmapFileForeignPtrLazy, + mmapFileByteStringLazy +) +where + +import System.IO () +import Foreign.Ptr (Ptr,FunPtr,nullPtr,plusPtr,minusPtr,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.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 qualified Data.ByteString as BS (ByteString) +import qualified Data.ByteString.Lazy as BSL (ByteString,fromChunks) + +import Debug.Trace + +-- TODO: +-- - support native characters (Unicode) in FilePath +-- - support externally given HANDLEs and FDs +-- - support data commit +-- - support memory region resize + +-- $mmap_intro +-- +-- This module is an interface to @mmap(2)@ system call under POSIX +-- (Unix, Linux, Mac OS X) and @CreateFileMapping@, @MapViewOfFile@ under +-- Windows. +-- +-- We can consider mmap as lazy IO pushed into the virtual memory +-- subsystem. +-- +-- It is only safe to mmap a file if you know you are the sole +-- user. Otherwise referential transparency may be or may be not +-- compromised. Sadly semantics differ much between operating systems. +-- +-- In case of IO errors all function use 'throwErrno' or 'throwErrnoPath'. +-- +-- In case of 'ForeignPtr' or 'BS.ByteString' functions the storage +-- manager is used to free the mapped memory. When the garbage +-- collector notices there are no further references to the mapped +-- memory, a call to @munmap@ is made. It is not necessary to do this +-- yourself. In tight memory situations it may be profitable to use +-- 'System.Mem.performGC' or 'finalizeForeignPtr' to force an unmap +-- action. You can also use 'mmapWithFilePtr' that uses scope based +-- resource allocation. +-- +-- To free resources returned as Ptr use 'munmapFilePtr'. +-- +-- For modes 'ReadOnly', 'ReadWrite' and 'WriteCopy' file must exist +-- before mapping it into memory. It also needs to have correct +-- permissions for reading and/or writing (depending on mode). In +-- 'ReadWriteEx' the file will be created with default permissions if +-- it does not exist. +-- +-- If mode is 'ReadWrite', 'ReadWriteEx' or 'WriteCopy' the returned +-- memory region may be written to with 'Foreign.Storable.poke' and +-- friends. In 'WriteCopy' mode changes will not be written to disk. +-- It is an error to modify mapped memory in 'ReadOnly' mode. If is +-- undefined if and how changes from external changes affect your +-- mmapped regions, they may reflect in your memory or may not and +-- this note applies equally to all modes. +-- +-- Range specified may be 'Nothing', in this case whole file will be +-- mapped. Otherwise range should be 'Just (offset,size)' where +-- offsets is the beginning byte of file region to map and size tells +-- mapping length. There are no alignment requirements. Returned Ptr or +-- ForeignPtr will be aligned to page size boundary and you'll be +-- given offset to your data. Both @offset@ and @size@ must be +-- nonnegative. Sum @offset + size@ should not be greater than file +-- length, except in 'ReadWriteEx' mode when file will be extended to +-- cover whole range. We do allow @size@ to be 0 and we do mmap files +-- of 0 length. If your offset is 0 you are guaranteed to receive page +-- aligned pointer back. You are required to give explicit range in +-- case of 'ReadWriteEx' even if the file exists. +-- +-- File extension in 'ReadWriteEx' mode seems to use sparse files +-- whenever supported by oprating system and therefore returns +-- immediatelly as postpones real block allocation for later. +-- +-- For more details about mmap and its consequences see: +-- +-- * +-- +-- * +-- +-- * +-- +-- Questions and Answers +-- +-- * Q: What happens if somebody writes to my mmapped file? A: +-- Undefined. System is free to not synchronize write system call and +-- mmap so nothing is sure. So this might be reflected in your memory +-- or not. This applies even in 'WriteCopy' mode. +-- +-- * Q: What happens if I map 'ReadWrite' and change memory? A: After +-- some time in will be written to disk. It is unspecified when this +-- happens. +-- +-- * Q: What if somebody removes my file? A: Undefined. File with +-- mmapped region is treated by system as open file. Removing such +-- file works the same way as removing open file and different systems +-- have different ideas what to do in such case. +-- +-- * Q: Why can't I open my file for writting after mmaping it? A: +-- File needs to be unmapped first. Either make sure you don't +-- reference memory mapped regions and force garbage collection (this +-- is hard to do) or better yet use mmaping with explicit memory +-- management. +-- +-- * Q: Can I map region after end of file? A: You need to use +-- 'ReadWriteEx' mode. +-- + + +-- | Mode of mapping. Four cases are supported. +data Mode = ReadOnly -- ^ file is mapped read-only, file must + -- exist + | ReadWrite -- ^ file is mapped read-write, file must + -- exist + | WriteCopy -- ^ file is mapped read-write, but changes + -- aren't propagated to disk, file must exist + | ReadWriteEx -- ^ file is mapped read-write, if file does + -- not exist it will be created with default + -- permissions, region parameter specifies + -- size, if file size is lower it will be + -- extended with zeros + 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 + longsize <- c_system_io_file_size handle + let needsize = fromIntegral (offset + fromIntegral length) + when (longsize < needsize) + ((throwErrnoPathIfMinus1 "extend file size" filepath $ + c_system_io_extend_file_size handle needsize) >> return ()) + 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 + longsize <- c_system_io_file_size handle >>= \x -> return (fromIntegral x) + let Just (_,sizetype) = region + (offset,size) <- case region of + Just (offset,size) -> do + when (size<0) $ + ioError (errnoToIOError "mmap negative size reguested" eINVAL Nothing (Just filepath)) + when (offset<0) $ + ioError (errnoToIOError "mmap negative offset reguested" eINVAL Nothing (Just filepath)) + when (mode/=ReadWriteEx && (longsize do + when (longsize > fromIntegral (maxBound `asTypeOf` sizetype)) $ + ioError (errnoToIOError "mmap requested size is greater then maxBound" eINVAL Nothing (Just filepath)) + return (0,fromIntegral longsize) + return (offset,size) + +checkModeRegion :: FilePath -> Mode -> Maybe a -> IO () +checkModeRegion filepath ReadWriteEx Nothing = + ioError (errnoToIOError "mmap ReadWriteEx must have explicit region" eINVAL Nothing (Just filepath)) +checkModeRegion _ _ _ = return () + +-- | The 'mmapFilePtr' function maps a file or device into memory, +-- returning a tuple @(ptr,rawsize,offset,size)@ where: +-- +-- * @ptr@ is pointer to mmapped region +-- +-- * @rawsize@ is length (in bytes) of mapped data, rawsize might be +-- greater than size because of alignment +-- +-- * @offset@ tell where your data lives: @plusPtr ptr offset@ +-- +-- * @size@ your data length (in bytes) +-- +-- If 'mmapFilePtr' fails for some reason, a 'throwErrno' is used. +-- +-- Use @munmapFilePtr ptr rawsize@ to unmap memory. +-- +-- Memory mapped files will behave as if they were read lazily +-- pages from the file will be loaded into memory on demand. +-- + +mmapFilePtr :: FilePath -- ^ name of file to mmap + -> Mode -- ^ access mode + -> Maybe (Int64,Int) -- ^ range to map, maps whole file if Nothing + -> IO (Ptr a,Int,Int,Int) -- ^ (ptr,rawsize,offset,size) +mmapFilePtr filepath mode offsetsize = do + checkModeRegion filepath mode offsetsize + bracket (mmapFileOpen filepath mode) + (finalizeForeignPtr) mmap + where + 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) + (fromIntegral offsetraw) (fromIntegral sizeraw) + when (ptr == nullPtr) $ + throwErrnoPath ("mmap of '" ++ filepath ++ "' failed") filepath + return (castPtr ptr,sizeraw,fromIntegral align,size) + +-- | Memory map region of file using autounmap semantics. See +-- 'mmapFilePtr' for description of parameters. The @action@ will be +-- executed with tuple @(ptr,size)@ as single argument. This is the +-- pointer to mapped data already adjusted and size of requested +-- region. Return value is that of action. +mmapWithFilePtr :: FilePath -- ^ name of file to mmap + -> Mode -- ^ access mode + -> Maybe (Int64,Int) -- ^ range to map, maps whole file if Nothing + -> ((Ptr (),Int) -> IO a) -- ^ action to run + -> IO a -- ^ result of action +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 + 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, + -- offset to your data and size of your data +mmapFileForeignPtr filepath mode range = do + checkModeRegion filepath mode range + (rawptr,rawsize,offset,size) <- mmapFilePtr filepath mode range + let rawsizeptr = castIntToPtr rawsize + foreignptr <- newForeignPtrEnv c_system_io_mmap_munmap_funptr rawsizeptr rawptr + return (foreignptr,offset,size) + +-- | Maps region of file and returns it as 'BS.ByteString'. File is +-- mapped in in 'ReadOnly' mode. See 'mmapFilePtr' for details. +mmapFileByteString :: FilePath -- ^ name of file to map + -> Maybe (Int64,Int) -- ^ range to map, maps whole file if Nothing + -> IO BS.ByteString -- ^ bytestring with file contents +mmapFileByteString filepath range = do + (foreignptr,offset,size) <- mmapFileForeignPtr filepath ReadOnly range + 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'. +-- +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) + (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) + +chunks :: Int64 -> Int64 -> [(Int64,Int)] +chunks offset 0 = [] +chunks offset size | size <= fromIntegral chunkSize = [(offset,fromIntegral size)] + | otherwise = let offset2 = ((offset + chunkSize + chunkSize - 1) `div` chunkSize) * chunkSize + size2 = offset2 - offset + in (offset,fromIntegral size2) : chunks offset2 (size-size2) + +-- | Maps region of file and returns it as 'BSL.ByteString'. File is +-- mapped in in 'ReadOnly' mode. See 'mmapFileForeignPtrLazy' for +-- details. +mmapFileByteStringLazy :: FilePath -- ^ name of file to map + -> Maybe (Int64,Int64) -- ^ range to map, maps whole file if Nothing + -> IO BSL.ByteString -- ^ bytestring with file content +mmapFileByteStringLazy filepath offsetsize = do + list <- mmapFileForeignPtrLazy filepath ReadOnly offsetsize + return (BSL.fromChunks (map turn list)) + where + turn (foreignptr,offset,size) = BS.fromForeignPtr foreignptr offset size + +-- | Unmaps memory region. As parameters use values marked as ptr and +-- rawsize in description of 'mmapFilePtr'. +munmapFilePtr :: Ptr a -- ^ pointer + -> Int -- ^ rawsize + -> 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 + +mmapFileOpen :: FilePath -> Mode -> IO (ForeignPtr ()) +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 + handle <- newForeignPtr c_system_io_mmap_file_close ptr + return handle + +castPtrToInt :: Ptr a -> Int +castPtrToInt ptr = ptr `minusPtr` nullPtr + +castIntToPtr :: Int -> Ptr a +castIntToPtr int = nullPtr `plusPtr` int + + +-- | Should open file given as CString in mode given as CInt +foreign import ccall unsafe "HsMmap.h system_io_mmap_file_open" + c_system_io_mmap_file_open :: CString -- ^ file path, system encoding + -> CInt -- ^ mode as 0, 1, 2, fromEnum + -> IO (Ptr ()) -- ^ file handle returned, nullPtr on error (and errno set) +-- | Used in finalizers, to close handle +foreign import ccall unsafe "HsMmap.h &system_io_mmap_file_close" + c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ()) + +-- | Mmemory maps file from handle, using mode, starting offset and size +foreign import ccall unsafe "HsMmap.h system_io_mmap_mmap" + c_system_io_mmap_mmap :: Ptr () -- ^ handle from c_system_io_mmap_file_open + -> CInt -- ^ mode + -> CLLong -- ^ starting offset, must be nonegative + -> CSize -- ^ length, must be greater than zero + -> IO (Ptr a) -- ^ starting pointer to byte data, nullPtr on error (plus errno set) +-- | Used in finalizers +foreign import ccall unsafe "HsMmap.h &system_io_mmap_munmap" + c_system_io_mmap_munmap_funptr :: FunPtr(Ptr () -> Ptr a -> IO ()) +-- | Unmap region of memory. Size must be the same as returned by +-- mmap. If size is zero, does nothing (treats pointer as invalid) +foreign import ccall unsafe "HsMmap.h system_io_mmap_munmap" + c_system_io_mmap_munmap :: Ptr () -> Ptr a -> IO () +-- | Get file size in system specific manner +foreign import ccall unsafe "HsMmap.h system_io_mmap_file_size" + c_system_io_file_size :: Ptr () -> IO CLLong +-- | Set file size in system specific manner. It is guaranteed to be called +-- only with new size being at least current size. +foreign import ccall unsafe "HsMmap.h system_io_mmap_extend_file_size" + c_system_io_extend_file_size :: Ptr () -> CLLong -> IO CInt +-- | Memory mapping granularity. +foreign import ccall unsafe "HsMmap.h system_io_mmap_granularity" + c_system_io_granularity :: CInt diff --git a/cbits/posix.c b/cbits/posix.c --- a/cbits/posix.c +++ b/cbits/posix.c @@ -1,165 +1,166 @@ -#include "HsMmap.h" - -#define _LARGEFILE64_SOURCE 1 -#define _FILE_OFFSET_BITS 64 - -#include -#include -#include -#include -#include -#include -#include - -#ifdef _DEBUG -int counters = 0; - -int system_io_mmap_counters() -{ - return counters; -} -#endif - -//foreign import ccall unsafe "system_io_mmap_file_open" c_system_io_mmap_file_open :: CString -> CInt -> IO (Ptr ()) -void *system_io_mmap_file_open(const char *filepath, int mode) -{ - void *handle = NULL; - int access, fd; - if( !filepath ) - return NULL; - switch(mode) { - case 0: - access = O_RDONLY; - break; - case 1: - access = O_RDWR; - break; - case 2: - access = O_RDONLY; - break; - case 3: - access = O_RDWR|O_CREAT; - break; - default: - return NULL; - } -#ifdef O_NOCTTY - access |= O_NOCTTY; -#endif -#ifdef O_LARGEFILE - access |= O_LARGEFILE; -#endif -#ifdef O_NOINHERIT - access |= O_NOINHERIT; -#endif - fd = open(filepath,access,0666); - if( fd == -1 ) { - return NULL; - } -#ifdef _DEBUG - counters++; -#endif - handle = (void *)((intptr_t)fd + 1); - return handle; -} - -//foreign import ccall unsafe "system_io_mmap_file_close" c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ()) -void system_io_mmap_file_close(void *handle) -{ - int fd = (int)(intptr_t)handle - 1; - close(fd); -#ifdef _DEBUG - counters--; -#endif -} - -static char zerolength[1]; - -//foreign import ccall unsafe "system_io_mmap_mmap" c_system_io_mmap_mmap :: Ptr () -> CInt -> CLLong -> CInt -> IO (Ptr ()) -void *system_io_mmap_mmap(void *handle, int mode, long long offset, size_t size) -{ - void *ptr = NULL; - int prot; - int flags; - int fd = (int)(intptr_t)handle - 1; - - switch(mode) { - case 0: - prot = PROT_READ; - flags = MAP_PRIVATE; - break; - case 1: - prot = PROT_READ|PROT_WRITE; - flags = MAP_SHARED; - break; - case 2: - prot = PROT_READ|PROT_WRITE; - flags = MAP_PRIVATE; - break; - case 3: - prot = PROT_READ|PROT_WRITE; - flags = MAP_SHARED; - break; - default: - return NULL; - } - - if( size>0 ) { - ptr = mmap(NULL,size,prot,flags,fd,offset); - - if( ptr == MAP_FAILED ) { - return NULL; - } - } - else { - ptr = zerolength; - } -#ifdef _DEBUG - if( ptr ) { - counters++; - } -#endif - - return ptr; -} - -void system_io_mmap_munmap(void *sizeasptr, void *ptr) // Ptr CInt -> Ptr a -> IO () -{ - size_t size = (size_t)sizeasptr; - int result = 0; - if( size>0 ) { - result = munmap(ptr,size); -#ifdef _DEBUG - if( result==0 ) { - counters--; - } -#endif - } - else { -#ifdef _DEBUG - counters--; -#endif - } -} - -//foreign import ccall unsafe "system_io_mmap_file_size" c_system_io_file_size :: Ptr () -> IO (CLLong) -long long system_io_mmap_file_size(void *handle) -{ - int fd = (int)(intptr_t)handle - 1; - struct stat st; - fstat(fd,&st); - return st.st_size; -} - -int system_io_mmap_extend_file_size(void *handle, long long size) -{ - int fd = (int)(intptr_t)handle - 1; - return ftruncate(fd,size); -} - - -//foreign import ccall unsafe "system_io_mmap_granularity" c_system_io_granularity :: CInt -int system_io_mmap_granularity() -{ - return getpagesize(); -} +#include "HsMmap.h" + +#define _LARGEFILE64_SOURCE 1 +#define _FILE_OFFSET_BITS 64 + +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef _DEBUG +int counters = 0; + +int system_io_mmap_counters() +{ + return counters; +} +#endif + +//foreign import ccall unsafe "system_io_mmap_file_open" c_system_io_mmap_file_open :: CString -> CInt -> IO (Ptr ()) +void *system_io_mmap_file_open(const char *filepath, int mode) +{ + void *handle = NULL; + int access, fd; + if( !filepath ) + return NULL; + switch(mode) { + case 0: + access = O_RDONLY; + break; + case 1: + access = O_RDWR; + break; + case 2: + access = O_RDONLY; + break; + case 3: + access = O_RDWR|O_CREAT; + break; + default: + return NULL; + } +#ifdef O_NOCTTY + access |= O_NOCTTY; +#endif +#ifdef O_LARGEFILE + access |= O_LARGEFILE; +#endif +#ifdef O_NOINHERIT + access |= O_NOINHERIT; +#endif + fd = open(filepath,access,0666); + if( fd == -1 ) { + return NULL; + } +#ifdef _DEBUG + counters++; +#endif + handle = (void *)((intptr_t)fd + 1); + return handle; +} + +//foreign import ccall unsafe "system_io_mmap_file_close" c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ()) +void system_io_mmap_file_close(void *handle) +{ + int fd = (int)(intptr_t)handle - 1; + close(fd); +#ifdef _DEBUG + counters--; +#endif +} + +static char zerolength[1]; + +//foreign import ccall unsafe "system_io_mmap_mmap" c_system_io_mmap_mmap :: Ptr () -> CInt -> CLLong -> CInt -> IO (Ptr ()) +void *system_io_mmap_mmap(void *handle, int mode, long long offset, size_t size) +{ + void *ptr = NULL; + int prot; + int flags; + int fd = (int)(intptr_t)handle - 1; + + switch(mode) { + case 0: + prot = PROT_READ; + flags = MAP_PRIVATE; + break; + case 1: + prot = PROT_READ|PROT_WRITE; + flags = MAP_SHARED; + break; + case 2: + prot = PROT_READ|PROT_WRITE; + flags = MAP_PRIVATE; + break; + case 3: + prot = PROT_READ|PROT_WRITE; + flags = MAP_SHARED; + break; + default: + return NULL; + } + + if( size>0 ) { + ptr = mmap(NULL,size,prot,flags,fd,offset); + + if( ptr == MAP_FAILED ) { + return NULL; + } + } + else { + ptr = zerolength; + } +#ifdef _DEBUG + if( ptr ) { + counters++; + } +#endif + + return ptr; +} + +void system_io_mmap_munmap(void *sizeasptr, void *ptr) // Ptr CInt -> Ptr a -> IO () +{ + size_t size = (size_t)sizeasptr; + int result = 0; + if( size>0 ) { + result = munmap(ptr,size); +#ifdef _DEBUG + if( result==0 ) { + counters--; + } +#endif + } + else { +#ifdef _DEBUG + counters--; +#endif + } +} + +//foreign import ccall unsafe "system_io_mmap_file_size" c_system_io_file_size :: Ptr () -> IO (CLLong) +long long system_io_mmap_file_size(void *handle) +{ + int fd = (int)(intptr_t)handle - 1; + struct stat st; + fstat(fd,&st); + return st.st_size; +} + +int system_io_mmap_extend_file_size(void *handle, long long size) +{ + int fd = (int)(intptr_t)handle - 1; + return ftruncate(fd,size); +} + + +//foreign import ccall unsafe "system_io_mmap_granularity" c_system_io_granularity :: CInt +int system_io_mmap_granularity() +{ + return getpagesize(); +} diff --git a/cbits/win32.c b/cbits/win32.c --- a/cbits/win32.c +++ b/cbits/win32.c @@ -1,206 +1,206 @@ -#include "HsMmap.h" -#include - -#ifdef _DEBUG -int counters = 0; - -int system_io_mmap_counters() -{ - return counters; -} -#endif - - -//foreign import ccall unsafe "system_io_mmap_file_open" c_system_io_mmap_file_open :: CString -> CInt -> IO (Ptr ()) -void *system_io_mmap_file_open(const char *filepath, int mode) -{ - /* - HANDLE WINAPI CreateFileA( - __in LPCTSTR lpFileName, - __in DWORD dwDesiredAccess, - __in DWORD dwShareMode, - __in_opt LPSECURITY_ATTRIBUTES lpSecurityAttributes, - __in DWORD dwCreationDisposition, - __in DWORD dwFlagsAndAttributes, - __in_opt HANDLE hTemplateFile - ); - */ - void *handle = NULL; - DWORD dwDesiredAccess; - DWORD dwCreationDisposition; - if( !filepath ) - return NULL; - switch(mode) { - case 0: - dwDesiredAccess = GENERIC_READ; - dwCreationDisposition = OPEN_EXISTING; - break; - case 1: - dwDesiredAccess = GENERIC_WRITE|GENERIC_READ; - dwCreationDisposition = OPEN_EXISTING; - break; - case 2: - dwDesiredAccess = GENERIC_READ; - dwCreationDisposition = OPEN_EXISTING; - break; - case 3: - dwDesiredAccess = GENERIC_WRITE|GENERIC_READ; - dwCreationDisposition = OPEN_ALWAYS; - break; - default: - return NULL; - } - handle = CreateFileA(filepath, - dwDesiredAccess, - FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, - NULL, - dwCreationDisposition, - FILE_ATTRIBUTE_NORMAL, - NULL); - if( handle==INVALID_HANDLE_VALUE ) - return NULL; -#ifdef _DEBUG - counters++; -#endif - return handle; -} - -//foreign import ccall unsafe "system_io_mmap_file_close" c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ()) -void system_io_mmap_file_close(void *handle) -{ - CloseHandle(handle); -#ifdef _DEBUG - counters--; -#endif -} - -static char zerolength[1]; - -//foreign import ccall unsafe "system_io_mmap_mmap" c_system_io_mmap_mmap :: Ptr () -> CInt -> CLLong -> CInt -> IO (Ptr ()) -void *system_io_mmap_mmap(void *handle, int mode, long long offset, size_t size) -{ - /* - HANDLE WINAPI CreateFileMapping( - __in HANDLE hFile, - __in_opt LPSECURITY_ATTRIBUTES lpAttributes, - __in DWORD flProtect, - __in DWORD dwMaximumSizeHigh, - __in DWORD dwMaximumSizeLow, - __in_opt LPCTSTR lpName - ); - LPVOID WINAPI MapViewOfFile( - __in HANDLE hFileMappingObject, - __in DWORD dwDesiredAccess, - __in DWORD dwFileOffsetHigh, - __in DWORD dwFileOffsetLow, - __in SIZE_T dwNumberOfBytesToMap - ); - */ - HANDLE mapping; - void *ptr = NULL; - DWORD flProtect; - DWORD dwDesiredAccess; - switch(mode) { - case 0: - flProtect = PAGE_READONLY; - dwDesiredAccess = FILE_MAP_READ; - break; - case 1: - flProtect = PAGE_READWRITE; - dwDesiredAccess = FILE_MAP_WRITE; - break; - case 2: - flProtect = PAGE_WRITECOPY; - dwDesiredAccess = FILE_MAP_COPY; - break; - case 3: - flProtect = PAGE_READWRITE; - dwDesiredAccess = FILE_MAP_WRITE; - break; - default: - return NULL; - } - - if( size>0 ) { - - mapping = CreateFileMapping(handle, NULL, flProtect, (DWORD) ((offset + size)>>32), (DWORD)(offset + size), NULL); - if( !mapping ) { - // FIXME: check error code and translate this to errno - // DWORD dw = GetLastError(); - } - ptr = MapViewOfFile(mapping,dwDesiredAccess, (DWORD)(offset>>32), (DWORD)(offset), size ); - if( !ptr ) { - // FIXME: check error code and translate this to errno - // DWORD dw = GetLastError(); - } - CloseHandle(mapping); - } - else { - ptr = zerolength; - } -#ifdef _DEBUG - if( ptr ) { - counters++; - } -#endif - return ptr; -} - -/* - * MSDN states: - * - * Although an application may close the file handle used to create a file mapping object, - * the system holds the corresponding file open until the last view of the file is unmapped: - * - * Files for which the last view has not yet been unmapped are held open with no sharing restrictions. - * - * Who knows what this means? - * - * http://msdn.microsoft.com/en-us/library/aa366882(VS.85).aspx - */ -void system_io_mmap_munmap(void *sizeasptr, void *ptr) // Ptr () -> Ptr a -> IO () -{ - size_t size = (size_t)sizeasptr; - BOOL result; - if( size>0 ) { - result = UnmapViewOfFile(ptr); -#ifdef _DEBUG - if( result ) { - counters--; - } -#endif - } - else { -#ifdef _DEBUG - counters--; -#endif - } -} - -//foreign import ccall unsafe "system_io_mmap_file_size" c_system_io_file_size :: Ptr () -> IO (CLLong) -long long system_io_mmap_file_size(void *handle) -{ - DWORD lobits, hibits; - lobits = GetFileSize(handle,&hibits); - return (long long)lobits + ((long long)hibits << 32); -} - -int system_io_mmap_extend_file_size(void *handle, long long size) -{ - DWORD lobits = (DWORD)size, hibits = (DWORD)(size>>32); - HANDLE mapping = CreateFileMapping(handle,NULL,PAGE_READWRITE,hibits,lobits,NULL); - if(mapping==NULL) - return -1; - CloseHandle(mapping); - return 0; -} - -//foreign import ccall unsafe "system_io_mmap_granularity" c_system_io_granularity :: CInt -int system_io_mmap_granularity() -{ - SYSTEM_INFO sysinfo; - GetSystemInfo(&sysinfo); - return sysinfo.dwAllocationGranularity; -} - - +#include "HsMmap.h" +#include + +#ifdef _DEBUG +int counters = 0; + +int system_io_mmap_counters() +{ + return counters; +} +#endif + + +//foreign import ccall unsafe "system_io_mmap_file_open" c_system_io_mmap_file_open :: CString -> CInt -> IO (Ptr ()) +void *system_io_mmap_file_open(const char *filepath, int mode) +{ + /* + HANDLE WINAPI CreateFileA( + __in LPCTSTR lpFileName, + __in DWORD dwDesiredAccess, + __in DWORD dwShareMode, + __in_opt LPSECURITY_ATTRIBUTES lpSecurityAttributes, + __in DWORD dwCreationDisposition, + __in DWORD dwFlagsAndAttributes, + __in_opt HANDLE hTemplateFile + ); + */ + void *handle = NULL; + DWORD dwDesiredAccess; + DWORD dwCreationDisposition; + if( !filepath ) + return NULL; + switch(mode) { + case 0: + dwDesiredAccess = GENERIC_READ; + dwCreationDisposition = OPEN_EXISTING; + break; + case 1: + dwDesiredAccess = GENERIC_WRITE|GENERIC_READ; + dwCreationDisposition = OPEN_EXISTING; + break; + case 2: + dwDesiredAccess = GENERIC_READ; + dwCreationDisposition = OPEN_EXISTING; + break; + case 3: + dwDesiredAccess = GENERIC_WRITE|GENERIC_READ; + dwCreationDisposition = OPEN_ALWAYS; + break; + default: + return NULL; + } + handle = CreateFileA(filepath, + dwDesiredAccess, + FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, + NULL, + dwCreationDisposition, + FILE_ATTRIBUTE_NORMAL, + NULL); + if( handle==INVALID_HANDLE_VALUE ) + return NULL; +#ifdef _DEBUG + counters++; +#endif + return handle; +} + +//foreign import ccall unsafe "system_io_mmap_file_close" c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ()) +void system_io_mmap_file_close(void *handle) +{ + CloseHandle(handle); +#ifdef _DEBUG + counters--; +#endif +} + +static char zerolength[1]; + +//foreign import ccall unsafe "system_io_mmap_mmap" c_system_io_mmap_mmap :: Ptr () -> CInt -> CLLong -> CInt -> IO (Ptr ()) +void *system_io_mmap_mmap(void *handle, int mode, long long offset, size_t size) +{ + /* + HANDLE WINAPI CreateFileMapping( + __in HANDLE hFile, + __in_opt LPSECURITY_ATTRIBUTES lpAttributes, + __in DWORD flProtect, + __in DWORD dwMaximumSizeHigh, + __in DWORD dwMaximumSizeLow, + __in_opt LPCTSTR lpName + ); + LPVOID WINAPI MapViewOfFile( + __in HANDLE hFileMappingObject, + __in DWORD dwDesiredAccess, + __in DWORD dwFileOffsetHigh, + __in DWORD dwFileOffsetLow, + __in SIZE_T dwNumberOfBytesToMap + ); + */ + HANDLE mapping; + void *ptr = NULL; + DWORD flProtect; + DWORD dwDesiredAccess; + switch(mode) { + case 0: + flProtect = PAGE_READONLY; + dwDesiredAccess = FILE_MAP_READ; + break; + case 1: + flProtect = PAGE_READWRITE; + dwDesiredAccess = FILE_MAP_WRITE; + break; + case 2: + flProtect = PAGE_WRITECOPY; + dwDesiredAccess = FILE_MAP_COPY; + break; + case 3: + flProtect = PAGE_READWRITE; + dwDesiredAccess = FILE_MAP_WRITE; + break; + default: + return NULL; + } + + if( size>0 ) { + + mapping = CreateFileMapping(handle, NULL, flProtect, (DWORD) ((offset + size)>>32), (DWORD)(offset + size), NULL); + if( !mapping ) { + // FIXME: check error code and translate this to errno + // DWORD dw = GetLastError(); + } + ptr = MapViewOfFile(mapping,dwDesiredAccess, (DWORD)(offset>>32), (DWORD)(offset), size ); + if( !ptr ) { + // FIXME: check error code and translate this to errno + // DWORD dw = GetLastError(); + } + CloseHandle(mapping); + } + else { + ptr = zerolength; + } +#ifdef _DEBUG + if( ptr ) { + counters++; + } +#endif + return ptr; +} + +/* + * MSDN states: + * + * Although an application may close the file handle used to create a file mapping object, + * the system holds the corresponding file open until the last view of the file is unmapped: + * + * Files for which the last view has not yet been unmapped are held open with no sharing restrictions. + * + * Who knows what this means? + * + * http://msdn.microsoft.com/en-us/library/aa366882(VS.85).aspx + */ +void system_io_mmap_munmap(void *sizeasptr, void *ptr) // Ptr () -> Ptr a -> IO () +{ + size_t size = (size_t)sizeasptr; + BOOL result; + if( size>0 ) { + result = UnmapViewOfFile(ptr); +#ifdef _DEBUG + if( result ) { + counters--; + } +#endif + } + else { +#ifdef _DEBUG + counters--; +#endif + } +} + +//foreign import ccall unsafe "system_io_mmap_file_size" c_system_io_file_size :: Ptr () -> IO (CLLong) +long long system_io_mmap_file_size(void *handle) +{ + DWORD lobits, hibits; + lobits = GetFileSize(handle,&hibits); + return (long long)lobits + ((long long)hibits << 32); +} + +int system_io_mmap_extend_file_size(void *handle, long long size) +{ + DWORD lobits = (DWORD)size, hibits = (DWORD)(size>>32); + HANDLE mapping = CreateFileMapping(handle,NULL,PAGE_READWRITE,hibits,lobits,NULL); + if(mapping==NULL) + return -1; + CloseHandle(mapping); + return 0; +} + +//foreign import ccall unsafe "system_io_mmap_granularity" c_system_io_granularity :: CInt +int system_io_mmap_granularity() +{ + SYSTEM_INFO sysinfo; + GetSystemInfo(&sysinfo); + return sysinfo.dwAllocationGranularity; +} + + diff --git a/mmap.cabal b/mmap.cabal --- a/mmap.cabal +++ b/mmap.cabal @@ -1,5 +1,5 @@ Name: mmap -Version: 0.5.6 +Version: 0.5.7 Stability: alpha License: BSD3 License-File: LICENSE @@ -37,9 +37,9 @@ Main-is: tests/mmaptest.hs if flag(mmaptest) Buildable: True + Build-depends: base<5, bytestring, HUnit, directory else Buildable: False - Build-depends: base<5, bytestring, HUnit, directory Extensions: ForeignFunctionInterface, ScopedTypeVariables, CPP Hs-source-dirs: . CC-options: -Wall -D_DEBUG diff --git a/tests/mmaptest.hs b/tests/mmaptest.hs deleted file mode 100644 --- a/tests/mmaptest.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} - -module Main where - -import System.IO.MMap -import Data.ByteString.Char8 as BSC -import Data.ByteString.Unsafe as BSC -import qualified Data.ByteString.Lazy as BSL -import Data.Word -import Foreign.ForeignPtr -import Foreign.Storable -import Foreign.Ptr -import System.Mem -import Control.Concurrent -import Test.HUnit -import System.Directory -import Foreign.C.Types (CInt,CLLong) -import Control.Monad -import System.IO -import Data.Int -#ifdef WINDOWS -import qualified System.Win32.File as W -#endif - -ignoreExceptions doit = (doit >> return ()) `catch` (\e -> return ()) - -foreign import ccall unsafe "HsMmap.h system_io_mmap_counters" - c_system_io_counters :: IO CInt - -removeFileDelayed :: FilePath -> IO () -#ifdef WINDOWS -removeFileDelayed filepath = do - h <- W.createFile filepath - W.dELETE - W.fILE_SHARE_NONE - Nothing - W.oPEN_ALWAYS - W.fILE_FLAG_DELETE_ON_CLOSE - Nothing - W.closeHandle h -#else -removeFileDelayed filepath = removeFile filepath -#endif - -content = BSC.pack "Memory mapping of files for POSIX and Windows" -contentLazy = BSL.fromChunks [content] - -test_normal_readonly = do - BSC.writeFile "test_normal.bin" content - bs <- mmapFileByteString "test_normal.bin" Nothing - bs @?= content - -test_normal_readonly_many_times = do - BSC.writeFile "test_normal.bin" content - bs1 <- mmapFileByteString "test_normal.bin" Nothing - bs2 <- mmapFileByteString "test_normal.bin" Nothing - bs3 <- mmapFileByteString "test_normal.bin" Nothing - BSC.concat [bs1,bs2,bs3] @?= BSC.concat [content, content, content] - -test_normal_readonly_lazy = do - let filename = "test_normalQ.bin" - BSC.writeFile filename content - bs <- mmapFileByteStringLazy filename Nothing - bs @?= contentLazy - -test_normal_readonly_zero_length = do - BSC.writeFile "test_zerolength.bin" BSC.empty - bs <- mmapFileByteString "test_zerolength.bin" Nothing - bs @?= BSC.empty - -test_non_existing_readonly = do - ignoreExceptions $ removeFile "test_notexists.bin" - ignoreExceptions $ do - mmapFileByteString "test_notexists.bin" Nothing - assertFailure "Should throw exception" - -test_no_permission_readonly = do - let filename = "test_nopermission.bin" - ignoreExceptions $ setPermissions filename (Permissions {readable = True, - writable = True, - executable = True, - searchable = True}) - 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 - then ignoreExceptions $ do - mmapFileByteString filename Nothing - assertFailure "Should throw exception" - else return () - -test_normal_negative_offset_readonly = do - ignoreExceptions $ removeFile "test_normal1.bin" - BSC.writeFile "test_normal1.bin" content - ignoreExceptions $ do - mmapFileByteString "test_normal1.bin" (Just (-20,5)) - assertFailure "Should throw exception" - -test_normal_negative_size_readonly = do - ignoreExceptions $ removeFile "test_normal2.bin" - BSC.writeFile "test_normal2.bin" content - ignoreExceptions $ do - mmapFileByteString "test_normal2.bin" (Just (0,-5)) - assertFailure "Should throw exception" - -test_normal_offset_size_readonly = do - let filename = "test_normal5.bin" - BSC.writeFile filename content - bs <- mmapFileByteString filename (Just (5,5)) - let exp = BSC.take 5 (BSC.drop 5 content) - bs @?= exp - -test_normal_offset_size_zero_readonly = do - let filename = "test_normal6.bin" - BSC.writeFile filename content - bs <- mmapFileByteString filename (Just (5,0)) - let exp = BSC.empty - bs @?= exp - -test_normal_offset_size_zero_readonly_lazy = do - let filename = "test_normal6x.bin" - BSC.writeFile filename content - bs <- mmapFileByteStringLazy filename (Just (5,0)) - let exp = BSL.empty - bs @?= exp - -test_normal_offset_beyond_eof_readonly = do - let filename = "test_normal9.bin" - BSC.writeFile filename content - ignoreExceptions $ do - mmapFileByteString filename (Just (1000,5)) - assertFailure "Should throw exception" - -test_normal_offset_beyond_eof_readonly_lazy = do - -- although lazy, should throw exception - let filename = "test_normal9.bin" - BSC.writeFile filename content - ignoreExceptions $ do - mmapFileByteStringLazy filename (Just (1000,5)) - assertFailure "Should throw exception" - -test_normal_offset_plus_size_beyond_eof_readonly = do - let filename = "test_normal7.bin" - BSC.writeFile filename content - ignoreExceptions $ do - mmapFileByteString filename (Just (4,5000)) - assertFailure "Should throw exception" - -test_normal_offset_plus_size_beyond_eof_readonly_lazy = do - let filename = "test_normal7.bin" - BSC.writeFile filename content - ignoreExceptions $ do - mmapFileByteStringLazy filename (Just (4,5000)) - assertFailure "Should throw exception" - -test_normal_offset_plus_size_beyond_eof_readwriteex = do - let filename = "test_normal8.bin" - BSC.writeFile filename content - mmapWithFilePtr filename ReadWriteEx (Just (4,5000)) $ \(ptr,size) -> do - size @?= 5000 - 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 - let filename = "test_normalU.bin" - BSC.writeFile filename content - mmapWithFilePtr filename ReadOnly Nothing $ \(ptr,size) -> do - removeFileDelayed filename - bs <- BSC.packCStringLen (castPtr ptr,size) - bs @?= content - v <- doesFileExist filename - False @=? v - -test_readwriteex_lazy_make_a_touch = do - let filename = "test_normal8.bin" - BSC.writeFile filename content - let threegb = 3*1000*1000*1000 - ignore <- mmapFileForeignPtrLazy filename ReadWriteEx (Just (4,threegb)) - let size = sum (Prelude.map (\(_,_,s) -> s) ignore) - size @?= fromIntegral threegb - -test_readwriteex_lazy_make_dont_touch = do - let filename = "test_normal86.bin" - BSC.writeFile filename content - let threegb = 3*1000 - mmapFileForeignPtrLazy filename ReadWriteEx (Just (0,threegb)) - System.Mem.performGC - threadDelay 1000 - size <- withFile filename ReadMode hFileSize - size @?= fromIntegral threegb - -test_create_offset_plus_size_readwriteex = do - let filename = "test_normal9.bin" - ignoreExceptions $ removeFile filename - mmapWithFilePtr filename ReadWriteEx (Just (4,5000)) $ \(ptr,size) -> do - size @?= 5000 - bs <- BSC.packCStringLen (castPtr ptr,size) - bs @?= BSC.replicate 5000 '\0' - -test_create_readwriteex_no_way = do - let filename = "zonk/test_normal9.bin" - ignoreExceptions $ mmapWithFilePtr filename ReadWriteEx (Just (4,5000)) $ \(ptr,size) -> do - assertFailure "Should throw exception" - -test_create_nothing_readwriteex_should_throw = do - let filename = "test_normalA.bin" - ignoreExceptions $ removeFile filename - ignoreExceptions $ mmapWithFilePtr filename ReadWriteEx Nothing $ \(ptr,size) -> do - size @?= 5000 - bs <- BSC.packCStringLen (castPtr ptr,size) - bs @?= BSC.replicate 5000 '\0' - assertFailure "Should throw exception" - x <- doesFileExist filename - x @?= False - -test_change_two_places = do - let filename = "test_normalAB.bin" - BSC.writeFile filename content - mmapWithFilePtr filename ReadWrite Nothing $ \(ptr1,size1) -> - do - -- this should change one common memory - let v1 = 0x41414141::Int32 - poke (castPtr ptr1) v1 - v2 <- peek (castPtr ptr1) - v2 @?= v1 - bs2 <- mmapFileByteString filename Nothing - size1 @?= BSC.length bs2 - 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) -> - do - poke (castPtr ptr1) (0x41414141::Int32) - bs3 <- BSC.readFile filename - bs3 @?= BSC.pack "\x41\x41\x41\x41" `BSC.append` BSC.drop 4 content - -test_writecopy = do - let filename = "test_normalAD.bin" - BSC.writeFile filename content - mmapWithFilePtr filename WriteCopy Nothing $ \(ptr1,size1) -> - do - poke (castPtr ptr1) (0x41414141::Int32) - -- change should NOT be reflected in file on disk - bs3 <- BSC.readFile filename - bs3 @?= content - -test_counters_zero = do - System.Mem.performGC - threadDelay 1000 - counters <- c_system_io_counters - return (counters @?= 0) - -alltests = [ "Normal read only mmap" ~: - test_normal_readonly - , "Normal read only mmap lazy" ~: - test_normal_readonly_lazy - , "Zero length file mmap" ~: - test_normal_readonly_zero_length - , "File does not exist" ~: - test_non_existing_readonly - , "No permission to read file" ~: - test_no_permission_readonly - , "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_normal_offset_size_readonly - , "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_normal_offset_size_zero_readonly_lazy - , "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" ~: - test_normal_offset_beyond_eof_readonly_lazy - , "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" ~: - test_normal_offset_plus_size_beyond_eof_readonly_lazy - , "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 - , "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 - , "MMap byte string many times" ~: - test_normal_readonly_many_times - , "Mmap common memory" ~: - test_change_two_places - , "Mmap read write memory" ~: - test_change_read_write - , "Mmap WriteCopy mode" ~: - test_writecopy - - --, "ReadWriteEx in lazy should extend file beyond 3GB when mapped in" ~: - -- Test_readwriteex_lazy_make_a_touch - -- insert tests above this line - , "Counters should be zero" ~: - test_counters_zero - ] - -main = do - runTestTT (test alltests) - -{- -main = do - BSC.writeFile "test.bin" content - bs <- mmapFileByteString "test.bin" Nothing - BSC.putStrLn bs - print (bs == content) - bs2 <- mmapFileByteString "test.bin" (Just (5,5)) - print (bs2 == BSC.take 5 (BSC.drop 5 content)) - - -- create 5 gigabyte file - let l = 1024*1024*1024*5 - (f,s) <- mmapFileForeignPtr "test.bin" ReadWrite (Just (l,5)) - withForeignPtr f $ \f -> poke (castPtr f) (64::Word8) - - E.catch (do - bs3 <- mmapFileByteString "test.bin" Nothing - print (fromIntegral l==BSC.length bs3 + 5 )) - (\E -> print True -- exception here is also ok - ) - bs4 <- mmapFileByteStringLazy "test.bin" Nothing - print (BSL.fromChunks [content] == BSL.take (fromIntegral $ BSC.length content) bs4) - bs5 <- mmapFileByteStringLazy "test.bin" (Just (5,5)) - print (BSC.take 5 (BSC.drop 5 content) == BSC.concat (BSL.toChunks bs5)) - - System.Mem.performGC - threadDelay 10000 - --} -