module System.IO.MMap
(
mmapFilePtr,
mmapFileForeignPtr,
mmapFileByteString,
mmapFilePtrLazy,
mmapFileForeignPtrLazy,
mmapFileByteStringLazy,
Mode(..)
)
where
import System.IO ()
import Foreign.Ptr (Ptr,FunPtr,nullPtr,plusPtr)
import Foreign.C.Types (CInt,CLLong)
import Foreign.C.String (CString,withCString)
import Foreign.ForeignPtr (ForeignPtr,withForeignPtr,finalizeForeignPtr,newForeignPtr,newForeignPtrEnv)
import Foreign.Storable( poke )
import Foreign.Marshal.Alloc( malloc )
import Foreign.C.Error ( throwErrno )
import qualified Foreign.Concurrent( newForeignPtr )
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Unsafe as BS (unsafePackCStringFinalizer)
import Data.Int (Int64)
import Control.Monad (when)
import Control.Exception (bracket)
import qualified Data.ByteString as BS (ByteString)
import qualified Data.ByteString.Lazy as BSL (ByteString,fromChunks)
data Mode = ReadOnly
| ReadWrite
| WriteCopy
deriving (Eq,Ord,Enum)
mmapFilePtr :: FilePath
-> Mode
-> Maybe (Int64,Int)
-> IO (Ptr a,IO (),Int)
mmapFilePtr fp m range = do
(ptr, size) <- mmapFilePtr' fp m range
sizeptr <- malloc
poke sizeptr (fromIntegral size)
return (ptr, c_system_io_mmap_munmap sizeptr ptr, size)
mmapFileForeignPtr :: FilePath
-> Mode
-> Maybe (Int64,Int)
-> IO (ForeignPtr a,Int)
mmapFileForeignPtr fp m range = do
(ptr, size) <- mmapFilePtr' fp m range
sizeptr <- malloc
poke sizeptr (fromIntegral size)
foreignptr <- newForeignPtrEnv c_system_io_mmap_munmap_funptr sizeptr ptr
return (foreignptr,size)
mmapFilePtr' :: FilePath
-> Mode
-> Maybe (Int64,Int)
-> IO (Ptr a,Int)
mmapFilePtr' filepath mode offsetsize = do
bracket (mmapFileOpen filepath mode)
(finalizeForeignPtr) mmap
where
mmap handle = do
(offset,size) <- case offsetsize of
Just (offset,size) -> return (offset,size)
Nothing -> do
longsize <- withForeignPtr handle c_system_io_file_size
when (longsize > fromIntegral (maxBound :: Int)) $
fail ("file is longer (" ++ show longsize ++ ") than maxBound::Int")
return (0,fromIntegral longsize)
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) $
throwErrno $ "mmap of '" ++ filepath ++ "' failed"
return (ptr `plusPtr` fromIntegral align,fromIntegral size)
mmapFileByteString :: FilePath
-> Maybe (Int64,Int)
-> IO BS.ByteString
mmapFileByteString filepath offsetsize = do
(ptr,finalizer,size) <- mmapFilePtr filepath ReadOnly offsetsize
bytestring <- BS.unsafePackCStringFinalizer ptr size finalizer
return bytestring
mmapFilePtrLazy :: FilePath
-> Mode
-> Maybe (Int64,Int64)
-> IO [(Ptr a,IO (),Int)]
mmapFilePtrLazy filepath mode offsetsize = do
handle <- mmapFileOpen filepath mode
mmap handle
where
mmap handle = do
(offset,size) <- case offsetsize of
Just (offset,size) -> return (offset,size)
Nothing -> do
longsize <- withForeignPtr handle c_system_io_file_size
return (0,fromIntegral longsize)
return $ map (mapChunk handle) (chunks offset size)
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) $
throwErrno $ "mmap of '" ++ filepath ++ "' failed"
sizeptr <- malloc
poke sizeptr $ fromIntegral sizeraw
let finalizer = c_system_io_mmap_munmap sizeptr ptr
return (ptr `plusPtr` fromIntegral align,finalizer,fromIntegral size)
chunks :: Int64 -> Int64 -> [(Int64,Int)]
chunks offset size | size <= fromIntegral chunkSize = [(offset,fromIntegral size)]
| otherwise = let offset2 = offset + fromIntegral chunkSize `div` fromIntegral chunkSize * fromIntegral chunkSize
size2 = fromIntegral (offset2 offset)
in (offset,size2) : chunks (offset2) (sizefromIntegral size2)
mmapFileForeignPtrLazy :: FilePath
-> Mode
-> Maybe (Int64,Int64)
-> IO [(ForeignPtr a,Int)]
mmapFileForeignPtrLazy filepath mode offsetsize = do
list <- mmapFilePtrLazy filepath mode offsetsize
return (map turn list)
where
turn (ptr,finalizer,size) = unsafePerformIO $ do
foreignptr <- Foreign.Concurrent.newForeignPtr ptr finalizer
return (foreignptr,size)
mmapFileByteStringLazy :: FilePath
-> Maybe (Int64,Int64)
-> IO BSL.ByteString
mmapFileByteStringLazy filepath offsetsize = do
list <- mmapFilePtrLazy filepath ReadOnly offsetsize
return (BSL.fromChunks (map turn list))
where
turn (ptr,finalizer,size) = unsafePerformIO $ do
bytestring <- BS.unsafePackCStringFinalizer ptr size finalizer
return bytestring
chunkSize :: Int
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) $
throwErrno $ "opening of '" ++ filepath ++ "' failed"
handle <- newForeignPtr c_system_io_mmap_file_close ptr
return handle
foreign import ccall unsafe "system_io_mmap_file_open"
c_system_io_mmap_file_open :: CString -> CInt -> IO (Ptr ())
foreign import ccall unsafe "&system_io_mmap_file_close"
c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ())
foreign import ccall unsafe "system_io_mmap_mmap"
c_system_io_mmap_mmap :: Ptr () -> CInt -> CLLong -> CInt -> IO (Ptr a)
foreign import ccall unsafe "&system_io_mmap_munmap"
c_system_io_mmap_munmap_funptr :: FunPtr(Ptr CInt -> Ptr a -> IO ())
foreign import ccall unsafe "system_io_mmap_munmap"
c_system_io_mmap_munmap :: Ptr CInt -> Ptr a -> IO ()
foreign import ccall unsafe "system_io_mmap_file_size"
c_system_io_file_size :: Ptr () -> IO (CLLong)
foreign import ccall unsafe "system_io_mmap_granularity"
c_system_io_granularity :: CInt