{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} module Control.Concurrent.Speculation ( -- * Speculative application spec , spec' , specBy , specBy' , specOn , specOn' -- * Speculative application with transactional rollback , specSTM , specSTM' , specOnSTM , specOnSTM' , specBySTM , specBySTM' -- * Codensity STM speculation , specCSTM , specCSTM' , specOnCSTM , specOnCSTM' , specByCSTM , specByCSTM' , CSTM -- * Codensity , Codensity(..) , liftCodensity , lowerCodensity ) where import Control.Concurrent.STM import Control.Concurrent.Speculation.Internal (Codensity(..), liftCodensity, lowerCodensity, evaluated) import Control.Exception (Exception, throw, fromException) import Control.Parallel (par) import Data.Typeable (Typeable) import Data.Function (on) import System.IO.Unsafe (unsafePerformIO) type CSTM = Codensity STM -- * Basic speculation -- | @'spec' g f a@ evaluates @f g@ while forcing @a@, if @g == a@ then @f g@ is returned. Otherwise @f a@ is evaluated. -- -- Furthermore, if the argument has already been evaluated, we avoid sparking the parallel computation 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. -- -- > spec a f a = f $! a -- -- The best-case timeline looks like: -- -- > [---- f g ----] -- > [----- a -----] -- > [-- spec g f a --] -- -- The worst-case timeline looks like: -- -- > [---- f g ----] -- > [----- a -----] -- > [---- f a ----] -- > [------- spec g f a -----------] -- -- Compare these to the timeline of @f $! a@: -- -- > [---- a -----] -- > [---- f a ----] spec :: Eq a => a -> (a -> b) -> a -> b spec = specBy (==) {-# INLINE spec #-} -- | Unlike 'spec', this version does not check to see if the argument has already been evaluated. This can save -- a small amount of work when you know the argument will always require computation. spec' :: Eq a => a -> (a -> b) -> a -> b spec' = specBy' (==) {-# INLINE spec' #-} -- | 'spec' with a user defined comparison function specBy :: (a -> a -> Bool) -> a -> (a -> b) -> a -> b specBy cmp g f a | evaluated a = f a | otherwise = specBy' cmp g f a {-# INLINE specBy #-} -- | 'spec'' with a user defined comparison function specBy' :: (a -> a -> Bool) -> a -> (a -> b) -> a -> b specBy' cmp guess f a = speculation `par` if cmp guess a then speculation else f a where speculation = f guess {-# INLINE specBy' #-} -- | 'spec' comparing by projection onto another type specOn :: Eq c => (a -> c) -> a -> (a -> b) -> a -> b specOn = specBy . on (==) {-# INLINE specOn #-} -- | 'spec'' comparing by projection onto another type specOn' :: Eq c => (a -> c) -> a -> (a -> b) -> a -> b specOn' = specBy' . on (==) {-# INLINE specOn' #-} -- * STM-based 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 = specBySTM (==) {-# INLINE specSTM #-} -- | Unlike 'specSTM', 'specSTM'' doesn't check if the argument has already been evaluated. specSTM' :: Eq a => a -> (a -> STM b) -> a -> STM b specSTM' = specBySTM' (==) {-# INLINE specSTM' #-} -- | 'specSTM' using a user defined comparison function specBySTM :: (a -> a -> Bool) -> a -> (a -> STM b) -> a -> STM b specBySTM cmp g f a | evaluated a = f a | otherwise = specBySTM' cmp g f a {-# INLINE specBySTM #-} -- | 'specSTM'' using a user defined comparison function specBySTM' :: (a -> a -> Bool) -> a -> (a -> STM b) -> a -> STM b specBySTM' cmp g f a = a `par` do exn <- freshSpeculation let try = do result <- f g if cmp g a then return result else throw exn 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 {-# INLINE specBySTM' #-} -- | 'specBySTM' . 'on' (==)' specOnSTM :: Eq c => (a -> c) -> a -> (a -> STM b) -> a -> STM b specOnSTM = specBySTM . on (==) {-# INLINE specOnSTM #-} -- | 'specBySTM'' . 'on' (==)' specOnSTM' :: Eq c => (a -> c) -> a -> (a -> STM b) -> a -> STM b specOnSTM' = specBySTM' . on (==) {-# INLINE specOnSTM' #-} -- ** Codensity STM speculation specCSTM :: Eq a => a -> (a -> CSTM b) -> a -> CSTM b specCSTM = specByCSTM (==) {-# INLINE specCSTM #-} -- | Unlike 'specSTM', 'specSTM'' doesn't check if the argument has already been evaluated. specCSTM' :: Eq a => a -> (a -> CSTM b) -> a -> CSTM b specCSTM' = specByCSTM' (==) {-# INLINE specCSTM' #-} -- | 'specSTM' using a user defined comparison function specByCSTM :: (a -> a -> Bool) -> a -> (a -> CSTM b) -> a -> CSTM b specByCSTM cmp g f a | evaluated a = f a | otherwise = specByCSTM' cmp g f a {-# INLINE specByCSTM #-} -- | 'specCSTM'' using a user defined comparison function specByCSTM' :: (a -> a -> Bool) -> a -> (a -> CSTM b) -> a -> CSTM b specByCSTM' cmp g f a = a `par` Codensity $ \k -> do exn <- freshSpeculation let try = do result <- lowerCodensity (f g) if cmp g a then k result else throw exn try `catchSTM` \e -> case fromException e of Just exn' | exn == exn' -> lowerCodensity (f a) >>= k -- rerun with alternative inputs _ -> throw e -- this is somebody else's problem {-# INLINE specByCSTM' #-} -- | 'specByCSTM' . 'on' (==)' specOnCSTM :: Eq c => (a -> c) -> a -> (a -> CSTM b) -> a -> CSTM b specOnCSTM = specByCSTM . on (==) {-# INLINE specOnCSTM #-} -- | 'specByCSTM'' . 'on' (==)' specOnCSTM' :: Eq c => (a -> c) -> a -> (a -> CSTM b) -> a -> CSTM b specOnCSTM' = specByCSTM' . on (==) {-# INLINE specOnCSTM' #-} -- | TVar used to allocate speculation exceptions speculationSupply :: TVar Int speculationSupply = unsafePerformIO $ newTVarIO 0 {-# NOINLINE speculationSupply #-} freshSpeculation :: STM Speculation freshSpeculation = do n <- readTVar speculationSupply writeTVar speculationSupply $! n + 1 return (Speculation n) {-# INLINE freshSpeculation #-} newtype Speculation = Speculation Int deriving (Show,Eq,Typeable) instance Exception Speculation