MemoryMap.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS -fasm #-}
module Data.CompactMap.MemoryMap
    ( Protection(..)
    , Flag(..)
    , mmap
    , alignSize
    , mremap
    , munmap
--    , mprotect
    , getPageSize
    ) where

import Control.Monad
import GHC.IOBase
import Foreign.C
import Foreign
import Data.Bits
import Numeric
import Data.List
import Data.Char

foreign import ccall unsafe "mmap" c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> CInt -> IO (Ptr a)
foreign import ccall unsafe "munmap" c_munmap :: Ptr a -> CSize -> IO CInt
foreign import ccall unsafe "mremap" c_mremap :: Ptr a -> CSize -> CSize -> CInt -> IO (Ptr a)
--foreign import ccall unsafe "mprotect" c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt

foreign import ccall unsafe "getpagesize" c_getpagesize :: IO CInt

getPageSize :: IO Int
getPageSize = liftM fromIntegral c_getpagesize

{-
failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL name f = do
   addr <- f
   if addr == nullPtr
      then ioError (IOError Nothing ResourceExhausted name 
                                        "out of memory" Nothing)
      else return addr
-}

data Protection
    = Execute
    | Read
    | Write

protToBit Read = 0x1
protToBit Write = 0x2
protToBit Execute = 0x4

data Flag
    = Fixed
    | Shared
    | Private
    | Anonymous
    | NoReserve

flagToBit Fixed = 0x10
flagToBit Shared = 0x01
flagToBit Private = 0x02
flagToBit Anonymous = 0x20
flagToBit NoReserve = 0x04000

errPtr :: Ptr a
errPtr = nullPtr `plusPtr` (-1)
{-
mprotect :: Ptr a -> Int -> [Protection] -> IO ()
mprotect ptr size flags
    = let cprot = foldr (.|.) 0 (map protToBit flags)
      in do throwErrnoIf (== -1) "mprotect" (c_mprotect ptr (fromIntegral size) cprot)
            return ()
-}
mmap :: Int -> [Protection] -> [Flag] -> IO (Ptr a)
mmap size prot flags
    = do let cprot = foldr (.|.) 0 (map protToBit prot)
             cflags = foldr (.|.) 0 (map flagToBit flags)
         throwErrnoIf (== errPtr) "mmap" (c_mmap nullPtr (fromIntegral size) cprot cflags (-1) 0)

alignSize :: Int -> IO Int
alignSize size
    = do page <- getPageSize
         return $ if size <= 0 then page
                  else (size `div` page) * page + if size `mod` page == 0 then 0 else page

mremap :: Ptr a -> Int -> Int -> IO (Ptr a)
mremap ptr oldSize newSize
    = throwErrnoIf (== errPtr) "mremap" (c_mremap ptr (fromIntegral oldSize) (fromIntegral newSize) 1)

munmap :: Ptr a -> Int -> IO ()
munmap ptr size
    = throwErrnoIfMinus1_ "munmap" $ c_munmap ptr (fromIntegral size)
{-
showSize :: Int -> String
showSize n'
    = loop sizes (fromIntegral n')
    where loop [] n = showFFloat (Just 0) (n::Float) " bytes"
          loop ((s,p):xs) n | n >= s = showFFloat (Just 2) (n/s) p
                            | otherwise = loop xs n
          sizes = [ (giga, " GiB")
                  , (mega, " MiB")
                  , (kilo, " KiB")]
-}