1#if __GLASGOW_HASKELL__ >= 709
2{-# LANGUAGE Safe #-}
3#else
4{-# LANGUAGE Trustworthy #-}
5#endif
6-----------------------------------------------------------------------------
7-- |
8-- Module      :  System.Posix.SharedMem
9-- Copyright   :  (c) Daniel Franke 2007
10-- License     :  BSD-style (see the file libraries/base/LICENSE)
11--
12-- Maintainer  :  libraries@haskell.org
13-- Stability   :  experimental
14-- Portability :  non-portable (requires POSIX)
15--
16-- POSIX shared memory support.
17--
18-----------------------------------------------------------------------------
19
20module System.Posix.SharedMem
21    (ShmOpenFlags(..), shmOpen, shmUnlink)
22    where
23
24#include "HsUnix.h"
25
26#include <sys/types.h>
27#include <sys/mman.h>
28#include <fcntl.h>
29
30import System.Posix.Types
31#if defined(HAVE_SHM_OPEN) || defined(HAVE_SHM_UNLINK)
32import Foreign.C
33#endif
34#ifdef HAVE_SHM_OPEN
35import Data.Bits
36#endif
37
38data ShmOpenFlags = ShmOpenFlags
39    { shmReadWrite :: Bool,
40      -- ^ If true, open the shm object read-write rather than read-only.
41      shmCreate :: Bool,
42      -- ^ If true, create the shm object if it does not exist.
43      shmExclusive :: Bool,
44      -- ^ If true, throw an exception if the shm object already exists.
45      shmTrunc :: Bool
46      -- ^ If true, wipe the contents of the shm object after opening it.
47    }
48
49-- | Open a shared memory object with the given name, flags, and mode.
50shmOpen :: String -> ShmOpenFlags -> FileMode -> IO Fd
51#ifdef HAVE_SHM_OPEN
52shmOpen name flags mode =
53    do cflags0 <- return 0
54       cflags1 <- return $ cflags0 .|. (if shmReadWrite flags
55                                        then #{const O_RDWR}
56                                        else #{const O_RDONLY})
57       cflags2 <- return $ cflags1 .|. (if shmCreate flags then #{const O_CREAT}
58                                        else 0)
59       cflags3 <- return $ cflags2 .|. (if shmExclusive flags
60                                        then #{const O_EXCL}
61                                        else 0)
62       cflags4 <- return $ cflags3 .|. (if shmTrunc flags then #{const O_TRUNC}
63                                        else 0)
64       withCAString name (shmOpen' cflags4)
65    where shmOpen' cflags cname =
66              do fd <- throwErrnoIfMinus1 "shmOpen" $
67                       shm_open cname cflags mode
68                 return $ Fd fd
69#else
70shmOpen = error "System.Posix.SharedMem:shm_open: not available"
71#endif
72
73-- | Delete the shared memory object with the given name.
74shmUnlink :: String -> IO ()
75#ifdef HAVE_SHM_UNLINK
76shmUnlink name = withCAString name shmUnlink'
77    where shmUnlink' cname =
78              throwErrnoIfMinus1_ "shmUnlink" $ shm_unlink cname
79#else
80shmUnlink = error "System.Posix.SharedMem:shm_unlink: not available"
81#endif
82
83#ifdef HAVE_SHM_OPEN
84foreign import ccall unsafe "shm_open"
85        shm_open :: CString -> CInt -> CMode -> IO CInt
86#endif
87
88#ifdef HAVE_SHM_UNLINK
89foreign import ccall unsafe "shm_unlink"
90        shm_unlink :: CString -> IO CInt
91#endif
92