{-# 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 System.Mem
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 "dynamic"
    toFun :: FunPtr(Ptr () -> IO ())
	-> 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{-ReadWriteEx-}
	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
		-- putStrLn$"mmap at "++show ptr
		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 (Table _ (mvar,handle)) =
	modifyMVar_ mvar$ \mp-> do { 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
		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
		bool <- readIORef errref
		when bool$fail"unmapAll: FlushViewOfFile or msync failed";
		performGC;
		return empty }