Speculation.hs

{-# LANGUAGE DeriveDataTypeable #-}
module Control.Concurrent.STM.Speculation 
    ( specSTM
    , specSTM'
    ) where

import Control.Concurrent.STM
import Control.Concurrent.Speculation (evaluated)
import Control.Exception (Exception, throw, fromException)
import Control.Parallel (par)
import Data.Typeable (Typeable)
import System.IO.Unsafe (unsafePerformIO)

newtype Speculation = Speculation Int deriving (Show,Eq,Typeable)
instance Exception Speculation

-- | @'specSTM' g f a@ evaluates @f g@ while forcing @a@, if @g == a@ then @f g@ is returned. Otherwise the side-effects 
-- of the current STM transaction are rolled back and @f a@ is evaluated.
--   
-- If the argument @a@ is already evaluated, we don\'t bother to perform @f g@ at all.
--
-- If a good guess at the value of @a@ is available, this is one way to induce parallelism in an otherwise sequential task. 
--
-- However, if the guess isn\'t available more cheaply than the actual answer then this saves no work, and if the guess is
-- wrong, you risk evaluating the function twice.
--
-- > specSTM a f a = f $! a
--
-- The best-case timeline looks like:
--
-- > [------ f g ------]
-- >     [------- a -------]
-- > [--- specSTM g f a ---]
--
-- The worst-case timeline looks like:
--
-- > [------ f g ------] 
-- >     [------- a -------]
-- >                       [-- rollback --]
-- >                                      [------ f a ------]     
-- > [------------------ spec g f a ------------------------]
--
-- Compare these to the timeline of @f $! a@:
--
-- > [------- a -------]
-- >                   [------ f a ------]

specSTM :: Eq a => a -> (a -> STM b) -> a -> STM b
specSTM g f a 
    | evaluated a = f a 
    | otherwise   = specSTM' g f a

-- | Unlike @specSTM@, @specSTM'@ doesn't check if the argument has already been evaluated.

specSTM' :: Eq a => a -> (a -> STM b) -> a -> STM b
specSTM' g f a = a `par` do
    exn <- freshSpeculation
    let try = do
            result <- f g 
            if a /= g 
                then throw exn
                else return result
    try `catchSTM` \e -> case fromException e of
        Just exn' | exn == exn' -> f a -- rerun with alternative inputs
        _ -> throw e                   -- this is somebody else's problem

speculationSupply :: TVar Int
speculationSupply = unsafePerformIO $ newTVarIO 0

freshSpeculation :: STM Speculation
freshSpeculation = do
    n <- readTVar speculationSupply
    writeTVar speculationSupply $! n + 1
    return (Speculation n)