module Control.Concurrent.Speculation
( spec
, evaluated
, specFoldr
, specFoldl
, Speculative(..)
, WrappedFoldable(..)
, WithoutSpeculation(..)
) where
import Prelude hiding (foldl, foldl1, foldr, foldr1)
import Data.Array
import Data.Ix ()
import Data.Foldable
import Data.Traversable
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Set (Set)
import Data.Sequence (Seq)
import Data.Data
import Control.Parallel (par)
import Data.Bits
import Foreign
import Unsafe.Coerce
data Box a = Box a
tag :: a -> Int
tag a = unsafeCoerce (Box a) .&. (sizeOf (undefined :: Int) 1)
evaluated :: a -> Bool
evaluated a = tag a /= 0
spec :: Eq a => a -> (a -> b) -> a -> b
spec guess f a
| evaluated a = f a
| otherwise =
speculation `par`
if guess == a
then speculation
else f a
where
speculation = f guess
specFoldr :: (Speculative f, Eq b) => (Int -> b) -> (a -> b -> b) -> b -> f a -> b
specFoldr = specFoldrN 0
specFoldl :: (Speculative f, Eq b) => (Int -> b) -> (b -> a -> b) -> b -> f a -> b
specFoldl = specFoldlN 0
class Foldable f => Speculative f where
specFoldr1 :: Eq a => (Int -> a) -> (a -> a -> a) -> f a -> a
specFoldrN :: Eq b => Int -> (Int -> b) -> (a -> b -> b) -> b -> f a -> b
specFoldl1 :: Eq a => (Int -> a) -> (a -> a -> a) -> f a -> a
specFoldlN :: Eq b => Int -> (Int -> b) -> (b -> a -> b) -> b -> f a -> b
specFoldr1 g f = specFoldr1 g f . toList
specFoldrN n g f z = specFoldrN n g f z . toList
specFoldl1 g f = specFoldl1 g f . toList
specFoldlN n g f z = specFoldlN n g f z . toList
errorEmptyStructure :: String -> a
errorEmptyStructure f = error $ f ++ ": error empty structure"
instance Speculative [] where
specFoldr1 g f = go 0
where
go _ [] = errorEmptyStructure "specFoldr1"
go !n (x:xs) = n' `seq` spec (g n') (f x) (go n' xs)
where
n' = n + 1
specFoldrN _ _ _ z [] = z
specFoldrN !n g f z (x:xs) = n' `seq` spec (g n') (f x) (specFoldrN n' g f z xs)
where
n' = n + 1
specFoldl1 _ _ [] = errorEmptyStructure "specFoldl1"
specFoldl1 g f (x:xs) = specFoldlN 1 g f x xs
specFoldlN _ _ _ z [] = z
specFoldlN !n g f z (x:xs) = n' `seq` spec (g n') (\z' -> specFoldlN n' g f z' xs) (f z x)
where
n' = n + 1
instance Speculative Maybe where
specFoldr1 _ = foldr1
specFoldrN _ _ = foldr
specFoldl1 _ = foldl1
specFoldlN _ _ = foldl
instance Ix i => Speculative (Array i)
instance Speculative Set
instance Speculative (Map a)
instance Speculative IntMap
instance Speculative Seq
newtype WrappedFoldable f a = WrappedFoldable { getWrappedFoldable :: f a }
deriving (Functor, Foldable, Traversable)
instance Foldable f => Speculative (WrappedFoldable f)
instance Typeable1 f => Typeable1 (WrappedFoldable f) where
typeOf1 tfa = mkTyConApp wrappedTyCon [typeOf1 (undefined `asArgsType` tfa)]
where asArgsType :: f a -> t f a -> f a
asArgsType = const
wrappedTyCon :: TyCon
wrappedTyCon = mkTyCon "Control.Concurrent.Speculation.WrappedFoldable"
wrappedConstr :: Constr
wrappedConstr = mkConstr wrappedDataType "WrappedFoldable" [] Prefix
wrappedDataType :: DataType
wrappedDataType = mkDataType "Control.Concurrent.Speculation.WrappedFoldable" [wrappedConstr]
instance (Typeable1 f, Data (f a), Data a) => Data (WrappedFoldable f a) where
gfoldl f z (WrappedFoldable a) = z WrappedFoldable `f` a
toConstr _ = wrappedConstr
gunfold k z c = case constrIndex c of
1 -> k (z WrappedFoldable)
_ -> error "gunfold"
dataTypeOf _ = wrappedDataType
dataCast1 f = gcast1 f
newtype WithoutSpeculation f a = WithoutSpeculation { getWithoutSpeculation :: f a }
deriving (Functor, Foldable, Traversable)
instance Typeable1 f => Typeable1 (WithoutSpeculation f) where
typeOf1 tfa = mkTyConApp withoutTyCon [typeOf1 (undefined `asArgsType` tfa)]
where asArgsType :: f a -> t f a -> f a
asArgsType = const
instance Foldable f => Speculative (WithoutSpeculation f) where
specFoldr1 _ = foldr1
specFoldrN _ _ = foldr
specFoldl1 _ = foldl1
specFoldlN _ _ = foldl
withoutTyCon :: TyCon
withoutTyCon = mkTyCon "Control.Concurrent.Speculation.WithoutSpeculation"
withoutConstr :: Constr
withoutConstr = mkConstr withoutDataType "WithoutSpeculation" [] Prefix
withoutDataType :: DataType
withoutDataType = mkDataType "Control.Concurrent.Speculation.WithoutSpeculation" [withoutConstr]
instance (Typeable1 f, Data (f a), Data a) => Data (WithoutSpeculation f a) where
gfoldl f z (WithoutSpeculation a) = z WithoutSpeculation `f` a
toConstr _ = withoutConstr
gunfold k z c = case constrIndex c of
1 -> k (z WithoutSpeculation)
_ -> error "gunfold"
dataTypeOf _ = withoutDataType
dataCast1 f = gcast1 f