{-# LINE 1 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Foundation.Foreign.MemoryMap.Posix
-- Copyright   :  (c) Vincent Hanquez 2014
-- License     :  BSD-style
--
-- Maintainer  :  Vincent Hanquez
-- Stability   :  provisional
-- Portability :  non-portable (requires POSIX)
--
-- Functions defined by the POSIX standards for manipulating memory maps
--
-- When a function that calls an underlying POSIX function fails, the errno
-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'.
-- For a list of which errno codes may be generated, consult the POSIX
-- documentation for the underlying function.
--
-----------------------------------------------------------------------------




{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
module Foundation.Foreign.MemoryMap.Posix
    ( memoryMap
    , memoryUnmap
    , memoryAdvise
    , memoryLock
    , memoryUnlock
    , memoryProtect
    , memorySync
    -- * Flags types
    , MemoryMapFlag(..)
    , MemoryProtection(..)
    , MemoryAdvice(..)
    , MemorySyncFlag(..)
    -- * system page size
    , sysconfPageSize
    -- * High level
    , fileMapRead
    ) where

import Basement.Compat.Base
import Basement.Compat.C.Types
import Basement.Types.OffsetSize
import System.Posix.Types
import Foreign.Ptr
import Foreign.C.Error
import Data.Bits

import Foundation.Collection.Foldable
import Foundation.VFS
import qualified Prelude (fromIntegral)
import Foundation.Foreign.MemoryMap.Types
import Control.Exception

import           GHC.IO.FD
import           GHC.IO.IOMode
import qualified GHC.IO.Device as IO

foreign import ccall unsafe "mmap"
    c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)

foreign import ccall unsafe "munmap"
    c_munmap :: Ptr a -> CSize -> IO CInt


{-# LINE 69 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
foreign import ccall unsafe "posix_madvise"
    c_madvise :: Ptr a -> CSize -> CInt -> IO CInt

{-# LINE 75 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

foreign import ccall unsafe "msync"
    c_msync :: Ptr a -> CSize -> CInt -> IO CInt

foreign import ccall unsafe "mprotect"
    c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt


{-# LINE 83 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
foreign import ccall unsafe "mlock"
    c_mlock :: Ptr a -> CSize -> IO CInt

{-# LINE 89 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}


{-# LINE 91 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
foreign import ccall unsafe "munlock"
    c_munlock :: Ptr a -> CSize -> IO CInt

{-# LINE 97 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

foreign import ccall unsafe "sysconf"
    c_sysconf :: CInt -> CLong

-- | Mapping flag
data MemoryMapFlag =
      MemoryMapShared  -- ^ memory changes are shared between process
    | MemoryMapPrivate -- ^ memory changes are private to process
    deriving (Show,Eq)

-- | Memory protection
data MemoryProtection =
      MemoryProtectionNone
    | MemoryProtectionRead
    | MemoryProtectionWrite
    | MemoryProtectionExecute
    deriving (Show,Eq)

-- | Advice to put on memory.
--
-- only define the posix one.
data MemoryAdvice =
      MemoryAdviceNormal     -- ^ no specific advice, the default.
    | MemoryAdviceRandom     -- ^ Expect page references in random order. No readahead should occur.
    | MemoryAdviceSequential -- ^ Expect page references in sequential order. Page should be readahead aggressively.
    | MemoryAdviceWillNeed   -- ^ Expect access in the near future. Probably a good idea to readahead early
    | MemoryAdviceDontNeed   -- ^ Do not expect access in the near future.
    deriving (Show,Eq)

-- | Memory synchronization flags
data MemorySyncFlag =
      MemorySyncAsync      -- ^ perform asynchronous write.
    | MemorySyncSync       -- ^ perform synchronous write.
    | MemorySyncInvalidate -- ^ invalidate cache data.
    deriving (Show,Eq)

cvalueOfMemoryProts :: [MemoryProtection] -> CInt
cvalueOfMemoryProts = foldl' (.|.) 0 . fmap toProt
  where toProt :: MemoryProtection -> CInt
        toProt MemoryProtectionNone    = (0)
{-# LINE 137 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toProt MemoryProtectionRead    = (1)
{-# LINE 138 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toProt MemoryProtectionWrite   = (2)
{-# LINE 139 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toProt MemoryProtectionExecute = (4)
{-# LINE 140 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

cvalueOfMemorySync :: [MemorySyncFlag] -> CInt
cvalueOfMemorySync = foldl' (.|.) 0 . fmap toSync
  where toSync MemorySyncAsync      = (1)
{-# LINE 144 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toSync MemorySyncSync       = (16)
{-# LINE 145 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toSync MemorySyncInvalidate = (2)
{-# LINE 146 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

-- | Map pages of memory.
--
-- If fd is present, this memory will represent the file associated.
-- Otherwise, the memory will be an anonymous mapping.
--
-- use 'mmap'
memoryMap :: Maybe (Ptr a)      -- ^ The address to map to if MapFixed is used.
          -> CSize              -- ^ The length of the mapping
          -> [MemoryProtection] -- ^ the memory protection associated with the mapping
          -> MemoryMapFlag      -- ^
          -> Maybe Fd
          -> COff
          -> IO (Ptr a)
memoryMap initPtr sz prots flag mfd off =
    throwErrnoIf (== m1ptr) "mmap" (c_mmap (maybe nullPtr id initPtr) sz cprot cflags fd off)
  where m1ptr  = nullPtr `plusPtr` (-1)
        fd     = maybe (-1) (\(Fd v) -> v) mfd
        cprot  = cvalueOfMemoryProts prots
        cflags = maybe cMapAnon (const 0) mfd
             .|. maybe 0 (const cMapFixed) initPtr
             .|. toMapFlag flag


{-# LINE 170 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        cMapAnon  = (4096)
{-# LINE 171 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

{-# LINE 174 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        cMapFixed = (16)
{-# LINE 175 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

        toMapFlag MemoryMapShared  = (1)
{-# LINE 177 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toMapFlag MemoryMapPrivate = (2)
{-# LINE 178 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

-- | Unmap pages of memory
--
-- use 'munmap'
memoryUnmap :: Ptr a -> CSize -> IO ()
memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz)

-- | give advice to the operating system about use of memory
--
-- call 'madvise'
memoryAdvise :: Ptr a -> CSize -> MemoryAdvice -> IO ()
memoryAdvise ptr sz adv = throwErrnoIfMinus1_ "madvise" (c_madvise ptr sz cadv)
  where cadv = toAdvice adv

{-# LINE 192 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toAdvice MemoryAdviceNormal = (0)
{-# LINE 193 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toAdvice MemoryAdviceRandom = (1)
{-# LINE 194 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toAdvice MemoryAdviceSequential = (2)
{-# LINE 195 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toAdvice MemoryAdviceWillNeed = (3)
{-# LINE 196 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
        toAdvice MemoryAdviceDontNeed = (4)
{-# LINE 197 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

{-# LINE 204 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

-- | lock a range of process address space
--
-- call 'mlock'
memoryLock :: Ptr a -> CSize -> IO ()
memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz)

-- | unlock a range of process address space
--
-- call 'munlock'
memoryUnlock :: Ptr a -> CSize -> IO ()
memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz)

-- | set protection of memory mapping
--
-- call 'mprotect'
memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO ()
memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot)
  where cprot = cvalueOfMemoryProts prots

-- | memorySync synchronize memory with physical storage.
--
-- On an anonymous mapping this function does not have any effect.
-- call 'msync'
memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO ()
memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags)
  where cflags = cvalueOfMemorySync flags

-- | Return the operating system page size.
--
-- call 'sysconf'
sysconfPageSize :: Int
sysconfPageSize = Prelude.fromIntegral $ c_sysconf (29)
{-# LINE 237 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}

--------------------------------------------------------------------------------

fileSizeToCSize :: FileSize -> CSize
fileSizeToCSize (FileSize sz) = Prelude.fromIntegral sz

fileSizeFromInteger :: Integer -> FileSize
fileSizeFromInteger = FileSize . Prelude.fromIntegral

fileMapRead :: FileMapReadF
fileMapRead fp = bracket (openFile (filePathToLString fp) ReadMode True) (IO.close . fst) $ \(fd,_) -> do
    sz   <- fileSizeFromInteger `fmap` IO.getSize fd
    let csz = fileSizeToCSize sz
    p    <- memoryMap Nothing csz [MemoryProtectionRead] MemoryMapPrivate (Just $ Fd $ fdFD fd) 0
    return $ FileMapping p sz (memoryUnmap p csz)