diff --git a/src/Data/Unamb.hs b/src/Data/Unamb.hs --- a/src/Data/Unamb.hs +++ b/src/Data/Unamb.hs @@ -14,6 +14,8 @@ -- For non-flat types (where values may be partially defined, rather than -- necessarily bottom or fully defined) and information merging, see the -- lub package, . +-- +-- See unamb.cabal for the list of contributors. ---------------------------------------------------------------------- -- #include "Typeable.h" @@ -34,19 +36,23 @@ import Prelude hiding (catch) import System.IO.Unsafe -import Data.Function (on) import Control.Monad.Instances () -- for function functor import Control.Concurrent import Control.Exception import Data.Typeable ---import Data.IsEvaluated +-- import Data.IsEvaluated --- Use a particular exception as our representation for waiting forever. +-- | Use a particular exception as our representation for waiting forever. data BothBottom = BothBottom deriving(Show,Typeable) instance Exception BothBottom +-- | And another as our representation for a no-longer-needed value +data DontBother = DontBother deriving(Show,Typeable) + +instance Exception DontBother + -- | Unambiguous choice operator. Equivalent to the ambiguous choice -- operator, but with arguments restricted to be equal where not bottom, -- so that the choice doesn't matter. See also 'amb'. @@ -54,37 +60,79 @@ -- If anything kills unamb while it is evaluating (like nested unambs), it can -- be retried later but, unlike most functions, work may be lost. unamb :: a -> a -> a -unamb a b = unsafePerformIO $ do - -- First, check whether one of the values already is evaluated - -- #ifdef this for GHC - a' <- return False --isEvaluated a - b' <- return False --isEvaluated b - case (a',b') of - (True,_) -> return a - (_,True) -> return b - _ -> do retry (amb a b) - where retry act = act `catch` - (\(SomeException e) -> do - -- The throwTo is apparently needed, to ensure the - -- exception is thrown to *this* thread. - -- unsafePerformIO would otherwise restart the - -- throwIO call when re-invoked. --- print "abort" - myid <- myThreadId - unblock $ throwTo myid e >> retry act) +unamb = (fmap.fmap) restartingUnsafePerformIO amb +-- unamb a b = restartingUnsafePerformIO (amb a b) +restartingUnsafePerformIO :: IO a -> a +restartingUnsafePerformIO = unsafePerformIO . retry + where + -- Exception handling in unsafePerformIO does not happen like you're + -- used to in normal code. Specifically: + -- + -- * If a thread running unsafePerformIO code catches an asynchronous + -- exception, the stack is unwound until the first matching exception + -- handler as per normal, but if that unwinds it past the invocation + -- of the unsafePerformIO thunk, the entire state of the code running + -- in it is saved for later use. If the thunk is later re-entered, it + -- "unpauses" the code and it continues from where it stopped. + -- * If the code throws a normal exception, eg. throw/throwIO/pattern + -- match failure, etc. past the invocation thunk, the thunk is altered + -- to immediately throw that same exception if it is ever re-entered. + -- + -- These are both normally good things for efficiency reasons. It + -- presents us with a pickle when implementing unamb, however: + -- + -- * unamb is implemented by calling race, which creates threads that + -- it kills once it completes, for any reason, including exceptions. + -- * As invocations of unamb are often recursive, this means that + -- invocations of unamb are often killed by asynchronous exceptions. + -- * The normal "unpausing" behavior of unsafePerformIO would have them + -- keep trying to read a dead MVar, whose writers are now-dead threads. + -- + -- To fix this, we want to restart the action entirely when we catch an + -- exception. + -- + -- We do this by adding this exception handler, which instead of returning + -- normally retries the action at the end. We do of course want to throw + -- the exception on; however, we can't use throw/throwIO (as that would + -- make the thunk record itself as bottom), therefore we use throwTo + -- instead. + -- + -- Ensuring that the code doesn't execute the retry before the exception + -- is propagated, throwTo doesn't return until the exception has been + -- handled. + -- + -- Incidentally, all exception handlers run inside an implicit block, and + -- blocking operations contain an implicit unblock. This ensures that any + -- further pending exceptions won't mess this scheme up, as they can't be + -- delivered until after throwTo has been called. + -- + retry :: IO a -> IO a + retry act = + act `catch` \ (SomeException e) -> do + myThreadId >>= flip throwTo e + unblock $ retry act + + -- | n-ary 'unamb' unambs :: [a] -> a unambs [] = undefined -unambs [x] = x -unambs xs = foldr unamb undefined xs +unambs xs = foldr1 unamb xs -- | Ambiguous choice operator. Yield either value. Evaluates in -- separate threads and picks whichever finishes first. See also -- 'unamb' and 'race'. amb :: a -> a -> IO a -amb = race `on` evaluate +amb a b = do + -- First, check whether one of the values already is evaluated + -- #ifdef this out for non-GHC code. + a' <- return False --isEvaluated a + b' <- return False --isEvaluated b + case (a',b') of + (True,_) -> return a + (_,True) -> return b + _ -> race (evaluate a) (evaluate b) -- | Race two actions against each other in separate threads, and pick -- whichever finishes first. See also 'amb'. @@ -121,8 +169,7 @@ -- Just ThreadKilled -> -- -- kill self asynchronously and then retry if -- -- evaluated again. --- do throwIO e --- myThreadId >>= killThread +-- do myThreadId >>= killThread -- unblock (race a b) -- _ -> throwIO e @@ -134,10 +181,10 @@ race a b = block $ do v <- newEmptyMVar - let f x = forkIO $ putCatch x v + let f x = forkIO $ putCatch (unblock x) v ta <- f a tb <- f b - let cleanup = killThread ta >> killThread tb + let cleanup = throwTo ta DontBother >> throwTo tb DontBother loop 0 = throwIO BothBottom loop t = do x <- takeMVar v case x of Nothing -> loop (t-1) @@ -158,6 +205,7 @@ [ Handler $ \ ErrorCall {} -> return () , Handler $ \ BothBottom {} -> return () , Handler $ \ PatternMatchFail {} -> return () + , Handler $ \ DontBother {} -> return () -- This next handler hides bogus black holes, which show up as -- "<>" messages. I'd rather eliminate the problem than hide it. -- TODO: Remove and stress-test (e.g., reactive-fieldtrip) diff --git a/unamb.cabal b/unamb.cabal --- a/unamb.cabal +++ b/unamb.cabal @@ -1,5 +1,5 @@ Name: unamb -Version: 0.2 +Version: 0.2.2 Cabal-Version: >= 1.2 Synopsis: Unambiguous choice Category: Concurrency, Data, Other @@ -32,7 +32,7 @@ Library hs-Source-Dirs: src Extensions: - Build-Depends: base >= 4 + Build-Depends: base >= 4 && < 5 Exposed-Modules: Data.Unamb ghc-options: -Wall @@ -52,7 +52,7 @@ -- Only enable the build-depends here if configured with "-ftest". This -- keeps users from having to install QuickCheck 2 in order to use EMGM. if flag(test) - build-depends: QuickCheck, checkers + build-depends: QuickCheck >= 2, checkers else buildable: False ghc-options: -threaded