diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -7,6 +7,33 @@ *de facto* standard Haskell versioning scheme. +0.7.2.0 +------- + +- **Date** 2017-09-16 +- **Git tag** [dejafu-0.7.2.0][] +- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.2.0 + +### Test.DejaFu.STM + +- The `STM n r` monad now has `Alternative` and `MonadPlus` instances, using `orElse` for the binary + operation and `retry` for the unit. + +### Miscellaneous + +- The `Eq` instance for `ThreadId`, `CRefId`, `MVarId`, and `TVarId` now only compares the numbers, + not the names. + + This makes it consistent with the `Ord` instances, and is also a small performance gain. + +- Now compatible with concurrency-1.2.0.0. + +[dejafu-0.7.2.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.2.0 + + +--------------------------------------------------------------------------------------------------- + + 0.7.1.3 ------- diff --git a/Test/DejaFu/Common.hs b/Test/DejaFu/Common.hs --- a/Test/DejaFu/Common.hs +++ b/Test/DejaFu/Common.hs @@ -76,10 +76,17 @@ -- | Every live thread has a unique identitifer. -- +-- The @Eq@ and @Ord@ instances only consider the int, not the name. +-- -- @since 0.4.0.0 -data ThreadId = ThreadId (Maybe String) Int - deriving Eq +data ThreadId = ThreadId (Maybe String) {-# UNPACK #-} !Int +-- | Previously this was a derived instance. +-- +-- @since 0.7.2.0 +instance Eq ThreadId where + (ThreadId _ i) == (ThreadId _ j) = i == j + instance Ord ThreadId where compare (ThreadId _ i) (ThreadId _ j) = compare i j @@ -93,10 +100,17 @@ -- | Every @CRef@ has a unique identifier. -- +-- The @Eq@ and @Ord@ instances only consider the int, not the name. +-- -- @since 0.4.0.0 -data CRefId = CRefId (Maybe String) Int - deriving Eq +data CRefId = CRefId (Maybe String) {-# UNPACK #-} !Int +-- | Previously this was a derived instance. +-- +-- @since 0.7.2.0 +instance Eq CRefId where + (CRefId _ i) == (CRefId _ j) = i == j + instance Ord CRefId where compare (CRefId _ i) (CRefId _ j) = compare i j @@ -110,10 +124,17 @@ -- | Every @MVar@ has a unique identifier. -- +-- The @Eq@ and @Ord@ instances only consider the int, not the name. +-- -- @since 0.4.0.0 -data MVarId = MVarId (Maybe String) Int - deriving Eq +data MVarId = MVarId (Maybe String) {-# UNPACK #-} !Int +-- | Previously this was a derived instance. +-- +-- @since 0.7.2.0 +instance Eq MVarId where + (MVarId _ i) == (MVarId _ j) = i == j + instance Ord MVarId where compare (MVarId _ i) (MVarId _ j) = compare i j @@ -127,9 +148,16 @@ -- | Every @TVar@ has a unique identifier. -- +-- The @Eq@ and @Ord@ instances only consider the int, not the name. +-- -- @since 0.4.0.0 -data TVarId = TVarId (Maybe String) Int - deriving Eq +data TVarId = TVarId (Maybe String) {-# UNPACK #-} !Int + +-- | Previously this was a derived instance. +-- +-- @since 0.7.2.0 +instance Eq TVarId where + (TVarId _ i) == (TVarId _ j) = i == j instance Ord TVarId where compare (TVarId _ i) (TVarId _ j) = compare i j diff --git a/Test/DejaFu/Conc/Internal/Memory.hs b/Test/DejaFu/Conc/Internal/Memory.hs --- a/Test/DejaFu/Conc/Internal/Memory.hs +++ b/Test/DejaFu/Conc/Internal/Memory.hs @@ -27,7 +27,8 @@ import Control.Monad.Ref (MonadRef, readRef, writeRef) import Data.Map.Strict (Map) -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, isJust, + maybeToList) import Data.Monoid ((<>)) import Data.Sequence (Seq, ViewL(..), singleton, viewl, (><)) @@ -130,10 +131,10 @@ -- | Add phantom threads to the thread list to commit pending writes. addCommitThreads :: WriteBuffer r -> Threads n r -> Threads n r addCommitThreads (WriteBuffer wb) ts = ts <> M.fromList phantoms where - phantoms = [ (ThreadId Nothing $ negate tid, mkthread $ fromJust c) + phantoms = [ (ThreadId Nothing $ negate tid, mkthread c) | ((_, b), tid) <- zip (M.toList wb) [1..] - , let c = go $ viewl b - , isJust c] + , c <- maybeToList (go $ viewl b) + ] go (BufferedWrite tid (CRef crid _) _ :< _) = Just $ ACommit tid crid go EmptyL = Nothing diff --git a/Test/DejaFu/SCT.hs b/Test/DejaFu/SCT.hs --- a/Test/DejaFu/SCT.hs +++ b/Test/DejaFu/SCT.hs @@ -355,11 +355,13 @@ } -- | Combination bound function -cBound :: Bounds -> IncrementalBoundFunc (((Int, Maybe ThreadId), M.Map ThreadId Int), Int) -cBound (Bounds pb fb lb) = - maybe (trueBound (0, Nothing)) pBound pb &+& - maybe (trueBound M.empty) fBound fb &+& - maybe (trueBound 0) lBound lb +cBound :: Bounds -> IncrementalBoundFunc ((Int, Maybe ThreadId), M.Map ThreadId Int, Int) +cBound (Bounds pb fb lb) (Just (k1, k2, k3)) prior lh = + let k1' = maybe (\k _ _ -> k) pBound pb (Just k1) prior lh + k2' = maybe (\k _ _ -> k) fBound fb (Just k2) prior lh + k3' = maybe (\k _ _ -> k) lBound lb (Just k3) prior lh + in (,,) <$> k1' <*> k2' <*> k3' +cBound _ Nothing _ _ = Just ((0, Nothing), M.empty, 1) -- | Combination backtracking function. Add all backtracking points -- corresponding to enabled bound functions. @@ -676,18 +678,6 @@ in go m' xs go m [] = m go' x0 m x = m `max` abs (x0 - x) - --- | The \"true\" bound, which allows everything. -trueBound :: k -> IncrementalBoundFunc k -trueBound k _ _ _ = Just k - --- | Combine two bounds into a larger bound, where both must be --- satisfied. -(&+&) :: IncrementalBoundFunc k1 -> IncrementalBoundFunc k2 -> IncrementalBoundFunc (k1, k2) -(&+&) f1 f2 ks prior lhead = - let k1' = f1 (fst <$> ks) prior lhead - k2' = f2 (snd <$> ks) prior lhead - in (,) <$> k1' <*> k2' -- | Apply the discard function. checkDiscard :: Functor f => (a -> Maybe Discard) -> a -> [b] -> f [(a, [b])] -> f [(a, [b])] diff --git a/Test/DejaFu/SCT/Internal.hs b/Test/DejaFu/SCT/Internal.hs --- a/Test/DejaFu/SCT/Internal.hs +++ b/Test/DejaFu/SCT/Internal.hs @@ -259,7 +259,7 @@ , let is = idxs' u n v tagged , not $ null is] - idxs' u n v = catMaybes . go' True where + idxs' u n v = go' True where {-# INLINE go' #-} go' final ((i,b):rest) -- Don't cross subconcurrency boundaries @@ -267,7 +267,7 @@ -- If this is the final action in the trace and the -- execution was killed due to nothing being within bounds -- (@killsEarly == True@) assume worst-case dependency. - | bcktThreadid b == v && (killsEarly || isDependent b) = Just i : go' False rest + | bcktThreadid b == v && (killsEarly || isDependent b) = i : go' False rest | otherwise = go' False rest go' _ [] = [] @@ -561,11 +561,10 @@ enabled = M.toList $ M.filterWithKey (\tid _ -> tid `elem` tids) weights' -- The weights, with any new threads added. - weights' = schedWeights s `M.union` M.fromList newWeights - (newWeights, g') = foldr assignWeight ([], schedGen s) $ filter (`M.notMember` schedWeights s) tids + (weights', g') = foldr assignWeight (M.empty, schedGen s) tids assignWeight tid ~(ws, g0) = - let (w, g) = weightf g0 - in ((tid, w):ws, g) + let (w, g) = maybe (weightf g0) (,g0) (M.lookup tid (schedWeights s)) + in (M.insert tid w ws, g) -- The runnable threads. tids = map fst (toList threads) @@ -675,17 +674,21 @@ (UnsynchronisedRead r1, _) | isBarrier a2 -> isBuffered ds r1 && memtype /= SequentialConsistency (_, UnsynchronisedRead r2) | isBarrier a1 -> isBuffered ds r2 && memtype /= SequentialConsistency - (_, _) + (_, _) -> case getSame crefOf of -- Two actions on the same CRef where at least one is synchronised - | same crefOf && (synchronises a1 (fromJust $ crefOf a1) || synchronises a2 (fromJust $ crefOf a2)) -> True + Just r -> synchronises a1 r || synchronises a2 r -- Two actions on the same MVar - | same mvarOf -> True - - _ -> False + _ -> same mvarOf where same :: Eq a => (ActionType -> Maybe a) -> Bool - same f = isJust (f a1) && f a1 == f a2 + same = isJust . getSame + + getSame :: Eq a => (ActionType -> Maybe a) -> Maybe a + getSame f = + let f1 = f a1 + f2 = f a2 + in if f1 == f2 then f1 else Nothing ------------------------------------------------------------------------------- -- Dependency function state diff --git a/Test/DejaFu/STM.hs b/Test/DejaFu/STM.hs --- a/Test/DejaFu/STM.hs +++ b/Test/DejaFu/STM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -8,7 +9,7 @@ -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies +-- Portability : CPP, GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies -- -- A 'MonadSTM' implementation, which can be run on top of 'IO' or -- 'ST'. @@ -26,7 +27,8 @@ , runTransaction ) where -import Control.Monad (unless) +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus(..), unless) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Ref (MonadRef) import Control.Monad.ST (ST) @@ -70,12 +72,24 @@ instance MonadCatch (STMLike n r) where catch (S stm) handler = toSTM (SCatch (runSTM . handler) stm) +-- | @since 0.7.2.0 +instance Alternative (STMLike n r) where + S a <|> S b = toSTM (SOrElse a b) + empty = toSTM (const SRetry) + +-- | @since 0.7.2.0 +instance MonadPlus (STMLike n r) + instance C.MonadSTM (STMLike n r) where type TVar (STMLike n r) = TVar r - retry = toSTM (const SRetry) - - orElse (S a) (S b) = toSTM (SOrElse a b) +#if MIN_VERSION_concurrency(1,2,0) + -- retry and orElse are top-level definitions in + -- Control.Monad.STM.Class in 1.2 and up +#else + retry = empty + orElse = (<|>) +#endif newTVarN n = toSTM . SNew n diff --git a/dejafu.cabal b/dejafu.cabal --- a/dejafu.cabal +++ b/dejafu.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dejafu -version: 0.7.1.3 +version: 0.7.2.0 synopsis: Systematic testing for Haskell concurrency. description: @@ -37,7 +37,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: dejafu-0.7.1.3 + tag: dejafu-0.7.2.0 library exposed-modules: Test.DejaFu @@ -58,15 +58,15 @@ -- other-modules: -- other-extensions: - build-depends: base >=4.8 && <5 - , concurrency ==1.1.* - , containers >=0.5 && <0.6 - , deepseq >=1.1 && <2 - , exceptions >=0.7 && <0.9 - , leancheck >=0.6 && <0.7 - , mtl >=2.2 && <2.3 - , random >=1.0 && <1.2 - , ref-fd >=0.4 && <0.5 + build-depends: base >=4.8 && <5 + , concurrency >=1.1 && <1.3 + , containers >=0.5 && <0.6 + , deepseq >=1.1 && <2 + , exceptions >=0.7 && <0.9 + , leancheck >=0.6 && <0.7 + , mtl >=2.2 && <2.3 + , random >=1.0 && <1.2 + , ref-fd >=0.4 && <0.5 -- remove semigroups dep when GHC 8.4 is out , semigroups >=0.16 && <0.19 , transformers >=0.4 && <0.6