module Data.Columbia.Mapper (Pointer, Table(..), newTable, fileSize, fileSizeShim, mapBlock, unmapAll) where
import Data.Map
import Data.Word
import Data.Int
import Data.Traversable (mapM)
import Data.IORef
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.String
import Foreign.C.Types
import Foreign.C.Error
import Control.Concurrent.MVar
import Control.Monad hiding (mapM)
import Control.Exception
import System.IO.MMap
import System.IO
import Prelude hiding (lookup, catch, mapM)
foreign import ccall "HsMmap.h system_io_mmap_file_open"
c_system_io_mmap_file_open :: CString
-> CInt
-> IO (Ptr ())
foreign import ccall "HsMmap.h &system_io_mmap_file_close"
c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ())
foreign import ccall unsafe "HsMmap.h system_io_mmap_mmap"
c_system_io_mmap_mmap :: Ptr ()
-> CInt
-> CLLong
-> CSize
-> IO (Ptr a)
#ifdef WIN32
foreign import stdcall "FileAPI.h FlushViewOfFile"
c_win32_flush_view_of_file :: Ptr () -> CSize -> IO Word32
foreign import stdcall "FileAPI.h FlushFileBuffers"
c_win32_flush_file_buffers :: Ptr () -> IO Word32
flush_file_buffers ptr = do
n <- c_win32_flush_file_buffers ptr
when(n==0)$fail"FlushFileBuffers: failed"
#else
foreign import ccall "sys/mman.h msync"
c_msync :: Ptr () -> CSize -> CInt -> IO Word32
#endif
type Pointer = Word32
data Table = Table !FilePath !(MVar (Map Pointer (Ptr ())), ForeignPtr ())
newTable path = do
mv <- newMVar empty
handle <- withCString path$ \p->c_system_io_mmap_file_open p 3
handle' <- newForeignPtr c_system_io_mmap_file_close handle
return$!Table path$!(mv,handle')
fileSize :: FilePath -> Map Pointer (Ptr ()) -> IO Word32
fileSize path mp =
liftM2
(max.fromInteger)
(bracket
(openBinaryFile path ReadWriteMode)
hClose
hFileSize)
(return$!maybe 0((+65536).fst.fst) (maxViewWithKey mp))
fileSizeShim :: Table -> IO Word32
fileSizeShim (Table path(mv,_)) = modifyMVar mv(\mp->liftM((,) mp) (fileSize path mp))
mapBlock :: Table -> Pointer -> IO (Ptr a)
mapBlock table@(Table path(mp,handle)) ptr = modifyMVar mp $ \mp -> case lookup aligned mp of
Just p -> return (mp, castPtr (plusPtr p (fromIntegral r)))
Nothing -> withForeignPtr handle$ \handle'->do
mp' <-return mp
sz <- fileSize path mp'
when(aligned>=sz)$
bracket
(openBinaryFile path ReadWriteMode)
hClose
(`hSetFileSize` (toInteger aligned+65536))
(mp'',p) <- liftM (\p -> (insert aligned p mp', plusPtr p (fromIntegral r))) $
c_system_io_mmap_mmap handle' 3 (fromIntegral aligned) 65536
return$!(mp'',p)
where
(d, r) = ptr `divMod` 65536
aligned = 65536 * d
_unmapAll isFinal handle mp = withForeignPtr handle$ \handle'->do
errref <- newIORef False
#ifdef WIN32
mapM(\ptr->do
n<-c_win32_flush_view_of_file ptr 65536
when(n==0)$writeIORef errref True) mp
when isFinal$flush_file_buffers handle'
#else
mapM(\ptr->do
n<-c_msync ptr 65536 2
when(n/=0)$writeIORef errref True) mp
#endif
mapM(\ptr -> munmapFilePtr ptr 65536) mp
bool <- readIORef errref
when bool$fail"unmapAll: FlushViewOfFile or msync failed"
return empty
unmapAll (Table _ (mvar,handle)) = modifyMVar_ mvar$_unmapAll True handle