diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2013 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +unix-memory +=========== + +Provide access to lowlevel syscalls for memory mapping. typically mmap, munmap, msync, mlock, mprotect, .. + +Documentation: [unix-memory on hackage](http://hackage.haskell.org/package/unix-memory) + +The goal is to fold the System.Posix.Memory module in the unix package. As the unix package +is tied to ghc, it's not convenient to upgrade the package, so this package can act as a +test ground, and a compatility module for older unix version. + +Portability is inherently difficult, but the goal is to support every unixoid (Linux, BSD, MacOSX) +that have mmap style functions. Bug reports and pull requests to improve portability more than welcome. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Posix/Memory.hsc b/System/Posix/Memory.hsc new file mode 100644 --- /dev/null +++ b/System/Posix/Memory.hsc @@ -0,0 +1,190 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Memory +-- 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. +-- +----------------------------------------------------------------------------- + +#include +#include + +{-# LANGUAGE ForeignFunctionInterface #-} +module System.Posix.Memory ( + memoryMap, + memoryUnmap, + memoryAdvise, + memoryLock, + memoryUnlock, + memoryProtect, + memorySync, + MemoryMapFlag(..), + MemoryProtection(..), + MemoryAdvice(..), + MemorySyncFlag(..), + sysconfPageSize + ) where + +import System.Posix.Types +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.Error +import Data.Bits + +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 + +foreign import ccall unsafe "madvise" + c_madvise :: Ptr a -> CSize -> CInt -> IO CInt + +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 + +foreign import ccall unsafe "mlock" + c_mlock :: Ptr a -> CSize -> IO CInt + +foreign import ccall unsafe "munlock" + c_munlock :: Ptr a -> CSize -> IO CInt + +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,Read,Eq) + +-- | Memory protection +data MemoryProtection = + MemoryProtectionNone + | MemoryProtectionRead + | MemoryProtectionWrite + | MemoryProtectionExecute + deriving (Show,Read,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,Read,Eq) + +-- | Memory synchronization flags +data MemorySyncFlag = + MemorySyncAsync -- ^ perform asynchronous write. + | MemorySyncSync -- ^ perform synchronous write. + | MemorySyncInvalidate -- ^ invalidate cache data. + deriving (Show,Read,Eq) + +cvalueOfMemoryProts :: [MemoryProtection] -> CInt +cvalueOfMemoryProts = foldl (.|.) 0 . map toProt + where toProt :: MemoryProtection -> CInt + toProt MemoryProtectionNone = (#const PROT_NONE) + toProt MemoryProtectionRead = (#const PROT_READ) + toProt MemoryProtectionWrite = (#const PROT_WRITE) + toProt MemoryProtectionExecute = (#const PROT_EXEC) + +cvalueOfMemorySync :: [MemorySyncFlag] -> CInt +cvalueOfMemorySync = foldl (.|.) 0 . map toSync + where toSync MemorySyncAsync = (#const MS_ASYNC) + toSync MemorySyncSync = (#const MS_SYNC) + toSync MemorySyncInvalidate = (#const MS_INVALIDATE) + +-- | 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 + + cMapAnon = (#const MAP_ANONYMOUS) + cMapFixed = (#const MAP_FIXED) + + toMapFlag MemoryMapShared = (#const MAP_SHARED) + toMapFlag MemoryMapPrivate = (#const MAP_PRIVATE) + +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 + + toAdvice MemoryAdviceNormal = (#const MADV_NORMAL) + toAdvice MemoryAdviceRandom = (#const MADV_RANDOM) + toAdvice MemoryAdviceSequential = (#const MADV_SEQUENTIAL) + toAdvice MemoryAdviceWillNeed = (#const MADV_WILLNEED) + toAdvice MemoryAdviceDontNeed = (#const MADV_DONTNEED) + +-- | 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 doesn't 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 = fromIntegral $ c_sysconf (#const _SC_PAGESIZE) diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,61 @@ +module Main where + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Test.QuickCheck.Monadic (monadicIO, run) + +import System.Posix.IO +import System.Posix.Memory + +import Control.Monad +import Control.Exception (bracket) + +import Foreign.C.Types +import Foreign.Storable + +import Data.Word + +psz :: CSize +psz = fromIntegral sysconfPageSize + +-- create an anonymous private mapping of page-size size. +withDummyMapping f = do + bracket (memoryMap Nothing psz [MemoryProtectionRead,MemoryProtectionWrite] MemoryMapPrivate Nothing 0) + (\mem -> memoryUnmap mem psz) + f + +withDevZeroMapping f = withOpenFd "/dev/zero" $ \fd -> + bracket (memoryMap Nothing psz [MemoryProtectionRead,MemoryProtectionWrite] MemoryMapPrivate (Just fd) 0) + (\mem -> memoryUnmap mem psz) + f + where withOpenFd filename g = do + bracket (openFd filename ReadWrite Nothing defaultFileFlags) + closeFd + g + +tests :: [Test] +tests = + [ testProperty "page-size" $ sysconfPageSize > 0 && sysconfPageSize < (2^(20::Int)) + , testGroup "anonymous" $ runTestWithMapping withDummyMapping + , testGroup "fd" $ runTestWithMapping withDevZeroMapping + ] + where runTestWithMapping mapF = + [ testProperty "mmap-munmap" $ monadicIO $ run $ mapF $ \_ -> return True + , testProperty "madvise" $ monadicIO $ run $ mapF $ \ptr -> + memoryAdvise ptr psz MemoryAdviceRandom >> return True + , testProperty "msync" $ monadicIO $ run $ mapF $ \ptr -> + memorySync ptr psz [MemorySyncAsync] >> return True + , testProperty "mlock-munlock" $ monadicIO $ run $ mapF $ \ptr -> do + memoryLock ptr psz + memoryUnlock ptr psz + return True + , testProperty "read" $ monadicIO $ run $ mapF $ \ptr -> do + res <- forM [0..(sysconfPageSize-1)] $ \off -> do + b <- peekElemOff ptr off :: IO Word8 + return (b == 0) + return $ and res + ] + +main :: IO () +main = defaultMain tests diff --git a/unix-memory.cabal b/unix-memory.cabal new file mode 100644 --- /dev/null +++ b/unix-memory.cabal @@ -0,0 +1,40 @@ +Name: unix-memory +Version: 0.1.0 +Synopsis: Unix memory syscalls +Description: unix memory syscalls (mmap, munmap, madvise, msync, mlock) +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: vincent@snarc.org +Category: System +Stability: experimental +Build-Type: Simple +Homepage: http://github.com/vincenthz/hs-unix-memory +Cabal-Version: >=1.8 +data-files: README.md + +Library + Exposed-modules: System.Posix.Memory + Build-depends: base >= 4 && < 5 + , unix + ghc-options: -Wall -fwarn-tabs + +Test-Suite test-memorymap + type: exitcode-stdio-1.0 + hs-source-dirs: tests + Main-is: Tests.hs + Build-Depends: base >= 3 && < 5 + , mtl + , QuickCheck >= 2 + , HUnit + , test-framework + , test-framework-quickcheck2 + , test-framework-hunit + , unix + , unix-memory + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + +source-repository head + type: git + location: git://github.com/vincenthz/hs-unix-memory