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)
import 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 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)) $
error ("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) $
error "c_system_io_mmap_mmap returned NULL"
let finalizer = c_system_io_mmap_munmap ptr (fromIntegral sizeraw)
return (ptr `plusPtr` fromIntegral align,finalizer,fromIntegral size)
mmapFileForeignPtr :: FilePath
-> Mode
-> Maybe (Int64,Int)
-> IO (ForeignPtr a,Int)
mmapFileForeignPtr filepath mode offsetsize = do
(ptr,finalizer,size) <- mmapFilePtr filepath mode offsetsize
foreignptr <- Foreign.Concurrent.newForeignPtr ptr finalizer
return (foreignptr,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) $
error "c_system_io_mmap_mmap returned NULL"
let finalizer = c_system_io_mmap_munmap ptr (fromIntegral sizeraw)
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) $
error "c_system_io_mmap_file_open returned NULL"
handle <- Foreign.ForeignPtr.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 ())
foreign import ccall unsafe "system_io_mmap_munmap" c_system_io_mmap_munmap :: Ptr () -> CInt -> 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