-- | A TSem is an unusual sort of lock in that it only protects the same thread
-- from acquiring it twice.  Different threads may acquire the same TSem
-- without problems.
--
-- The purpose of this is to allow computations which potentially would
-- loop forever by calling themselves to instead fail gracefully.  To
-- aid in this process, we also include in each TSem a String.  When we
-- attempt to acquire a TSem which is already acquired, we instead return
-- the String for this TSem and the TSems acquired within this one.
module Util.TSem(
   TSem,
   newTSem, -- :: IO String -> IO TSem
   synchronizeTSem, -- TSem -> IO a -> IO (Either [String] a)
   ) where

import System.IO.Unsafe
import Control.Exception

import Util.Object
import Util.ExtendedPrelude

import Util.ThreadDict

-- ---------------------------------------------------------------------------
-- Datatypes
-- ---------------------------------------------------------------------------

data TSem = TSem {
   TSem -> ObjectID
oId :: ObjectID,
   TSem -> IO String
label :: IO String
   }

newtype ThreadInfo = ThreadInfo [TSem]
   -- Information we keep per thread.

-- ---------------------------------------------------------------------------
-- The global dictionary of ThreadInfo
-- ---------------------------------------------------------------------------

threadInfoDict :: ThreadDict ThreadInfo
threadInfoDict :: ThreadDict ThreadInfo
threadInfoDict = IO (ThreadDict ThreadInfo) -> ThreadDict ThreadInfo
forall a. IO a -> a
unsafePerformIO IO (ThreadDict ThreadInfo)
forall a. IO (ThreadDict a)
newThreadDict
{-# NOINLINE threadInfoDict #-}

-- ---------------------------------------------------------------------------
-- The functions
-- ---------------------------------------------------------------------------

newTSem :: IO String -> IO TSem
newTSem :: IO String -> IO TSem
newTSem IO String
label =
   do
      ObjectID
oId <- IO ObjectID
newObject
      TSem -> IO TSem
forall (m :: * -> *) a. Monad m => a -> m a
return (TSem :: ObjectID -> IO String -> TSem
TSem {oId :: ObjectID
oId = ObjectID
oId,label :: IO String
label = IO String
label})

synchronizeTSem :: TSem -> IO a -> IO (Either [String] a)
synchronizeTSem :: TSem -> IO a -> IO (Either [String] a)
synchronizeTSem TSem
tSem IO a
act =
   do
      Maybe [IO String]
strActsOpt <- TSem -> IO (Maybe [IO String])
tryAcquire TSem
tSem
      case Maybe [IO String]
strActsOpt of
         Maybe [IO String]
Nothing -> IO (Either [String] a) -> IO () -> IO (Either [String] a)
forall a b. IO a -> IO b -> IO a
finally
            (do
                a
a <- IO a
act
                Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either [String] a
forall a b. b -> Either a b
Right a
a)
            )
            (TSem -> IO ()
release TSem
tSem)
         Just [IO String]
strActs ->
            do
               [String]
strs <- (IO String -> IO String) -> [IO String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IO String -> IO String
forall a. a -> a
id [IO String]
strActs
               Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Either [String] a
forall a b. a -> Either a b
Left [String]
strs)

tryAcquire :: TSem -> IO (Maybe [IO String])
-- if unsuccessful return the labels of all TSems held by this thread.
tryAcquire :: TSem -> IO (Maybe [IO String])
tryAcquire TSem
tSem =
   ThreadDict ThreadInfo
-> (Maybe ThreadInfo -> IO (Maybe ThreadInfo, Maybe [IO String]))
-> IO (Maybe [IO String])
forall a b. ThreadDict a -> (Maybe a -> IO (Maybe a, b)) -> IO b
modifyThreadDict ThreadDict ThreadInfo
threadInfoDict
      (\ Maybe ThreadInfo
threadInfoOpt ->
         (Maybe ThreadInfo, Maybe [IO String])
-> IO (Maybe ThreadInfo, Maybe [IO String])
forall (m :: * -> *) a. Monad m => a -> m a
return (case Maybe ThreadInfo
threadInfoOpt of
            Maybe ThreadInfo
Nothing -> (ThreadInfo -> Maybe ThreadInfo
forall a. a -> Maybe a
Just ([TSem] -> ThreadInfo
ThreadInfo [TSem
tSem]),Maybe [IO String]
forall a. Maybe a
Nothing)
            Just (ThreadInfo [TSem]
tSems) ->
               case (TSem -> Bool) -> [TSem] -> Maybe ([TSem], [TSem])
forall a. (a -> Bool) -> [a] -> Maybe ([a], [a])
splitToElem (\ TSem
tSem2 -> TSem -> ObjectID
oId TSem
tSem2 ObjectID -> ObjectID -> Bool
forall a. Eq a => a -> a -> Bool
== TSem -> ObjectID
oId TSem
tSem) [TSem]
tSems
                     of
                  Maybe ([TSem], [TSem])
Nothing -> -- not already locked
                     (ThreadInfo -> Maybe ThreadInfo
forall a. a -> Maybe a
Just ([TSem] -> ThreadInfo
ThreadInfo (TSem
tSem TSem -> [TSem] -> [TSem]
forall a. a -> [a] -> [a]
: [TSem]
tSems)),Maybe [IO String]
forall a. Maybe a
Nothing)
                  Just ([TSem]
tSems,[TSem]
_) -> -- already locked
                     (Maybe ThreadInfo
threadInfoOpt,[IO String] -> Maybe [IO String]
forall a. a -> Maybe a
Just ((TSem -> IO String) -> [TSem] -> [IO String]
forall a b. (a -> b) -> [a] -> [b]
map TSem -> IO String
label (TSem
tSem TSem -> [TSem] -> [TSem]
forall a. a -> [a] -> [a]
: [TSem] -> [TSem]
forall a. [a] -> [a]
reverse [TSem]
tSems)))
            )
         )

release :: TSem -> IO ()
release :: TSem -> IO ()
release TSem
tSem =
   ThreadDict ThreadInfo
-> (Maybe ThreadInfo -> IO (Maybe ThreadInfo, ())) -> IO ()
forall a b. ThreadDict a -> (Maybe a -> IO (Maybe a, b)) -> IO b
modifyThreadDict ThreadDict ThreadInfo
threadInfoDict
      (\ Maybe ThreadInfo
threadInfoOpt ->
         case Maybe ThreadInfo
threadInfoOpt of
            (Just (ThreadInfo (TSem
tSem2 : [TSem]
tSems)))
               | TSem -> ObjectID
oId TSem
tSem2 ObjectID -> ObjectID -> Bool
forall a. Eq a => a -> a -> Bool
== TSem -> ObjectID
oId TSem
tSem
               ->
               (Maybe ThreadInfo, ()) -> IO (Maybe ThreadInfo, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (
                  case [TSem]
tSems of
                     [] -> Maybe ThreadInfo
forall a. Maybe a
Nothing
                     [TSem]
_ -> ThreadInfo -> Maybe ThreadInfo
forall a. a -> Maybe a
Just ([TSem] -> ThreadInfo
ThreadInfo [TSem]
tSems)
                  , ())
            Maybe ThreadInfo
_ -> String -> IO (Maybe ThreadInfo, ())
forall a. HasCallStack => String -> a
error String
"TSem -- improperly nested release"
         )