Add pOr and pAnd

Summary:
These two operators are subtly non-deterministic, but can potentially
improve performance significantly in cases where

* We don't want to use .|| because it's too sequential
* We don't want to use || because it forces us to do wasted work

(and equivalently for &&).

The implementation is a bit subtle, see Note [tricky pOr/pAnd]

Reviewed By: xich

Differential Revision: D4611809

fbshipit-source-id: 832ace29dfc44e48c14cc5d4f52a0114ee326c92

Haxl/Core.hs

@@ -33,6 +33,9 @@ module Haxl.Core (
   memo, memoize, memoize1, memoize2,
   memoFingerprint, MemoFingerprintKey(..),
 
+  -- ** Conditionals
+  pAnd, pOr,
+
   -- ** Statistics
   Stats(..),
   RoundStats(..),

Haxl/Core/Monad.hs

@@ -51,6 +51,9 @@ module Haxl.Core.Monad (
 
     -- * Unsafe operations
     unsafeLiftIO, unsafeToHaxlException,
+
+    -- * Parallel operaitons
+    pAnd, pOr
   ) where
 
 import Haxl.Core.Types
@@ -1210,3 +1213,81 @@ runMemo2 (MemoVar2 r) k1 k2 = unsafeLiftIO (readIORef r) >>= \case
           (MemoTbl2 (f, HashMap.insert k1 (HashMap.insert k2 v h2) h1))
         runMemo v
       Just v -> runMemo v
+
+
+-- -----------------------------------------------------------------------------
+-- Parallel operations
+
+-- Bind more tightly than .&&, .||
+infixr 5 `pAnd`
+infixr 4 `pOr`
+
+-- | Parallel version of '(.||)'.  Both arguments are evaluated in
+-- parallel, and if either returns 'True' then the other is
+-- not evaluated any further.
+--
+-- WARNING: exceptions may be unpredictable when using 'pOr'.  If one
+-- argument returns 'True' before the other completes, then 'pOr'
+-- returns 'True' immediately, ignoring a possible exception that
+-- the other argument may have produced if it had been allowed to
+-- complete.
+pOr :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool
+GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env ref -> do
+  ra <- a env ref
+  case ra of
+    Done True -> return (Done True)
+    Done False -> b env ref
+    Throw _ -> return ra
+    Blocked a' -> do
+      rb <- b env ref
+      case rb of
+        Done True -> return (Blocked (Cont (return True)))
+          -- Note [tricky pOr/pAnd]
+        Done False -> return ra
+        Throw e -> return (Blocked (Cont (throw e)))
+        Blocked b' -> return (Blocked (Cont (toHaxl a' `pOr` toHaxl b')))
+
+-- | Parallel version of '(.&&)'.  Both arguments are evaluated in
+-- parallel, and if either returns 'False' then the other is
+-- not evaluated any further.
+--
+-- WARNING: exceptions may be unpredictable when using 'pAnd'.  If one
+-- argument returns 'False' before the other completes, then 'pAnd'
+-- returns 'False' immediately, ignoring a possible exception that
+-- the other argument may have produced if it had been allowed to
+-- complete.
+pAnd :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool
+GenHaxl a `pAnd` GenHaxl b = GenHaxl $ \env ref -> do
+  ra <- a env ref
+  case ra of
+    Done False -> return (Done False)
+    Done True -> b env ref
+    Throw _ -> return ra
+    Blocked a' -> do
+      rb <- b env ref
+      case rb of
+        Done False -> return (Blocked (Cont (return False)))
+          -- Note [tricky pOr/pAnd]
+        Done True -> return ra
+        Throw _ -> return rb
+        Blocked b' -> return (Blocked (Cont (toHaxl a' `pAnd` toHaxl b')))
+
+{-
+Note [tricky pOr/pAnd]
+
+If one branch returns (Done True) and the other returns (Blocked _),
+even though we know the result will be True (in the case of pOr), we
+must return Blocked.  This is because there are data fetches to
+perform, and if we don't do this, the cache is left with an empty
+ResultVar, and the next fetch for the same request will fail.
+
+Alternatives:
+
+ * Test for a non-empty RequestStore in runHaxl when we get Done, but
+   that would penalise every runHaxl.
+
+ * Try to abandon the fetches. This is hard: we've already stored the
+   requests and a ResultVars in the cache, and we don't know how to
+   find the right fetches to remove from the cache.  Furthermore, we
+   might have partially computed some memoized computations.
+-}

Haxl/Prelude.hs

@@ -52,6 +52,7 @@ module Haxl.Prelude (
     (.==), (./=), (.&&), (.||),
     (.++),
     pair,
+    pAnd, pOr,
 
     -- * Text things
     Text,

tests/BatchTests.hs

@@ -176,6 +176,103 @@ deterministicExceptions = do
      Left (NotFound "xxx") -> True
      _ -> False
 
+pOrTests = do
+  env <- makeTestEnv
+
+  -- Test semantics
+  r <- runHaxl env $ do
+        a <- return False `pOr` return False
+        b <- return False `pOr` return True
+        c <- return True `pOr` return False
+        d <- return True `pOr` return True
+        return (not a && b && c && d)
+  assertBool "pOr0" r
+
+  -- pOr is left-biased with respsect to exceptions:
+  r <- runHaxl env $ try $ return True `pOr` throw (NotFound "foo")
+  assertBool "pOr1" $
+    case (r :: Either NotFound Bool) of
+      Right True -> True
+      _ -> False
+  r <- runHaxl env $ try $ throw (NotFound "foo") `pOr` return True
+  assertBool "pOr2" $
+    case (r :: Either NotFound Bool) of
+      Left (NotFound "foo") -> True
+      _ -> False
+
+  -- pOr is non-deterministic (see also Note [tricky pOr/pAnd])
+  let nondet = (do _ <- friendsOf 1; throw (NotFound "foo")) `pOr` return True
+  r <- runHaxl env $ try nondet
+  assertBool "pOr3" $
+    case (r :: Either NotFound Bool) of
+      Right True -> True
+      _ -> False
+  -- next we populate the cache
+  _ <- runHaxl env $ friendsOf 1
+  -- and now exactly the same pOr again will throw this time:
+  r <- runHaxl env $ try nondet
+  assertBool "pOr4" $
+    case (r :: Either NotFound Bool) of
+      Left (NotFound "foo") -> True
+      _ -> False
+
+  -- One more test: Blocked/False => Blocked
+  r <- runHaxl env $ try $
+    (do _ <- friendsOf 2; throw (NotFound "foo")) `pOr` return False
+  assertBool "pOr5" $
+    case (r :: Either NotFound Bool) of
+      Left (NotFound _) -> True
+      _ -> False
+
+pAndTests = do
+  env <- makeTestEnv
+
+  -- Test semantics
+  r <- runHaxl env $ do
+        a <- return False `pAnd` return False
+        b <- return False `pAnd` return True
+        c <- return True `pAnd` return False
+        d <- return True `pAnd` return True
+        return (not a && not b && not c && d)
+  assertBool "pAnd0" r
+
+  -- pAnd is left-biased with respsect to exceptions:
+  r <- runHaxl env $ try $ return False `pAnd` throw (NotFound "foo")
+  assertBool "pAnd1" $
+    case (r :: Either NotFound Bool) of
+      Right False -> True
+      _ -> False
+  r <- runHaxl env $ try $ throw (NotFound "foo") `pAnd` return False
+  assertBool "pAnd2" $
+    case (r :: Either NotFound Bool) of
+      Left (NotFound "foo") -> True
+      _ -> False
+
+  -- pAnd is non-deterministic (see also Note [tricky pOr/pAnd])
+  let nondet =
+        (do _ <- friendsOf 1; throw (NotFound "foo")) `pAnd` return False
+  r <- runHaxl env $ try nondet
+  assertBool "pAnd3" $
+    case (r :: Either NotFound Bool) of
+      Right False -> True
+      _ -> False
+  -- next we populate the cache
+  _ <- runHaxl env $ friendsOf 1
+  -- and now exactly the same pAnd again will throw this time:
+  r <- runHaxl env $ try nondet
+  assertBool "pAnd4" $
+    case (r :: Either NotFound Bool) of
+      Left (NotFound "foo") -> True
+      _ -> False
+
+  -- One more test: Blocked/True => Blocked
+  r <- runHaxl env $ try $
+    (do _ <- friendsOf 2; throw (NotFound "foo")) `pAnd` return True
+  assertBool "pAnd5" $
+    case (r :: Either NotFound Bool) of
+      Left (NotFound _) -> True
+      _ -> False
+
 tests = TestList
   [ TestLabel "batching1" $ TestCase batching1
   , TestLabel "batching2" $ TestCase batching2
@@ -194,4 +291,6 @@ tests = TestList
   , TestLabel "exceptionTest1" $ TestCase exceptionTest1
   , TestLabel "exceptionTest2" $ TestCase exceptionTest2
   , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions
+  , TestLabel "pOrTest" $ TestCase pOrTests
+  , TestLabel "pAndTest" $ TestCase pAndTests
   ]