{-# LINE 1 "Foundation/Foreign/MemoryMap/Posix.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
module Foundation.Foreign.MemoryMap.Posix
( memoryMap
, memoryUnmap
, memoryAdvise
, memoryLock
, memoryUnlock
, memoryProtect
, memorySync
, MemoryMapFlag(..)
, MemoryProtection(..)
, MemoryAdvice(..)
, MemorySyncFlag(..)
, sysconfPageSize
, 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
data MemoryMapFlag =
MemoryMapShared
| MemoryMapPrivate
deriving (Show,Eq)
data MemoryProtection =
MemoryProtectionNone
| MemoryProtectionRead
| MemoryProtectionWrite
| MemoryProtectionExecute
deriving (Show,Eq)
data MemoryAdvice =
MemoryAdviceNormal
| MemoryAdviceRandom
| MemoryAdviceSequential
| MemoryAdviceWillNeed
| MemoryAdviceDontNeed
deriving (Show,Eq)
data MemorySyncFlag =
MemorySyncAsync
| MemorySyncSync
| MemorySyncInvalidate
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" #-}
memoryMap :: Maybe (Ptr a)
-> CSize
-> [MemoryProtection]
-> 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" #-}
memoryUnmap :: Ptr a -> CSize -> IO ()
memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz)
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" #-}
memoryLock :: Ptr a -> CSize -> IO ()
memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz)
memoryUnlock :: Ptr a -> CSize -> IO ()
memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz)
memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO ()
memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot)
where cprot = cvalueOfMemoryProts prots
memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO ()
memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags)
where cflags = cvalueOfMemorySync flags
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)