Mapper.hs

{-# LANGUAGE Trustworthy, ForeignFunctionInterface, CPP #-}

-- | Allows a block to be requested an unlimited number of times without using up the address space. N.B. Usage of memory cannot cross multiples of 64 kilobytes.
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 :: 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 (){-file handle-})

newTable path = do
	mv <- newMVar empty
	handle <- withCString path$ \p->c_system_io_mmap_file_open p 3{-ReadWriteEx-}
	handle' <- newForeignPtr_ 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
		-- putStrLn$"mmap at "++show ptr
		-- mp' <- _unmapAll False handle mp
		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{-ReadWriteEx-} (fromIntegral aligned) 65536
		-- putStrLn$"mmap complete"
		return$!(mp'',p)
	where
	(d, r) = ptr `divMod` 65536
	aligned = 65536 * d

{-newBlock :: Table -> IO (Ptr a, Int)
newBlock (Table path mp) = do
	-- Get the file size.
	hdl <- openBinaryFile path ReadWriteMode
	fileSz <- finally (hFileSize hdl) (hClose hdl)

	-- Add a new block at the end.
	(p, _, _, _) <- mmapFilePtr path ReadWriteEx (Just (fromInteger fileSz, 65536))

	-- Store it.
	modifyMVar_ mp (return . insert (fromInteger fileSz) (castPtr p))

	return (p, fromInteger fileSz)-}

_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 unmap operation is not final it is possible to skip this operation
		-- that does not dispose of individual pages.
		when isFinal$flush_file_buffers handle' -- To be *strictly correct*, must cause writeback manually.
#else
		mapM(\ptr->do
			n<-c_msync ptr 65536 2
			when(n/=0)$writeIORef errref True) mp
#endif
		mapM(\ptr -> munmapFilePtr ptr 65536) mp
		c_system_io_mmap_file_close handle'
		bool <- readIORef errref
		when bool$fail"unmapAll: FlushViewOfFile or msync failed"
		return empty

-- N.B. That this will crash if attempt is made to call twice on the same table object.
unmapAll (Table _ (mvar,handle)) = modifyMVar_ mvar$_unmapAll True handle