unamb 0.2 → 0.2.2

raw patch · 2 files changed

+79/−31 lines, 2 filesdep ~QuickCheck

Dependency ranges changed: QuickCheck

Files

• src/Data/Unamb.hs +76/−28
• unamb.cabal +3/−3

@@ -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, <http://haskell.org/haskellwiki/Lub>.+-- +-- 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                  -- "<<loop>>" messages.  I'd rather eliminate the problem than hide it.                  -- TODO: Remove and stress-test (e.g., reactive-fieldtrip)

@@ -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