From 5a8a98d2f2e33e377f36256fb9f62e8a4e664789 Mon Sep 17 00:00:00 2001 From: ekmett Date: Thu, 1 Jul 2010 15:12:39 -0700 Subject: [PATCH] more folds --- Control/Concurrent/Speculation.hs | 92 ++++++++++++--------- Control/Morphism/Speculation.hs | 31 ++++++++ Data/Foldable/Speculation.hs | 36 +++++++-- Data/List/Speculation.hs | 90 +++++++++++---------- Data/Traversable/Speculation.hs | 128 ++++++++++++++---------------- ISSUES.markdown | 8 ++ speculation.cabal | 43 +++++++--- 7 files changed, 264 insertions(+), 164 deletions(-) create mode 100644 Control/Morphism/Speculation.hs diff --git a/Control/Concurrent/Speculation.hs b/Control/Concurrent/Speculation.hs index 496a8cf..939299d 100644 --- a/Control/Concurrent/Speculation.hs +++ b/Control/Concurrent/Speculation.hs @@ -36,34 +36,43 @@ import Unsafe.Coerce (unsafeCoerce) -- * 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. +-- | @'spec' g f a@ evaluates @f g@ while forcing @a@, if @g == a@ then @f g@ is returned, otherwise @f a@ is evaluated and returned. Furthermore, if the argument has already been evaluated, we skip the @f g@ computation entirely. 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. Under high load, since 'f g' is computed via the spark queue, the speculation will be skipped and you will obtain the same answer as 'f $! a'. -- --- Furthermore, if the argument has already been evaluated, we avoid sparking the parallel computation at all. +--The best-case timeline looks like: -- --- 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 --] +-- > foreground: [----- a -----] +-- > foreground: [-] (check g == a) +-- > spark: [----- f g -----] +-- > overall: [--- spec g f a ---] -- -- The worst-case timeline looks like: -- --- > [---- f g ----] --- > [----- a -----] --- > [---- f a ----] --- > [------- spec g f a -----------] +-- > foreground: [----- a -----] +-- > foreground: [-] (check g == a) +-- > foreground: [---- f a ----] +-- > spark: [----- f g -----] +-- > overall: [-------- spec g f a ---------] +-- +-- Note that, if @f g@ takes longer than a to compute, in the HEAD release of GHC, @f g@ will be collected and killed during garbage collection. +-- +-- > foreground: [----- a -----] +-- > foreground: [-] (check g == a) +-- > foreground: [---- f a ----] +-- > spark: [---- f g ----###### (#'s mark when this spark is collectable) +-- > overall: [--------- spec g f a --------] +-- +-- Under high load: +-- +-- > foreground: [----- a -----] +-- > foreground: [-] (check g == a) +-- > foreground: [---- f a ----] +-- > overall: [-------- spec g f a ---------] -- -- Compare these to the timeline of @f $! a@: -- --- > [---- a -----] --- > [---- f a ----] +-- > foreground: [----- a -----] +-- > foreground: [---- f a ----] +-- > orverall: [---------- f $! a ---------] spec :: Eq a => a -> (a -> b) -> a -> b spec = specBy (==) @@ -106,36 +115,45 @@ specOn' = specBy' . on (==) -- * 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. +-- | @'specSTM' g f a@ evaluates @fg = do g' <- g; f g'@, while forcing @a@, then if @g' == a@ then @fg@ is returned. Otherwise the side-effects of @fg@ are rolled back and @f a@ is evaluated. @g@ is allowed to be a monadic action, so that we can kickstart the computation of @a@ earlier. -- --- If the argument @a@ is already evaluated, we don\'t bother to perform @f g@ at all. +-- If the argument @a@ is already evaluated, we don\'t bother to perform @fg@ 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 ---] +-- > foreground: [--- g >>= f ---] +-- > spark: [------- a -------] +-- > foreground: [-] (compare g' == a) +-- > overall: [---- specSTM g f a ----] -- -- The worst-case timeline looks like: -- --- > [------ f g ------] --- > [------- a -------] --- > [-- rollback --] --- > [------ f a ------] --- > [------------------ spec g f a ------------------------] +-- > foreground: [---- g >>= f ----] +-- > spark: [------- a -------] +-- > foreground: [-] (check if g' == a) +-- > foreground: [--] (rollback) +-- > foreground: [------ f a ------] +-- > overall: [------------ specSTM g f a ----------------] +-- +-- Under high load, 'specSTM' degrades less gracefully than 'spec': +-- +-- > foreground: [---- g >>= f ----] +-- > spark: [------- a -------] +-- > foreground: [-] (check if g' == a) +-- > foreground: [--] (rollback) +-- > foreground: [------ f a ------] +-- > overall: [--------------------specSTM g f a ------------------------] -- -- Compare these to the timeline of @f $! a@: -- --- > [------- a -------] --- > [------ f a ------] +-- > foreground: [------- a -------] +-- > foreground: [------ f a ------] +-- specSTM :: Eq a => STM a -> (a -> STM b) -> a -> STM b specSTM = specBySTM (returning (==)) @@ -177,8 +195,7 @@ specOnSTM' :: Eq c => (a -> STM c) -> STM a -> (a -> STM b) -> a -> STM b specOnSTM' = specBySTM' . on (liftM2 (==)) {-# INLINE specOnSTM' #-} - --- | Inspect the dynamic pointer tagging bits of a closure. This is an impure function that relies on GHC internals and may falsely return 0, but never give the wrong tag number if it returns a non-0 value. +-- | Inspect the dynamic pointer tagging bits of a closure. This is an impure function that relies on GHC internals and may falsely return 0, but should never give the wrong tag number if it returns a non-0 value. unsafeGetTagBits :: a -> Int {-# INLINE unsafeGetTagBits #-} #ifndef TAGGED @@ -193,4 +210,3 @@ data Box a = Box a unsafeIsEvaluated :: a -> Bool unsafeIsEvaluated a = unsafeGetTagBits a /= 0 {-# INLINE unsafeIsEvaluated #-} - diff --git a/Control/Morphism/Speculation.hs b/Control/Morphism/Speculation.hs new file mode 100644 index 0000000..e931eba --- /dev/null +++ b/Control/Morphism/Speculation.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns, MagicHash #-} +module Control.Morphism.Speculation + ( hylo + ) where + +import GHC.Prim +import GHC.Types + +import Control.Concurrent.Speculation + +{- +newtype Mu f = In { out :: f (Mu f) } + +ana :: (Functor f, Eq a) => (Int -> a) -> (a -> f a) -> a -> Mu f +ana g psi = go 0# + where + go n = In . fmap (go (n +# 1#)) . spec (g (I# n)) psi + +apo :: (Functor f, Eq a) => (Int -> a) -> (a -> f (Either (Mu f) a)) -> a -> Mu f +apo g psi = go 0# + where + go n = In . fmap (either id (go (n +# 1#))) . spec (g (I# n)) psi +-} + +-- | @'hylo' g phi psi@ is a hylomorphism using a speculative anamorphism, where +-- @g n@ estimates the seed after n iterations of 'psi'. + +hylo :: (Functor f, Eq a) => (Int -> a) -> (f b -> b) -> (a -> f a) -> a -> b +hylo g phi psi = go 0# + where + go n = phi . fmap (go (n +# 1#)) . spec (g (I# n)) psi diff --git a/Data/Foldable/Speculation.hs b/Data/Foldable/Speculation.hs index a95701d..0c76669 100644 --- a/Data/Foldable/Speculation.hs +++ b/Data/Foldable/Speculation.hs @@ -87,27 +87,49 @@ foldMap :: (Foldable f, Monoid m, Eq m) => (Int -> m) -> (a -> m) -> f a -> m foldMap = foldMapBy (==) {-# INLINE foldMap #-} +-- | 'foldMap' using 'specBy' foldMapBy :: (Foldable f, Monoid m) => (m -> m -> Bool) -> (Int -> m) -> (a -> m) -> f a -> m foldMapBy cmp g f = foldrBy cmp g (mappend . f) mempty {-# INLINE foldMapBy #-} + +foldr :: (Foldable f, Eq b) => (Int -> b) -> (a -> b -> b) -> b -> f a -> b +foldr = foldrBy (==) +{-# INLINE foldr #-} + -- | Given a valid estimator @g@, @'foldr' g f z xs@ yields the same answer as @'foldr'' f z xs@. -- -- @g n@ should supply an estimate of the value returned from folding over the last @n@ elements of the container. -- -- If @g n@ is accurate a reasonable percentage of the time and faster to compute than the fold, then this can -- provide increased opportunities for parallelism. - -foldr :: (Foldable f, Eq b) => (Int -> b) -> (a -> b -> b) -> b -> f a -> b -foldr = foldrBy (==) -{-# INLINE foldr #-} - foldrBy :: Foldable f => (b -> b -> Bool) -> (Int -> b) -> (a -> b -> b) -> b -> f a -> b foldrBy cmp g f z = extractAcc . Foldable.foldr mf (Acc 0 z) where mf a (Acc n b) = Acc (n + 1) (specBy' cmp (g n) (f a) b) {-# INLINE foldrBy #-} + +{- +-- Variations: +-- These variations are not used because the values ot the left shouldn't affect the intermediate state of a right fold. +-- +-- this version receiveds both the number of values remaining and the number so far + +foldrBy :: Foldable f => (b -> b -> Bool) -> (Int -> Int -> b) -> (a -> b -> b) -> b -> f a -> b +foldrBy cmp g f z xs = Foldable.foldr mf (Acc 0 (const z)) xs 0 + where + mf a (Acc r b) !l = let l' = l + 1 in Acc (r + 1) (specBy' cmp (g l') (f a) (b l')) +{-# INLINE foldrBy #-} + +-- this estimator receives the number of values to the left of the summation. +foldrBy :: Foldable f => (b -> b -> Bool) -> (Int -> b) -> (a -> b -> b) -> b -> f a -> b +foldrBy cmp g f z xs = Foldable.foldr mf (const z) xs 0 + where + mf a b !i = let i' = i + 1 in specBy' cmp (g i') (f a) (b i') +{-# INLINE foldrBy #-} +-} + foldlM :: (Foldable f, Monad m, Eq (m b)) => (Int -> m b) -> (b -> a -> m b) -> m b -> f a -> m b foldlM = foldlByM (==) {-# INLINE foldlM #-} @@ -240,12 +262,12 @@ mapByM_ cmp g f = foldrBy cmp (\n -> g n >> return ()) ((>>) . f) (return ()) -- | 'for_' is 'mapM_' with its arguments flipped. forM_ :: (Foldable t, Monad m, Eq (m ())) => (Int -> m c) -> t a -> (a -> m b) -> m () forM_ g = flip (mapM_ g) -{-# INLINE forM_#-} +{-# INLINE forM_ #-} -- | 'for_' is 'mapM_' with its arguments flipped. forSTM_ :: Foldable t => STM Bool -> (Int -> STM c) -> t a -> (a -> STM b) -> STM () forSTM_ chk g = flip (mapSTM_ chk g) -{-# INLINE forSTM_#-} +{-# INLINE forSTM_ #-} forByM_ :: (Foldable t, Monad m) => (m () -> m () -> Bool) -> (Int -> m c) -> t a -> (a -> m b) -> m () forByM_ cmp g = flip (mapByM_ cmp g) diff --git a/Data/List/Speculation.hs b/Data/List/Speculation.hs index 53f4c23..631c75f 100644 --- a/Data/List/Speculation.hs +++ b/Data/List/Speculation.hs @@ -29,10 +29,16 @@ import Prelude hiding import Data.Monoid import qualified Data.List as List - import Control.Concurrent.Speculation import Control.Concurrent.Speculation.Internal +-- | Given a valid estimator @g@, @'scan' g xs@ converts @xs@ into a list of the prefix sums. +-- +-- @g n@ should supply an estimate of the value of the monoidal summation over the first @n@ elements of the container. +-- +-- If @g n@ is accurate a reasonable percentage of the time and faster to compute than the prefix sum, then this can +-- provide increased opportunities for parallelism. + scan :: (Monoid m, Eq m) => (Int -> m) -> [m] -> [m] scan = scanBy (==) {-# INLINE scan #-} @@ -42,12 +48,15 @@ scanBy :: Monoid m => (m -> m -> Bool) -> (Int -> m) -> [m] -> [m] scanBy cmp g = scanrBy cmp g mappend mempty {-# INLINE scanBy #-} --- | Given a valid estimator @g@, @'scanMap' g f xs@ yields the same answer as @'scanMap' f xs@. +-- | Given a valid estimator @g@, @'scanMap' g f xs@ converts @xs@ into a list of the prefix sums. -- --- @g n@ should supply an estimate of the value of the monoidal summation over the last @n@ elements of the container. +-- @g n@ should supply an estimate of the value of the monoidal summation over the first @n@ elements of the container. -- -- If @g n@ is accurate a reasonable percentage of the time and faster to compute than the scan, then this can -- provide increased opportunities for parallelism. +-- +-- > scan = scanMap id +-- > scanMap = scanMapBy (==) scanMap :: (Monoid m, Eq m) => (Int -> m) -> (a -> m) -> [a] -> [m] scanMap = scanMapBy (==) @@ -74,19 +83,51 @@ scanrBy cmp g f z = map extractAcc . List.scanr mf (Acc 0 z) mf a (Acc n b) = let n' = n + 1 in Acc n' (specBy' cmp (g n') (f a) b) {-# INLINE scanrBy #-} + +scanl :: Eq b => (Int -> b) -> (b -> a -> b) -> b -> [a] -> [b] +scanl = scanlBy (==) +{-# INLINE scanl #-} + +scanlBy :: (b -> b -> Bool) -> (Int -> b) -> (b -> a -> b) -> b -> [a] -> [b] +scanlBy cmp g f z = map extractAcc . List.scanl mf (Acc 0 z) + where + mf (Acc n a) b = let n' = n + 1 in Acc n' (specBy' cmp (g n') (`f` b) a) +{-# INLINE scanlBy #-} + +scanr1 :: Eq a => (Int -> a) -> (a -> a -> a) -> [a] -> [a] +scanr1 = scanr1By (==) +{-# INLINE scanr1 #-} + +scanr1By :: (a -> a -> Bool) -> (Int -> a) -> (a -> a -> a) -> [a] -> [a] +scanr1By cmp g f xs = map (fromMaybeAcc undefined) $ List.scanr mf NothingAcc xs + where + mf a (JustAcc n b) = let n' = n + 1 in JustAcc n' (specBy' cmp (g n') (f a) b) + mf a NothingAcc = JustAcc 1 a +{-# INLINE scanr1By #-} + +scanl1 :: Eq a => (Int -> a) -> (a -> a -> a) -> [a] -> [a] +scanl1 = scanl1By (==) +{-# INLINE scanl1 #-} + +scanl1By :: (a -> a -> Bool) -> (Int -> a) -> (a -> a -> a) -> [a] -> [a] +scanl1By cmp g f xs = map (fromMaybeAcc undefined) $ List.scanl mf NothingAcc xs + where + mf (JustAcc n a) b = let n' = n + 1 in JustAcc n' (specBy' cmp (g n') (`f` b) a) + mf NothingAcc b = JustAcc 1 b +{-# INLINE scanl1By #-} + {- -scanlM :: (Monad m, Eq (m b)) => (Int -> m b) -> (b -> a -> m b) -> m b -> [a] -> m [b] +scanlM :: (Monad m, Eq b) => (Int -> b) -> (b -> a -> m b) -> b -> [a] -> m [b] scanlM = scanlByM (==) {-# INLINE scanlM #-} -scanlByM :: Monad m => (m b -> m b -> Bool) -> (Int -> m b) -> (b -> a -> m b) -> m b -> [a] -> m [b] +scanlByM :: Monad m => (b -> b -> Bool) -> (Int -> b) -> (b -> a -> m b) -> b -> [a] -> m [b] scanlByM cmp g f mz = liftM (map extractAcc) . List.scanl go (liftM (map (Acc 0)) mz) where go mia b = do Acc n a <- mia - let !n' = n + 1 - a' <- specBy' cmp (g n') (>>= (`f` b)) (return a) - return (Acc n' a') + a' <- specBy' cmp (g n) (`f` b) a + return (Acc (n + 1) a') {-# INLINE scanlByM #-} scanrM :: (Monad m, Eq (m b)) => (Int -> m b) -> (a -> b -> m b) -> m b -> [a] -> m [b] @@ -138,36 +179,3 @@ scanrBySTM cmp g f mz = liftM (map extractAcc) . List.scanr go (liftM (Acc 0) mz -- If @g n@ is accurate a reasonable percentage of the time and faster to compute than the scan, then this can -- provide increased opportunities for parallelism. -} - -scanl :: Eq b => (Int -> b) -> (b -> a -> b) -> b -> [a] -> [b] -scanl = scanlBy (==) -{-# INLINE scanl #-} - -scanlBy :: (b -> b -> Bool) -> (Int -> b) -> (b -> a -> b) -> b -> [a] -> [b] -scanlBy cmp g f z = map extractAcc . List.scanl mf (Acc 0 z) - where - mf (Acc n a) b = let n' = n + 1 in Acc n' (specBy' cmp (g n') (`f` b) a) -{-# INLINE scanlBy #-} - -scanr1 :: Eq a => (Int -> a) -> (a -> a -> a) -> [a] -> [a] -scanr1 = scanr1By (==) -{-# INLINE scanr1 #-} - -scanr1By :: (a -> a -> Bool) -> (Int -> a) -> (a -> a -> a) -> [a] -> [a] -scanr1By cmp g f xs = map (fromMaybeAcc undefined) $ List.scanr mf NothingAcc xs - where - mf a (JustAcc n b) = let n' = n + 1 in JustAcc n' (specBy' cmp (g n') (f a) b) - mf a NothingAcc = JustAcc 1 a -{-# INLINE scanr1By #-} - -scanl1 :: Eq a => (Int -> a) -> (a -> a -> a) -> [a] -> [a] -scanl1 = scanl1By (==) -{-# INLINE scanl1 #-} - -scanl1By :: (a -> a -> Bool) -> (Int -> a) -> (a -> a -> a) -> [a] -> [a] -scanl1By cmp g f xs = map (fromMaybeAcc undefined) $ List.scanl mf NothingAcc xs - where - mf (JustAcc n a) b = let n' = n + 1 in JustAcc n' (specBy' cmp (g n') (`f` b) a) - mf NothingAcc b = JustAcc 1 b -{-# INLINE scanl1By #-} - diff --git a/Data/Traversable/Speculation.hs b/Data/Traversable/Speculation.hs index f4ae6b9..2e82ea5 100644 --- a/Data/Traversable/Speculation.hs +++ b/Data/Traversable/Speculation.hs @@ -29,29 +29,6 @@ import Control.Concurrent.STM import Control.Concurrent.Speculation import Control.Concurrent.Speculation.Internal -acc :: Int# -> a -> Acc a -acc i a = Acc (I# i) a -{-# INLINE acc #-} - -data IntAccumL s a = IntAccumL (Int# -> s -> (# Int#, s, a #)) - -runIntAccumL :: IntAccumL s a -> Int -> s -> (s, a) -runIntAccumL (IntAccumL m) (I# i) s = case m i s of - (# _, s1, a #) -> (s1, a) -{-# INLINE runIntAccumL #-} - -instance Functor (IntAccumL s) where - fmap f (IntAccumL m) = IntAccumL (\i s -> case m i s of - (# i1, s1, a #) -> (# i1, s1, f a #)) - -instance Applicative (IntAccumL s) where - pure a = IntAccumL (\i s -> (# i, s, a #)) - IntAccumL mf <*> IntAccumL ma = IntAccumL (\i s -> - case mf i s of - (# i1, s1, f #) -> - case ma i1 s1 of - (# i2, s2, a #) -> (# i2, s2, f a #)) - mapAccumL :: (Traversable t, Eq a) => (Int -> a) -> (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumL = mapAccumLBy (==) {-# INLINE mapAccumL #-} @@ -64,25 +41,6 @@ mapAccumLBy cmp g f z xs = runIntAccumL (Traversable.traverse go xs) 0 z in (# n +# 1#, a', c #)) {-# INLINE mapAccumLBy #-} -data IntAccumR s a = IntAccumR (Int# -> s -> (# Int#, s, a #)) - -runIntAccumR :: IntAccumR s a -> Int -> s -> (s, a) -runIntAccumR (IntAccumR m) (I# i) s = case m i s of - (# _, s1, a #) -> (s1, a) -{-# INLINE runIntAccumR #-} - -instance Functor (IntAccumR s) where - fmap f (IntAccumR m) = IntAccumR (\i s -> case m i s of - (# i1, s1, a #) -> (# i1, s1, f a #)) - -instance Applicative (IntAccumR s) where - pure a = IntAccumR (\i s -> (# i, s, a #)) - IntAccumR mf <*> IntAccumR ma = IntAccumR (\i s -> - case ma i s of - (# i1, s1, a #) -> - case mf i1 s1 of - (# i2, s2, f #) -> (# i2, s2, f a #)) - mapAccumR :: (Traversable t, Eq a) => (Int -> a) -> (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumR = mapAccumRBy (==) {-# INLINE mapAccumR #-} @@ -95,31 +53,6 @@ mapAccumRBy cmp g f z xs = runIntAccumR (Traversable.traverse go xs) 0 z in (# n +# 1#, a', c #)) {-# INLINE mapAccumRBy #-} --- applicative composition with a strict integer state applicative -newtype AccT m a = AccT (Int# -> Acc (m a)) - -runAccT :: Applicative m => AccT m a -> Int -> m a -runAccT (AccT m) (I# i) = extractAcc (m i) -{-# INLINE runAccT #-} - -instance Functor f => Functor (AccT f) where - fmap f (AccT m) = AccT (\i# -> case m i# of Acc i a -> Acc i (fmap f a)) - -instance Applicative f => Applicative (AccT f) where - pure a = AccT (\i -> Acc (I# i) (pure a)) - AccT mf <*> AccT ma = AccT (\i0# -> - let !(Acc !(I# i1#) f) = mf i0# - !(Acc i2 a) = ma i1# - in Acc i2 (f <*> a)) - -newtype IntStateT m a = IntStateT { runIntStateT :: Int# -> m (Acc a) } - -instance Monad m => Monad (IntStateT m) where - return a = IntStateT (\i -> return (acc i a)) - IntStateT mm >>= k = IntStateT $ \i0 -> do - Acc (I# i1) m <- mm i0 - runIntStateT (k m) i1 - traverse :: (Traversable t, Applicative f, Eq a) => (Int -> a) -> (a -> f b) -> t a -> f (t b) traverse = traverseBy (==) {-# INLINE traverse #-} @@ -199,3 +132,64 @@ forSTM g = flip (mapSTM g) forBySTM :: Traversable t => (a -> a -> STM Bool) -> (Int -> STM a) -> t a -> (a -> STM b) -> STM (t b) forBySTM cmp g = flip (mapBySTM cmp g) {-# INLINE forBySTM #-} + +-- Utilities + +acc :: Int# -> a -> Acc a +acc i a = Acc (I# i) a +{-# INLINE acc #-} + +data IntAccumL s a = IntAccumL (Int# -> s -> (# Int#, s, a #)) + +runIntAccumL :: IntAccumL s a -> Int -> s -> (s, a) +runIntAccumL (IntAccumL m) (I# i) s = case m i s of + (# _, s1, a #) -> (s1, a) +{-# INLINE runIntAccumL #-} + +instance Functor (IntAccumL s) where + fmap f (IntAccumL m) = IntAccumL (\i s -> case m i s of + (# i1, s1, a #) -> (# i1, s1, f a #)) + +instance Applicative (IntAccumL s) where + pure a = IntAccumL (\i s -> (# i, s, a #)) + IntAccumL mf <*> IntAccumL ma = IntAccumL (\i s -> + case mf i s of + (# i1, s1, f #) -> + case ma i1 s1 of + (# i2, s2, a #) -> (# i2, s2, f a #)) + +data IntAccumR s a = IntAccumR (Int# -> s -> (# Int#, s, a #)) + +runIntAccumR :: IntAccumR s a -> Int -> s -> (s, a) +runIntAccumR (IntAccumR m) (I# i) s = case m i s of + (# _, s1, a #) -> (s1, a) +{-# INLINE runIntAccumR #-} + +instance Functor (IntAccumR s) where + fmap f (IntAccumR m) = IntAccumR (\i s -> case m i s of + (# i1, s1, a #) -> (# i1, s1, f a #)) + +instance Applicative (IntAccumR s) where + pure a = IntAccumR (\i s -> (# i, s, a #)) + IntAccumR mf <*> IntAccumR ma = IntAccumR (\i s -> + case ma i s of + (# i1, s1, a #) -> + case mf i1 s1 of + (# i2, s2, f #) -> (# i2, s2, f a #)) + +-- applicative composition with a strict integer state applicative +newtype AccT m a = AccT (Int# -> Acc (m a)) + +runAccT :: Applicative m => AccT m a -> Int -> m a +runAccT (AccT m) (I# i) = extractAcc (m i) +{-# INLINE runAccT #-} + +instance Functor f => Functor (AccT f) where + fmap f (AccT m) = AccT (\i# -> case m i# of Acc i a -> Acc i (fmap f a)) + +instance Applicative f => Applicative (AccT f) where + pure a = AccT (\i -> Acc (I# i) (pure a)) + AccT mf <*> AccT ma = AccT (\i0# -> + let !(Acc !(I# i1#) f) = mf i0# + !(Acc i2 a) = ma i1# + in Acc i2 (f <*> a)) diff --git a/ISSUES.markdown b/ISSUES.markdown index c54ae86..cd8d8ba 100644 --- a/ISSUES.markdown +++ b/ISSUES.markdown @@ -30,3 +30,11 @@ unboxed tag-checking -------------------- For tag checking purposes, we should be able to unsafeCoerce# a :: Word#, but it isn't subkinded. Ticket? + +inconsistent use of the estimator function +------------------------------------------ + +It is tricky to know which direction the estimator counts. Perhaps we should left bias all of them? + +But that would be less pleasant, because now the number of values you haven't looked at would determine the +guess at the value of the right fold. diff --git a/speculation.cabal b/speculation.cabal index 05d3aaa..7e38c83 100644 --- a/speculation.cabal +++ b/speculation.cabal @@ -24,27 +24,45 @@ description: . For example: . - @'spec' g f a@ evaluates @f g@ while forcing @a@, if @g == a@ then @f g@ is returned, otherwise @f a@ is evaluated and returned. Furthermore, if the argument has already been evaluated, we skip the @f g@ computation entirely. 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' g f a@ evaluates @f g@ while forcing @a@, if @g == a@ then @f g@ is returned, otherwise @f a@ is evaluated and returned. Furthermore, if the argument has already been evaluated, we skip the @f g@ computation entirely. 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. Under high load, since 'f g' is computed via the spark queue, the speculation will be skipped and you will obtain the same answer as 'f $! a'. . The best-case timeline looks like: . - > [---- f g ----] - > [----- a -----] - > [-- spec g f a --] + > foreground: [----- a -----] + > foreground: [-] (check g == a) + > spark: [----- f g -----] + > overall: [--- spec g f a ---] . The worst-case timeline looks like: . - > [---- f g ----] - > [----- a -----] - > [---- f a ----] - > [------- spec g f a -----------] + > foreground: [----- a -----] + > foreground: [-] (check g == a) + > foreground: [---- f a ----] + > spark: [----- f g -----] + > overall: [-------- spec g f a ---------] + . + Note that, if @f g@ takes longer than a to compute, in the HEAD release of GHC, @f g@ will be collected and killed during garbage collection. + . + > foreground: [----- a -----] + > foreground: [-] (check g == a) + > foreground: [---- f a ----] + > spark: [---- f g ----###### (#'s mark when this spark is collectable) + > overall: [--------- spec g f a --------] + . + Under high load: + . + > foreground: [----- a -----] + > foreground: [-] (check g == a) + > foreground: [---- f a ----] + > overall: [-------- spec g f a ---------] . Compare these to the timeline of @f $! a@: . - > [---- a -----] - > [---- f a ----] + > foreground: [----- a -----] + > foreground: [---- f a ----] + > orverall: [---------- f $! a ---------] . - 'specSTM' provides a similar time table for STM actions, but also rolls back side-effects. + 'specSTM' provides a similar time table for STM actions, but also rolls back side-effects. The one unfortunate operational distinction is that it is forced to compute 'a' in the background thread and therefore degrades slightly less gracefully under load. extra-source-files: README.markdown @@ -93,6 +111,7 @@ library exposed-modules: Control.Concurrent.Speculation + Control.Morphism.Speculation Data.Foldable.Speculation Data.Traversable.Speculation Data.List.Speculation @@ -122,6 +141,7 @@ executable test-speculation other-modules: Control.Concurrent.Speculation.Internal Control.Concurrent.Speculation + Control.Morphism.Speculation Data.Foldable.Speculation Data.Traversable.Speculation Data.List.Speculation @@ -144,6 +164,7 @@ executable benchmark-speculation other-modules: Control.Concurrent.Speculation.Internal Control.Concurrent.Speculation + Control.Morphism.Speculation Data.Foldable.Speculation Data.Traversable.Speculation Data.List.Speculation