The library uses SYSV semaphores under linux to make sure the functional argument of
"once" is only ever run once. It uses the ProcessID as the key for the semaphore, so will
even enforce the once-only property accross different Haskell threads. Some semaphore
functions are also exported, allowing other constraints to be used (for example, once
only over multiple processes by using a constant ID rather than the processID.
I have attached the source for the library incase anyone is interested. If people think
it is useful I could put it up on a website (let me know). Also attached is an example,
which can be compiled with:
ghc -o test NamedSem.hs Test.hs -package posix
Keean.
{-# OPTIONS -fffi #-}
module NamedSem(once,NamedSem,openNamedSem,closeNamedSem,tasNamedSem) where
import IO
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import System.Posix.Process
foreign import ccall "wrapper" mkCallback :: IO CInt -> IO (FunPtr (IO CInt))
foreign import ccall unsafe "stdlib.h malloc" mallocSemOp :: CInt -> IO (Ptr SemOp)
foreign import ccall unsafe "stdlib.h free" freeSemOp :: Ptr SemOp -> IO ()
foreign import ccall unsafe "stdlib.h atexit" atexit :: FunPtr (IO CInt) -> IO ()
foreign import ccall unsafe "sys/sem.h semget" semget :: CInt -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "sys/sem.h semop" semop :: CInt -> Ptr SemOp -> CInt -> IO CInt
foreign import ccall unsafe "sys/sem.h semctl" semctl :: CInt -> CInt -> CInt -> IO CInt
data NamedSem = NamedSem CInt deriving Show
data SemOp = SemOp CShort CShort CShort
instance Storable SemOp where
peek p = do { n <- peekByteOff p 0; o <- peekByteOff p 2; f <- peekByteOff p 4; return (SemOp n o f) }
poke p (SemOp n o f) = do { pokeByteOff p 0 n; pokeByteOff p 2 o; pokeByteOff p 4 f }
sizeOf _ = 6
alignment _ = 2
atExit :: IO CInt -> IO ()
atExit f = do { g <- mkCallback f; atexit g }
openNamedSem :: Int -> IO (Maybe NamedSem)
openNamedSem n = do
id <- semget (fromIntegral n) 1 0o1660
if id >= 0
then do { atExit (semctl id 0 0); return $ Just (NamedSem id) }
else return $ Nothing
closeNamedSem :: NamedSem -> IO ()
closeNamedSem (NamedSem id) = do
_ <- semctl id 0 0 -- remove semaphore set
return ()
copySemOpList :: Ptr SemOp -> [SemOp] -> IO Int
copySemOpList op = foldl
(\a b -> do { i <- a; pokeElemOff op i b; return (i+1) })
(return 0)
applySemOpList :: NamedSem -> [SemOp] -> IO Bool
applySemOpList (NamedSem id) ol@(o0:_) = bracket
(mallocSemOp $ fromIntegral $ sizeOf o0 * length ol)
freeSemOp $ \op -> do
i <- copySemOpList op ol
j <- semop id op (fromIntegral i)
return (j >= 0)
tasNamedSem :: NamedSem -> IO Bool
tasNamedSem ns = applySemOpList ns [
SemOp 0 0 0o4000, -- test for zero
SemOp 0 1 0 -- add 1 to semaphore
]
once :: IO () -> IO ()
once f = do
i <- getProcessID
s <- openNamedSem (fromIntegral i)
case s of
Just n -> do
b <- tasNamedSem n
if b then f else return ()
_ -> error "unable to get semaphore"
{-# OPTIONS -fglasgow-exts #-}
module Main where
import NamedSem
test :: IO ()
test = once $ putStrLn "testing"
main :: IO ()
main = do
test
test
test
test
test
test
_______________________________________________ Haskell-Cafe mailing list [EMAIL PROTECTED] http://www.haskell.org/mailman/listinfo/haskell-cafe
