diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown deleted file mode 100644 --- a/CHANGELOG.markdown +++ /dev/null @@ -1,805 +0,0 @@ -Release Notes -============= - -All notable changes to this project will be documented in this file. - -This project is versioned according to the [Package Versioning Policy](https://pvp.haskell.org), the -*de facto* standard Haskell versioning scheme. - - -0.9.1.2 -------- - -- **Date** 2017-12-12 -- **Git tag** [dejafu-0.9.1.2][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.1.2 - -### Miscellaneous - -- The upper bound on leancheck was bumped to <0.8. - -[dejafu-0.9.1.2]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.1.2 - - ---------------------------------------------------------------------------------------------------- - - -0.9.1.1 -------- - -- **Date** 2017-12-08 -- **Git tag** [dejafu-0.9.1.1][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.1.1 - -### Miscellaneous - -- Fix an issue where nested masks nested inside unmasks would sometimes not be pre-empted in - systematic testing. - -[dejafu-0.9.1.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.1.1 - - ---------------------------------------------------------------------------------------------------- - - -0.9.1.0 -------- - -- **Date** 2017-11-26 -- **Git tag** [dejafu-0.9.1.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.1.0 - -### Test.DejaFu.Common - -- Fix some incorrect "@since" haddock comments. -- Pretty-printed traces now display a pre-emption following a yield with a little "p". - -### Test.DejaFu.Conc - -- Add a missing `MonadFail` instance. - -### Test.DejaFu.STM - -- Add a missing `MonadFail` instance. - -[dejafu-0.9.1.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.1.0 - - ---------------------------------------------------------------------------------------------------- - - -0.9.0.3 -------- - -- **Date** 2017-11-06 -- **Git tag** [dejafu-0.9.0.3][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.0.3 - -### Miscellaneous - -- Impose a dependency between commits and memory barriers, to make barriers sound (#138). - -[dejafu-0.9.0.3]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.0.3 - - ---------------------------------------------------------------------------------------------------- - - -0.9.0.2 -------- - -- **Date** 2017-11-02 -- **Git tag** [dejafu-0.9.0.2][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.0.2 - -### Miscellaneous - -- Small improvement to dependency detection of STM transactions. -- A fair bound of 0 will now prevent all yields. - -[dejafu-0.9.0.2]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.0.2 - - ---------------------------------------------------------------------------------------------------- - - -0.9.0.1 -------- - -- **Date** 2017-10-28 -- **Git tag** [dejafu-0.9.0.1][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.0.1 - -### Miscellaneous - -- Fixed an issue where tests with exception handlers would sometimes skip over nested handlers or - try to take the tail of an empty list (#139 and #141). - -[dejafu-0.9.0.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.0.1 - - ---------------------------------------------------------------------------------------------------- - - -0.9.0.0 -------- - -- **Date** 2017-10-11 -- **Git tag** [dejafu-0.9.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.0.0 - -### Test.DejaFu.Common - -- New `isInternalError`, `isAbort`, `isDeadlock`, `isUncaughtException`, and - `isIllegalSubconcurrency` functions for matching failure types. Also exported from Test.DejaFu. - -- The `UncaughtException` `Failure` constructor now includes the exception. - - The `Read`, `Enum`, and `Bounded` instances are gone. The `Eq`, `Ord`, and `NFData` instances - use the `show` of the exception. Pretty-printed failures include the exception text. - -- New `ThreadDelay` and `WillThreadDelay` constructors in `ThreadAction` and `Lookahead`. Uses of - `threadDelay` are no longer reported as a use of `yield`. - -[dejafu-0.9.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.8.0.0 -------- - -- **Date** 2017-09-26 -- **Git tag** [dejafu-0.8.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.8.0.0 - -### Test.DejaFu.Common - -- Execution traces now only include a single item of lookahead (#120). -- STM traces now include IDs of created `TVar`s (#80). - -### Test.DejaFu.Schedule - -- Schedulers no longer take the execution trace so far (#106). -- The `Scheduler` type is now a newtype (#122). - -[dejafu-0.8.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.8.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.7.3.0 -------- - -- **Date** 2017-09-26 -- **Git tag** [dejafu-0.7.3.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.3.0 - -### Test.DejaFu.Common - -- A new function `threadNames`, to get all named threads from a trace. - -### Miscellaneous - -- Escaping a mask by raising an exception now correctly restores the masking state (#118). -- Named threads which are only started by a pre-emption now show up in the trace (#101). - -[dejafu-0.7.3.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.3.0 - - ---------------------------------------------------------------------------------------------------- - - -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 -------- - -- **Date** 2017-09-08 -- **Git tag** [dejafu-0.7.1.3][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.1.3 - -### Miscellaneous - -- Aborted STM transactions are now rolled back correctly (issue #111). -- Slightly improved run-time of systematic testing. - -[dejafu-0.7.1.3]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.1.3 - - ---------------------------------------------------------------------------------------------------- - - -0.7.1.2 -------- - -- **Date** 2017-08-21 -- **Git tag** [dejafu-0.7.1.2][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.1.2 - -### Miscellaneous - -- Errors thrown with `Control.Monad.fail` no longer terminate testing, and are now correctly treated - as asynchronous exceptions. - -[dejafu-0.7.1.2]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.1.2 - - ---------------------------------------------------------------------------------------------------- - - -0.7.1.1 -------- - -- **Date** 2017-08-16 -- **Git tag** [dejafu-0.7.1.1][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.1.1 - -### Miscellaneous - -- Significantly reduced memory usage in systematic testing when discarding traces. - - Previously this was `O(max trace length * number of executions)` - - Now it's `O(max trace length + total size of traces kept)` - -[dejafu-0.7.1.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.1.1 - - ---------------------------------------------------------------------------------------------------- - - -0.7.1.0 -------- - -- **Date** 2017-08-10 -- **Git tag** [dejafu-0.7.1.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.1.0 - -### Test.DejaFu - -- Exposed the new SCT discard functions through `dejafuDiscard` and `dejafuDiscardIO`. - - There are no `dejafusDiscard` and `dejafusDiscardIO` functions because this would probably be - confusing, as the traces are shared. - -- The `Discard` type and `defaultDiscard` function are also exposed. - -### Test.DejaFu.Defaults - -- Added a new `defaultDiscarder` function, which discards nothing. - -### Test.DejaFu.SCT - -- Added new SCT functions to selectively discard results or traces, which can be a significant - memory saving if you know what sorts of results you are interested in: - - New type: `Discard`. - - New functions: `runSCTDiscard`, `resultsSetDiscard`, `sctBoundDiscard`, - `sctUniformRandomDiscard`, and `sctWeightedRandomDiscard`. - - `resultsSet` and `resultsSet'` now discard traces as they are produced, rather than all at the - end, greatly improving performance when traces are large. - -[dejafu-0.7.1.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.1.0 - - ---------------------------------------------------------------------------------------------------- - - -0.7.0.2 -------- - -- **Date** 2017-06-12 -- **Git tag** [dejafu-0.7.0.2][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.0.2 - -### Test.DejaFu.Refinement - -- Removed unnecessary typeclass constraints from `check`, `check'`, `checkFor`, and - `counterExamples`. - -### Miscellaneous - -- Removed an unnecessary dependency on [monad-loops][]. - -[monad-loops]: https://hackage.haskell.org/package/monad-loops -[dejafu-0.7.0.2]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.0.2 - - ---------------------------------------------------------------------------------------------------- - - -0.7.0.1 -------- - -- **Date** 2017-06-09 -- **Git tag** [dejafu-0.7.0.1][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.0.1 - -### Test.DejaFu.Refinement - -- `check`, `check'`, and `checkFor` are now faster if there are multiple counterexamples. -- The above and `counterExamples` are now faster even if there is only a single counterexample in - some cases. - -[dejafu-0.7.0.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.0.1 - - ---------------------------------------------------------------------------------------------------- - - -0.7.0.0 -------- - -- **Date** 2017-06-07 -- **Git tag** [dejafu-0.7.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.0.0 - -### Test.DejaFu - -- The new Test.DejaFu.Defaults and Test.DejaFu.Refinement modules are re-exported. -- The new smart constructors from Test.DejaFu.SCT are exported. - -### Test.DejaFu.Defaults - -- The `default*` values are now defined in the new Test.DejaFu.Defaults module. There is no breaking - API change as they are re-exported from Test.DejaFu. - -### Test.DejaFu.Refinement - -- A new module for checking observational properties of the side-effects of stateful, concurrent - functions. - - This is related to my work on [CoCo][], allowing dejafu to test what CoCo discovers. - -### Test.DejaFu.SCT - -- The `Way` type is now abstract and exposes smart constructor functions: - - `systematically`, corresponding to the old `Systematically`. - - `randomly`, corresponding to the old `Randomly`, - - `uniformly`, a new uniform random (as opposed to weighted random) scheduler. - - `swarmy`, corresponding to the old `Randomly` and specifying how many executions to use the - same weights for. -- A new `sctUniformRandom` function to do uniform (non-weighted) scheduling. -- The `sctRandom` function is now called `sctWeightedRandom` and can now re-use the same weights for - multiple executions. -- The `sctPreBound`, `sctFairBound`, and `sctLengthBound` functions have been removed. - -### Fixed - -- An issue where `subconcurrency` would re-use `MVar` IDs, leading to false reports of deadlock on - occasion (issue #81). - -[CoCo]: https://github.com/barrucadu/coco -[dejafu-0.7.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.6.0.0 -------- - -- **Date** 2017-04-08 -- **Git tag** [dejafu-0.6.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.6.0.0 - -### Test.DejaFu.Conc - -- The `Conc n r a` type is now `ConcT r n a`, and has been given a `MonadTrans` instance. Uses of - `lift` appear in the execution trace in the same way as `liftBase` and `liftIO`. - - The `ConcIO` and `ConcST` aliases have been updated, so this should be an invisible change to - most users. - -### Test.DejaFu.SCT - -- `Way` is now a GADT, no longer taking a type parameter. This greatly improves type inference when - the `Systematically` constructor is used. - - The `NFData` instance for `Way` is now gone. The alternative was requiring that any - `RandomGen` used also implement `NFData`, which is *very* restrictive - -### Miscellaneous - -- There is now a changelog. -- Test.DejaFu.Common is now considered to form part of the public API of the library. -- Every definition and instance now has a Haddock "@since" annotation. - -[dejafu-0.6.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.6.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.5.1.3 -------- - -- **Date** 2017-04-05 -- **Git tag** [dejafu-0.5.1.3][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.5.1.3 - -### Miscellaneous - -- The version range on the concurrency package has been changed to 1.1.*. - -[dejafu-0.5.1.3]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.5.1.3 - - ---------------------------------------------------------------------------------------------------- - - -0.5.1.2 -------- - -- **Date** 2017-03-04 -- **Git tag** [dejafu-0.5.1.2][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.5.1.2 - -**This version was misnumbered! It should have caused a minor version bump!** - -### Test.DejaFu.Conc - -- New `MonadRef` and `MonadAtomicRef` instances for the `Conc` type using `CRef`. - -### Fixed - -- A long-standing bug where if the main thread is killed with a `throwTo`, the throwing neither - appears in the trace nor correctly terminates the execution. - -### Miscellaneous - -- The maximum supported version of the concurrency package has been changed to 1.1.1.*. - -[dejafu-0.5.1.2]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.5.1.2 - - ---------------------------------------------------------------------------------------------------- - - -0.5.1.1 -------- - -- **Date** 2017-02-25 -- **Git tag** [dejafu-0.5.1.1][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.5.1.1 - -### Fixed - -- The correct scheduler state is now passed to the scheduler immediately after the termination of a - `subconcurrency` action. -- SCT of subconcurrency no longer loops infinitely. - -[dejafu-0.5.1.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.5.1.1 - - ---------------------------------------------------------------------------------------------------- - - -0.5.1.0 -------- - -- **Date** 2017-02-25 -- **Git tag** [dejafu-0.5.1.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.5.1.0 - -### Test.DejaFu - -- A new `NFData` instance for `Result`. - -### Test.DejaFu.Common - -- New instances: - - `NFData` for `ThreadId`, `CRefId`, `MVarId`, `TVarId`, `IdSource`, `ThreadAction`, - `Lookahead`, `ActionType`, `TAction`, `Decision`, `Failure`, and `MemType`. - - `Eq`, `Ord`, and `Show` instances for `IdSource`. - -### Test.DejaFu.SCT - -- New `NFData` instances for `Way`, `Bounds`, `PreemptionBound`, `FairBound`, and `LengthBound`. -- New strict variants of `runSCT` and `resultsSet`: `runSCT'` and `resultsSet'`. - -### Test.DejaFu.STM - -- A new `NFData` instance for `Result`. - -[dejafu-0.5.1.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.5.1.0 - - ---------------------------------------------------------------------------------------------------- - - -0.5.0.2 -------- - -- **Date** 2017-02-22 -- **Git tag** [dejafu-0.5.0.2][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.5.0.2 - -**This version was misnumbered! It should have caused a major version bump!** - -### Test.DejaFu.Common - -- A new `StopSubconcurrency` constructor of `ThreadAction`. - -### Changed - -- A `StopConcurrency` action appears in the execution trace immediately after the end of a - `subconcurrency` action (much like the `PopCatching` and `ResetMasking` actions which appear after - a catch and mask). -- A `subconcurrency` action now inherits the number of capabilities from the outer computation, - rather than being reset to 2 as before. - -### Miscellaneous - -- Test.DejaFu.SCT now compiles with MonoLocalBinds enabled (implied by GADTs and TypeFamilies), - which may be relevant to hackers. - -[dejafu-0.5.0.2]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.5.0.2 - - ---------------------------------------------------------------------------------------------------- - - -0.5.0.1 -------- - -- **Date** 2017-02-21 -- **Git tag** [dejafu-0.5.0.1][] -- **This version was never pushed to hackage, whoops!** - -### Fixed - -- `readMVar` is once again considered a "release action" for the purposes of fair-bounding. - -[dejafu-0.5.0.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.5.0.1 - - ---------------------------------------------------------------------------------------------------- - - -0.5.0.0 -------- - -- **Date** 2017-02-21 -- **Git tag** [dejafu-0.5.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.5.0.0 - -### Test.DejaFu - -- All the functions which did take a `Bounds` now take a `Way` instead and support random scheduling - as well. - -### Test.DejaFu.Common - -- New `Eq` instances for `ThreadAction` and `Lookahead`. -- A `TryReadMVar` constructor for `ThreadAction` and a corresponding `WillTryReadMVar` constructor - for `Lookahead`. - -### Test.DejaFu.Conc - -- A new testing-only `subconcurrency` function, to run a concurrent action and do something with its - result in the same concurrent context, even if it fails. - -### Test.DejaFu.SCT - -- An `sctRandom` function to run a fixed number of randomly-scheduled executions of a program. -- The `Way` type, to abstract over how to run a concurrent program, used by new functions `runSCT` - and `resultsSet`. - -### Fixed - -- Some previously-missed `CRef` action dependencies are no longer missed. - -### Miscellaneous - -- The supported version of the concurrency package was bumped to 1.1.0.0, introducing `tryReadMVar`. -- A bunch of things were called "Var" or "Ref", these are now consistently "MVar" and "CRef". -- Significant performance improvements in both time and space. -- The dpor package has been merged back into this, as it turned out not to be very generally - useful. There is no direct replacement, but I have no intent to update it, so the dpor package is - now __deprecated__. - -[dejafu-0.5.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.5.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.4.0.0 -------- - -- **Date** 2016-09-10 -- **Git tag** [dejafu-0.4.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.4.0.0 - -### Test.DejaFu - -- The `autocheck'` function now takes the schedule bounds as a parameter. -- New `runTestM` and `runTestM'` functions, monad-polymorphic variants of the now-removed - `runTestIO` and `runTestIO'` functions. - -### Test.DejaFu.Conc - -- The `Conc` type no longer has the STM type as a parameter. -- A new `runConcurrent` function, a monad-polymorphic version of the now-removed `runConcST` and - `runConcIO` functions. - -### Test.DejaFu.SCT - -- The `ST`-specific functions are now monad-polymorphic. -- The `IO` function variants have been removed. - -### Test.DejaFu.STM - -- A new `runTransaction` function, a monad-polymorphic version of the now-removed `runTransactionST` - and `runTransactionIO` functions. - -### Changed - -- The termination of the main thread in execution traces now appears as a single `Stop`, rather than - the sequence `Lift, Stop`. -- Execution traces printed by the helpful functions in Test.DejaFu now include a key of thread - names. - -### Miscellaneous - -- Remodularisation: - - The Control.* modules have all been split out into a separate "concurrency" package. - - Many definitions from other modules have been moved to the new Test.DejaFu.Common module. - - The Test.DejaFu.Deterministic module has been renamed to Test.DejaFu.Conc - -[dejafu-0.4.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.4.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.3.2.1 -------- - -- **Date** 2016-07-21 -- **Git tag** [dejafu-0.3.2.1][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.3.2.1 - -### Fixed - -- The implementation of the STM `orElse` for `STMLike` incorrectly handled some state - non-associatively, leading to false deadlocks being reported in some cases. - -[dejafu-0.3.2.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.3.2.1 - - ---------------------------------------------------------------------------------------------------- - - -0.3.2.0 -------- - -- **Date** 2016-06-06 -- **Git tag** [dejafu-0.3.2.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.3.2.0 - -**Builds with both dpor-0.1 and dpor-0.2, however some improvements require dpor-0.2.** - -### Fixed - -- (faster with dpor-0.2) Executions missed due to daemon threads with uninteresting first actions - are no longer missed. - -### Changed - -- (requires dpor-0.2) Significantly improved dependency inference of exceptions, greatly improving - performance of testcases using exceptions. -- Significantly improved dependency inference of STM transactions, greatly improving performance of - testcases using STM. - -[dejafu-0.3.2.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.3.2.0 - - ---------------------------------------------------------------------------------------------------- - - -0.3.1.1 -------- - -- **Date** 2016-05-26 -- **Git tag** [dejafu-0.3.1.1][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.3.1.1 - -### Miscellaneous - -- Now supports GHC 8. - -[dejafu-0.3.1.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.3.1.1 - - ---------------------------------------------------------------------------------------------------- - - -0.3.1.0 -------- - -- **Date** 2016-05-02 -- **Git tag** [dejafu-0.3.1.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.3.1.0 - -### Fixed - -- Context switches around relaxed memory commit actions could cause the number of pre-emptions in an - execution to be miscounted, leading to the pre-emption bounding being too lenient. - -[dejafu-0.3.1.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.3.1.0 - - ---------------------------------------------------------------------------------------------------- - - -0.3.0.0 -------- - -- **Date** 2016-04-03 -- **Git tag** [dejafu-0.3.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.3.0.0 - -**The minimum supported version of GHC is now 7.10.** - -I didn't write proper release notes, and this is so far back I don't really care to dig through the -logs. - -[dejafu-0.3.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.3.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.2.0.0 -------- - -- **Date** 2015-12-01 -- **Git tag** [0.2.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.2.0.0 - -I didn't write proper release notes, and this is so far back I don't really care to dig through the -logs. - -[0.2.0.0]: https://github.com/barrucadu/dejafu/releases/tag/0.2.0.0 - - ---------------------------------------------------------------------------------------------------- - - -0.1.0.0 -------- - -- **Date** 2015-08-27 -- **Git tag** [0.1.0.0][] -- **Hackage** https://hackage.haskell.org/package/dejafu-0.1.0.0 - -Initial release. Go read the API docs. - -[0.1.0.0]: https://github.com/barrucadu/dejafu/releases/tag/0.1.0.0 diff --git a/CHANGELOG.rst b/CHANGELOG.rst new file mode 100644 --- /dev/null +++ b/CHANGELOG.rst @@ -0,0 +1,1910 @@ +Release Notes +============= + +This project is versioned according to the PVP_, the *de facto* +standard Haskell versioning scheme. + +.. _PVP: https://pvp.haskell.org/ + + +2.4.0.8 (2026-01-13) +-------------------- + +* Git: :tag:`dejafu-2.4.0.8` +* Hackage: :hackage:`dejafu-2.4.0.8` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`containers` is <0.9. + + +2.4.0.7 (2025-01-06) +-------------------- + +* Git: :tag:`dejafu-2.4.0.7` +* Hackage: :hackage:`dejafu-2.4.0.7` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`random` is <1.4. + + +2.4.0.6 (2024-12-11) +-------------------- + +* Git: :tag:`dejafu-2.4.0.6` +* Hackage: :hackage:`dejafu-2.4.0.6` + +**Contributors:** :u:`telser` (:pull:`417`). + +Miscellaneous +~~~~~~~~~~~~~ + +* Update documentation link in ``Test.DejaFu``. +* Fix GHC compatibility warning. +* The upper bound on :hackage:`containers` is <0.8. + + +2.4.0.5 (2023-06-17) +-------------------- + +* Git: :tag:`dejafu-2.4.0.5` +* Hackage: :hackage:`dejafu-2.4.0.5` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`transformers` is <0.7. + + +2.4.0.4 (2022-08-22) +-------------------- + +* Git: :tag:`dejafu-2.4.0.4` +* Hackage: :hackage:`dejafu-2.4.0.4` + +Miscellaneous +~~~~~~~~~~~~~ + +* Update doctest examples in `Test.DejaFu`. +* The upper bound on :hackage:`leancheck` is <2. + + +2.4.0.3 (2021-08-15) +-------------------- + +* Git: :tag:`dejafu-2.4.0.3` +* Hackage: :hackage:`dejafu-2.4.0.3` + +Miscellaneous +~~~~~~~~~~~~~ + +* Remove reference to freenode in README. + + +2.4.0.2 (2021-03-14) +-------------------- + +* Git: :tag:`dejafu-2.4.0.2` +* Hackage: :hackage:`dejafu-2.4.0.2` + +Fixed +~~~~~ + +* (:issue:`334`) Compilation error under GHC 9 due to use of + ``const``. + + +2.4.0.1 (2020-12-28) +-------------------- + +* Git: :tag:`dejafu-2.4.0.1` +* Hackage: :hackage:`dejafu-2.4.0.1` + +Fixed +~~~~~ + +* (:issue:`331`) Initial TVar values from setup actions are now + restored for subsequent executions. + + +2.4.0.0 (2020-07-01) +-------------------- + +* Git: :tag:`dejafu-2.4.0.0` +* Hackage: :hackage:`dejafu-2.4.0.0` + +Added +~~~~~ + +* Thread action constructor for STM transactions which throw an + exception: ``Test.DejaFu.Types.ThreadAction`` ``ThrownSTM`` + +Changed +~~~~~~~ + +* ``Test.DejaFu.Types.ThreadAction``, ``Throw``, and ``ThrowTo`` now + include the resultant masking state, and no bool. + +Fixed +~~~~~ + +* (:issue:`324`) Jumping out of a restored mask into an exception + handler now atomically restores the masking state. + + +2.3.0.1 (2020-06-24) +-------------------- + +* Git: :tag:`dejafu-2.3.0.1` +* Hackage: :hackage:`dejafu-2.3.0.1` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`random` is <1.3. + + +2.3.0.0 (2020-05-14) +-------------------- + +* Git: :tag:`dejafu-2.3.0.0` +* Hackage: :hackage:`dejafu-2.3.0.0` + +Miscellaneous +~~~~~~~~~~~~~ + +* The version bound on :hackage:`concurrency` is >=1.11 <1.12. + + +2.2.0.0 (2020-05-10) +-------------------- + +* Git: :tag:`dejafu-2.2.0.0` +* Hackage: :hackage:`dejafu-2.2.0.0` + +Added +~~~~~ + +* Thread action constructors for the ``MonadConc`` ``getMaskingState`` + function: + + * ``Test.DejaFu.Types.ThreadAction``, ``GetMaskingState`` + * ``Test.DejaFu.Types.Lookahead``, ``WillGetMaskingState`` + +Miscellaneous +~~~~~~~~~~~~~ + +* The version bound on :hackage:`concurrency` is >=1.10 <1.11. + + +2.1.0.3 (2020-02-29) +-------------------- + +* Git: :tag:`dejafu-2.1.0.3` +* Hackage: :hackage:`dejafu-2.1.0.3` + +Fixed +~~~~~ + +* Fixed an internal error message. + + +2.1.0.2 (2020-02-29) +-------------------- + +* Git: :tag:`dejafu-2.1.0.2` +* Hackage: :hackage:`dejafu-2.1.0.2` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper version bound on :hackage:`concurrency` is <1.10. + + +2.1.0.1 (2019-10-04) +-------------------- + +* Git: :tag:`dejafu-2.1.0.1` +* Hackage: :hackage:`dejafu-2.1.0.1` + +Miscellaneous +~~~~~~~~~~~~~ + +* Fixed a compilation error with GHC 8.8 +* The upper version bound on :hackage:`concurrency` is <1.9. + + +2.1.0.0 (2019-03-24) +-------------------- + +* Git: :tag:`dejafu-2.1.0.0` +* Hackage: :hackage:`dejafu-2.1.0.0` + +Added +~~~~~ + +* The ``Test.DejaFu.Types.MonadDejaFu`` typeclass, containing the primitives + needed to run a concurrent program. There are instances for: + + * ``IO``, which is probably the ``MonadConc`` instance people used previously, + so there is no breaking change there. + * ``CatchT (ST t)``, meaning that concurrent programs can be run without + ``IO`` once more. + +* Thread action constructors for ``MonadConc`` ``supportsBoundThreads`` + function: + + * ``Test.DejaFu.Types.ThreadAction``, ``SupportsBoundThreads`` + * ``Test.DejaFu.Types.Lookahead``, ``WillSupportsBoundThreads`` + +Changed +~~~~~~~ + +* Many functions which had a ``MonadConc`` constraint now have a ``MonadDejaFu`` + constraint: + + * In ``Test.DejaFu`` + + * ``autocheck`` + * ``autocheckWay`` + * ``autocheckWithSettings`` + * ``dejafu`` + * ``dejafuWay`` + * ``dejafuWithSettings`` + * ``dejafus`` + * ``dejafusWay`` + * ``dejafusWithSettings`` + * ``runTest`` + * ``runTestWay`` + * ``runTestWithSettings`` + + * In ``Test.DejaFu.Conc`` + + * ``runConcurrent`` + * ``recordSnapshot`` + * ``runSnapshot`` + + * In ``Test.DejaFu.SCT`` + + * ``runSCT`` + * ``resultsSet`` + * ``runSCT'`` + * ``resultsSet'`` + * ``runSCTWithSettings`` + * ``resultsSetWithSettings`` + * ``runSCTWithSettings'`` + * ``resultsSetWithSettings'`` + +Miscellaneous +~~~~~~~~~~~~~ + +* The version bound on :hackage:`concurrency` is >=1.7 and <1.8. + + +2.0.0.1 (2019-03-14) +-------------------- + +* Git: :tag:`dejafu-2.0.0.1` +* Hackage: :hackage:`dejafu-2.0.0.1` + +Fixed +~~~~~ + +* (:issue:`267`) Throwing an asynchronous exception to the current + thread interrupts the current thread even if it is masked. + + +2.0.0.0 (2019-02-12) +-------------------- + +* Git: :tag:`dejafu-2.0.0.0` +* Hackage: :hackage:`dejafu-2.0.0.0` + +Added +~~~~~ + +* The ``Program`` types and their constructors (re-exported from + ``Test.DejaFu``): + + * ``Test.DejaFu.Conc.Program`` + * ``Test.DejaFu.Conc.Basic`` + * ``Test.DejaFu.Conc.WithSetup`` + * ``Test.DejaFu.Conc.WithSetupAndTeardown`` + * ``Test.DejaFu.Conc.withSetup`` + * ``Test.DejaFu.Conc.withTeardown`` + * ``Test.DejaFu.Conc.withSetupAndTeardown`` + +* The ``Invariant`` type and associated functions (re-exported from + ``Test.DejaFu``): + + * ``Test.DejaFu.Conc.Invariant`` + * ``Test.DejaFu.Conc.registerInvariant`` + * ``Test.DejaFu.Conc.inspectIORef`` + * ``Test.DejaFu.Conc.inspectMVar`` + * ``Test.DejaFu.Conc.inspectTVar`` + +* New snapshotting functions: + + * ``Test.DejaFu.Conc.Snapshot`` + * ``Test.DejaFu.Conc.recordSnapshot`` + * ``Test.DejaFu.Conc.runSnapshot`` + +* ``Test.DejaFu.Settings.llengthBound``, which now applies to all ways + of testing. + +* ``Test.DejaFu.Types.isInvariantFailure`` (re-exported from + ``Test.DejaFu``). + +* ``Test.DejaFu.runTestWithSettings`` function. + +* A simplified form of the concurrency state: + + * ``Test.DejaFu.Types.ConcurrencyState`` + * ``Test.DejaFu.Types.isBuffered`` + * ``Test.DejaFu.Types.numBuffered`` + * ``Test.DejaFu.Types.isFull`` + * ``Test.DejaFu.Types.canInterrupt`` + * ``Test.DejaFu.Types.canInterruptL`` + * ``Test.DejaFu.Types.isMaskedInterruptible`` + * ``Test.DejaFu.Types.isMaskedUninterruptible`` + +Changed +~~~~~~~ + +* ``Test.DejaFu.Schedule.Scheduler`` has a ``ConcurrencyState`` + parameter. + +* ``Test.DejaFu.alwaysSameBy`` and ``Test.DejaFu.notAlwaysSameBy`` + return a representative trace for each unique condition. + +* Functions which took a ``ConcT`` now take a ``Program pty``: + + * ``Test.DejaFu.autocheck`` + * ``Test.DejaFu.autocheckWay`` + * ``Test.DejaFu.autocheckWithSettings`` + * ``Test.DejaFu.dejafu`` + * ``Test.DejaFu.dejafuWay`` + * ``Test.DejaFu.dejafuWithSettings`` + * ``Test.DejaFu.dejafus`` + * ``Test.DejaFu.dejafusWay`` + * ``Test.DejaFu.dejafusWithSettings`` + * ``Test.DejaFu.runTest`` + * ``Test.DejaFu.runTestWay`` + * ``Test.DejaFu.runTestWithSettings`` + * ``Test.DejaFu.Conc.runConcurrent`` + * ``Test.DejaFu.SCT.runSCT`` + * ``Test.DejaFu.SCT.resultsSet`` + * ``Test.DejaFu.SCT.runSCT'`` + * ``Test.DejaFu.SCT.resultsSet'`` + * ``Test.DejaFu.SCT.runSCTWithSettings`` + * ``Test.DejaFu.SCT.resultsSetWithSettings`` + * ``Test.DejaFu.SCT.runSCTWithSettings'`` + * ``Test.DejaFu.SCT.resultsSetWithSettings'`` + +* ``Test.DejaFu.Conc.ConcT`` is an alias for ``Program Basic``. + +* ``Test.DejaFu.Types.Bounds``: + + * Removed ``boundLength`` field. + +* ``Test.DejaFu.Types.Condition``: + + * Added ``InvariantFailure`` constructor + * Removed ``STMDeadlock`` constructor + +* ``Test.DejaFu.Types.Error``: + + * Removed ``NestedSubconcurrency``, ``MultithreadedSubconcurrency``, and + ``LateDontCheck`` constructors. + +* ``Test.DejaFu.Types.Lookahead``: + + * Added ``WillRegisterInvariant`` constructor + * Removed ``WillSubconcurrency``, ``WillStopSubconcurrency``, and + ``WillDontCheck`` constructors + +* ``Test.DejaFu.Types.ThreadAction``: + + * Added ``RegisterInvariant`` constructor + * Removed ``Subconcurrency``, ``StopSubconcurrency``, and + ``DontCheck`` constructors + +Removed +~~~~~~~ + +* The deprecated functions: + + * ``Test.DejaFu.dejafuDiscard`` + * ``Test.DejaFu.SCT.runSCTDiscard`` + * ``Test.DejaFu.SCT.runSCTDiscard'`` + * ``Test.DejaFu.SCT.resultsSetDiscard`` + * ``Test.DejaFu.SCT.resultsSetDiscard'`` + * ``Test.DejaFu.SCT.sctBound`` + * ``Test.DejaFu.SCT.sctBoundDiscard`` + * ``Test.DejaFu.SCT.sctUniformRandom`` + * ``Test.DejaFu.SCT.sctUniformRandomDiscard`` + * ``Test.DejaFu.SCT.sctWeightedRandom`` + * ``Test.DejaFu.SCT.sctWeightedRandomDiscard`` + +* The deprecated type ``Test.DejaFu.Types.Failure`` + +* Old snapshotting functions: + + * ``Test.DejaFu.Conc.DCSnapshot`` + * ``Test.DejaFu.Conc.runForDCSnapshot`` + * ``Test.DejaFu.Conc.runWithDCSnapshot`` + * ``Test.DejaFu.Conc.canDCSnapshot`` + * ``Test.DejaFu.Conc.threadsFromDCSnapshot`` + +* ``Test.DejaFu.Conc.dontCheck`` + +* ``Test.DejaFu.Conc.subconcurrency`` + +* ``Test.DejaFu.Settings.defaultLengthBound`` + +* ``Test.DejaFu.Types.isIncorrectUsage`` + + +1.12.0.0 (2019-01-20) +--------------------- + +* Git: :tag:`dejafu-1.12.0.0` +* Hackage: :hackage:`dejafu-1.12.0.0` + +Added +~~~~~ + +* ``Test.DejaFu.Types.Error`` for internal errors and misuses, with + predicates: + + * ``Test.DejaFu.Types.isSchedulerError`` + * ``Test.DejaFu.Types.isIncorrectUsage`` + +* Deprecated ``Test.DejaFu.Types.Failure`` type synonym for + ``Condition``. + +* The ``Test.DejaFu.Settings.lshowAborts`` option, to make SCT + functions show ``Abort`` conditions. + +* ``Test.DejaFu.Utils.showCondition`` + +Changed +~~~~~~~ + +* Renamed ``Test.DejaFu.Types.Failure`` to + ``Test.DejaFu.Types.Condition``. + +* The SCT functions drop ``Left Abort`` results by default, restore + the old behaviour with ``Test.DejaFu.Settings.lshowAborts``. + +Removed +~~~~~~~ + +* ``Test.DejaFu.Types.isInternalError`` +* ``Test.DejaFu.Types.isIllegalDontCheck`` +* ``Test.DejaFu.Types.isIllegalSubconcurrency`` +* ``Test.DejaFu.Utils.showFail`` + + +1.11.0.5 (2019-01-17) +--------------------- + +* Git: :tag:`dejafu-1.11.0.5` +* Hackage: :hackage:`dejafu-1.11.0.5` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`leancheck` is <0.10. + + +1.11.0.4 (2018-12-02) +--------------------- + +* Git: :tag:`dejafu-1.11.0.4` +* Hackage: :hackage:`dejafu-1.11.0.4` + +**Contributors:** :u:`pepeiborra` (:pull:`290`). + +Miscellaneous +~~~~~~~~~~~~~ + +* (:pull:`290`) The upper bound on :hackage:`containers` is <0.7. +* (:pull:`290`) The upper bound on :hackage:`leancheck` is <0.9. + + +1.11.0.3 (2018-07-15) +--------------------- + +* Git: :tag:`dejafu-1.11.0.3` +* Hackage: :hackage:`dejafu-1.11.0.3` + +Fixed +~~~~~ + +* (:issue:`275`) In trace simplification, only remove a commit if + there are no other buffered writes for that same `IORef`. + + +1.11.0.2 (2018-07-08) +--------------------- + +* Git: :tag:`dejafu-1.11.0.2` +* Hackage: :hackage:`dejafu-1.11.0.2` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`profunctors` is <6. + + +1.11.0.1 (2018-07-02) +--------------------- + +* Git: :tag:`dejafu-1.11.0.1` +* Hackage: :hackage:`dejafu-1.11.0.1` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`contravariant` is <1.6. + + +1.11.0.0 - IORefs (2018-07-01) +------------------------------ + +* Git: :tag:`dejafu-1.11.0.0` +* Hackage: :hackage:`dejafu-1.11.0.0` + +Changed +~~~~~~~ + +* (:issue:`274`) ``CRef`` is now ``IORef``: all functions, data + constructors, and types have been renamed. + +* The lower bound on :hackage:`concurrency` is 1.6. + + +1.10.1.0 (2018-06-17) +--------------------- + +* Git: :tag:`dejafu-1.10.1.0` +* Hackage: :hackage:`dejafu-1.10.1.0` + +Added +~~~~~ + +* (:issue:`224`) The ``Test.DejaFu.Settings.lsafeIO`` option, for when + all lifted IO is thread-safe (such as exclusively managing + thread-local state). + + +1.10.0.0 (2018-06-17) +--------------------- + +* Git: :tag:`dejafu-1.10.0.0` +* Hackage: :hackage:`dejafu-1.10.0.0` + +Added +~~~~~ + +* The ``Test.DejaFu.notAlwaysSameOn`` and ``notAlwaysSameBy`` + predicates, generalising ``notAlwaysSame``. + +Changed +~~~~~~~ + +* ``Test.DejaFu.autocheck`` and related functions use the + ``successful`` predicate, rather than looking specifically for + deadlocks and uncaught exceptions. + +* (:issue:`259`) The ``Test.DejaFu.alwaysSame``, ``alwaysSameOn``, + ``alwaysSameBy``, and ``notAlwaysSame`` predicates fail if the + computation under test fails. + + +1.9.1.0 (2018-06-10) +-------------------- + +* Git: :tag:`dejafu-1.9.1.0` +* Hackage: :hackage:`dejafu-1.9.1.0` + +Added +~~~~~ + +* A ``Test.DejaFu.successful`` predicate, to check that a computation + never fails. + + +1.9.0.0 (2018-06-10) +-------------------- + +* Git: :tag:`dejafu-1.9.0.0` +* Hackage: :hackage:`dejafu-1.9.0.0` + +Changed +~~~~~~~ + +* (:issue:`190`) ``Test.DejaFu.Types.Throw`` and ``ThrowTo`` have a + ``Bool`` parameter, which is ``True`` if the exception kills the + thread. + + +1.8.0.0 (2018-06-03) +-------------------- + +* Git: :tag:`dejafu-1.8.0.0` +* Hackage: :hackage:`dejafu-1.8.0.0` + +Changed +~~~~~~~ + +* (:issue:`258`) Length bounding is disabled by default. This is not + a breaking API change, but it is a breaking semantics change. + + +1.7.0.0 (2018-06-03) +-------------------- + +* Git: :tag:`dejafu-1.7.0.0` +* Hackage: :hackage:`dejafu-1.7.0.0` + +Changed +~~~~~~~ + +* (:issue:`237`) ``Test.DejaFu.SCT.sctWeightedRandom`` and + ``sctWeightedRandomDiscard`` no longer take the number of executions + to use the same weights for as a parameter. + +Removed +~~~~~~~ + +* (:issue:`237`) The deprecated function + ``Test.DejaFu.Settings.swarmy``. + + +1.6.0.0 (2018-05-11) +-------------------- + +* Git: :tag:`dejafu-1.6.0.0` +* Hackage: :hackage:`dejafu-1.6.0.0` + +Removed +~~~~~~~ + +* The deprecated module ``Test.DejaFu.Defaults``. + + +1.5.1.0 (2018-03-29) +-------------------- + +* Git: :tag:`dejafu-1.5.1.0` +* Hackage: :hackage:`dejafu-1.5.1.0` + +Added +~~~~~ + +- (:issue:`210`) ``Test.DejaFu.Types.Weaken`` and ``Strengthen`` + newtype wrappers around discard functions, with ``Semigroup``, + ``Monoid``, ``Contravariant``, and ``Divisible`` instances + corresponding to ``weakenDiscard`` and ``strengthenDiscard``. + + +1.5.0.0 - No More 7.10 (2018-03-28) +----------------------------------- + +* Git: :tag:`dejafu-1.5.0.0` +* Hackage: :hackage:`dejafu-1.5.0.0` + +Miscellaneous +~~~~~~~~~~~~~ + +* GHC 7.10 support is dropped. Dependency lower bounds are: + + * :hackage:`base`: 4.9 + * :hackage:`concurrency`: 1.5 + * :hackage:`transformers`: 0.5 + +* The upper bound on :hackage:`concurrency` is 1.6. + + +1.4.0.0 (2018-03-17) +-------------------- + +* Git: :tag:`dejafu-1.4.0.0` +* Hackage: :hackage:`dejafu-1.4.0.0` + +Changed +~~~~~~~ + +- (:issue:`201`) ``Test.DejaFu.Conc.ConcT r n a`` drops its ``r`` + parameter, becoming ``ConcT n a``. + +- (:issue:`201`) All functions drop the ``MonadConc`` constraint. + +Removed +~~~~~~~ + +- (:issue:`201`) The ``MonadRef`` and ``MonadAtomicRef`` instances for + ``Test.DejaFu.Conc.ConcT``. + +- (:issue:`198`) The ``Test.DejaFu.Types.Killed`` thread action, which + was unused. + +Fixed +~~~~~ + +- (:issue:`250`) Add missing dependency for ``throwTo`` actions. + + +1.3.2.0 (2018-03-12) +-------------------- + +* Git: :tag:`dejafu-1.3.2.0` +* Hackage: :hackage:`dejafu-1.3.2.0` + +Added +~~~~~ + +* (:issue:`183`) SCT settings for trace simplification: + + * ``Test.DejaFu.Settings.lequality`` + * ``Test.DejaFu.Settings.lsimplify`` + +* (:pull:`248`) ``Test.DejaFu.Utils.toTIdTrace`` to extract thread IDs + from a trace. + +* (:pull:`248`) SCT setting to make some recoverable errors fatal: + ``Test.DejaFu.Settings.ldebugFatal`` + +Performance +~~~~~~~~~~~ + +* (:pull:`248`) Prune some unnecessary interleavings of ``CRef`` + actions in systematic testing when using sequential consistency. + + +1.3.1.0 (2018-03-11) +-------------------- + +* Git: :tag:`dejafu-1.3.1.0` +* Hackage: :hackage:`dejafu-1.3.1.0` + +Added +~~~~~ + +* (:pull:`246`) ``Generic`` instances for: + + * ``Test.DejaFu.Types.ThreadId`` + * ``Test.DejaFu.Types.CRefId`` + * ``Test.DejaFu.Types.MVarId`` + * ``Test.DejaFu.Types.TVarId`` + * ``Test.DejaFu.Types.Id`` + * ``Test.DejaFu.Types.ThreadAction`` + * ``Test.DejaFu.Types.Lookahead`` + * ``Test.DejaFu.Types.TAction`` + * ``Test.DejaFu.Types.Decision`` + * ``Test.DejaFu.Types.Failure`` + * ``Test.DejaFu.Types.Bounds`` + * ``Test.DejaFu.Types.PreemptionBound`` + * ``Test.DejaFu.Types.FairBound`` + * ``Test.DejaFu.Types.LengthBound`` + * ``Test.DejaFu.Types.Discard`` + * ``Test.DejaFu.Types.MemType`` + * ``Test.DejaFu.Types.MonadFailException`` + +* (:pull:`246`) ``NFData`` instance for + ``Test.DejaFu.Types.MonadFailException`` + +Fixed +~~~~~ + +* (:issue:`199`) Missing cases in the ``NFData`` instances for + ``Test.DejaFu.Types.ThreadAction`` and ``TAction`` + + +1.3.0.3 (2018-03-11) +-------------------- + +* Git: :tag:`dejafu-1.3.0.3` +* Hackage: :hackage:`dejafu-1.3.0.3` + +Miscellaneous +~~~~~~~~~~~~~ + +* (:pull:`245`) The upper bound on :hackage:`exceptions` is <0.11. + + +1.3.0.2 (2018-03-11) +-------------------- + +* Git: :tag:`dejafu-1.3.0.2` +* Hackage: :hackage:`dejafu-1.3.0.2` + +Fixed +~~~~~ + +* (:pull:`244`) Add missing dependency for ``setNumCapabilities`` + actions. + + +1.3.0.1 (2018-03-08) +-------------------- + +* Git: :tag:`dejafu-1.3.0.1` +* Hackage: :hackage:`dejafu-1.3.0.1` + +Fixed +~~~~~ + +* (:pull:`242`) A compilation error when building with + :hackage:`exceptions-0.9.0`. + + +1.3.0.0 (2018-03-06) +-------------------- + +* Git: :tag:`dejafu-1.3.0.0` +* Hackage: :hackage:`dejafu-1.3.0.0` + +Deprecated +~~~~~~~~~~ + +* (:pull:`240`) ``Test.DejaFu.Settings.swarmy`` + + +1.2.0.0 - The Settings Release (2018-03-06) +------------------------------------------- + +* Git: :tag:`dejafu-1.2.0.0` +* Hackage: :hackage:`dejafu-1.2.0.0` + +**Contributors:** :u:`qrilka` (:pull:`236`). + +Added +~~~~~ + +* (:pull:`238`) A record-based approach to SCT configuration: + + * ``Test.DejaFu.Settings`` (re-exported from ``Test.Dejafu`` and + ``Test.DejaFu.SCT``) + * ``Test.DejaFu.Settings.Settings`` + * ``Test.DejaFu.Settings.defaultSettings`` + * ``Test.DejaFu.Settings.fromWayAndMemType`` + + * Lenses: + + * ``Test.DejaFu.Settings.lway`` + * ``Test.DejaFu.Settings.lmemtype`` + * ``Test.DejaFu.Settings.ldiscard`` + * ``Test.DejaFu.Settings.learlyExit`` + * ``Test.DejaFu.Settings.ldebugShow`` + * ``Test.DejaFu.Settings.ldebugPrint`` + + * Lens helpers: + + * ``Test.DejaFu.Settings.get`` + * ``Test.DejaFu.Settings.set`` + + * Runners: + + * ``Test.DejaFu.SCT.runSCTWithSettings`` + * ``Test.DejaFu.SCT.runSCTWithSettings'`` + * ``Test.DejaFu.SCT.resultsSetWithSettings`` + * ``Test.DejaFu.SCT.resultsSetWithSettings'`` + +* (:pull:`238`) Settings-based test functions: + + * ``Test.DejaFu.autocheckWithSettings`` + * ``Test.DejaFu.dejafuWithSettings`` + * ``Test.DejaFu.dejafusWithSettings`` + * ``Test.DejaFu.runTestWithSettings`` + +Deprecated +~~~~~~~~~~ + +* (:pull:`238`) SCT function variants: + + * ``Test.DejaFu.SCT.runSCTDiscard`` + * ``Test.DejaFu.SCT.resultSetDiscard`` + * ``Test.DejaFu.SCT.runSCTDiscard'`` + * ``Test.DejaFu.SCT.resultSetDiscard'`` + * ``Test.DejaFu.SCT.sctBound`` + * ``Test.DejaFu.SCT.sctBoundDiscard`` + * ``Test.DejaFu.SCT.sctUniformRandom`` + * ``Test.DejaFu.SCT.sctUniformRandomDiscard`` + * ``Test.DejaFu.SCT.sctWeightedRandom`` + * ``Test.DejaFu.SCT.sctWeightedRandomDiscard`` + +* (:pull:`238`) The ``Test.DejaFu.Defaults`` module. Import + ``Test.DejaFu.Settings`` instead. + +* (:pull:`238`) ``Test.DejaFu.dejafuDiscard``. + +Removed +~~~~~~~ + +* (:pull:`238`) ``Test.DejaFu.Defaults.defaultDiscarder``, as the + discard function is optional. + + +1.1.0.2 (2018-03-01) +-------------------- + +* Git: :tag:`dejafu-1.1.0.2` +* Hackage: :hackage:`dejafu-1.1.0.2` + +Miscellaneous +~~~~~~~~~~~~~ + +* (:pull:`235`) The documentation for ``Test.DejaFu.Conc.dontCheck`` + and ``subconcurrency`` clarify that an illegal use does not + necessarily cause a failing test. + + +1.1.0.1 (2018-02-26) +-------------------- + +* Git: :tag:`dejafu-1.1.0.1` +* Hackage: :hackage:`dejafu-1.1.0.1` + +**Contributors:** :u:`qrilka` (:pull:`229`). + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`exceptions` is <0.10. + + +1.1.0.0 (2018-02-22) +-------------------- + +* Git: :tag:`dejafu-1.1.0.0` +* Hackage: :hackage:`dejafu-1.1.0.0` + +**Contributors:** :u:`qrilka` (:pull:`228`). + +Added +~~~~~ + +* (:pull:`219`) The testing-only ``Test.DejaFu.Conc.dontCheck`` + function, and associated definitions: + + * ``Test.DejaFu.Types.DontCheck`` + * ``Test.DejaFu.Types.WillDontCheck`` + * ``Test.DejaFu.Types.IllegalDontCheck`` + * ``Test.DejaFu.Types.isIllegalDontCheck`` + +* (:pull:`219`) A snapshotting approach based on + ``Test.DejaFu.Conc.dontCheck``: + + * ``Test.DejaFu.Conc.runForDCSnapshot`` + * ``Test.DejaFu.Conc.runWithDCSnapshot`` + * ``Test.DejaFu.Conc.canDCSnapshot`` + * ``Test.DejaFu.Conc.threadsFromDCSnapshot`` + +Changed +~~~~~~~ + +* (:pull:`219`) SCT functions automatically use the snapshotting + mechanism when possible. + + +1.0.0.2 (2018-02-18) +-------------------- + +* Git: :tag:`dejafu-1.0.0.2` +* Hackage: :hackage:`dejafu-1.0.0.2` + +**Contributors:** :u:`qrilka` (:pull:`214`). + +Changed +~~~~~~~ + +* (:issue:`193`) Deterministically assign commit thread IDs. + +Fixed +~~~~~ + +* (:issue:`189`) Remove an incorrect optimisation in systematic + testing for ``getNumCapabilities`` and ``setNumCapabilities``. + +* (:issue:`204`) Fix missed interleavings in systematic testing with + some uses of STM. + +* (:issue:`205`) Fix ``forkOS`` being recorded in an execution trace + as if it were a ``fork``. + +Miscellaneous +~~~~~~~~~~~~~ + +* (:pull:`180`) Doctest Haddock examples in ``Test.DejaFu`` and + ``Test.DejaFu.Refinement``. + +* (:pull:`185`, :pull:`215`) Check some more internal invariants and + throw on error. + +* (:pull:`214`) Remove unnecessary use of ``head``. + + +1.0.0.1 (2018-01-19) +-------------------- + +* Git: :tag:`dejafu-1.0.0.1` +* Hackage: :hackage:`dejafu-1.0.0.1` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`concurrency` is <1.5. + + +1.0.0.0 - The API Friendliness Release (2017-12-23) +--------------------------------------------------- + +* Git: :tag:`dejafu-1.0.0.0` +* Hackage: :hackage:`dejafu-1.0.0.0` + +Added +~~~~~ + +* ``Test.DejaFu.alwaysSameOn`` and ``alwaysSameBy`` predicate helpers. + +* ``Test.DejaFu.SCT.strengthenDiscard`` and ``weakenDiscard`` + functions to combine discard functions. + +* (:issue:`124`) The ``Test.DejaFu.ProPredicate`` type, which contains + both an old-style ``Predicate`` and a discard function. It is also + a ``Profunctor``, parameterised by the input and output types. + +* (:issue:`124`) ``Test.DejaFu.alwaysNothing`` and + ``somewhereNothing`` predicate helpers, like ``alwaysTrue`` and + ``somewhereTrue``, to lift regular functions into a + ``ProPredicate``. + +* (:issue:`137`) The ``Test.DejaFu.Types.Id`` type. + +* (:pull:`145`) Thread action and lookahead values for bound threads: + + * ``Test.DejaFu.Types.ForkOS`` + * ``Test.DejaFu.Types.IsCurrentThreadBound`` + * ``Test.DejaFu.Types.WillForkOS`` + * ``Test.DejaFu.Types.WillIsCurrentThreadBound`` + +* (:issue:`155`) ``Test.DejaFu.Types`` and ``Test.DejaFu.Utils`` + modules, each containing some of what was in ``Test.DejaFu.Common``. + +Changed +~~~~~~~ + +* All testing functions require ``MonadConc``, ``MonadRef``, and + ``MonadIO`` constraints. Testing with ``ST`` is no longer possible. + +* The ``Test.DejaFu.alwaysSame`` predicate helper gives the simplest + trace leading to each distinct result. + +* The ``MonadIO Test.DejaFu.Conc.ConcIO`` instance is now the more + general ``MonadIO n => MonadIO (ConcT r n)``. + +* (:issue:`121`) The chosen thread is no longer redundantly included + in trace lookahead. + +* (:issue:`123`) All testing functions in ``Test.DejaFu`` take the + action to run as the final parameter. + +* (:issue:`124`) All testing functions in ``Test.DejaFu`` have been + generalised to take a ``ProPredicate`` instead of a ``Predicate``. + +* (:issue:`124`) The ``Test.DejaFu.Predicate`` type is an alias for + ``ProPredicate a a``. + +* (:issue:`124`) The ``Test.DejaFu.Result`` type no longer includes a + number of cases checked. + +* (:issue:`137`) The ``Test.DejaFu.Types.ThreadId``, ``CRefId``, + ``MVarId``, and ``TVarId`` types are now wrappers for an ``Id``. + +* (:pull:`145`) If built with the threaded runtime, the main thread in + a test is executed as a bound thread. + +* (:issue:`155`) The ``Test.DejaFu.SCT.Discard`` type is defined in + ``Test.DejaFu.Types``, and re-exported from ``Test.DejaFu.SCT``. + +* (:issue:`155`) The ``Test.DejaFu.Schedule.tidOf`` and ``decisionOf`` + functions are defined in ``Test.DejaFu.Utils``, but not re-exported + from ``Test.DejaFu.Schedule``. + +Removed +~~~~~~~ + +* The ``IO`` specific testing functions: + + * ``Test.DejaFu.autocheckIO`` + * ``Test.DejaFu.dejafuIO`` + * ``Test.DejaFu.dejafusIO`` + * ``Test.DejaFu.autocheckWayIO`` + * ``Test.DejaFu.dejafuWayIO`` + * ``Test.DejaFu.dejafusWayIO`` + * ``Test.DejaFu.dejafuDiscardIO`` + * ``Test.DejaFu.runTestM`` + * ``Test.DejaFu.runTestWayM`` + +* The ``Test.DejaFu.Conc.ConcST`` type alias. + +* The ``MonadBaseControl IO Test.DejaFu.Conc.ConcIO`` typeclass instance. + +* The ``Test.DejaFu.alwaysTrue2`` function, which had confusing + behaviour. + +* The ``Test.DejaFu.Common.TTrace`` type synonym for ``[TAction]``. + +* The ``Test.DejaFu.Common.preEmpCount`` function. + +* Re-exports of ``Decision`` and ``NonEmpty`` from + ``Test.DejaFu.Schedule``. + +* (:issue:`155`) The ``Test.DejaFu.Common`` and ``Test.DejaFu.STM`` + modules. + +Fixed +~~~~~ + +* In refinement property testing, a blocking interference function is + not reported as a deadlocking execution. + +Performance +~~~~~~~~~~~ + +* (:issue:`124`) Passing tests should use substantially less memory. + +* (:issue:`168`) Prune some unnecessary interleavings of ``MVar`` + actions in systematic testing. + +Miscellaneous +~~~~~~~~~~~~~ + +* The lower bound on :hackage:`concurrency` is >=1.3. + + +0.9.1.2 (2017-12-12) +-------------------- + +* Git: :tag:`dejafu-0.9.1.2` +* Hackage: :hackage:`dejafu-0.9.1.2` + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`leancheck` is <0.8. + + +0.9.1.1 (2017-12-08) +-------------------- + +* Git: :tag:`dejafu-0.9.1.1` +* Hackage: :hackage:`dejafu-0.9.1.1` + +Fixed +~~~~~ + +* (:issue:`160`) Fix an off-by-one issue with nested masks during + systematic testing. + + +0.9.1.0 (2017-11-26) +-------------------- + +* Git: :tag:`dejafu-0.9.1.0` +* Hackage: :hackage:`dejafu-0.9.1.0` + +Added +~~~~~ + +* ``MonadFail`` instance for ``Test.DejaFu.Conc.ConcT``. +* ``MonadFail`` instance for ``Test.DejaFu.STM.STMLike``. + +Changed +~~~~~~~ + +* Pretty-printed traces display a pre-emption following a yield with a + little "p". + +Fixed +~~~~~ + +* Some incorrect Haddock ``@since`` comments. + + +0.9.0.3 (2017-11-06) +-------------------- + +* Git: :tag:`dejafu-0.9.0.3` +* Hackage: :hackage:`dejafu-0.9.0.3` + +Fixed +~~~~~ + +* (:issue:`138`) Fix missed interleavings in systematic testing with + some relaxed memory programs. + + +0.9.0.2 (2017-11-02) +-------------------- + +* Git: :tag:`dejafu-0.9.0.2` +* Hackage: :hackage:`dejafu-0.9.0.2` + +Changed +~~~~~~~ + +* A fair bound of 0 prevents yielding or delaying. + +Performance +~~~~~~~~~~~ + +* Prune some unnecessary interleavings of STM transactions in + systematic testing. + + +0.9.0.1 (2017-10-28) +-------------------- + +* Git: :tag:`dejafu-0.9.0.1` +* Hackage: :hackage:`dejafu-0.9.0.1` + +Fixed +~~~~~ + +* (:issue:`139`) Fix double pop of exception handler stack. + + +0.9.0.0 (2017-10-11) +-------------------- + +* Git: :tag:`dejafu-0.9.0.0` +* Hackage: :hackage:`dejafu-0.9.0.0` + +Added +~~~~~ + +* Failure predicates (also exported from ``Test.DejaFu``): + + * ``Test.DejaFu.Common.isAbort`` + * ``Test.DejaFu.Common.isDeadlock`` + * ``Test.DejaFu.Common.isIllegalSubconcurrency`` + * ``Test.DejaFu.Common.isInternalError`` + * ``Test.DejaFu.Common.isUncaughtException`` + +* Thread action and lookahead values for ``threadDelay``: + + * ``Test.DejaFu.Common.ThreadDelay`` + * ``Test.DejaFu.Common.WillThreadDelay`` + +Changed +~~~~~~~ + +* The ``UncaughtException`` constructor for + ``Test.DejaFu.Common.Failure`` now includes the exception value. + +* Uses of ``threadDelay`` are no longer reported in the trace as a use + of ``yield``. + +Removed +~~~~~~~ + +* The ``Bounded``, ``Enum``, and ``Read`` instances for + ``Test.DejaFu.Common.Failure``. + + +0.8.0.0 (2017-09-26) +-------------------- + +* Git: :tag:`dejafu-0.8.0.0` +* Hackage: :hackage:`dejafu-0.8.0.0` + +Changed +~~~~~~~ + +* (:issue:`80`) STM traces now include the ID of a newly-created + ``TVar``. + +* (:issue:`106`) Schedulers are not given the execution trace so far. + +* (:issue:`120`) Traces only include a single action of lookahead. + +* (:issue:`122`) The ``Test.DejaFu.Scheduler.Scheduler`` type is now a + newtype, rather than a type synonym. + + +0.7.3.0 (2017-09-26) +-------------------- + +* Git: :tag:`dejafu-0.7.3.0` +* Hackage: :hackage:`dejafu-0.7.3.0` + +Added +~~~~~ + +* The ``Test.DejaFu.Common.threadNames`` function. + +Fixed +~~~~~ + +* (:issue:`101`) Named threads which are only started by a pre-emption + are shown in the pretty-printed trace key. + +* (:issue:`118`) Escaping a mask by raising an exception correctly + restores the masking state (#118). + + +0.7.2.0 (2017-09-16) +-------------------- + +* Git: :tag:`dejafu-0.7.2.0` +* Hackage: :hackage:`dejafu-0.7.2.0` + +Added +~~~~~ + +* ``Alternative`` and ``MonadPlus`` instances for + ``Test.DejaFu.STM.STM``. + +Fixed +~~~~~ + +* The ``Eq`` and ``Ord`` instances for + ``Test.DejaFu.Common.ThreadId``, ``CRefId``, ``MVarId``, and + ``TVarId`` are consistent. + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`concurrency` is <1.2. + + +0.7.1.3 (2017-09-08) +-------------------- + +* Git: :tag:`dejafu-0.7.1.3` +* Hackage: :hackage:`dejafu-0.7.1.3` + +Fixed +~~~~~ + +* (:issue:`111`) Aborted STM transactions are correctly rolled back. + +Performance +~~~~~~~~~~~ + +* (:issue:`105`) Use a more efficient approach for an internal + component of the systematic testing. + + +0.7.1.2 (2017-08-21) +-------------------- + +* Git: :tag:`dejafu-0.7.1.2` +* Hackage: :hackage:`dejafu-0.7.1.2` + +Fixed +~~~~~ + +* (:issue:`110`) Errors thrown with ``Control.Monad.fail`` are + correctly treated as asynchronous exceptions. + + +0.7.1.1 (2017-08-16) +-------------------- + +* Git: :tag:`dejafu-0.7.1.1` +* Hackage: :hackage:`dejafu-0.7.1.1` + +Performance +~~~~~~~~~~~ + +* (:issue:`64`) Greatly reduce memory usage in systematic testing when + discarding traces by using an alternative data structure. + + * Old: ``O(max trace length * number of executions)`` + * New: ``O(max trace length * number of traces kept)`` + + +0.7.1.0 - The Discard Release (2017-08-10) +------------------------------------------ + +* Git: :tag:`dejafu-0.7.1.0` +* Hackage: :hackage:`dejafu-0.7.1.0` + +Added +~~~~~ + +* (:issue:`90`) A way to selectively discard results or traces: + + * Type: ``Test.DejaFu.SCT.Discard`` + * Functions: ``Test.DejaFu.SCT.runSCTDiscard``, ``resultsSetDiscard``, + ``sctBoundDiscard``, ``sctUniformRandomDiscard``, and + ``sctWeightedRandomDiscard``. + +* (:issue:`90`) Discarding variants of the testing functions: + + * ``Test.DejaFu.dejafuDiscard`` + * ``Test.DejaFu.dejafuDiscardIO`` + +* (:issue:`90`) ``Test.DejaFu.Defaults.defaultDiscarder``. + +Performance +~~~~~~~~~~~ + +* (:issue:`90`) The ``Test.DejaFu.SCT.resultsSet`` and ``resultsSet'`` + functions discard traces as they are produced, rather than all at + the end. + + +0.7.0.2 (2017-06-12) +-------------------- + +* Git: :tag:`dejafu-0.7.0.2` +* Hackage: :hackage:`dejafu-0.7.0.2` + +Changed +~~~~~~~ + +* Remove unnecessary typeclass constraints from + ``Test.DejaFu.Refinement.check``, ``check'``, ``checkFor``, and + ``counterExamples``. + +Miscellaneous +~~~~~~~~~~~~~ + +* Remove an unnecessary dependency on :hackage:`monad-loops`. + + +0.7.0.1 (2017-06-09) +-------------------- + +* Git: :tag:`dejafu-0.7.0.1` +* Hackage: :hackage:`dejafu-0.7.0.1` + +Performance +~~~~~~~~~~~ + +* The ``Test.DejaFu.Refinement.check``, ``check'``, and ``checkFor`` + functions no longer need to compute all counterexamples before + showing only one. + +* The above and ``counterExamples`` are now faster even if there is + only a single counterexample in some cases. + + +0.7.0.0 - The Refinement Release (2017-06-07) +--------------------------------------------- + +* Git: :tag:`dejafu-0.7.0.0` +* Hackage: :hackage:`dejafu-0.7.0.0` + +Added +~~~~~ + +* The ``Test.DejaFu.Refinement`` module, re-exported from + ``Test.DejaFu``. + +* The ``Test.DejaFu.SCT.sctUniformRandom`` function for SCT via random + scheduling. + +* Smart constructors for ``Test.DejaFu.SCT.Way`` (also re-exported + from ``Test.DejaFu``): + + * ``Test.DejaFu.SCT.systematically``, like the old ``Systematically``. + * ``Test.DejaFu.SCT.randomly``, like the old ``Randomly``. + * ``Test.DejaFu.SCT.uniformly``, a new uniform (as opposed to weighted) random + scheduler. + * ``Test.DejaFu.SCT.swarmy``, like the old ``Randomly`` but which can use the + same weights for multiple executions. + +Changed +~~~~~~~ + +* The ``default*`` values are defined in ``Test.DejaFu.Defaults`` and + re-exported from ``Test.DejaFu``. + +* The ``Test.DejaFu.SCT.sctRandom`` function is now called + ``sctWeightedRandom`` and can re-use the same weights for multiple + executions. + +Removed +~~~~~~~ + +* The ``Test.DejaFu.SCT.Way`` type is now abstract, so its + constructors are no longer exported: + + * ``Test.DejaFu.SCT.Systematically`` + * ``Test.DejaFu.SCT.Randomly`` + +* The ``Test.DejaFu.SCT.sctPreBound``, ``sctFairBound``, and + ``sctLengthBound`` functions. + +Fixed +~~~~~ + +* (:issue:`81`) ``Test.DejaFu.Conc.subconcurrency`` no longer re-uses + IDs. + + +0.6.0.0 (2017-04-08) +-------------------- + +* Git: :tag:`dejafu-0.6.0.0` +* Hackage: :hackage:`dejafu-0.6.0.0` + +Changed +~~~~~~~ + +* The ``Test.DejaFu.Conc.Conc n r a`` type is ``ConcT r n a``, and has + a ``MonadTrans`` instance. + +* The ``Test.DejaFu.SCT.Way`` type is a GADT, and does not expose the + type parameter of the random generator. + +Removed +~~~~~~~ + +* The ``NFData`` instance for ``Test.DejaFu.SCT.Way``. + +Miscellaneous +~~~~~~~~~~~~~ + +* ``Test.DejaFu.Common`` forms part of the public API. + +* Every definition, class, and instance now has a Haddock ``@since`` + annotation. + + +0.5.1.3 (2017-04-05) +-------------------- + +* Git: :tag:`dejafu-0.5.1.3` +* Hackage: :hackage:`dejafu-0.5.1.3` + +Miscellaneous +~~~~~~~~~~~~~ + +* The version bounds on :hackage:`concurrency` are 1.1.*. + + +0.5.1.2 (2017-03-04) +-------------------- + +* Git: :tag:`dejafu-0.5.1.2` +* Hackage: :hackage:`dejafu-0.5.1.2` + +**Note:** this version was misnumbered! It should have caused a minor + version bump! + +Added +~~~~~ + +* ``MonadRef`` and ``MonadAtomicRef`` instances for + ``Test.DejaFu.Conc.Conc`` using ``CRef``. + +Fixed +~~~~~ + +* A long-standing bug where if the main thread is killed with a + ``throwTo``, the throwing neither appears in the trace nor correctly + terminates the execution. + +Miscellaneous +~~~~~~~~~~~~~ + +* The upper bound on :hackage:`concurrency` is <1.1.1. + + +0.5.1.1 (2017-02-25) +-------------------- + +* Git: :tag:`dejafu-0.5.1.1` +* Hackage: :hackage:`dejafu-0.5.1.1` + +Fixed +~~~~~ + +* Fix using incorrect correct scheduler state after a `subconcurrency` + action. + +* Fix infinite loop in SCT of subconcurrency. + + +0.5.1.0 (2017-02-25) +-------------------- + +* Git: :tag:`dejafu-0.5.1.0` +* Hackage: :hackage:`dejafu-0.5.1.0` + +Added +~~~~~ + +* ``NFData`` instances for: + + * ``Test.DejaFu.Result`` + * ``Test.DejaFu.Common.ThreadId`` + * ``Test.DejaFu.Common.CRefId`` + * ``Test.DejaFu.Common.MVarId`` + * ``Test.DejaFu.Common.TVarId`` + * ``Test.DejaFu.Common.IdSource`` + * ``Test.DejaFu.Common.ThreadAction`` + * ``Test.DejaFu.Common.Lookahead`` + * ``Test.DejaFu.Common.ActionType`` + * ``Test.DejaFu.Common.TAction`` + * ``Test.DejaFu.Common.Decision`` + * ``Test.DejaFu.Common.Failure`` + * ``Test.DejaFu.Common.MemType`` + * ``Test.DejaFu.SCT.Bounds`` + * ``Test.DejaFu.SCT.PreemptionBound`` + * ``Test.DejaFu.SCT.FairBound`` + * ``Test.DejaFu.SCT.LengthBound`` + * ``Test.DejaFu.SCT.Way`` + * ``Test.DejaFu.STM.Result`` + +* ``Eq``, ``Ord``, and ``Show`` instances for + ``Test.DejaFu.Common.IdSource``. + +* Strict variants of ``Test.DejaFu.SCT.runSCT`` and ``resultsSet``: + ``runSCT'`` and ``resultsSet'``. + + +0.5.0.2 (2017-02-22) +-------------------- + +* Git: :tag:`dejafu-0.5.0.2` +* Hackage: :hackage:`dejafu-0.5.0.2` + +**Note:** this version was misnumbered! It should have caused a major + version bump! + +Added +~~~~~ + +* ``StopSubconcurrency`` constructor for + ``Test.DejaFu.Common.ThreadAction``. + +Changed +~~~~~~~ + +* A ``Test.DejaFu.Common.StopConcurrency`` action appears in the + execution trace immediately after the end of a + ``Test.DejaFu.Conc.subconcurrency`` action. + +Fixed +~~~~~ + +* A ``Test.DejaFu.Conc.subconcurrency`` action inherits the number of + capabilities from the outer computation. + +Miscellaneous +~~~~~~~~~~~~~ + +- ``Test.DejaFu.SCT`` compiles with ``MonoLocalBinds`` enabled + (implied by ``GADTs`` and ``TypeFamilies``), which may be relevant + to hackers. + + +0.5.0.1 (2017-02-21) +-------------------- + +* Git: :tag:`dejafu-0.5.0.1` +* Hackage: :hackage:`ps!**` + +Fixed +~~~~~ + +* ``readMVar`` is considered a "release action" for the purposes of + fair-bounding. + + +0.5.0.0 - The Way Release (2017-02-21) +-------------------------------------- + +* Git: :tag:`dejafu-0.5.0.0` +* Hackage: :hackage:`dejafu-0.5.0.0` + +Added +~~~~~ + +* ``Eq`` instances for ``Test.DejaFu.Common.ThreadAction`` and + ``Lookahead``. + +* Thread action and lookahead values for ``tryReadMVar``: + + * ``Test.DejaFu.Common.TryReadMVar`` + * ``Test.DejaFu.Common.WillTryReadMVar`` + +* The testing-only ``Test.DejaFu.Conc.subconcurrency`` function. + +* SCT through weighted random scheduling: + ``Test.DejaFu.SCT.sctRandom``. + +* The ``Test.DejaFu.SCT.Way`` type, used by the new functions + ``runSCT`` and ``resultsSet``. + +Changed +~~~~~~~ + +* All the functions which took a ``Test.DejaFu.SCT.Bounds`` now take a + ``Way`` instead. + +Fixed +~~~~~ + +* Some previously-missed ``CRef`` action dependencies are no longer + missed. + +Miscellaneous +~~~~~~~~~~~~~ + +* The version bounds on :hackage:`concurrency` are 1.1.0.*. + +* A bunch of things were called "Var" or "Ref", these are now + consistently "MVar" and "CRef". + +* Significant performance improvements in both time and space. + +* The :hackage:`dpor` package has been merged back into this, as it + turned out not to be very generally useful. + + +0.4.0.0 - The Packaging Release (2016-09-10) +-------------------------------------------- + +* Git: :tag:`dejafu-0.4.0.0` +* Hackage: :hackage:`dejafu-0.4.0.0` + +Added +~~~~~ + +* The ``Test.DejaFu.runTestM`` and ``runTestM'`` functions. + +* The ``Test.DejaFu.Conc.runConcurrent`` function. + +* The ``Test.DejaFu.STM.runTransaction`` function. + +* The ``Test.DejaFu.Common`` module. + +Changed +~~~~~~~ + +* The ``Control.*`` modules have all been split out into a separate + :hackage:`concurrency` package. + +* The ``Test.DejaFu.Deterministic`` module has been renamed to + ``Test.DejaFu.Conc``. + +* Many definitions from other modules have been moved to the + ``Test.DejaFu.Common`` module. + +* The ``Test.DejaFu.autocheck'`` function takes the schedule bounds as + a parameter. + +* The ``Test.DejaFu.Conc.Conc`` type no longer has the STM type as a + parameter. + +* The ``ST`` specific functions in ``Test.DejaFu.SCT`` are polymorphic + in the monad. + +* The termination of the main thread in execution traces appears as a + single ``Stop``, rather than the previous ``Lift, Stop``. + +* Execution traces printed by the helpful functions in ``Test.DejaFu`` + include a key of thread names. + +Removed +~~~~~~~ + +* The ``Test.DejaFu.runTestIO`` and ``runTestIO'`` functions: use + ``runTestM`` and ``runTestM'`` instead. + +* The ``Test.DejaFu.Conc.runConcST`` and ``runConcIO`` functions: use + ``runConcurrent`` instead. + +* The ``Test.DejaFu.STM.runTransactionST`` and ``runTransactionIO`` + functions: use ``runTransaction`` instead. + +* The ``IO`` specific functions in ``Test.DejaFu.SCT``. + + + +0.3.2.1 (2016-07-21) +-------------------- + +* Git: :tag:`dejafu-0.3.2.1` +* Hackage: :hackage:`dejafu-0.3.2.1` + +Fixed +~~~~~ + +* (:issue:`55`) Fix incorrect detection of deadlocks with some nested + STM transactions. + + +0.3.2.0 (2016-06-06) +-------------------- + +* Git: :tag:`dejafu-0.3.2.0` +* Hackage: :hackage:`dejafu-0.3.2.0` + +Fixed +~~~~~ + +* (:issue:`40`) Fix missing executions with daemon threads with + uninteresting first actions. This is significantly faster with + :hackage:`dpor-0.2.0.0`. + +Performance +~~~~~~~~~~~ + +* When using :hackage:`dpor-0.2.0.0`, greatly improve dependency + inference of exceptions during systematic testing. + +* Improve dependency inference of STM transactions during systematic + testing. + + +0.3.1.1 (2016-05-26) +-------------------- + +* Git: :tag:`dejafu-0.3.1.1` +* Hackage: :hackage:`dejafu-0.3.1.1` + +Miscellaneous +~~~~~~~~~~~~~ + +* Now supports GHC 8. + + +0.3.1.0 (2016-05-02) +-------------------- + +* Git: :tag:`dejafu-0.3.1.0` +* Hackage: :hackage:`dejafu-0.3.1.0` + +Fixed +~~~~~ + +* Fix inaccurate counting of pre-emptions in an execution trace when + relaxed memory commit actions are present. + + +0.3.0.0 (2016-04-03) +-------------------- + +* Git: :tag:`dejafu-0.3.0.0` +* Hackage: :hackage:`dejafu-0.3.0.0` + +**The minimum supported version of GHC is now 7.10.** + +I didn't write proper release notes, and this is so far back I don't +really care to dig through the logs. + + +0.2.0.0 (2015-12-01) +-------------------- + +* Git: :tag:`0.2.0.0` +* Hackage: :hackage:`dejafu-0.2.0.0` + +I didn't write proper release notes, and this is so far back I don't +really care to dig through the logs. + + +0.1.0.0 - The Initial Release (2015-08-27) +------------------------------------------ + +* Git: :tag:`0.1.0.0` +* Hackage: :hackage:`dejafu-0.1.0.0` + +Added +~~~~~ + +* Everything. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Michael Walker +Copyright (c) 2015--2018, Michael Walker Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -7,66 +7,129 @@ > > -- Terry Pratchett, Thief of Time -Concurrency is nice, deadlocks and race conditions not so much. The -`Par` monad family, as defined in [abstract-par][] provides -deterministic parallelism, but sometimes we can tolerate a bit of -nondeterminism. +- [Installation](#installation) +- [Quick start guide](#quick-start-guide) +- [Why Déjà Fu?](#why-déjà-fu) +- [Contributing](#contributing) +- [Release notes](#release-notes) +- [Questions, feedback, discussion](#questions-feedback-discussion) +- [Bibliography](#bibliography) +- **[The website!](https://dejafu.docs.barrucadu.co.uk/)** -This package builds on the concurrency package (also in this -repository) by enabling you to systematically and deterministically -test your concurrent programs. +Déjà Fu is a unit-testing library for concurrent Haskell programs. +Tests are deterministic and expressive, making it easy and convenient +to test your threaded code. Available on [GitHub][], [Hackage][], and +[Stackage][]. -The documentation of the latest developmental version is -[available online][docs]. Examples can be found in the test suite. +[GitHub]: https://github.com/barrucadu/dejafu +[Hackage]: https://hackage.haskell.org/package/dejafu +[Stackage]: https://www.stackage.org/package/dejafu -**Note on the test suite:** This is in a separate project -(dejafu-tests) because Cabal-the-library is a bit naff. See this -[issue][]. -Déjà Fu and `IO` ----------------- +Installation +------------ -The core assumption underlying Déjà Fu is that any apparent -nondeterminism arises purely from the scheduling behaviour. To put it -another way, a given computation, parametrised with a fixed set of -scheduling decisions, is deterministic. +Install from Hackage globally: -Whilst this assumption may not hold in general when `IO` is involved, -you should strive to produce test cases where it does. +``` +$ cabal install dejafu +``` -Memory Model +Or add it to your cabal file: + +``` +build-depends: ... + , dejafu +``` + +Or to your package.yaml: + +``` +dependencies: + ... + - dejafu +``` + + +Quick start guide +----------------- + +Déjà Fu supports unit testing, and comes with a helper function called +`autocheck` to look for some common issues. Let's see it in action: + +```haskell +import Control.Concurrent.Classy + +myFunction :: MonadConc m => m String +myFunction = do + var <- newEmptyMVar + fork (putMVar var "hello") + fork (putMVar var "world") + readMVar var +``` + +That `MonadConc` is a typeclass abstraction over concurrency, but +we'll get onto that shortly. First, the result of testing: + +``` +> autocheck myFunction +[pass] Never Deadlocks +[pass] No Exceptions +[fail] Consistent Result + "hello" S0----S1--S0-- + + "world" S0----S2--S0-- +False +``` + +There are no deadlocks or uncaught exceptions, which is good; but the +program is (as you probably spotted) nondeterministic! + +Along with each result, Déjà Fu gives us a representative execution +trace in an abbreviated form. `Sn` means that thread `n` started +executing, and `Pn` means that thread `n` pre-empted the previously +running thread. + + +Why Déjà Fu? ------------ -The testing functionality supports a few different memory models, for -computations which use non-synchronised `CRef` operations. The -supported models are: +Testing concurrent programs is difficult, because in general they are +nondeterministic. This leads to people using work-arounds like +running their testsuite many thousands of times; or running their +testsuite while putting their machine under heavy load. -- **Sequential Consistency:** A program behaves as a simple - interleaving of the actions in different threads. When a CRef is - written to, that write is immediately visible to all threads. +These approaches are inadequate for a few reasons: -- **Total Store Order (TSO):** Each thread has a write buffer. A - thread sees its writes immediately, but other threads will only - see writes when they are committed, which may happen later. Writes - are committed in the same order that they are created. +- **How many runs is enough?** When you are just hopping to spot a bug + by coincidence, how do you know to stop? +- **How do you know if you've fixed a bug you saw previously?** + Because the scheduler is a black box, you don't know if the + previously buggy schedule has been re-run. +- **You won't get that much scheduling variety!** Operating systems + and language runtimes like to run threads for long periods of time, + which reduces the variety you get (and so drives up the number of + runs you need). -- **Partial Store Order (PSO):** Each CRef has a write buffer. A - thread sees its writes immediately, but other threads will only - see writes when they are committed, which may happen later. Writes - to different CRefs are not necessarily committed in the same order - that they are created. +Déjà Fu addresses these points by offering *complete* testing. You +can run a test case and be guaranteed to find all results with some +bounds. These bounds can be configured, or even disabled! The +underlying approach used is smarter than merely trying all possible +executions, and will in general explore the state-space quickly. -If a testing function does not take the memory model as a parameter, -it uses TSO. +If your test case is just too big for complete testing, there is also +a random scheduling mode, which is necessarily *incomplete*. However, +Déjà Fu will tend to produce much more schedule variety than just +running your test case in `IO` the same number of times, and so bugs +will tend to crop up sooner. Furthermore, as you get execution traces +out, you can be certain that a bug has been fixed by simply following +the trace by eye. + Contributing ------------ Bug reports, pull requests, and comments are very welcome! -Feel free to contact me on GitHub, through IRC (#haskell on freenode), -or email (mike@barrucadu.co.uk). - -[docs]: https://docs.barrucadu.co.uk/dejafu -[abstract-par]: https://hackage.haskell.org/package/abstract-par/docs/Control-Monad-Par-Class.html -[issue]: https://github.com/commercialhaskell/stack/issues/1122 +Feel free to contact me on GitHub, through IRC (#haskell on +libera.chat), or email (mike@barrucadu.co.uk). diff --git a/Test/DejaFu.hs b/Test/DejaFu.hs --- a/Test/DejaFu.hs +++ b/Test/DejaFu.hs @@ -1,802 +1,1038 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Module : Test.DejaFu --- Copyright : (c) 2016 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : RankNTypes --- --- Deterministic testing for concurrent computations. --- --- As an example, consider this program, which has two locks and a --- shared variable. Two threads are spawned, which claim the locks, --- update the shared variable, and release the locks. The main thread --- waits for them both to terminate, and returns the final result. --- --- > example1 :: MonadConc m => m Int --- > example1 = do --- > a <- newEmptyMVar --- > b <- newEmptyMVar --- > --- > c <- newMVar 0 --- > --- > let lock m = putMVar m () --- > let unlock = takeMVar --- > --- > j1 <- spawn $ lock a >> lock b >> modifyMVar_ c (return . succ) >> unlock b >> unlock a --- > j2 <- spawn $ lock b >> lock a >> modifyMVar_ c (return . pred) >> unlock a >> unlock b --- > --- > takeMVar j1 --- > takeMVar j2 --- > --- > takeMVar c --- --- The correct result is 0, as it starts out as 0 and is incremented --- and decremented by threads 1 and 2, respectively. However, note the --- order of acquisition of the locks in the two threads. If thread 2 --- pre-empts thread 1 between the acquisition of the locks (or if --- thread 1 pre-empts thread 2), a deadlock situation will arise, as --- thread 1 will have lock @a@ and be waiting on @b@, and thread 2 --- will have @b@ and be waiting on @a@. --- --- Here is what Deja Fu has to say about it: --- --- > > autocheck example1 --- > [fail] Never Deadlocks (checked: 5) --- > [deadlock] S0------------S1-P2--S1- --- > [pass] No Exceptions (checked: 12) --- > [fail] Consistent Result (checked: 11) --- > 0 S0------------S2-----------------S1-----------------S0---- --- > --- > [deadlock] S0------------S1-P2--S1- --- > False --- --- It identifies the deadlock, and also the possible results the --- computation can produce, and displays a simplified trace leading to --- each failing outcome. The trace contains thread numbers, and the --- names (which can be set by the programmer) are displayed beneath. --- It also returns @False@ as there are test failures. The automatic --- testing functionality is good enough if you only want to check your --- computation is deterministic, but if you have more specific --- requirements (or have some expected and tolerated level of --- nondeterminism), you can write tests yourself using the @dejafu*@ --- functions. --- --- __Warning:__ If your computation under test does @IO@, the @IO@ --- will be executed lots of times! Be sure that it is deterministic --- enough not to invalidate your test results. Mocking may be useful --- where possible. -module Test.DejaFu - ( -- * Testing - - -- | Testing in Deja Fu is similar to unit testing, the programmer - -- produces a self-contained monadic action to execute under - -- different schedules, and supplies a list of predicates to apply - -- to the list of results produced. - -- - -- If you simply wish to check that something is deterministic, see - -- the 'autocheck' and 'autocheckIO' functions. - -- - -- These functions use a Total Store Order (TSO) memory model for - -- unsynchronised actions, see \"Testing under Alternative Memory - -- Models\" for some explanation of this. - - autocheck - , dejafu - , dejafus - , autocheckIO - , dejafuIO - , dejafusIO - - -- * Testing with different settings - - , Way - , defaultWay - , systematically - , randomly - , uniformly - , swarmy - - , autocheckWay - , autocheckWayIO - , dejafuWay - , dejafuWayIO - , dejafusWay - , dejafusWayIO - - , Discard(..) - , defaultDiscarder - - , dejafuDiscard - , dejafuDiscardIO - - -- ** Memory Models - - -- | Threads running under modern multicore processors do not behave - -- as a simple interleaving of the individual thread - -- actions. Processors do all sorts of complex things to increase - -- speed, such as buffering writes. For concurrent programs which - -- make use of non-synchronised functions (such as 'readCRef' - -- coupled with 'writeCRef') different memory models may yield - -- different results. - -- - -- As an example, consider this program (modified from the - -- Data.IORef documentation). Two @CRef@s are created, and two - -- threads spawned to write to and read from both. Each thread - -- returns the value it observes. - -- - -- > example2 :: MonadConc m => m (Bool, Bool) - -- > example2 = do - -- > r1 <- newCRef False - -- > r2 <- newCRef False - -- > - -- > x <- spawn $ writeCRef r1 True >> readCRef r2 - -- > y <- spawn $ writeCRef r2 True >> readCRef r1 - -- > - -- > (,) <$> readMVar x <*> readMVar y - -- - -- Under a sequentially consistent memory model the possible results - -- are @(True, True)@, @(True, False)@, and @(False, True)@. Under - -- total or partial store order, @(False, False)@ is also a possible - -- result, even though there is no interleaving of the threads which - -- can lead to this. - -- - -- We can see this by testing with different memory models: - -- - -- > > autocheckWay defaultWay SequentialConsistency example2 - -- > [pass] Never Deadlocks (checked: 6) - -- > [pass] No Exceptions (checked: 6) - -- > [fail] Consistent Result (checked: 5) - -- > (False,True) S0-------S1-----S0--S2-----S0--- - -- > (True,False) S0-------S1-P2-----S1----S0---- - -- > (True,True) S0-------S1--P2-----S1---S0---- - -- > (False,True) S0-------S1---P2-----S1--S0---- - -- > (True,False) S0-------S2-----S1-----S0---- - -- > ... - -- > False - -- - -- > > autocheckWay defaultWay TotalStoreOrder example2 - -- > [pass] Never Deadlocks (checked: 303) - -- > [pass] No Exceptions (checked: 303) - -- > [fail] Consistent Result (checked: 302) - -- > (False,True) S0-------S1-----C-S0--S2-----C-S0--- - -- > (True,False) S0-------S1-P2-----C-S1----S0---- - -- > (True,True) S0-------S1-P2--C-S1----C-S0--S2---S0--- - -- > (False,True) S0-------S1-P2--P1--C-C-S1--S0--S2---S0--- - -- > (False,False) S0-------S1-P2--P1----S2---C-C-S0---- - -- > ... - -- > False - -- - -- Traces for non-sequentially-consistent memory models show where - -- writes to @CRef@s are /committed/, which makes a write visible to - -- all threads rather than just the one which performed the - -- write. Only 'writeCRef' is broken up into separate write and - -- commit steps, 'atomicModifyCRef' is still atomic and imposes a - -- memory barrier. - - , MemType(..) - , defaultMemType - - -- ** Schedule Bounding - - -- | Schedule bounding is an optimisation which only considers - -- schedules within some /bound/. This sacrifices completeness - -- outside of the bound, but can drastically reduce the number of - -- schedules to test, and is in fact necessary for non-terminating - -- programs. - -- - -- The standard testing mechanism uses a combination of pre-emption - -- bounding, fair bounding, and length bounding. Pre-emption + fair - -- bounding is useful for programs which use loop/yield control - -- flows but are otherwise terminating. Length bounding makes it - -- possible to test potentially non-terminating programs. - - , Bounds(..) - , defaultBounds - , noBounds - , PreemptionBound(..) - , defaultPreemptionBound - , FairBound(..) - , defaultFairBound - , LengthBound(..) - , defaultLengthBound - - -- * Results - - -- | The results of a test can be pretty-printed to the console, as - -- with the above functions, or used in their original, much richer, - -- form for debugging purposes. These functions provide full access - -- to this data type which, most usefully, contains a detailed trace - -- of execution, showing what each thread did at each point. - - , Result(..) - , Failure(..) - , runTest - , runTestWay - , runTestM - , runTestWayM - - -- * Predicates - - -- | Predicates evaluate a list of results of execution and decide - -- whether some test case has passed or failed. They can be lazy and - -- make use of short-circuit evaluation to avoid needing to examine - -- the entire list of results, and can check any property which can - -- be defined for the return type of your monadic action. - -- - -- A collection of common predicates are provided, along with the - -- helper functions 'alwaysTrue', 'alwaysTrue2' and 'somewhereTrue' - -- to lfit predicates over a single result to over a collection of - -- results. - - , Predicate - , representative - , abortsNever - , abortsAlways - , abortsSometimes - , deadlocksNever - , deadlocksAlways - , deadlocksSometimes - , exceptionsNever - , exceptionsAlways - , exceptionsSometimes - , alwaysSame - , notAlwaysSame - , alwaysTrue - , alwaysTrue2 - , somewhereTrue - , gives - , gives' - - -- ** Failures - - , isInternalError - , isAbort - , isDeadlock - , isUncaughtException - , isIllegalSubconcurrency - - -- * Refinement property testing - - -- | Consider this statement about @MVar@s: \"using @readMVar@ is - -- better than @takeMVar@ followed by @putMVar@ because the former - -- is atomic but the latter is not.\" - -- - -- Deja Fu can test properties like that: - -- - -- @ - -- sig e = Sig - -- { initialise = maybe newEmptyMVar newMVar - -- , observe = \\v _ -> tryReadMVar v - -- , interfere = \\v s -> tryTakeMVar v >> maybe (pure ()) (void . tryPutMVar v) s - -- , expression = e - -- } - -- - -- > check $ sig (void . readMVar) \`equivalentTo\` sig (\\v -> takeMVar v >>= putMVar v) - -- *** Failure: (seed Just ()) - -- left: [(Nothing,Just ())] - -- right: [(Nothing,Just ()),(Just Deadlock,Just ())] - -- @ - -- - -- The two expressions are not equivalent, and we get given the - -- counterexample! - , module Test.DejaFu.Refinement - ) where - -import Control.Arrow (first) -import Control.DeepSeq (NFData(..)) -import Control.Monad (unless, when) -import Control.Monad.Ref (MonadRef) -import Control.Monad.ST (runST) -import Data.Function (on) -import Data.List (intercalate, intersperse, minimumBy) -import Data.Ord (comparing) - -import Test.DejaFu.Common -import Test.DejaFu.Conc -import Test.DejaFu.Defaults -import Test.DejaFu.Refinement -import Test.DejaFu.SCT - - -------------------------------------------------------------------------------- --- DejaFu - --- | Automatically test a computation. In particular, look for --- deadlocks, uncaught exceptions, and multiple return values. --- --- This uses the 'Conc' monad for testing, which is an instance of --- 'MonadConc'. If you need to test something which also uses --- 'MonadIO', use 'autocheckIO'. --- --- @since 0.1.0.0 -autocheck :: (Eq a, Show a) - => (forall t. ConcST t a) - -- ^ The computation to test - -> IO Bool -autocheck = autocheckWay defaultWay defaultMemType - --- | Variant of 'autocheck' which takes a way to run the program and a --- memory model. --- --- Schedule bounding is used to filter the large number of possible --- schedules, and can be iteratively increased for further coverage --- guarantees. Empirical studies (/Concurrency Testing Using Schedule --- Bounding: an Empirical Study/, P. Thompson, A. Donaldson, and --- A. Betts) have found that many concurrency bugs can be exhibited --- with as few as two threads and two pre-emptions, which is part of --- what 'dejafus' uses. --- --- __Warning:__ Using largers bounds will almost certainly --- significantly increase the time taken to test! --- --- @since 0.6.0.0 -autocheckWay :: (Eq a, Show a) - => Way - -- ^ How to run the concurrent program. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> (forall t. ConcST t a) - -- ^ The computation to test - -> IO Bool -autocheckWay way memtype conc = - dejafusWay way memtype conc autocheckCases - --- | Variant of 'autocheck' for computations which do 'IO'. --- --- @since 0.2.0.0 -autocheckIO :: (Eq a, Show a) => ConcIO a -> IO Bool -autocheckIO = autocheckWayIO defaultWay defaultMemType - --- | Variant of 'autocheckWay' for computations which do 'IO'. --- --- @since 0.6.0.0 -autocheckWayIO :: (Eq a, Show a) => Way -> MemType -> ConcIO a -> IO Bool -autocheckWayIO way memtype concio = - dejafusWayIO way memtype concio autocheckCases - --- | Predicates for the various autocheck functions. -autocheckCases :: Eq a => [(String, Predicate a)] -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative - ] - --- | Check a predicate and print the result to stdout, return 'True' --- if it passes. --- --- @since 0.1.0.0 -dejafu :: Show a - => (forall t. ConcST t a) - -- ^ The computation to test - -> (String, Predicate a) - -- ^ The predicate (with a name) to check - -> IO Bool -dejafu = dejafuWay defaultWay defaultMemType - --- | Variant of 'dejafu' which takes a way to run the program and a --- memory model. --- --- @since 0.6.0.0 -dejafuWay :: Show a - => Way - -- ^ How to run the concurrent program. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> (forall t. ConcST t a) - -- ^ The computation to test - -> (String, Predicate a) - -- ^ The predicate (with a name) to check - -> IO Bool -dejafuWay = dejafuDiscard (const Nothing) - --- | Variant of 'dejafuWay' which can selectively discard results. --- --- @since 0.7.1.0 -dejafuDiscard :: Show a - => (Either Failure a -> Maybe Discard) - -- ^ Selectively discard results. - -> Way - -- ^ How to run the concurrent program. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> (forall t. ConcST t a) - -- ^ The computation to test - -> (String, Predicate a) - -- ^ The predicate (with a name) to check - -> IO Bool -dejafuDiscard discard way memtype conc (name, test) = do - let traces = runST (runSCTDiscard discard way memtype conc) - doTest name (test traces) - --- | Variant of 'dejafu' which takes a collection of predicates to --- test, returning 'True' if all pass. --- --- @since 0.1.0.0 -dejafus :: Show a - => (forall t. ConcST t a) - -- ^ The computation to test - -> [(String, Predicate a)] - -- ^ The list of predicates (with names) to check - -> IO Bool -dejafus = dejafusWay defaultWay defaultMemType - --- | Variant of 'dejafus' which takes a way to run the program and a --- memory model. --- --- @since 0.6.0.0 -dejafusWay :: Show a - => Way - -- ^ How to run the concurrent program. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> (forall t. ConcST t a) - -- ^ The computation to test - -> [(String, Predicate a)] - -- ^ The list of predicates (with names) to check - -> IO Bool -dejafusWay way memtype conc tests = do - let traces = runST (runSCT way memtype conc) - results <- mapM (\(name, test) -> doTest name $ test traces) tests - pure (and results) - --- | Variant of 'dejafu' for computations which do 'IO'. --- --- @since 0.2.0.0 -dejafuIO :: Show a => ConcIO a -> (String, Predicate a) -> IO Bool -dejafuIO = dejafuWayIO defaultWay defaultMemType - --- | Variant of 'dejafuWay' for computations which do 'IO'. --- --- @since 0.6.0.0 -dejafuWayIO :: Show a => Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool -dejafuWayIO = dejafuDiscardIO (const Nothing) - --- | Variant of 'dejafuDiscard' for computations which do 'IO'. --- --- @since 0.7.1.0 -dejafuDiscardIO :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool -dejafuDiscardIO discard way memtype concio (name, test) = do - traces <- runSCTDiscard discard way memtype concio - doTest name (test traces) - --- | Variant of 'dejafus' for computations which do 'IO'. --- --- @since 0.2.0.0 -dejafusIO :: Show a => ConcIO a -> [(String, Predicate a)] -> IO Bool -dejafusIO = dejafusWayIO defaultWay defaultMemType - --- | Variant of 'dejafusWay' for computations which do 'IO'. --- --- @since 0.6.0.0 -dejafusWayIO :: Show a => Way -> MemType -> ConcIO a -> [(String, Predicate a)] -> IO Bool -dejafusWayIO way memtype concio tests = do - traces <- runSCT way memtype concio - results <- mapM (\(name, test) -> doTest name $ test traces) tests - pure (and results) - - -------------------------------------------------------------------------------- --- Test cases - --- | The results of a test, including the number of cases checked to --- determine the final boolean outcome. --- --- @since 0.2.0.0 -data Result a = Result - { _pass :: Bool - -- ^ Whether the test passed or not. - , _casesChecked :: Int - -- ^ The number of cases checked. - , _failures :: [(Either Failure a, Trace)] - -- ^ The failing cases, if any. - , _failureMsg :: String - -- ^ A message to display on failure, if nonempty - } deriving (Eq, Show) - --- | @since 0.5.1.0 -instance NFData a => NFData (Result a) where - rnf r = rnf ( _pass r - , _casesChecked r - , _failures r - , _failureMsg r - ) - --- | A failed result, taking the given list of failures. -defaultFail :: [(Either Failure a, Trace)] -> Result a -defaultFail failures = Result False 0 failures "" - --- | A passed result. -defaultPass :: Result a -defaultPass = Result True 0 [] "" - -instance Functor Result where - fmap f r = r { _failures = map (first $ fmap f) $ _failures r } - -instance Foldable Result where - foldMap f r = foldMap f [a | (Right a, _) <- _failures r] - --- | Run a predicate over all executions within the default schedule --- bounds. --- --- @since 0.1.0.0 -runTest :: - Predicate a - -- ^ The predicate to check - -> (forall t. ConcST t a) - -- ^ The computation to test - -> Result a -runTest test conc = - runST (runTestM test conc) - --- | Variant of 'runTest' which takes a way to run the program and a --- memory model. --- --- @since 0.6.0.0 -runTestWay - :: Way - -- ^ How to run the concurrent program. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> Predicate a - -- ^ The predicate to check - -> (forall t. ConcST t a) - -- ^ The computation to test - -> Result a -runTestWay way memtype predicate conc = - runST (runTestWayM way memtype predicate conc) - --- | Monad-polymorphic variant of 'runTest'. --- --- @since 0.4.0.0 -runTestM :: MonadRef r n - => Predicate a -> ConcT r n a -> n (Result a) -runTestM = runTestWayM defaultWay defaultMemType - --- | Monad-polymorphic variant of 'runTest''. --- --- @since 0.6.0.0 -runTestWayM :: MonadRef r n - => Way -> MemType -> Predicate a -> ConcT r n a -> n (Result a) -runTestWayM way memtype predicate conc = - predicate <$> runSCT way memtype conc - - -------------------------------------------------------------------------------- --- Predicates - --- | A @Predicate@ is a function which collapses a list of results --- into a 'Result'. --- --- @since 0.1.0.0 -type Predicate a = [(Either Failure a, Trace)] -> Result a - --- | Reduce the list of failures in a @Predicate@ to one --- representative trace for each unique result. --- --- This may throw away \"duplicate\" failures which have a unique --- cause but happen to manifest in the same way. However, it is --- convenient for filtering out true duplicates. --- --- @since 0.2.0.0 -representative :: Eq a => Predicate a -> Predicate a -representative p xs = result { _failures = choose . collect $ _failures result } where - result = p xs - collect = groupBy' [] ((==) `on` fst) - choose = map $ minimumBy (comparing $ \(_, trc) -> (preEmps trc, length trc)) - - preEmps trc = preEmpCount (map (\(d,_,a) -> (d, a)) trc) (Continue, WillStop) - - groupBy' res _ [] = res - groupBy' res eq (y:ys) = groupBy' (insert' eq y res) eq ys - - insert' _ x [] = [[x]] - insert' eq x (ys@(y:_):yss) - | x `eq` y = (x:ys) : yss - | otherwise = ys : insert' eq x yss - insert' _ _ ([]:_) = undefined - --- | Check that a computation never aborts. --- --- @since 0.2.0.0 -abortsNever :: Predicate a -abortsNever = alwaysTrue (not . either (==Abort) (const False)) - --- | Check that a computation always aborts. --- --- @since 0.2.0.0 -abortsAlways :: Predicate a -abortsAlways = alwaysTrue $ either (==Abort) (const False) - --- | Check that a computation aborts at least once. --- --- @since 0.2.0.0 -abortsSometimes :: Predicate a -abortsSometimes = somewhereTrue $ either (==Abort) (const False) - --- | Check that a computation never deadlocks. --- --- @since 0.1.0.0 -deadlocksNever :: Predicate a -deadlocksNever = alwaysTrue (not . either isDeadlock (const False)) - --- | Check that a computation always deadlocks. --- --- @since 0.1.0.0 -deadlocksAlways :: Predicate a -deadlocksAlways = alwaysTrue $ either isDeadlock (const False) - --- | Check that a computation deadlocks at least once. --- --- @since 0.1.0.0 -deadlocksSometimes :: Predicate a -deadlocksSometimes = somewhereTrue $ either isDeadlock (const False) - --- | Check that a computation never fails with an uncaught exception. --- --- @since 0.1.0.0 -exceptionsNever :: Predicate a -exceptionsNever = alwaysTrue (not . either isUncaughtException (const False)) - --- | Check that a computation always fails with an uncaught exception. --- --- @since 0.1.0.0 -exceptionsAlways :: Predicate a -exceptionsAlways = alwaysTrue $ either isUncaughtException (const False) - --- | Check that a computation fails with an uncaught exception at least once. --- --- @since 0.1.0.0 -exceptionsSometimes :: Predicate a -exceptionsSometimes = somewhereTrue $ either isUncaughtException (const False) - --- | Check that the result of a computation is always the same. In --- particular this means either: (a) it always fails in the same way, --- or (b) it never fails and the values returned are all equal. --- --- @since 0.1.0.0 -alwaysSame :: Eq a => Predicate a -alwaysSame = representative $ alwaysTrue2 (==) - --- | Check that the result of a computation is not always the same. --- --- @since 0.1.0.0 -notAlwaysSame :: Eq a => Predicate a -notAlwaysSame [x] = (defaultFail [x]) { _casesChecked = 1 } -notAlwaysSame xs = go xs $ defaultFail [] where - go [y1,y2] res - | fst y1 /= fst y2 = incCC res { _pass = True } - | otherwise = incCC res { _failures = y1 : y2 : _failures res } - go (y1:y2:ys) res - | fst y1 /= fst y2 = go (y2:ys) . incCC $ res { _pass = True } - | otherwise = go (y2:ys) . incCC $ res { _failures = y1 : y2 : _failures res } - go _ res = res - --- | Check that the result of a unary boolean predicate is always --- true. --- --- @since 0.1.0.0 -alwaysTrue :: (Either Failure a -> Bool) -> Predicate a -alwaysTrue p xs = go xs $ (defaultFail failures) { _pass = True } where - go (y:ys) res - | p (fst y) = go ys . incCC $ res - | otherwise = incCC $ res { _pass = False } - go [] res = res - - failures = filter (not . p . fst) xs - --- | Check that the result of a binary boolean predicate is true --- between all pairs of results. Only properties which are transitive --- and symmetric should be used here. --- --- If the predicate fails, /both/ (result,trace) tuples will be added --- to the failures list. --- --- @since 0.1.0.0 -alwaysTrue2 :: (Either Failure a -> Either Failure a -> Bool) -> Predicate a -alwaysTrue2 _ [_] = defaultPass { _casesChecked = 1 } -alwaysTrue2 p xs = go xs $ defaultPass { _failures = failures } where - go [y1,y2] res - | p (fst y1) (fst y2) = incCC res - | otherwise = incCC res { _pass = False } - go (y1:y2:ys) res - | p (fst y1) (fst y2) = go (y2:ys) . incCC $ res - | otherwise = go (y2:ys) . incCC $ res { _pass = False } - go _ res = res - - failures = fgo xs where - fgo (y1:y2:ys) - | p (fst y1) (fst y2) = fgo (y2:ys) - | otherwise = y1 : y2 : fgo2 y2 ys - fgo _ = [] - - fgo2 y1 (y2:ys) - | p (fst y1) (fst y2) = fgo (y2:ys) - | otherwise = y2 : fgo2 y2 ys - fgo2 _ _ = [] - --- | Check that the result of a unary boolean predicate is true at --- least once. --- --- @since 0.1.0.0 -somewhereTrue :: (Either Failure a -> Bool) -> Predicate a -somewhereTrue p xs = go xs $ defaultFail failures where - go (y:ys) res - | p (fst y) = incCC $ res { _pass = True } - | otherwise = go ys . incCC $ res { _failures = y : _failures res } - go [] res = res - - failures = filter (not . p . fst) xs - --- | Predicate for when there is a known set of results where every --- result must be exhibited at least once. --- --- @since 0.2.0.0 -gives :: (Eq a, Show a) => [Either Failure a] -> Predicate a -gives expected results = go expected [] results $ defaultFail failures where - go waitingFor alreadySeen ((x, _):xs) res - -- If it's a result we're waiting for, move it to the - -- @alreadySeen@ list and continue. - | x `elem` waitingFor = go (filter (/=x) waitingFor) (x:alreadySeen) xs res { _casesChecked = _casesChecked res + 1 } - - -- If it's a result we've already seen, continue. - | x `elem` alreadySeen = go waitingFor alreadySeen xs res { _casesChecked = _casesChecked res + 1 } - - -- If it's not a result we expected, fail. - | otherwise = res { _casesChecked = _casesChecked res + 1 } - - go [] _ [] res = res { _pass = True } - go es _ [] res = res { _failureMsg = unlines $ map (\e -> "Expected: " ++ show e) es } - - failures = filter (\(r, _) -> r `notElem` expected) results - --- | Variant of 'gives' that doesn't allow for expected failures. --- --- @since 0.2.0.0 -gives' :: (Eq a, Show a) => [a] -> Predicate a -gives' = gives . map Right - - -------------------------------------------------------------------------------- --- Utils - --- | Run a test and print to stdout -doTest :: Show a => String -> Result a -> IO Bool -doTest name result = do - if _pass result - then - -- Display a pass message. - putStrLn $ "\27[32m[pass]\27[0m " ++ name ++ " (checked: " ++ show (_casesChecked result) ++ ")" - else do - -- Display a failure message, and the first 5 (simplified) failed traces - putStrLn ("\27[31m[fail]\27[0m " ++ name ++ " (checked: " ++ show (_casesChecked result) ++ ")") - - unless (null $ _failureMsg result) $ - putStrLn $ _failureMsg result - - let failures = _failures result - let output = map (\(r, t) -> putStrLn . indent $ either showFail show r ++ " " ++ showTrace t) $ take 5 failures - sequence_ $ intersperse (putStrLn "") output - when (moreThan 5 failures) $ - putStrLn (indent "...") - - pure (_pass result) - --- | Check if a list is longer than some value, without needing to --- compute the entire length. -moreThan :: Int -> [a] -> Bool -moreThan n [] = n < 0 -moreThan 0 _ = True -moreThan n (_:rest) = moreThan (n-1) rest - --- | Increment the cases -incCC :: Result a -> Result a -incCC r = r { _casesChecked = _casesChecked r + 1 } - --- | Indent every line of a string. -indent :: String -> String -indent = intercalate "\n" . map ('\t':) . lines +{-# LANGUAGE TupleSections #-} + +{- | +Module : Test.DejaFu +Copyright : (c) 2015--2019 Michael Walker +License : MIT +Maintainer : Michael Walker +Stability : experimental +Portability : TupleSections + +dejafu is a library for unit-testing concurrent Haskell programs which +are written using the package's 'MonadConc' typeclass. + +For more in-depth documentation, including migration guides from +earlier versions of dejafu, see the . + +__A first test:__ This is a simple concurrent program which forks two +threads and each races to write to the same @MVar@: + +>>> :{ +let example = do + var <- newEmptyMVar + fork (putMVar var "hello") + fork (putMVar var "world") + readMVar var +:} + +We can test it with dejafu like so: + +>>> autocheck example +[pass] Successful +[fail] Deterministic + "hello" S0----S1--S0-- + + "world" S0----S2--S0-- +False + +The 'autocheck' function takes a concurrent program to test and looks +for concurrency errors and nondeterminism. Here we see the program is +nondeterministic, dejafu gives us all the distinct results it found +and, for each, a summarised execution trace leading to that result: + + * \"Sn\" means that thread \"n\" started executing after the previous + thread terminated or blocked. + + * \"Pn\" means that thread \"n\" started executing, even though the + previous thread could have continued running. + + * Each \"-\" represents one \"step\" of the computation. + +__Memory models:__ dejafu supports three different memory models, +which affect how one thread's 'IORef' updates become visible to other +threads. + + * Sequential consistency: a program behaves as a simple interleaving + of the actions in different threads. When an 'IORef' is written to, + that write is immediately visible to all threads. + + * Total store order (TSO): each thread has a write buffer. A thread + sees its writes immediately, but other threads will only see + writes when they are committed, which may happen later. Writes + are committed in the same order that they are created. + + * Partial store order (PSO): each 'IORef' has a write buffer. A + thread sees its writes immediately, but other threads will only + see writes when they are committed, which may happen later. + Writes to different 'IORef's are not necessarily committed in the + same order that they are created. + +This small example shows the difference between sequential consistency +and TSO: + +>>> :{ +let relaxed = do + r1 <- newIORef False + r2 <- newIORef False + x <- spawn $ writeIORef r1 True >> readIORef r2 + y <- spawn $ writeIORef r2 True >> readIORef r1 + (,) <$> readMVar x <*> readMVar y +:} + +The 'autocheckWay' function will let us specify the memory model: + +>>> autocheckWay defaultWay SequentialConsistency relaxed +[pass] Successful +[fail] Deterministic + (False,True) S0---------S1----S0--S2----S0-- + + (True,True) S0---------S1-P2----S1---S0--- + + (True,False) S0---------S2----S1----S0--- +False + +>>> autocheckWay defaultWay TotalStoreOrder relaxed +[pass] Successful +[fail] Deterministic + (False,True) S0---------S1----S0--S2----S0-- + + (False,False) S0---------S1--P2----S1--S0--- + + (True,False) S0---------S2----S1----S0--- + + (True,True) S0---------S1-C-S2----S1---S0--- +False + +The result @(False,False)@ is possible using TSO and PSO, but not +sequential consistency. The \"C\" in the trace shows where a /commit/ +action occurred, which makes a write to an 'IORef' visible to all +threads. + +__Beware of 'liftIO':__ dejafu works by running your test case lots of +times with different schedules. If you use 'liftIO' at all, make sure +that any @IO@ you perform is deterministic when executed in the same +order. + +If you need to test things with /nondeterministc/ @IO@, see the +'autocheckWay', 'dejafuWay', and 'dejafusWay' functions: the +'randomly' and 'uniformly' testing modes can cope with nondeterminism. +-} +module Test.DejaFu + ( -- * Unit testing + + autocheck + , dejafu + , dejafus + + -- ** Configuration + + {- | + +There are a few knobs to tweak to control the behaviour of dejafu. +The defaults should generally be good enough, but if not you have a +few tricks available. The main two are: the 'Way', which controls how +schedules are explored; and the 'MemType', which controls how reads +and writes to @IORef@s behave; see "Test.DejaFu.Settings" for a +complete listing. + +-} + + , autocheckWay + , dejafuWay + , dejafusWay + , autocheckWithSettings + , dejafuWithSettings + , dejafusWithSettings + + , module Test.DejaFu.Settings + + -- ** Manual testing + + {- | + +The standard testing functions print their result to stdout, and throw +away some information. The traces are pretty-printed, and if there +are many failures, only the first few are shown. + +If you need more information, use these functions. + +-} + + , Result(..) + , runTest + , runTestWay + , runTestWithSettings + + -- ** Predicates + + {- | + +A dejafu test has two parts: the concurrent program to test, and a +predicate to determine if the test passes, based on the results of the +schedule exploration. + +All of these predicates discard results and traces as eagerly as +possible, to reduce memory usage. + +-} + + , Predicate + , ProPredicate(..) + , successful + , alwaysSame + , notAlwaysSame + , abortsNever + , abortsAlways + , abortsSometimes + , deadlocksNever + , deadlocksAlways + , deadlocksSometimes + , exceptionsNever + , exceptionsAlways + , exceptionsSometimes + + -- *** Helpers + + {- | + +Helper functions to produce your own predicates. Such predicates +discard results and traces as eagerly as possible, to reduce memory +usage. + +-} + + , representative + , alwaysSameOn + , alwaysSameBy + , notAlwaysSameOn + , notAlwaysSameBy + , alwaysTrue + , somewhereTrue + , alwaysNothing + , somewhereNothing + , gives + , gives' + + -- *** Conditions + + {- | + +Helper functions to identify conditions. + +-} + + , Condition(..) + , isAbort + , isDeadlock + , isUncaughtException + , isInvariantFailure + + -- * Property-based testing + + {- | + +dejafu can also use a property-based testing style to test stateful +operations for a variety of inputs. Inputs are generated using the + library for +enumerative testing. + +__Testing @MVar@ operations with multiple producers__: These are a +little different to the property tests you may be familiar with from +libraries like QuickCheck (and leancheck). As we're testing +properties of /stateful/ and /concurrent/ things, we need to provide +some extra information. + +A property consists of two /signatures/ and a relation between them. +A signature contains: + + * An initialisation function, to construct the initial state. + + * An observation function, to take a snapshot of the state at the + end. + + * An interference function, to mess with the state in some way. + + * The expression to evaluate, as a function over the state. + +>>> import Control.Monad (void) +>>> :{ +let sig e = Sig + { initialise = maybe newEmptyMVar newMVar + , observe = \v _ -> tryReadMVar v + , interfere = \v _ -> putMVar v 42 + , expression = void . e + } +:} + +This is a signature for operations over @Num n => MVar n@ values where +there are multiple producers. The initialisation function takes a +@Maybe n@ and constructs an @MVar n@, empty if it gets @Nothing@; the +observation function reads the @MVar@; and the interference function +puts a new value in. + +Given this signature, we can check if @readMVar@ is the same as a +@takeMVar@ followed by a @putMVar@: + +>>> check $ sig readMVar === sig (\v -> takeMVar v >>= putMVar v) +*** Failure: (seed Just 0) + left: [(Nothing,Just 0)] + right: [(Nothing,Just 0),(Just Deadlock,Just 42)] +False + +The two expressions are not equivalent, and we get a counterexample: +if the @MVar@ is nonempty, then the left expression (@readMVar@) will +preserve the value, but the right expression (@\v -> takeMVar v >>= +putMVar v@) may cause it to change. This is because of the concurrent +interference we have provided: the left term never empties a full +@MVar@, but the Right term does. + +-} + + , module Test.DejaFu.Refinement + + -- * Expressing concurrent programs + , Program + , Basic + , ConcT + , ConcIO + + -- ** Setup and teardown + , WithSetup + , WithSetupAndTeardown + , withSetup + , withTeardown + , withSetupAndTeardown + + -- ** Invariants + , Invariant + , registerInvariant + , inspectIORef + , inspectMVar + , inspectTVar +) where + +import Control.Arrow (first) +import Control.DeepSeq (NFData(..)) +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Either (isLeft) +import Data.Function (on) +import Data.List (intercalate, intersperse, partition) +import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe) +import Data.Profunctor (Profunctor(..)) +import System.Environment (lookupEnv) + +import Test.DejaFu.Conc +import Test.DejaFu.Internal +import Test.DejaFu.Refinement +import Test.DejaFu.SCT +import Test.DejaFu.Settings +import Test.DejaFu.Types +import Test.DejaFu.Utils + +{- $setup + +>>> import Control.Concurrent.Classy hiding (check) + +>>> :{ +let example = do + var <- newEmptyMVar + fork (putMVar var "hello") + fork (putMVar var "world") + readMVar var +:} + +>>> :{ +let relaxed = do + r1 <- newIORef False + r2 <- newIORef False + x <- spawn $ writeIORef r1 True >> readIORef r2 + y <- spawn $ writeIORef r2 True >> readIORef r1 + (,) <$> readMVar x <*> readMVar y +:} + +-} + +------------------------------------------------------------------------------- +-- DejaFu + +-- | Automatically test a computation. +-- +-- In particular, concurrency errors and nondeterminism. Returns +-- @True@ if all tests pass +-- +-- >>> autocheck example +-- [pass] Successful +-- [fail] Deterministic +-- "hello" S0----S1--S0-- +-- +-- "world" S0----S2--S0-- +-- False +-- +-- @since 2.1.0.0 +autocheck :: (MonadDejaFu n, MonadIO n, Eq a, Show a) + => Program pty n a + -- ^ The computation to test. + -> n Bool +autocheck = autocheckWithSettings defaultSettings + +-- | Variant of 'autocheck' which takes a way to run the program and a +-- memory model. +-- +-- >>> autocheckWay defaultWay defaultMemType relaxed +-- [pass] Successful +-- [fail] Deterministic +-- (False,True) S0---------S1----S0--S2----S0-- +-- +-- (False,False) S0---------S1--P2----S1--S0--- +-- +-- (True,False) S0---------S2----S1----S0--- +-- +-- (True,True) S0---------S1-C-S2----S1---S0--- +-- False +-- +-- >>> autocheckWay defaultWay SequentialConsistency relaxed +-- [pass] Successful +-- [fail] Deterministic +-- (False,True) S0---------S1----S0--S2----S0-- +-- +-- (True,True) S0---------S1-P2----S1---S0--- +-- +-- (True,False) S0---------S2----S1----S0--- +-- False +-- +-- @since 2.1.0.0 +autocheckWay :: (MonadDejaFu n, MonadIO n, Eq a, Show a) + => Way + -- ^ How to run the concurrent program. + -> MemType + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +autocheckWay way = autocheckWithSettings . fromWayAndMemType way + +-- | Variant of 'autocheck' which takes a settings record. +-- +-- >>> autocheckWithSettings (fromWayAndMemType defaultWay defaultMemType) relaxed +-- [pass] Successful +-- [fail] Deterministic +-- (False,True) S0---------S1----S0--S2----S0-- +-- +-- (False,False) S0---------S1--P2----S1--S0--- +-- +-- (True,False) S0---------S2----S1----S0--- +-- +-- (True,True) S0---------S1-C-S2----S1---S0--- +-- False +-- +-- >>> autocheckWithSettings (fromWayAndMemType defaultWay SequentialConsistency) relaxed +-- [pass] Successful +-- [fail] Deterministic +-- (False,True) S0---------S1----S0--S2----S0-- +-- +-- (True,True) S0---------S1-P2----S1---S0--- +-- +-- (True,False) S0---------S2----S1----S0--- +-- False +-- +-- @since 2.1.0.0 +autocheckWithSettings :: (MonadDejaFu n, MonadIO n, Eq a, Show a) + => Settings n a + -- ^ The SCT settings. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +autocheckWithSettings settings = dejafusWithSettings settings + [ ("Successful", representative successful) + , ("Deterministic", representative alwaysSame) + ] + +-- | Check a predicate and print the result to stdout, return 'True' +-- if it passes. +-- +-- A dejafu test has two parts: the program you are testing, and a +-- predicate to determine if the test passes. Predicates can look for +-- anything, including checking for some expected nondeterminism. +-- +-- >>> dejafu "Test Name" alwaysSame example +-- [fail] Test Name +-- "hello" S0----S1--S0-- +-- +-- "world" S0----S2--S0-- +-- False +-- +-- @since 2.1.0.0 +dejafu :: (MonadDejaFu n, MonadIO n, Show b) + => String + -- ^ The name of the test. + -> ProPredicate a b + -- ^ The predicate to check. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +dejafu = dejafuWithSettings defaultSettings + +-- | Variant of 'dejafu' which takes a way to run the program and a +-- memory model. +-- +-- >>> import System.Random +-- +-- >>> dejafuWay (randomly (mkStdGen 0) 100) defaultMemType "Randomly!" alwaysSame example +-- [fail] Randomly! +-- "hello" S0----S1--S0-- +-- +-- "world" S0----S2--S0-- +-- False +-- +-- >>> dejafuWay (randomly (mkStdGen 1) 100) defaultMemType "Randomly!" alwaysSame example +-- [fail] Randomly! +-- "hello" S0----S1--S0-- +-- +-- "world" S0---P2--S0-- +-- False +-- +-- @since 2.1.0.0 +dejafuWay :: (MonadDejaFu n, MonadIO n, Show b) + => Way + -- ^ How to run the concurrent program. + -> MemType + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> String + -- ^ The name of the test. + -> ProPredicate a b + -- ^ The predicate to check. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +dejafuWay way = dejafuWithSettings . fromWayAndMemType way + +-- | Variant of 'dejafu' which takes a settings record. +-- +-- >>> import System.Random +-- +-- >>> dejafuWithSettings (fromWayAndMemType (randomly (mkStdGen 1) 100) defaultMemType) "Randomly!" alwaysSame example +-- [fail] Randomly! +-- "hello" S0----S1--S0-- +-- +-- "world" S0---P2--S0-- +-- False +-- +-- @since 2.1.0.0 +dejafuWithSettings :: (MonadDejaFu n, MonadIO n, Show b) + => Settings n a + -- ^ The SCT settings. + -> String + -- ^ The name of the test. + -> ProPredicate a b + -- ^ The predicate to check. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +dejafuWithSettings settings name test = + dejafusWithSettings settings [(name, test)] + +-- | Variant of 'dejafu' which takes a collection of predicates to +-- test, returning 'True' if all pass. +-- +-- >>> dejafus [("A", alwaysSame), ("B", deadlocksNever)] example +-- [fail] A +-- "hello" S0----S1--S0-- +-- +-- "world" S0----S2--S0-- +-- [pass] B +-- False +-- +-- @since 2.1.0.0 +dejafus :: (MonadDejaFu n, MonadIO n, Show b) + => [(String, ProPredicate a b)] + -- ^ The list of predicates (with names) to check. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +dejafus = dejafusWithSettings defaultSettings + +-- | Variant of 'dejafus' which takes a way to run the program and a +-- memory model. +-- +-- >>> dejafusWay defaultWay SequentialConsistency [("A", alwaysSame), ("B", exceptionsNever)] relaxed +-- [fail] A +-- (False,True) S0---------S1----S0--S2----S0-- +-- +-- (True,True) S0---------S1-P2----S1---S0--- +-- +-- (True,False) S0---------S2----S1----S0--- +-- [pass] B +-- False +-- +-- @since 2.1.0.0 +dejafusWay :: (MonadDejaFu n, MonadIO n, Show b) + => Way + -- ^ How to run the concurrent program. + -> MemType + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> [(String, ProPredicate a b)] + -- ^ The list of predicates (with names) to check. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +dejafusWay way = dejafusWithSettings . fromWayAndMemType way + +-- | Variant of 'dejafus' which takes a settings record. +-- +-- >>> dejafusWithSettings (fromWayAndMemType defaultWay SequentialConsistency) [("A", alwaysSame), ("B", exceptionsNever)] relaxed +-- [fail] A +-- (False,True) S0---------S1----S0--S2----S0-- +-- +-- (True,True) S0---------S1-P2----S1---S0--- +-- +-- (True,False) S0---------S2----S1----S0--- +-- [pass] B +-- False +-- +-- @since 2.1.0.0 +dejafusWithSettings :: (MonadDejaFu n, MonadIO n, Show b) + => Settings n a + -- ^ The SCT settings. + -> [(String, ProPredicate a b)] + -- ^ The list of predicates (with names) to check. + -> Program pty n a + -- ^ The computation to test. + -> n Bool +dejafusWithSettings settings tests conc = do + traces <- runSCTWithSettings (set ldiscard (Just discarder) settings) conc + results <- mapM (\(name, test) -> liftIO . doTest name $ chk test traces) tests + pure (and results) + where + discarder = maybe id strengthenDiscard (get ldiscard settings) $ foldr + (weakenDiscard . pdiscard . snd) + (const (Just DiscardResultAndTrace)) + tests + + -- for evaluating each individual predicate, we only want the + -- results/traces it would not discard, but the traces set may + -- include more than this if the different predicates have + -- different discard functions, so we do another pass of + -- discarding. + chk p rs + | moreThan 1 rs = + let go r@(efa, _) = case pdiscard p efa of + Just DiscardResultAndTrace -> Nothing + Just DiscardTrace -> Just (efa, []) + Nothing -> Just r + in peval p (mapMaybe go rs) + | otherwise = peval p rs + +------------------------------------------------------------------------------- +-- Test cases + +-- | The results of a test, including the number of cases checked to +-- determine the final boolean outcome. +-- +-- @since 1.0.0.0 +data Result a = Result + { _pass :: Bool + -- ^ Whether the test passed or not. + , _failures :: [(Either Condition a, Trace)] + -- ^ The failing cases, if any. + , _failureMsg :: String + -- ^ A message to display on failure, if nonempty + } deriving (Eq, Show) + +instance NFData a => NFData (Result a) where + rnf r = rnf ( _pass r + , _failures r + , _failureMsg r + ) + +-- | A failed result, taking the given list of failures. +defaultFail :: [(Either Condition a, Trace)] -> Result a +defaultFail failures = Result False failures "" + +-- | A passed result. +defaultPass :: Result a +defaultPass = Result True [] "" + +instance Functor Result where + fmap f r = r { _failures = map (first $ fmap f) $ _failures r } + +instance Foldable Result where + foldMap f r = foldMap f [a | (Right a, _) <- _failures r] + +-- | Run a predicate over all executions within the default schedule +-- bounds. +-- +-- The exact executions tried, and the order in which results are +-- found, is unspecified and may change between releases. This may +-- affect which failing traces are reported, when there is a failure. +-- +-- @since 2.1.0.0 +runTest :: MonadDejaFu n + => ProPredicate a b + -- ^ The predicate to check + -> Program pty n a + -- ^ The computation to test + -> n (Result b) +runTest = runTestWithSettings defaultSettings + +-- | Variant of 'runTest' which takes a way to run the program and a +-- memory model. +-- +-- The exact executions tried, and the order in which results are +-- found, is unspecified and may change between releases. This may +-- affect which failing traces are reported, when there is a failure. +-- +-- @since 2.1.0.0 +runTestWay :: MonadDejaFu n + => Way + -- ^ How to run the concurrent program. + -> MemType + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> ProPredicate a b + -- ^ The predicate to check + -> Program pty n a + -- ^ The computation to test + -> n (Result b) +runTestWay way = runTestWithSettings . fromWayAndMemType way + +-- | Variant of 'runTest' which takes a settings record. +-- +-- The exact executions tried, and the order in which results are +-- found, is unspecified and may change between releases. This may +-- affect which failing traces are reported, when there is a failure. +-- +-- @since 2.1.0.0 +runTestWithSettings :: MonadDejaFu n + => Settings n a + -- ^ The SCT settings. + -> ProPredicate a b + -- ^ The predicate to check + -> Program pty n a + -- ^ The computation to test + -> n (Result b) +runTestWithSettings settings p conc = + let discarder = maybe id strengthenDiscard (get ldiscard settings) (pdiscard p) + in peval p <$> runSCTWithSettings (set ldiscard (Just discarder) settings) conc + + +------------------------------------------------------------------------------- +-- Predicates + +-- | A @Predicate@ is a function which collapses a list of results +-- into a 'Result', possibly discarding some on the way. +-- +-- @Predicate@ cannot be a functor as the type parameter is used both +-- co- and contravariantly. +-- +-- @since 1.0.0.0 +type Predicate a = ProPredicate a a + +-- | A @ProPredicate@ is a function which collapses a list of results +-- into a 'Result', possibly discarding some on the way. +-- +-- @since 1.0.0.0 +data ProPredicate a b = ProPredicate + { pdiscard :: Either Condition a -> Maybe Discard + -- ^ Selectively discard results before computing the result. + , peval :: [(Either Condition a, Trace)] -> Result b + -- ^ Compute the result with the un-discarded results. + } + +instance Profunctor ProPredicate where + dimap f g p = ProPredicate + { pdiscard = pdiscard p . fmap f + , peval = fmap g . peval p . map (first (fmap f)) + } + +instance Functor (ProPredicate x) where + fmap = dimap id + +-- | Reduce the list of failures in a @ProPredicate@ to one +-- representative trace for each unique result. +-- +-- This may throw away \"duplicate\" failures which have a unique +-- cause but happen to manifest in the same way. However, it is +-- convenient for filtering out true duplicates. +-- +-- @since 1.0.0.0 +representative :: Eq b => ProPredicate a b -> ProPredicate a b +representative p = p + { peval = \xs -> + let result = peval p xs + in result { _failures = simplestsBy (==) (_failures result) } + } + +-- | Check that a computation never produces a @Left@ value. +-- +-- @since 1.9.1.0 +successful :: Predicate a +successful = alwaysTrue (either (const False) (const True)) + +-- | Check that a computation never aborts. +-- +-- Any result other than an abort, including other 'Condition's, is +-- allowed. +-- +-- @since 1.0.0.0 +abortsNever :: Predicate a +abortsNever = alwaysTrue (not . either (==Abort) (const False)) + +-- | Check that a computation always aborts. +-- +-- @since 1.0.0.0 +abortsAlways :: Predicate a +abortsAlways = alwaysTrue $ either (==Abort) (const False) + +-- | Check that a computation aborts at least once. +-- +-- Any result other than an abort, including other 'Condition's, is +-- allowed. +-- +-- @since 1.0.0.0 +abortsSometimes :: Predicate a +abortsSometimes = somewhereTrue $ either (==Abort) (const False) + +-- | Check that a computation never deadlocks. +-- +-- Any result other than a deadlock, including other 'Condition's, is +-- allowed. +-- +-- @since 1.0.0.0 +deadlocksNever :: Predicate a +deadlocksNever = alwaysTrue (not . either isDeadlock (const False)) + +-- | Check that a computation always deadlocks. +-- +-- @since 1.0.0.0 +deadlocksAlways :: Predicate a +deadlocksAlways = alwaysTrue $ either isDeadlock (const False) + +-- | Check that a computation deadlocks at least once. +-- +-- Any result other than a deadlock, including other 'Condition's, is +-- allowed. +-- +-- @since 1.0.0.0 +deadlocksSometimes :: Predicate a +deadlocksSometimes = somewhereTrue $ either isDeadlock (const False) + +-- | Check that a computation never fails with an uncaught exception. +-- +-- Any result other than an uncaught exception, including other +-- 'Condition's, is allowed. +-- +-- @since 1.0.0.0 +exceptionsNever :: Predicate a +exceptionsNever = alwaysTrue (not . either isUncaughtException (const False)) + +-- | Check that a computation always fails with an uncaught exception. +-- +-- @since 1.0.0.0 +exceptionsAlways :: Predicate a +exceptionsAlways = alwaysTrue $ either isUncaughtException (const False) + +-- | Check that a computation fails with an uncaught exception at least once. +-- +-- Any result other than an uncaught exception, including other +-- 'Condition's, is allowed. +-- +-- @since 1.0.0.0 +exceptionsSometimes :: Predicate a +exceptionsSometimes = somewhereTrue $ either isUncaughtException (const False) + +-- | Check that a computation always gives the same, @Right@, result. +-- +-- > alwaysSame = alwaysSameBy (==) +-- +-- @since 1.10.0.0 +alwaysSame :: Eq a => Predicate a +alwaysSame = alwaysSameBy (==) + +-- | Check that a computation always gives the same (according to the +-- provided function), @Right@, result. +-- +-- > alwaysSameOn = alwaysSameBy ((==) `on` f) +-- +-- @since 1.10.0.0 +alwaysSameOn :: Eq b => (a -> b) -> Predicate a +alwaysSameOn f = alwaysSameBy ((==) `on` f) + +-- | Check that the result of a computation is always the same, using +-- some transformation on results. +-- +-- @since 1.10.0.0 +alwaysSameBy :: (a -> a -> Bool) -> Predicate a +alwaysSameBy f = ProPredicate + { pdiscard = const Nothing + , peval = \xs -> + let (failures, successes) = partition (isLeft . fst) xs + simpleSuccesses = simplestsBy (f `on` efromRight) successes + simpleFailures = simplestsBy ((==) `on` efromLeft) failures + in case (simpleFailures, simpleSuccesses) of + ([], []) -> defaultPass + ([], [_]) -> defaultPass + (_, _) -> defaultFail (simpleFailures ++ simpleSuccesses) + } + +-- | Check that a computation never fails, and gives multiple distinct +-- @Right@ results. +-- +-- > notAlwaysSame = notAlwaysSameBy (==) +-- +-- @since 1.10.0.0 +notAlwaysSame :: Eq a => Predicate a +notAlwaysSame = notAlwaysSameBy (==) + +-- | Check that a computation never fails, and gives multiple distinct +-- (according to the provided function) @Right@ results. +-- +-- > notAlwaysSameOn = notAlwaysSameBy ((==) `on` f) +-- +-- @since 1.10.0.0 +notAlwaysSameOn :: Eq b => (a -> b) -> Predicate a +notAlwaysSameOn f = notAlwaysSameBy ((==) `on` f) + +-- | Check that a computation never fails, and gives multiple distinct +-- @Right@ results, by applying a transformation on results. +-- +-- This inverts the condition, so (eg) @notAlwaysSameBy (==)@ will +-- pass if there are unequal results. +-- +-- @since 1.10.0.0 +notAlwaysSameBy :: (a -> a -> Bool) -> Predicate a +notAlwaysSameBy f = ProPredicate + { pdiscard = const Nothing + , peval = \xs -> + let (failures, successes) = partition (isLeft . fst) xs + simpleFailures = simplestsBy ((==) `on` efromLeft) failures + in case successes of + [x] -> defaultFail (x : simpleFailures) + _ -> + let res = go successes (defaultFail []) + in case failures of + [] -> res + _ -> res { _failures = simpleFailures ++ _failures res, _pass = False } + } + where + y1 .*. y2 = not (on f (efromRight . fst) y1 y2) + + go [y1,y2] res + | y1 .*. y2 = res { _pass = True } + | otherwise = res { _failures = y1 : y2 : _failures res } + go (y1:y2:ys) res + | y1 .*. y2 = go (y2:ys) res { _pass = True } + | otherwise = go (y2:ys) res { _failures = y1 : y2 : _failures res } + go _ res = res + +-- | Check that a @Maybe@-producing function always returns 'Nothing'. +-- +-- @since 1.0.0.0 +alwaysNothing :: (Either Condition a -> Maybe (Either Condition b)) -> ProPredicate a b +alwaysNothing f = ProPredicate + { pdiscard = maybe (Just DiscardResultAndTrace) (const Nothing) . f + , peval = \xs -> + let failures = mapMaybe (\(efa,trc) -> (,trc) <$> f efa) xs + in Result (null failures) failures "" + } + +-- | Check that the result of a unary boolean predicate is always +-- true. +-- +-- @since 1.0.0.0 +alwaysTrue :: (Either Condition a -> Bool) -> Predicate a +alwaysTrue p = alwaysNothing (\efa -> if p efa then Nothing else Just efa) + +-- | Check that a @Maybe@-producing function returns 'Nothing' at +-- least once. +-- +-- @since 1.0.0.0 +somewhereNothing :: (Either Condition a -> Maybe (Either Condition b)) -> ProPredicate a b +somewhereNothing f = ProPredicate + { pdiscard = maybe (Just DiscardTrace) (const Nothing) . f + , peval = \xs -> + let failures = map (\(efa,trc) -> (,trc) <$> f efa) xs + in Result (any isNothing failures) (catMaybes failures) "" + } + +-- | Check that the result of a unary boolean predicate is true at +-- least once. +-- +-- @since 1.0.0.0 +somewhereTrue :: (Either Condition a -> Bool) -> Predicate a +somewhereTrue p = somewhereNothing (\efa -> if p efa then Nothing else Just efa) + +-- | Predicate for when there is a known set of results where every +-- result must be exhibited at least once. +-- +-- @since 1.0.0.0 +gives :: (Eq a, Show a) => [Either Condition a] -> Predicate a +gives expected = ProPredicate + { pdiscard = \efa -> if efa `elem` expected then Just DiscardTrace else Nothing + , peval = \xs -> go expected [] xs $ defaultFail (failures xs) + } + where + go waitingFor alreadySeen ((x, _):xs) res + -- If it's a result we're waiting for, move it to the + -- @alreadySeen@ list and continue. + | x `elem` waitingFor = go (filter (/=x) waitingFor) (x:alreadySeen) xs res + -- If it's a result we've already seen, continue. + | x `elem` alreadySeen = go waitingFor alreadySeen xs res + -- If it's not a result we expected, fail. + | otherwise = res + + go [] _ [] res = res { _pass = True } + go es _ [] res = res { _failureMsg = unlines $ map (\e -> "Expected: " ++ show e) es } + + failures = filter (\(r, _) -> r `notElem` expected) + +-- | Variant of 'gives' that doesn't allow for @Left@ results. +-- +-- > gives' = gives . map Right +-- +-- @since 1.0.0.0 +gives' :: (Eq a, Show a) => [a] -> Predicate a +gives' = gives . map Right + + +------------------------------------------------------------------------------- +-- Utils + +-- | Run a test and print to stdout +doTest :: Show a => String -> Result a -> IO Bool +doTest name result = do + doctest <- isJust <$> lookupEnv "DEJAFU_DOCTEST" + if _pass result + then putStrLn (passmsg doctest) + else do + -- Display a failure message, and the first 5 (simplified) failed traces + putStrLn (failmsg doctest) + + unless (null $ _failureMsg result) $ + putStrLn $ _failureMsg result + + let failures = _failures result + let output = map (\(r, t) -> putStrLn . indent $ either showCondition show r ++ " " ++ showTrace t) $ take 5 failures + sequence_ $ intersperse (putStrLn "") output + when (moreThan 5 failures) $ + putStrLn (indent "...") + + pure (_pass result) + where + passmsg True = "[pass] " ++ name + passmsg False = "\27[32m[pass]\27[0m " ++ name + + failmsg True = "[fail] " ++ name + failmsg False = "\27[31m[fail]\27[0m " ++ name + +-- | Check if a list is longer than some value, without needing to +-- compute the entire length. +moreThan :: Int -> [a] -> Bool +moreThan n [] = n < 0 +moreThan 0 _ = True +moreThan n (_:rest) = moreThan (n-1) rest + +-- | Indent every line of a string. +indent :: String -> String +indent = intercalate "\n" . map (" "++) . lines diff --git a/Test/DejaFu/Common.hs b/Test/DejaFu/Common.hs deleted file mode 100644 --- a/Test/DejaFu/Common.hs +++ /dev/null @@ -1,1070 +0,0 @@ --- | --- Module : Test.DejaFu.Common --- Copyright : (c) 2016 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : portable --- --- Common types and functions used throughout DejaFu. -module Test.DejaFu.Common - ( -- * Identifiers - ThreadId(..) - , CRefId(..) - , MVarId(..) - , TVarId(..) - , initialThread - -- ** Identifier source - , IdSource(..) - , nextCRId - , nextMVId - , nextTVId - , nextTId - , initialIdSource - - -- * Actions - -- ** Thread actions - , ThreadAction(..) - , isBlock - , tvarsOf - , tvarsWritten - , tvarsRead - -- ** Lookahead - , Lookahead(..) - , rewind - , willRelease - -- ** Simplified actions - , ActionType(..) - , isBarrier - , isCommit - , synchronises - , crefOf - , mvarOf - , simplifyAction - , simplifyLookahead - -- ** STM actions - , TTrace - , TAction(..) - - -- * Traces - , Trace - , Decision(..) - , showTrace - , threadNames - , preEmpCount - - -- * Failures - , Failure(..) - , isInternalError - , isAbort - , isDeadlock - , isUncaughtException - , isIllegalSubconcurrency - , showFail - - -- * Memory models - , MemType(..) - - -- * Miscellaneous - , MonadFailException(..) - , runRefCont - , ehead - , etail - , eidx - , efromJust - , efromList - , fatal - ) where - -import Control.DeepSeq (NFData(..)) -import Control.Exception (Exception(..), MaskingState(..), - SomeException, displayException) -import Control.Monad.Ref (MonadRef(..)) -import Data.Function (on) -import Data.List (intercalate) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set (Set) -import qualified Data.Set as S - -------------------------------------------------------------------------------- --- Identifiers - --- | 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) {-# 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 - -instance Show ThreadId where - show (ThreadId (Just n) _) = n - show (ThreadId Nothing i) = show i - --- | @since 0.5.1.0 -instance NFData ThreadId where - rnf (ThreadId n i) = rnf (n, i) - --- | 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) {-# 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 - -instance Show CRefId where - show (CRefId (Just n) _) = n - show (CRefId Nothing i) = show i - --- | @since 0.5.1.0 -instance NFData CRefId where - rnf (CRefId n i) = rnf (n, i) - --- | 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) {-# 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 - -instance Show MVarId where - show (MVarId (Just n) _) = n - show (MVarId Nothing i) = show i - --- | @since 0.5.1.0 -instance NFData MVarId where - rnf (MVarId n i) = rnf (n, i) - --- | 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) {-# 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 - -instance Show TVarId where - show (TVarId (Just n) _) = n - show (TVarId Nothing i) = show i - --- | @since 0.5.1.0 -instance NFData TVarId where - rnf (TVarId n i) = rnf (n, i) - --- | The ID of the initial thread. --- --- @since 0.4.0.0 -initialThread :: ThreadId -initialThread = ThreadId (Just "main") 0 - ---------------------------------------- --- Identifier source - --- | The number of ID parameters was getting a bit unwieldy, so this --- hides them all away. --- --- @since 0.4.0.0 -data IdSource = Id - { _nextCRId :: Int - , _nextMVId :: Int - , _nextTVId :: Int - , _nextTId :: Int - , _usedCRNames :: [String] - , _usedMVNames :: [String] - , _usedTVNames :: [String] - , _usedTNames :: [String] - } deriving (Eq, Ord, Show) - --- | @since 0.5.1.0 -instance NFData IdSource where - rnf idsource = rnf ( _nextCRId idsource - , _nextMVId idsource - , _nextTVId idsource - , _nextTId idsource - , _usedCRNames idsource - , _usedMVNames idsource - , _usedTVNames idsource - , _usedTNames idsource - ) - --- | Get the next free 'CRefId'. --- --- @since 0.4.0.0 -nextCRId :: String -> IdSource -> (IdSource, CRefId) -nextCRId name idsource = (newIdSource, newCRId) where - newIdSource = idsource { _nextCRId = newId, _usedCRNames = newUsed } - newCRId = CRefId newName newId - newId = _nextCRId idsource + 1 - (newName, newUsed) = nextId name (_usedCRNames idsource) - --- | Get the next free 'MVarId'. --- --- @since 0.4.0.0 -nextMVId :: String -> IdSource -> (IdSource, MVarId) -nextMVId name idsource = (newIdSource, newMVId) where - newIdSource = idsource { _nextMVId = newId, _usedMVNames = newUsed } - newMVId = MVarId newName newId - newId = _nextMVId idsource + 1 - (newName, newUsed) = nextId name (_usedMVNames idsource) - --- | Get the next free 'TVarId'. --- --- @since 0.4.0.0 -nextTVId :: String -> IdSource -> (IdSource, TVarId) -nextTVId name idsource = (newIdSource, newTVId) where - newIdSource = idsource { _nextTVId = newId, _usedTVNames = newUsed } - newTVId = TVarId newName newId - newId = _nextTVId idsource + 1 - (newName, newUsed) = nextId name (_usedTVNames idsource) - --- | Get the next free 'ThreadId'. --- --- @since 0.4.0.0 -nextTId :: String -> IdSource -> (IdSource, ThreadId) -nextTId name idsource = (newIdSource, newTId) where - newIdSource = idsource { _nextTId = newId, _usedTNames = newUsed } - newTId = ThreadId newName newId - newId = _nextTId idsource + 1 - (newName, newUsed) = nextId name (_usedTNames idsource) - --- | The initial ID source. --- --- @since 0.4.0.0 -initialIdSource :: IdSource -initialIdSource = Id 0 0 0 0 [] [] [] [] - -------------------------------------------------------------------------------- --- Actions - ---------------------------------------- --- Thread actions - --- | All the actions that a thread can perform. --- --- @since 0.9.0.0 -data ThreadAction = - Fork ThreadId - -- ^ Start a new thread. - | MyThreadId - -- ^ Get the 'ThreadId' of the current thread. - | GetNumCapabilities Int - -- ^ Get the number of Haskell threads that can run simultaneously. - | SetNumCapabilities Int - -- ^ Set the number of Haskell threads that can run simultaneously. - | Yield - -- ^ Yield the current thread. - | ThreadDelay Int - -- ^ Yield/delay the current thread. - | NewMVar MVarId - -- ^ Create a new 'MVar'. - | PutMVar MVarId [ThreadId] - -- ^ Put into a 'MVar', possibly waking up some threads. - | BlockedPutMVar MVarId - -- ^ Get blocked on a put. - | TryPutMVar MVarId Bool [ThreadId] - -- ^ Try to put into a 'MVar', possibly waking up some threads. - | ReadMVar MVarId - -- ^ Read from a 'MVar'. - | TryReadMVar MVarId Bool - -- ^ Try to read from a 'MVar'. - | BlockedReadMVar MVarId - -- ^ Get blocked on a read. - | TakeMVar MVarId [ThreadId] - -- ^ Take from a 'MVar', possibly waking up some threads. - | BlockedTakeMVar MVarId - -- ^ Get blocked on a take. - | TryTakeMVar MVarId Bool [ThreadId] - -- ^ Try to take from a 'MVar', possibly waking up some threads. - | NewCRef CRefId - -- ^ Create a new 'CRef'. - | ReadCRef CRefId - -- ^ Read from a 'CRef'. - | ReadCRefCas CRefId - -- ^ Read from a 'CRef' for a future compare-and-swap. - | ModCRef CRefId - -- ^ Modify a 'CRef'. - | ModCRefCas CRefId - -- ^ Modify a 'CRef' using a compare-and-swap. - | WriteCRef CRefId - -- ^ Write to a 'CRef' without synchronising. - | CasCRef CRefId Bool - -- ^ Attempt to to a 'CRef' using a compare-and-swap, synchronising - -- it. - | CommitCRef ThreadId CRefId - -- ^ Commit the last write to the given 'CRef' by the given thread, - -- so that all threads can see the updated value. - | STM TTrace [ThreadId] - -- ^ An STM transaction was executed, possibly waking up some - -- threads. - | BlockedSTM TTrace - -- ^ Got blocked in an STM transaction. - | Catching - -- ^ Register a new exception handler - | PopCatching - -- ^ Pop the innermost exception handler from the stack. - | Throw - -- ^ Throw an exception. - | ThrowTo ThreadId - -- ^ Throw an exception to a thread. - | BlockedThrowTo ThreadId - -- ^ Get blocked on a 'throwTo'. - | Killed - -- ^ Killed by an uncaught exception. - | SetMasking Bool MaskingState - -- ^ Set the masking state. If 'True', this is being used to set the - -- masking state to the original state in the argument passed to a - -- 'mask'ed function. - | ResetMasking Bool MaskingState - -- ^ Return to an earlier masking state. If 'True', this is being - -- used to return to the state of the masked block in the argument - -- passed to a 'mask'ed function. - | LiftIO - -- ^ Lift an IO action. Note that this can only happen with - -- 'ConcIO'. - | Return - -- ^ A 'return' or 'pure' action was executed. - | Stop - -- ^ Cease execution and terminate. - | Subconcurrency - -- ^ Start executing an action with @subconcurrency@. - | StopSubconcurrency - -- ^ Stop executing an action with @subconcurrency@. - deriving (Eq, Show) - -instance NFData ThreadAction where - rnf (Fork t) = rnf t - rnf (ThreadDelay n) = rnf n - rnf (GetNumCapabilities c) = rnf c - rnf (SetNumCapabilities c) = rnf c - rnf (NewMVar m) = rnf m - rnf (PutMVar m ts) = rnf (m, ts) - rnf (BlockedPutMVar m) = rnf m - rnf (TryPutMVar m b ts) = rnf (m, b, ts) - rnf (ReadMVar m) = rnf m - rnf (TryReadMVar m b) = rnf (m, b) - rnf (BlockedReadMVar m) = rnf m - rnf (TakeMVar m ts) = rnf (m, ts) - rnf (BlockedTakeMVar m) = rnf m - rnf (TryTakeMVar m b ts) = rnf (m, b, ts) - rnf (NewCRef c) = rnf c - rnf (ReadCRef c) = rnf c - rnf (ReadCRefCas c) = rnf c - rnf (ModCRef c) = rnf c - rnf (ModCRefCas c) = rnf c - rnf (WriteCRef c) = rnf c - rnf (CasCRef c b) = rnf (c, b) - rnf (CommitCRef t c) = rnf (t, c) - rnf (STM tr ts) = rnf (tr, ts) - rnf (BlockedSTM tr) = rnf tr - rnf (ThrowTo t) = rnf t - rnf (BlockedThrowTo t) = rnf t - rnf (SetMasking b m) = b `seq` m `seq` () - rnf (ResetMasking b m) = b `seq` m `seq` () - rnf a = a `seq` () - --- | Check if a @ThreadAction@ immediately blocks. --- --- @since 0.4.0.0 -isBlock :: ThreadAction -> Bool -isBlock (BlockedThrowTo _) = True -isBlock (BlockedTakeMVar _) = True -isBlock (BlockedReadMVar _) = True -isBlock (BlockedPutMVar _) = True -isBlock (BlockedSTM _) = True -isBlock _ = False - --- | Get the @TVar@s affected by a @ThreadAction@. --- --- @since 0.4.0.0 -tvarsOf :: ThreadAction -> Set TVarId -tvarsOf act = tvarsRead act `S.union` tvarsWritten act - --- | Get the @TVar@s a transaction wrote to (or would have, if it --- didn't @retry@). --- --- @since 0.9.0.2 -tvarsWritten :: ThreadAction -> Set TVarId -tvarsWritten act = S.fromList $ case act of - STM trc _ -> concatMap tvarsOf' trc - BlockedSTM trc -> concatMap tvarsOf' trc - _ -> [] - - where - tvarsOf' (TWrite tv) = [tv] - tvarsOf' (TOrElse ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) - tvarsOf' (TCatch ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) - tvarsOf' _ = [] - --- | Get the @TVar@s a transaction read from. --- --- @since 0.9.0.2 -tvarsRead :: ThreadAction -> Set TVarId -tvarsRead act = S.fromList $ case act of - STM trc _ -> concatMap tvarsOf' trc - BlockedSTM trc -> concatMap tvarsOf' trc - _ -> [] - - where - tvarsOf' (TRead tv) = [tv] - tvarsOf' (TOrElse ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) - tvarsOf' (TCatch ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) - tvarsOf' _ = [] - ---------------------------------------- --- Lookahead - --- | A one-step look-ahead at what a thread will do next. --- --- @since 0.9.0.0 -data Lookahead = - WillFork - -- ^ Will start a new thread. - | WillMyThreadId - -- ^ Will get the 'ThreadId'. - | WillGetNumCapabilities - -- ^ Will get the number of Haskell threads that can run - -- simultaneously. - | WillSetNumCapabilities Int - -- ^ Will set the number of Haskell threads that can run - -- simultaneously. - | WillYield - -- ^ Will yield the current thread. - | WillThreadDelay Int - -- ^ Will yield/delay the current thread. - | WillNewMVar - -- ^ Will create a new 'MVar'. - | WillPutMVar MVarId - -- ^ Will put into a 'MVar', possibly waking up some threads. - | WillTryPutMVar MVarId - -- ^ Will try to put into a 'MVar', possibly waking up some threads. - | WillReadMVar MVarId - -- ^ Will read from a 'MVar'. - | WillTryReadMVar MVarId - -- ^ Will try to read from a 'MVar'. - | WillTakeMVar MVarId - -- ^ Will take from a 'MVar', possibly waking up some threads. - | WillTryTakeMVar MVarId - -- ^ Will try to take from a 'MVar', possibly waking up some threads. - | WillNewCRef - -- ^ Will create a new 'CRef'. - | WillReadCRef CRefId - -- ^ Will read from a 'CRef'. - | WillReadCRefCas CRefId - -- ^ Will read from a 'CRef' for a future compare-and-swap. - | WillModCRef CRefId - -- ^ Will modify a 'CRef'. - | WillModCRefCas CRefId - -- ^ Will modify a 'CRef' using a compare-and-swap. - | WillWriteCRef CRefId - -- ^ Will write to a 'CRef' without synchronising. - | WillCasCRef CRefId - -- ^ Will attempt to to a 'CRef' using a compare-and-swap, - -- synchronising it. - | WillCommitCRef ThreadId CRefId - -- ^ Will commit the last write by the given thread to the 'CRef'. - | WillSTM - -- ^ Will execute an STM transaction, possibly waking up some - -- threads. - | WillCatching - -- ^ Will register a new exception handler - | WillPopCatching - -- ^ Will pop the innermost exception handler from the stack. - | WillThrow - -- ^ Will throw an exception. - | WillThrowTo ThreadId - -- ^ Will throw an exception to a thread. - | WillSetMasking Bool MaskingState - -- ^ Will set the masking state. If 'True', this is being used to - -- set the masking state to the original state in the argument - -- passed to a 'mask'ed function. - | WillResetMasking Bool MaskingState - -- ^ Will return to an earlier masking state. If 'True', this is - -- being used to return to the state of the masked block in the - -- argument passed to a 'mask'ed function. - | WillLiftIO - -- ^ Will lift an IO action. Note that this can only happen with - -- 'ConcIO'. - | WillReturn - -- ^ Will execute a 'return' or 'pure' action. - | WillStop - -- ^ Will cease execution and terminate. - | WillSubconcurrency - -- ^ Will execute an action with @subconcurrency@. - | WillStopSubconcurrency - -- ^ Will stop executing an extion with @subconcurrency@. - deriving (Eq, Show) - -instance NFData Lookahead where - rnf (WillThreadDelay n) = rnf n - rnf (WillSetNumCapabilities c) = rnf c - rnf (WillPutMVar m) = rnf m - rnf (WillTryPutMVar m) = rnf m - rnf (WillReadMVar m) = rnf m - rnf (WillTryReadMVar m) = rnf m - rnf (WillTakeMVar m) = rnf m - rnf (WillTryTakeMVar m) = rnf m - rnf (WillReadCRef c) = rnf c - rnf (WillReadCRefCas c) = rnf c - rnf (WillModCRef c) = rnf c - rnf (WillModCRefCas c) = rnf c - rnf (WillWriteCRef c) = rnf c - rnf (WillCasCRef c) = rnf c - rnf (WillCommitCRef t c) = rnf (t, c) - rnf (WillThrowTo t) = rnf t - rnf (WillSetMasking b m) = b `seq` m `seq` () - rnf (WillResetMasking b m) = b `seq` m `seq` () - rnf l = l `seq` () - --- | Convert a 'ThreadAction' into a 'Lookahead': \"rewind\" what has --- happened. 'Killed' has no 'Lookahead' counterpart. --- --- @since 0.4.0.0 -rewind :: ThreadAction -> Maybe Lookahead -rewind (Fork _) = Just WillFork -rewind MyThreadId = Just WillMyThreadId -rewind (GetNumCapabilities _) = Just WillGetNumCapabilities -rewind (SetNumCapabilities i) = Just (WillSetNumCapabilities i) -rewind Yield = Just WillYield -rewind (ThreadDelay n) = Just (WillThreadDelay n) -rewind (NewMVar _) = Just WillNewMVar -rewind (PutMVar c _) = Just (WillPutMVar c) -rewind (BlockedPutMVar c) = Just (WillPutMVar c) -rewind (TryPutMVar c _ _) = Just (WillTryPutMVar c) -rewind (ReadMVar c) = Just (WillReadMVar c) -rewind (BlockedReadMVar c) = Just (WillReadMVar c) -rewind (TryReadMVar c _) = Just (WillTryReadMVar c) -rewind (TakeMVar c _) = Just (WillTakeMVar c) -rewind (BlockedTakeMVar c) = Just (WillTakeMVar c) -rewind (TryTakeMVar c _ _) = Just (WillTryTakeMVar c) -rewind (NewCRef _) = Just WillNewCRef -rewind (ReadCRef c) = Just (WillReadCRef c) -rewind (ReadCRefCas c) = Just (WillReadCRefCas c) -rewind (ModCRef c) = Just (WillModCRef c) -rewind (ModCRefCas c) = Just (WillModCRefCas c) -rewind (WriteCRef c) = Just (WillWriteCRef c) -rewind (CasCRef c _) = Just (WillCasCRef c) -rewind (CommitCRef t c) = Just (WillCommitCRef t c) -rewind (STM _ _) = Just WillSTM -rewind (BlockedSTM _) = Just WillSTM -rewind Catching = Just WillCatching -rewind PopCatching = Just WillPopCatching -rewind Throw = Just WillThrow -rewind (ThrowTo t) = Just (WillThrowTo t) -rewind (BlockedThrowTo t) = Just (WillThrowTo t) -rewind Killed = Nothing -rewind (SetMasking b m) = Just (WillSetMasking b m) -rewind (ResetMasking b m) = Just (WillResetMasking b m) -rewind LiftIO = Just WillLiftIO -rewind Return = Just WillReturn -rewind Stop = Just WillStop -rewind Subconcurrency = Just WillSubconcurrency -rewind StopSubconcurrency = Just WillStopSubconcurrency - --- | Check if an operation could enable another thread. --- --- @since 0.4.0.0 -willRelease :: Lookahead -> Bool -willRelease WillFork = True -willRelease WillYield = True -willRelease (WillThreadDelay _) = True -willRelease (WillPutMVar _) = True -willRelease (WillTryPutMVar _) = True -willRelease (WillReadMVar _) = True -willRelease (WillTakeMVar _) = True -willRelease (WillTryTakeMVar _) = True -willRelease WillSTM = True -willRelease WillThrow = True -willRelease (WillSetMasking _ _) = True -willRelease (WillResetMasking _ _) = True -willRelease WillStop = True -willRelease _ = False - ---------------------------------------- --- Simplified actions - --- | A simplified view of the possible actions a thread can perform. --- --- @since 0.4.0.0 -data ActionType = - UnsynchronisedRead CRefId - -- ^ A 'readCRef' or a 'readForCAS'. - | UnsynchronisedWrite CRefId - -- ^ A 'writeCRef'. - | UnsynchronisedOther - -- ^ Some other action which doesn't require cross-thread - -- communication. - | PartiallySynchronisedCommit CRefId - -- ^ A commit. - | PartiallySynchronisedWrite CRefId - -- ^ A 'casCRef' - | PartiallySynchronisedModify CRefId - -- ^ A 'modifyCRefCAS' - | SynchronisedModify CRefId - -- ^ An 'atomicModifyCRef'. - | SynchronisedRead MVarId - -- ^ A 'readMVar' or 'takeMVar' (or @try@/@blocked@ variants). - | SynchronisedWrite MVarId - -- ^ A 'putMVar' (or @try@/@blocked@ variant). - | SynchronisedOther - -- ^ Some other action which does require cross-thread - -- communication. - deriving (Eq, Show) - --- | @since 0.5.1.0 -instance NFData ActionType where - rnf (UnsynchronisedRead c) = rnf c - rnf (UnsynchronisedWrite c) = rnf c - rnf (PartiallySynchronisedCommit c) = rnf c - rnf (PartiallySynchronisedWrite c) = rnf c - rnf (PartiallySynchronisedModify c) = rnf c - rnf (SynchronisedModify c) = rnf c - rnf (SynchronisedRead m) = rnf m - rnf (SynchronisedWrite m) = rnf m - rnf a = a `seq` () - --- | Check if an action imposes a write barrier. --- --- @since 0.4.0.0 -isBarrier :: ActionType -> Bool -isBarrier (SynchronisedModify _) = True -isBarrier (SynchronisedRead _) = True -isBarrier (SynchronisedWrite _) = True -isBarrier SynchronisedOther = True -isBarrier _ = False - --- | Check if an action commits a given 'CRef'. --- --- @since 0.4.0.0 -isCommit :: ActionType -> CRefId -> Bool -isCommit (PartiallySynchronisedCommit c) r = c == r -isCommit (PartiallySynchronisedWrite c) r = c == r -isCommit (PartiallySynchronisedModify c) r = c == r -isCommit _ _ = False - --- | Check if an action synchronises a given 'CRef'. --- --- @since 0.4.0.0 -synchronises :: ActionType -> CRefId -> Bool -synchronises a r = isCommit a r || isBarrier a - --- | Get the 'CRef' affected. --- --- @since 0.4.0.0 -crefOf :: ActionType -> Maybe CRefId -crefOf (UnsynchronisedRead r) = Just r -crefOf (UnsynchronisedWrite r) = Just r -crefOf (SynchronisedModify r) = Just r -crefOf (PartiallySynchronisedCommit r) = Just r -crefOf (PartiallySynchronisedWrite r) = Just r -crefOf (PartiallySynchronisedModify r) = Just r -crefOf _ = Nothing - --- | Get the 'MVar' affected. --- --- @since 0.4.0.0 -mvarOf :: ActionType -> Maybe MVarId -mvarOf (SynchronisedRead c) = Just c -mvarOf (SynchronisedWrite c) = Just c -mvarOf _ = Nothing - --- | Throw away information from a 'ThreadAction' and give a --- simplified view of what is happening. --- --- This is used in the SCT code to help determine interesting --- alternative scheduling decisions. --- --- @since 0.4.0.0 -simplifyAction :: ThreadAction -> ActionType -simplifyAction = maybe UnsynchronisedOther simplifyLookahead . rewind - --- | Variant of 'simplifyAction' that takes a 'Lookahead'. --- --- @since 0.4.0.0 -simplifyLookahead :: Lookahead -> ActionType -simplifyLookahead (WillPutMVar c) = SynchronisedWrite c -simplifyLookahead (WillTryPutMVar c) = SynchronisedWrite c -simplifyLookahead (WillReadMVar c) = SynchronisedRead c -simplifyLookahead (WillTryReadMVar c) = SynchronisedRead c -simplifyLookahead (WillTakeMVar c) = SynchronisedRead c -simplifyLookahead (WillTryTakeMVar c) = SynchronisedRead c -simplifyLookahead (WillReadCRef r) = UnsynchronisedRead r -simplifyLookahead (WillReadCRefCas r) = UnsynchronisedRead r -simplifyLookahead (WillModCRef r) = SynchronisedModify r -simplifyLookahead (WillModCRefCas r) = PartiallySynchronisedModify r -simplifyLookahead (WillWriteCRef r) = UnsynchronisedWrite r -simplifyLookahead (WillCasCRef r) = PartiallySynchronisedWrite r -simplifyLookahead (WillCommitCRef _ r) = PartiallySynchronisedCommit r -simplifyLookahead WillSTM = SynchronisedOther -simplifyLookahead (WillThrowTo _) = SynchronisedOther -simplifyLookahead _ = UnsynchronisedOther - ---------------------------------------- --- STM actions - --- | A trace of an STM transaction is just a list of actions that --- occurred, as there are no scheduling decisions to make. --- --- @since 0.4.0.0 -type TTrace = [TAction] - --- | All the actions that an STM transaction can perform. --- --- @since 0.8.0.0 -data TAction = - TNew TVarId - -- ^ Create a new @TVar@ - | TRead TVarId - -- ^ Read from a @TVar@. - | TWrite TVarId - -- ^ Write to a @TVar@. - | TRetry - -- ^ Abort and discard effects. - | TOrElse TTrace (Maybe TTrace) - -- ^ Execute a transaction until it succeeds (@STMStop@) or aborts - -- (@STMRetry@) and, if it aborts, execute the other transaction. - | TThrow - -- ^ Throw an exception, abort, and discard effects. - | TCatch TTrace (Maybe TTrace) - -- ^ Execute a transaction until it succeeds (@STMStop@) or aborts - -- (@STMThrow@). If the exception is of the appropriate type, it is - -- handled and execution continues; otherwise aborts, propagating - -- the exception upwards. - | TStop - -- ^ Terminate successfully and commit effects. - deriving (Eq, Show) - --- | @since 0.5.1.0 -instance NFData TAction where - rnf (TRead t) = rnf t - rnf (TWrite t) = rnf t - rnf (TOrElse tr mtr) = rnf (tr, mtr) - rnf (TCatch tr mtr) = rnf (tr, mtr) - rnf ta = ta `seq` () - -------------------------------------------------------------------------------- --- Traces - --- | One of the outputs of the runner is a @Trace@, which is a log of --- decisions made, all the runnable threads and what they would do, --- and the action a thread took in its step. --- --- @since 0.8.0.0 -type Trace - = [(Decision, [(ThreadId, Lookahead)], ThreadAction)] - --- | Scheduling decisions are based on the state of the running --- program, and so we can capture some of that state in recording what --- specific decision we made. --- --- @since 0.5.0.0 -data Decision = - Start ThreadId - -- ^ Start a new thread, because the last was blocked (or it's the - -- start of computation). - | Continue - -- ^ Continue running the last thread for another step. - | SwitchTo ThreadId - -- ^ Pre-empt the running thread, and switch to another. - deriving (Eq, Show) - --- | @since 0.5.1.0 -instance NFData Decision where - rnf (Start t) = rnf t - rnf (SwitchTo t) = rnf t - rnf d = d `seq` () - --- | Pretty-print a trace, including a key of the thread IDs (not --- including thread 0). Each line of the key is indented by two --- spaces. --- --- @since 0.5.0.0 -showTrace :: Trace -> String -showTrace [] = "" -showTrace trc = intercalate "\n" $ go False trc : strkey where - go _ ((_,_,CommitCRef _ _):rest) = "C-" ++ go False rest - go _ ((Start (ThreadId _ i),_,a):rest) = "S" ++ show i ++ "-" ++ go (didYield a) rest - go y ((SwitchTo (ThreadId _ i),_,a):rest) = (if y then "p" else "P") ++ show i ++ "-" ++ go (didYield a) rest - go _ ((Continue,_,a):rest) = '-' : go (didYield a) rest - go _ _ = "" - - strkey = - [" " ++ show i ++ ": " ++ name | (i, name) <- threadNames trc] - - didYield Yield = True - didYield (ThreadDelay _) = True - didYield _ = False - --- | Get all named threads in the trace. --- --- @since 0.7.3.0 -threadNames :: Trace -> [(Int, String)] -threadNames = mapMaybe go where - go (_, _, Fork (ThreadId (Just name) i)) = Just (i, name) - go _ = Nothing - --- | Count the number of pre-emptions in a schedule prefix. --- --- Commit threads complicate this a bit. Conceptually, commits are --- happening truly in parallel, nondeterministically. The commit --- thread implementation is just there to unify the two sources of --- nondeterminism: commit timing and thread scheduling. --- --- SO, we don't count a switch TO a commit thread as a --- preemption. HOWEVER, the switch FROM a commit thread counts as a --- preemption if it is not to the thread that the commit interrupted. --- --- @since 0.5.0.0 -preEmpCount :: [(Decision, ThreadAction)] - -> (Decision, Lookahead) - -> Int -preEmpCount (x:xs) (d, _) = go initialThread x xs where - go _ (_, Yield) (r@(SwitchTo t, _):rest) = go t r rest - go _ (_, ThreadDelay _) (r@(SwitchTo t, _):rest) = go t r rest - go tid prior (r@(SwitchTo t, _):rest) - | isCommitThread t = go tid prior (skip rest) - | otherwise = 1 + go t r rest - go _ _ (r@(Start t, _):rest) = go t r rest - go tid _ (r@(Continue, _):rest) = go tid r rest - go _ prior [] = case (prior, d) of - ((_, Yield), SwitchTo _) -> 0 - ((_, ThreadDelay _), SwitchTo _) -> 0 - (_, SwitchTo _) -> 1 - _ -> 0 - - -- Commit threads have negative thread IDs for easy identification. - isCommitThread = (< initialThread) - - -- Skip until the next context switch. - skip = dropWhile (not . isContextSwitch . fst) - isContextSwitch Continue = False - isContextSwitch _ = True -preEmpCount [] _ = 0 - -------------------------------------------------------------------------------- --- Failures - - --- | An indication of how a concurrent computation failed. --- --- The @Eq@, @Ord@, and @NFData@ instances compare/evaluate the --- exception with @show@ in the @UncaughtException@ case. --- --- @since 0.9.0.0 -data Failure - = InternalError - -- ^ Will be raised if the scheduler does something bad. This should - -- never arise unless you write your own, faulty, scheduler! If it - -- does, please file a bug report. - | Abort - -- ^ The scheduler chose to abort execution. This will be produced - -- if, for example, all possible decisions exceed the specified - -- bounds (there have been too many pre-emptions, the computation - -- has executed for too long, or there have been too many yields). - | Deadlock - -- ^ The computation became blocked indefinitely on @MVar@s. - | STMDeadlock - -- ^ The computation became blocked indefinitely on @TVar@s. - | UncaughtException SomeException - -- ^ An uncaught exception bubbled to the top of the computation. - | IllegalSubconcurrency - -- ^ Calls to @subconcurrency@ were nested, or attempted when - -- multiple threads existed. - deriving Show - -instance Eq Failure where - (==) = (==) `on` _other - -instance Ord Failure where - compare = compare `on` _other - -instance NFData Failure where - rnf = rnf . _other - --- | Convert failures into a different representation we can Eq / Ord --- / NFData. -_other :: Failure -> (Int, Maybe String) -_other InternalError = (0, Nothing) -_other Abort = (1, Nothing) -_other Deadlock = (2, Nothing) -_other STMDeadlock = (3, Nothing) -_other (UncaughtException e) = (4, Just (show e)) -_other IllegalSubconcurrency = (5, Nothing) - --- | Pretty-print a failure --- --- @since 0.4.0.0 -showFail :: Failure -> String -showFail Abort = "[abort]" -showFail Deadlock = "[deadlock]" -showFail STMDeadlock = "[stm-deadlock]" -showFail InternalError = "[internal-error]" -showFail (UncaughtException exc) = "[" ++ displayException exc ++ "]" -showFail IllegalSubconcurrency = "[illegal-subconcurrency]" - --- | Check if a failure is an @InternalError@. --- --- @since 0.9.0.0 -isInternalError :: Failure -> Bool -isInternalError InternalError = True -isInternalError _ = False - --- | Check if a failure is an @Abort@. --- --- @since 0.9.0.0 -isAbort :: Failure -> Bool -isAbort Abort = True -isAbort _ = False - --- | Check if a failure is a @Deadlock@ or an @STMDeadlock@. --- --- @since 0.9.0.0 -isDeadlock :: Failure -> Bool -isDeadlock Deadlock = True -isDeadlock STMDeadlock = True -isDeadlock _ = False - --- | Check if a failure is an @UncaughtException@ --- --- @since 0.9.0.0 -isUncaughtException :: Failure -> Bool -isUncaughtException (UncaughtException _) = True -isUncaughtException _ = False - --- | Check if a failure is an @IllegalSubconcurrency@ --- --- @since 0.9.0.0 -isIllegalSubconcurrency :: Failure -> Bool -isIllegalSubconcurrency IllegalSubconcurrency = True -isIllegalSubconcurrency _ = False - -------------------------------------------------------------------------------- --- Memory Models - --- | The memory model to use for non-synchronised 'CRef' operations. --- --- @since 0.4.0.0 -data MemType = - SequentialConsistency - -- ^ The most intuitive model: a program behaves as a simple - -- interleaving of the actions in different threads. When a 'CRef' - -- is written to, that write is immediately visible to all threads. - | TotalStoreOrder - -- ^ Each thread has a write buffer. A thread sees its writes - -- immediately, but other threads will only see writes when they are - -- committed, which may happen later. Writes are committed in the - -- same order that they are created. - | PartialStoreOrder - -- ^ Each 'CRef' has a write buffer. A thread sees its writes - -- immediately, but other threads will only see writes when they are - -- committed, which may happen later. Writes to different 'CRef's - -- are not necessarily committed in the same order that they are - -- created. - deriving (Eq, Show, Read, Ord, Enum, Bounded) - --- | @since 0.5.1.0 -instance NFData MemType where - rnf m = m `seq` () - -------------------------------------------------------------------------------- --- Miscellaneous - --- | An exception for errors in testing caused by use of 'fail'. -newtype MonadFailException = MonadFailException String - deriving Show - -instance Exception MonadFailException - --- | Run with a continuation that writes its value into a reference, --- returning the computation and the reference. Using the reference --- is non-blocking, it is up to you to ensure you wait sufficiently. -runRefCont :: MonadRef r n => (n () -> x) -> (a -> Maybe b) -> ((a -> x) -> x) -> n (x, r (Maybe b)) -runRefCont act f k = do - ref <- newRef Nothing - let c = k (act . writeRef ref . f) - pure (c, ref) - --- | 'head' but with a better error message if it fails. Use this --- only where it shouldn't fail! -ehead :: String -> [a] -> a -ehead _ (x:_) = x -ehead src _ = fatal src "head: empty list" - --- | 'tail' but with a better error message if it fails. Use this --- only where it shouldn't fail! -etail :: String -> [a] -> [a] -etail _ (_:xs) = xs -etail src _ = fatal src "tail: empty list" - --- | '(!!)' but with a better error message if it fails. Use this --- only where it shouldn't fail! -eidx :: String -> [a] -> Int -> a -eidx src xs i - | i < length xs = xs !! i - | otherwise = fatal src "(!!): index too large" - --- | 'fromJust' but with a better error message if it fails. Use this --- only where it shouldn't fail! -efromJust :: String -> Maybe a -> a -efromJust _ (Just x) = x -efromJust src _ = fatal src "fromJust: Nothing" - --- | 'fromList' but with a better error message if it fails. Use this --- only where it shouldn't fail! -efromList :: String -> [a] -> NonEmpty a -efromList _ (x:xs) = x:|xs -efromList src _ = fatal src "fromList: empty list" - --- | 'error' but saying where it came from -fatal :: String -> String -> a -fatal src msg = error ("(dejafu: " ++ src ++ ") " ++ msg) - - -------------------------------------------------------------------------------- --- Utilities - --- | Helper for @next*@ -nextId :: String -> [String] -> (Maybe String, [String]) -nextId name used = (newName, newUsed) where - newName - | null name = Nothing - | occurrences > 0 = Just (name ++ "-" ++ show occurrences) - | otherwise = Just name - newUsed - | null name = used - | otherwise = name : used - occurrences = length (filter (==name) used) diff --git a/Test/DejaFu/Conc.hs b/Test/DejaFu/Conc.hs --- a/Test/DejaFu/Conc.hs +++ b/Test/DejaFu/Conc.hs @@ -1,18 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - -- | -- Module : Test.DejaFu.Conc --- Copyright : (c) 2016 Michael Walker +-- Copyright : (c) 2016--2019 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : CPP, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances +-- Portability : portable -- -- Deterministic traced execution of concurrent computations. -- @@ -20,206 +12,183 @@ -- out to the supplied scheduler after each step to determine which -- thread runs next. module Test.DejaFu.Conc - ( -- * The @ConcT@ monad transformer - ConcT - , ConcST + ( -- * Expressing concurrent programs + Program + , Basic + , ConcT , ConcIO - -- * Executing computations - , Failure(..) + -- ** Setup and teardown + , WithSetup + , WithSetupAndTeardown + , withSetup + , withTeardown + , withSetupAndTeardown + + -- ** Invariants + , Invariant + , registerInvariant + , inspectIORef + , inspectMVar + , inspectTVar + + -- * Executing concurrent programs + , Snapshot , MemType(..) , runConcurrent - , subconcurrency + , recordSnapshot + , runSnapshot - -- * Execution traces + -- ** Scheduling + , module Test.DejaFu.Schedule + + -- * Results + , Condition(..) , Trace , Decision(..) , ThreadId(..) , ThreadAction(..) , Lookahead(..) , MVarId - , CRefId + , IORefId , MaskingState(..) , showTrace - , showFail - - -- * Scheduling - , module Test.DejaFu.Schedule + , showCondition ) where -import Control.Exception (MaskingState(..)) -import qualified Control.Monad.Base as Ba -import qualified Control.Monad.Catch as Ca -import qualified Control.Monad.IO.Class as IO -import Control.Monad.Ref (MonadRef) -import qualified Control.Monad.Ref as Re -import Control.Monad.ST (ST) -import Control.Monad.Trans.Class (MonadTrans(..)) -import qualified Data.Foldable as F -import Data.IORef (IORef) -import Data.STRef (STRef) -import Test.DejaFu.Schedule +import Control.Exception (MaskingState(..)) +import Control.Monad (void) -import qualified Control.Monad.Conc.Class as C -import Test.DejaFu.Common -import Test.DejaFu.Conc.Internal import Test.DejaFu.Conc.Internal.Common -import Test.DejaFu.STM - -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif - --- | @since 0.6.0.0 -newtype ConcT r n a = C { unC :: M n r a } deriving (Functor, Applicative, Monad) +import Test.DejaFu.Conc.Internal.Program +import Test.DejaFu.Conc.Internal.STM (ModelTVar) +import Test.DejaFu.Schedule +import Test.DejaFu.Types +import Test.DejaFu.Utils -#if MIN_VERSION_base(4,9,0) --- | @since 0.9.1.0 -instance Fail.MonadFail (ConcT r n) where - fail = C . fail -#endif +------------------------------------------------------------------------------- +-- Expressing concurrent programs --- | A 'MonadConc' implementation using @ST@, this should be preferred --- if you do not need 'liftIO'. --- --- @since 0.4.0.0 -type ConcST t = ConcT (STRef t) (ST t) +-- | @since 1.4.0.0 +type ConcT = Program Basic -- | A 'MonadConc' implementation using @IO@. -- -- @since 0.4.0.0 -type ConcIO = ConcT IORef IO - -toConc :: ((a -> Action n r) -> Action n r) -> ConcT r n a -toConc = C . cont - -wrap :: (M n r a -> M n r a) -> ConcT r n a -> ConcT r n a -wrap f = C . f . unC - -instance IO.MonadIO ConcIO where - liftIO ma = toConc (\c -> ALift (fmap c ma)) - -instance Ba.MonadBase IO ConcIO where - liftBase = IO.liftIO - -instance Re.MonadRef (CRef r) (ConcT r n) where - newRef a = toConc (ANewCRef "" a) - - readRef ref = toConc (AReadCRef ref) - - writeRef ref a = toConc (\c -> AWriteCRef ref a (c ())) - - modifyRef ref f = toConc (AModCRef ref (\a -> (f a, ()))) - -instance Re.MonadAtomicRef (CRef r) (ConcT r n) where - atomicModifyRef ref f = toConc (AModCRef ref f) - -instance MonadTrans (ConcT r) where - lift ma = toConc (\c -> ALift (fmap c ma)) - -instance Ca.MonadCatch (ConcT r n) where - catch ma h = toConc (ACatching (unC . h) (unC ma)) - -instance Ca.MonadThrow (ConcT r n) where - throwM e = toConc (\_ -> AThrow e) - -instance Ca.MonadMask (ConcT r n) where - mask mb = toConc (AMasking MaskedInterruptible (\f -> unC $ mb $ wrap f)) - uninterruptibleMask mb = toConc (AMasking MaskedUninterruptible (\f -> unC $ mb $ wrap f)) - -instance Monad n => C.MonadConc (ConcT r n) where - type MVar (ConcT r n) = MVar r - type CRef (ConcT r n) = CRef r - type Ticket (ConcT r n) = Ticket - type STM (ConcT r n) = STMLike n r - type ThreadId (ConcT r n) = ThreadId - - -- ---------- - - forkWithUnmaskN n ma = toConc (AFork n (\umask -> runCont (unC $ ma $ wrap umask) (\_ -> AStop (pure ())))) - forkOnWithUnmaskN n _ = C.forkWithUnmaskN n - - -- This implementation lies and returns 2 until a value is set. This - -- will potentially avoid special-case behaviour for 1 capability, - -- so it seems a sane choice. - getNumCapabilities = toConc AGetNumCapabilities - setNumCapabilities caps = toConc (\c -> ASetNumCapabilities caps (c ())) - - myThreadId = toConc AMyTId - - yield = toConc (\c -> AYield (c ())) - threadDelay n = toConc (\c -> ADelay n (c ())) - - -- ---------- - - newCRefN n a = toConc (ANewCRef n a) - - readCRef ref = toConc (AReadCRef ref) - readForCAS ref = toConc (AReadCRefCas ref) - - peekTicket' _ = _ticketVal - - writeCRef ref a = toConc (\c -> AWriteCRef ref a (c ())) - casCRef ref tick a = toConc (ACasCRef ref tick a) - - atomicModifyCRef ref f = toConc (AModCRef ref f) - modifyCRefCAS ref f = toConc (AModCRefCas ref f) - - -- ---------- - - newEmptyMVarN n = toConc (ANewMVar n) +type ConcIO = ConcT IO - putMVar var a = toConc (\c -> APutMVar var a (c ())) - readMVar var = toConc (AReadMVar var) - takeMVar var = toConc (ATakeMVar var) +------------------------------------------------------------------------------- +-- Setup & teardown - tryPutMVar var a = toConc (ATryPutMVar var a) - tryReadMVar var = toConc (ATryReadMVar var) - tryTakeMVar var = toConc (ATryTakeMVar var) +-- | A concurrent program with some set-up action. +-- +-- In terms of results, this is the same as @setup >>= program@. +-- However, the setup action will be __snapshotted__ (see +-- 'recordSnapshot' and 'runSnapshot') by the testing functions. This +-- means that even if dejafu runs this program many many times, the +-- setup action will only be run the first time, and its effects +-- remembered for subsequent executions. +-- +-- @since 2.0.0.0 +withSetup + :: Program Basic n x + -- ^ Setup action + -> (x -> Program Basic n a) + -- ^ Main program + -> Program (WithSetup x) n a +withSetup setup p = WithSetup + { wsSetup = setup + , wsProgram = p + } - -- ---------- +-- | A concurrent program with some set-up and teardown actions. +-- +-- This is similar to +-- +-- @ +-- do +-- x <- setup +-- y <- program x +-- teardown x y +-- @ +-- +-- But with two differences: +-- +-- * The setup action can be __snapshotted__, as described for +-- 'withSetup' +-- +-- * The teardown action will be executed even if the main action +-- fails to produce a value. +-- +-- @since 2.0.0.0 +withTeardown + :: (x -> Either Condition y -> Program Basic n a) + -- ^ Teardown action + -> Program (WithSetup x) n y + -- ^ Main program + -> Program (WithSetupAndTeardown x y) n a +withTeardown teardown ws = WithSetupAndTeardown + { wstSetup = wsSetup ws + , wstProgram = wsProgram ws + , wstTeardown = teardown + } - throwTo tid e = toConc (\c -> AThrowTo tid e (c ())) +-- | A combination of 'withSetup' and 'withTeardown' for convenience. +-- +-- @ +-- withSetupAndTeardown setup teardown = +-- withTeardown teardown . withSetup setup +-- @ +-- +-- @since 2.0.0.0 +withSetupAndTeardown + :: Program Basic n x + -- ^ Setup action + -> (x -> Either Condition y -> Program Basic n a) + -- ^ Teardown action + -> (x -> Program Basic n y) + -- ^ Main program + -> Program (WithSetupAndTeardown x y) n a +withSetupAndTeardown setup teardown = + withTeardown teardown . withSetup setup - -- ---------- +------------------------------------------------------------------------------- +-- Invariants - atomically = toConc . AAtom +-- | Call this in the setup phase to register new invariant which will +-- be checked after every scheduling point in the main phase. +-- Invariants are atomic actions which can inspect the shared state of +-- your computation. +-- +-- If the invariant throws an exception, the execution will be aborted +-- with n @InvariantFailure@. Any teardown action will still be run. +-- +-- @since 2.0.0.0 +registerInvariant :: Invariant n a -> Program Basic n () +registerInvariant inv = ModelConc (\c -> ANewInvariant (void inv) (c ())) --- | Run a concurrent computation with a given 'Scheduler' and initial --- state, returning a failure reason on error. Also returned is the --- final state of the scheduler, and an execution trace. +-- | Read the content of an @IORef@. -- --- __Warning:__ Blocking on the action of another thread in 'liftIO' --- cannot be detected! So if you perform some potentially blocking --- action in a 'liftIO' the entire collection of threads may deadlock! --- You should therefore keep @IO@ blocks small, and only perform --- blocking operations with the supplied primitives, insofar as --- possible. +-- This returns the globally visible value, which may not be the same +-- as the value visible to any particular thread when using a memory +-- model other than 'SequentialConsistency'. -- --- __Note:__ In order to prevent computation from hanging, the runtime --- will assume that a deadlock situation has arisen if the scheduler --- attempts to (a) schedule a blocked thread, or (b) schedule a --- nonexistent thread. In either of those cases, the computation will --- be halted. +-- @since 2.0.0.0 +inspectIORef :: ModelIORef n a -> Invariant n a +inspectIORef = Invariant . IInspectIORef + +-- | Read the content of an @MVar@. -- --- @since 0.8.0.0 -runConcurrent :: MonadRef r n - => Scheduler s - -> MemType - -> s - -> ConcT r n a - -> n (Either Failure a, s, Trace) -runConcurrent sched memtype s ma = do - (res, ctx, trace, _) <- runConcurrency sched memtype s initialIdSource 2 (unC ma) - pure (res, cSchedState ctx, F.toList trace) +-- This is essentially @tryReadMVar@. +-- +-- @since 2.0.0.0 +inspectMVar :: ModelMVar n a -> Invariant n (Maybe a) +inspectMVar = Invariant . IInspectMVar --- | Run a concurrent computation and return its result. +-- | Read the content of a @TVar@. -- --- This can only be called in the main thread, when no other threads --- exist. Calls to 'subconcurrency' cannot be nested. Violating either --- of these conditions will result in the computation failing with --- @IllegalSubconcurrency@. +-- This is essentially @readTVar@. -- --- @since 0.6.0.0 -subconcurrency :: ConcT r n a -> ConcT r n (Either Failure a) -subconcurrency ma = toConc (ASub (unC ma)) +-- @since 2.0.0.0 +inspectTVar :: ModelTVar n a -> Invariant n a +inspectTVar = Invariant . IInspectTVar diff --git a/Test/DejaFu/Conc/Internal.hs b/Test/DejaFu/Conc/Internal.hs --- a/Test/DejaFu/Conc/Internal.hs +++ b/Test/DejaFu/Conc/Internal.hs @@ -1,409 +1,768 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.DejaFu.Conc.Internal --- Copyright : (c) 2016 Michael Walker +-- Copyright : (c) 2016--2021 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : MultiParamTypeClasses, RankNTypes, ScopedTypeVariables +-- Portability : FlexibleContexts, LambdaCase, RankNTypes, RecordWildCards, ScopedTypeVariables -- -- Concurrent monads with a fixed scheduler: internal types and -- functions. This module is NOT considered to form part of the public -- interface of this library. module Test.DejaFu.Conc.Internal where -import Control.Exception (MaskingState(..), +import Control.Exception (Exception, + MaskingState(..), toException) -import Control.Monad.Ref (MonadRef, newRef, readRef, - writeRef) +import qualified Control.Monad.Catch as E +import Data.Foldable (foldrM) import Data.Functor (void) -import Data.List (sortOn) +import Data.List (nub, partition, sortOn) import qualified Data.Map.Strict as M -import Data.Maybe (isJust) +import Data.Maybe (isJust, isNothing) import Data.Monoid ((<>)) -import Data.Sequence (Seq, (<|)) +import Data.Sequence (Seq) import qualified Data.Sequence as Seq +import GHC.Stack (HasCallStack) -import Test.DejaFu.Common import Test.DejaFu.Conc.Internal.Common import Test.DejaFu.Conc.Internal.Memory +import Test.DejaFu.Conc.Internal.STM import Test.DejaFu.Conc.Internal.Threading +import Test.DejaFu.Internal import Test.DejaFu.Schedule -import Test.DejaFu.STM (Result(..), - runTransaction) +import Test.DejaFu.Types -------------------------------------------------------------------------------- --- * Execution +-- * Set-up -- | 'Trace' but as a sequence. type SeqTrace = Seq (Decision, [(ThreadId, Lookahead)], ThreadAction) +-- | The result of running a concurrent program. +data CResult n g a = CResult + { finalContext :: Context n g + , finalRef :: Ref n (Maybe (Either Condition a)) + , finalRestore :: Threads n -> n () + -- ^ Meaningless if this result doesn't come from a snapshotting + -- execution. + , finalTrace :: SeqTrace + , finalDecision :: Maybe (ThreadId, ThreadAction) + } + -- | Run a concurrent computation with a given 'Scheduler' and initial --- state, returning a failure reason on error. Also returned is the +-- state, returning a Condition reason on error. Also returned is the -- final state of the scheduler, and an execution trace. -runConcurrency :: MonadRef r n - => Scheduler g - -> MemType - -> g - -> IdSource - -> Int - -> M n r a - -> n (Either Failure a, Context n r g, SeqTrace, Maybe (ThreadId, ThreadAction)) -runConcurrency sched memtype g idsrc caps ma = do - (c, ref) <- runRefCont AStop (Just . Right) (runM ma) - let ctx = Context { cSchedState = g - , cIdSource = idsrc - , cThreads = launch' Unmasked initialThread (const c) M.empty - , cWriteBuf = emptyBuffer - , cCaps = caps +runConcurrency :: (MonadDejaFu n, HasCallStack) + => [Invariant n ()] + -> Bool + -> Scheduler g + -> MemType + -> g + -> IdSource + -> Int + -> ModelConc n a + -> n (CResult n g a) +runConcurrency invariants forSnapshot sched memtype g idsrc caps ma = do + let ctx = Context { cSchedState = g + , cIdSource = idsrc + , cThreads = M.empty + , cWriteBuf = emptyBuffer + , cCaps = caps + , cInvariants = InvariantContext { icActive = invariants, icBlocked = [] } + , cNewInvariants = [] + , cCState = initialCState } - (finalCtx, trace, finalAction) <- runThreads sched memtype ref ctx - out <- readRef ref - pure (efromJust "runConcurrency" out, finalCtx, trace, finalAction) + (c, ref) <- runRefCont AStop (Just . Right) (runModelConc ma) + let threads0 = launch' Unmasked initialThread (\_ -> c) (cThreads ctx) + threads <- case forkBoundThread of + Just fbt -> makeBound fbt initialThread threads0 + Nothing -> pure threads0 + res <- runThreads forSnapshot sched memtype ref ctx { cThreads = threads } + killAllThreads (finalContext res) + pure res +-- | Like 'runConcurrency' but starts from a snapshot. +runConcurrencyWithSnapshot :: (MonadDejaFu n, HasCallStack) + => Scheduler g + -> MemType + -> Context n g + -> (Threads n -> n ()) + -> ModelConc n a + -> n (CResult n g a) +runConcurrencyWithSnapshot sched memtype ctx restore ma = do + (c, ref) <- runRefCont AStop (Just . Right) (runModelConc ma) + let threads0 = M.delete initialThread (cThreads ctx) + let threads1 = launch' Unmasked initialThread (\_ -> c) threads0 + threads <- case forkBoundThread of + Just fbt -> do + let boundThreads = M.filter (isJust . _bound) threads1 + threads' <- makeBound fbt initialThread threads1 + foldrM (makeBound fbt) threads' (M.keys boundThreads) + Nothing -> pure threads1 + restore threads + res <- runThreads False sched memtype ref ctx { cThreads = threads } + killAllThreads (finalContext res) + pure res + +-- | Kill the remaining threads +killAllThreads :: (MonadDejaFu n, HasCallStack) => Context n g -> n () +killAllThreads ctx = + let finalThreads = cThreads ctx + in mapM_ (`kill` finalThreads) (M.keys finalThreads) + +------------------------------------------------------------------------------- +-- * Execution + -- | The context a collection of threads are running in. -data Context n r g = Context - { cSchedState :: g - , cIdSource :: IdSource - , cThreads :: Threads n r - , cWriteBuf :: WriteBuffer r - , cCaps :: Int +data Context n g = Context + { cSchedState :: g + , cIdSource :: IdSource + , cThreads :: Threads n + , cWriteBuf :: WriteBuffer n + , cCaps :: Int + , cInvariants :: InvariantContext n + , cNewInvariants :: [Invariant n ()] + , cCState :: ConcurrencyState } -- | Run a collection of threads, until there are no threads left. -runThreads :: MonadRef r n - => Scheduler g +runThreads :: (MonadDejaFu n, HasCallStack) + => Bool + -> Scheduler g -> MemType - -> r (Maybe (Either Failure a)) - -> Context n r g - -> n (Context n r g, SeqTrace, Maybe (ThreadId, ThreadAction)) -runThreads sched memtype ref = go Seq.empty Nothing where - go sofar prior ctx - | isTerminated = pure (ctx, sofar, prior) - | isDeadlocked = die sofar prior Deadlock ctx - | isSTMLocked = die sofar prior STMDeadlock ctx + -> Ref n (Maybe (Either Condition a)) + -> Context n g + -> n (CResult n g a) +runThreads forSnapshot sched memtype ref = schedule (const $ pure ()) Seq.empty Nothing where + -- signal failure & terminate + die reason finalR finalT finalD finalC = do + writeRef ref (Just $ Left reason) + stop finalR finalT finalD finalC + + -- just terminate; 'ref' must have been written to before calling + -- this + stop finalR finalT finalD finalC = pure CResult + { finalContext = finalC + , finalRef = ref + , finalRestore = finalR + , finalTrace = finalT + , finalDecision = finalD + } + + -- check for termination, pick a thread, and call 'step' + schedule restore sofar prior ctx + | isTerminated = stop restore sofar prior ctx + | isDeadlocked = die Deadlock restore sofar prior ctx | otherwise = let ctx' = ctx { cSchedState = g' } in case choice of Just chosen -> case M.lookup chosen threadsc of Just thread - | isBlocked thread -> die sofar prior InternalError ctx' - | otherwise -> step chosen thread ctx' - Nothing -> die sofar prior InternalError ctx' - Nothing -> die sofar prior Abort ctx' + | isBlocked thread -> E.throwM ScheduledBlockedThread + | otherwise -> + let decision + | Just chosen == (fst <$> prior) = Continue + | (fst <$> prior) `notElem` map (Just . fst) runnable' = Start chosen + | otherwise = SwitchTo chosen + alternatives = filter (\(t, _) -> t /= chosen) runnable' + in step decision alternatives chosen thread restore sofar prior ctx' + Nothing -> E.throwM ScheduledMissingThread + Nothing -> die Abort restore sofar prior ctx' where - (choice, g') = scheduleThread sched prior (efromList "runThreads" runnable') (cSchedState ctx) + (choice, g') = scheduleThread sched prior (efromList runnable') (cCState ctx) (cSchedState ctx) runnable' = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable] runnable = M.filter (not . isBlocked) threadsc threadsc = addCommitThreads (cWriteBuf ctx) threads threads = cThreads ctx isBlocked = isJust . _blocking isTerminated = initialThread `notElem` M.keys threads - isDeadlocked = M.null (M.filter (not . isBlocked) threads) && - (((~= OnMVarFull undefined) <$> M.lookup initialThread threads) == Just True || - ((~= OnMVarEmpty undefined) <$> M.lookup initialThread threads) == Just True || - ((~= OnMask undefined) <$> M.lookup initialThread threads) == Just True) - isSTMLocked = M.null (M.filter (not . isBlocked) threads) && - ((~= OnTVar []) <$> M.lookup initialThread threads) == Just True - - unblockWaitingOn tid = fmap unblock where - unblock thrd = case _blocking thrd of - Just (OnMask t) | t == tid -> thrd { _blocking = Nothing } - _ -> thrd + isDeadlocked = M.null (M.filter (not . isBlocked) threads) - die sofar' finalDecision reason finalCtx = do - writeRef ref (Just $ Left reason) - pure (finalCtx, sofar', finalDecision) + -- run the chosen thread for one step and then pass control back to + -- 'schedule' + step decision alternatives chosen thread restore sofar prior ctx = do + (res, actOrTrc, actionSnap) <- stepThread + forSnapshot + (isNothing prior) + sched + memtype + chosen + (_continuation thread) + ctx + let sofar' = sofar <> getTrc actOrTrc + let prior' = getPrior actOrTrc + let restore' threads' = + if forSnapshot + then restore threads' >> actionSnap threads' + else restore threads' + let ctx' = fixContext memtype chosen actOrTrc res ctx + case res of + Succeeded _ -> checkInvariants (cInvariants ctx') >>= \case + Right ic -> + schedule restore' sofar' prior' ctx' { cInvariants = ic } + Left exc -> + die (InvariantFailure exc) restore' sofar' prior' ctx' + Failed failure -> + die failure restore' sofar' prior' ctx' + where + getTrc a = Seq.singleton (decision, alternatives, a) - step chosen thread ctx' = do - (res, actOrTrc) <- stepThread sched memtype chosen (_continuation thread) $ ctx { cSchedState = g' } - let trc = getTrc actOrTrc - let sofar' = sofar <> trc - let prior' = getPrior actOrTrc - case res of - Right ctx'' -> - let threads' = if (interruptible <$> M.lookup chosen (cThreads ctx'')) /= Just False - then unblockWaitingOn chosen (cThreads ctx'') - else cThreads ctx'' - ctx''' = ctx'' { cThreads = delCommitThreads threads' } - in go sofar' prior' ctx''' - Left failure -> - let ctx'' = ctx' { cThreads = delCommitThreads threads } - in die sofar' prior' failure ctx'' - where - decision - | Just chosen == (fst <$> prior) = Continue - | (fst <$> prior) `notElem` map (Just . fst) runnable' = Start chosen - | otherwise = SwitchTo chosen + getPrior a = Just (chosen, a) - getTrc (Single a) = Seq.singleton (decision, runnable', a) - getTrc (SubC as _) = (decision, runnable', Subconcurrency) <| as +-- | Apply the context update from stepping an action. +fixContext :: MemType -> ThreadId -> ThreadAction -> What n g -> Context n g -> Context n g +fixContext memtype tid act what ctx0 = fixContextCommon $ case what of + Succeeded ctx@Context{..} -> ctx + { cThreads = + if (interruptible <$> M.lookup tid cThreads) /= Just False + then unblockWaitingOn tid cThreads + else cThreads + } + _ -> ctx0 + where + fixContextCommon ctx@Context{..} = ctx + { cThreads = delCommitThreads cThreads + , cInvariants = unblockInvariants act cInvariants + , cCState = updateCState memtype cCState tid act + } - getPrior (Single a) = Just (chosen, a) - getPrior (SubC _ finalD) = finalD +-- | @unblockWaitingOn tid@ unblocks every thread blocked in a +-- @throwTo tid@. +unblockWaitingOn :: ThreadId -> Threads n -> Threads n +unblockWaitingOn tid = fmap $ \thread -> case _blocking thread of + Just (OnMask t) | t == tid -> thread { _blocking = Nothing } + _ -> thread -------------------------------------------------------------------------------- -- * Single-step execution --- | What a thread did. -data Act - = Single ThreadAction - -- ^ Just one action. - | SubC SeqTrace (Maybe (ThreadId, ThreadAction)) - -- ^ Subconcurrency, with the given trace and final action. - deriving (Eq, Show) +-- | What a thread did, for execution purposes. +data What n g + = Succeeded (Context n g) + -- ^ Action succeeded: continue execution. + | Failed Condition + -- ^ Action caused computation to fail: stop. -- | Run a single thread one step, by dispatching on the type of -- 'Action'. -stepThread :: forall n r g. MonadRef r n - => Scheduler g +-- +-- Each case looks very similar. This is deliberate, so that the +-- essential differences between actions are more apparent, and not +-- hidden by accidental differences in how things are expressed. +-- +-- Note: the returned snapshot action will definitely not do the right +-- thing with relaxed memory. +stepThread :: forall n g. (MonadDejaFu n, HasCallStack) + => Bool + -- ^ Should we record a snapshot? + -> Bool + -- ^ Is this the first action? + -> Scheduler g -- ^ The scheduler. -> MemType -- ^ The memory model to use. -> ThreadId -- ^ ID of the current thread - -> Action n r + -> Action n -- ^ Action to step - -> Context n r g + -> Context n g -- ^ The execution context. - -> n (Either Failure (Context n r g), Act) -stepThread sched memtype tid action ctx = case action of - -- start a new thread, assigning it the next 'ThreadId' - AFork n a b -> pure $ - let threads' = launch tid newtid a (cThreads ctx) - (idSource', newtid) = nextTId n (cIdSource ctx) - in (Right ctx { cThreads = goto (b newtid) tid threads', cIdSource = idSource' }, Single (Fork newtid)) + -> n (What n g, ThreadAction, Threads n -> n ()) +-- start a new thread, assigning it the next 'ThreadId' +stepThread _ _ _ _ tid (AFork n a b) = \ctx@Context{..} -> pure $ + let (idSource', newtid) = nextTId n cIdSource + threads' = launch tid newtid a cThreads + in ( Succeeded ctx { cThreads = goto (b newtid) tid threads', cIdSource = idSource' } + , Fork newtid + , const (pure ()) + ) - -- get the 'ThreadId' of the current thread - AMyTId c -> simple (goto (c tid) tid (cThreads ctx)) MyThreadId +-- start a new bound thread, assigning it the next 'ThreadId' +stepThread _ _ _ _ tid (AForkOS n a b) = \ctx@Context{..} -> case forkBoundThread of + Just fbt -> do + let (idSource', newtid) = nextTId n cIdSource + let threads' = launch tid newtid a cThreads + threads'' <- makeBound fbt newtid threads' + pure ( Succeeded ctx { cThreads = goto (b newtid) tid threads'', cIdSource = idSource' } + , ForkOS newtid + , const (pure ()) + ) + Nothing -> + stepThrow Throw tid (MonadFailException "dejafu is running with bound threads disabled - do not use forkOS") ctx - -- get the number of capabilities - AGetNumCapabilities c -> simple (goto (c (cCaps ctx)) tid (cThreads ctx)) $ GetNumCapabilities (cCaps ctx) +-- check if we support bound threads +stepThread _ _ _ _ tid (ASupportsBoundThreads c) = \ctx@Context{..} -> do + let sbt = isJust (forkBoundThread :: Maybe (n (BoundThread n ()))) + pure ( Succeeded ctx { cThreads = goto (c sbt) tid cThreads } + , SupportsBoundThreads sbt + , const (pure ()) + ) - -- set the number of capabilities - ASetNumCapabilities i c -> pure - (Right ctx { cThreads = goto c tid (cThreads ctx), cCaps = i }, Single (SetNumCapabilities i)) +-- check if the current thread is bound +stepThread _ _ _ _ tid (AIsBound c) = \ctx@Context{..} -> do + let isBound = isJust . _bound $ elookup tid cThreads + pure ( Succeeded ctx { cThreads = goto (c isBound) tid cThreads } + , IsCurrentThreadBound isBound + , const (pure ()) + ) - -- yield the current thread - AYield c -> simple (goto c tid (cThreads ctx)) Yield +-- get the 'ThreadId' of the current thread +stepThread _ _ _ _ tid (AMyTId c) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto (c tid) tid cThreads } + , MyThreadId + , const (pure ()) + ) - -- yield the current thread (delay is ignored) - ADelay n c -> simple (goto c tid (cThreads ctx)) (ThreadDelay n) +-- get the number of capabilities +stepThread _ _ _ _ tid (AGetNumCapabilities c) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto (c cCaps) tid cThreads } + , GetNumCapabilities cCaps + , const (pure ()) + ) - -- create a new @MVar@, using the next 'MVarId'. - ANewMVar n c -> do - let (idSource', newmvid) = nextMVId n (cIdSource ctx) - ref <- newRef Nothing - let mvar = MVar newmvid ref - pure (Right ctx { cThreads = goto (c mvar) tid (cThreads ctx), cIdSource = idSource' }, Single (NewMVar newmvid)) +-- set the number of capabilities +stepThread _ _ _ _ tid (ASetNumCapabilities i c) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto c tid cThreads, cCaps = i } + , SetNumCapabilities i + , const (pure ()) + ) - -- put a value into a @MVar@, blocking the thread until it's empty. - APutMVar cvar@(MVar cvid _) a c -> synchronised $ do - (success, threads', woken) <- putIntoMVar cvar a c tid (cThreads ctx) - simple threads' $ if success then PutMVar cvid woken else BlockedPutMVar cvid +-- yield the current thread +stepThread _ _ _ _ tid (AYield c) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto c tid cThreads } + , Yield + , const (pure ()) + ) - -- try to put a value into a @MVar@, without blocking. - ATryPutMVar cvar@(MVar cvid _) a c -> synchronised $ do - (success, threads', woken) <- tryPutIntoMVar cvar a c tid (cThreads ctx) - simple threads' $ TryPutMVar cvid success woken +-- yield the current thread (delay is ignored) +stepThread _ _ _ _ tid (ADelay n c) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto c tid cThreads } + , ThreadDelay n + , const (pure ()) + ) - -- get the value from a @MVar@, without emptying, blocking the - -- thread until it's full. - AReadMVar cvar@(MVar cvid _) c -> synchronised $ do - (success, threads', _) <- readFromMVar cvar c tid (cThreads ctx) - simple threads' $ if success then ReadMVar cvid else BlockedReadMVar cvid +-- create a new @MVar@, using the next 'MVarId'. +stepThread _ _ _ _ tid (ANewMVar n c) = \ctx@Context{..} -> do + let (idSource', newmvid) = nextMVId n cIdSource + ref <- newRef Nothing + let mvar = ModelMVar newmvid ref + pure ( Succeeded ctx { cThreads = goto (c mvar) tid cThreads, cIdSource = idSource' } + , NewMVar newmvid + , const (writeRef ref Nothing) + ) - -- try to get the value from a @MVar@, without emptying, without - -- blocking. - ATryReadMVar cvar@(MVar cvid _) c -> synchronised $ do - (success, threads', _) <- tryReadFromMVar cvar c tid (cThreads ctx) - simple threads' $ TryReadMVar cvid success +-- put a value into a @MVar@, blocking the thread until it's empty. +stepThread _ _ _ _ tid (APutMVar mvar@ModelMVar{..} a c) = synchronised $ \ctx@Context{..} -> do + (success, threads', woken, effect) <- putIntoMVar mvar a c tid cThreads + pure ( Succeeded ctx { cThreads = threads' } + , if success then PutMVar mvarId woken else BlockedPutMVar mvarId + , const effect + ) - -- take the value from a @MVar@, blocking the thread until it's - -- full. - ATakeMVar cvar@(MVar cvid _) c -> synchronised $ do - (success, threads', woken) <- takeFromMVar cvar c tid (cThreads ctx) - simple threads' $ if success then TakeMVar cvid woken else BlockedTakeMVar cvid +-- try to put a value into a @MVar@, without blocking. +stepThread _ _ _ _ tid (ATryPutMVar mvar@ModelMVar{..} a c) = synchronised $ \ctx@Context{..} -> do + (success, threads', woken, effect) <- tryPutIntoMVar mvar a c tid cThreads + pure ( Succeeded ctx { cThreads = threads' } + , TryPutMVar mvarId success woken + , const effect + ) - -- try to take the value from a @MVar@, without blocking. - ATryTakeMVar cvar@(MVar cvid _) c -> synchronised $ do - (success, threads', woken) <- tryTakeFromMVar cvar c tid (cThreads ctx) - simple threads' $ TryTakeMVar cvid success woken +-- get the value from a @MVar@, without emptying, blocking the thread +-- until it's full. +stepThread _ _ _ _ tid (AReadMVar mvar@ModelMVar{..} c) = synchronised $ \ctx@Context{..} -> do + (success, threads', _, _) <- readFromMVar mvar c tid cThreads + pure ( Succeeded ctx { cThreads = threads' } + , if success then ReadMVar mvarId else BlockedReadMVar mvarId + , const (pure ()) + ) - -- create a new @CRef@, using the next 'CRefId'. - ANewCRef n a c -> do - let (idSource', newcrid) = nextCRId n (cIdSource ctx) - ref <- newRef (M.empty, 0, a) - let cref = CRef newcrid ref - pure (Right ctx { cThreads = goto (c cref) tid (cThreads ctx), cIdSource = idSource' }, Single (NewCRef newcrid)) +-- try to get the value from a @MVar@, without emptying, without +-- blocking. +stepThread _ _ _ _ tid (ATryReadMVar mvar@ModelMVar{..} c) = synchronised $ \ctx@Context{..} -> do + (success, threads', _, _) <- tryReadFromMVar mvar c tid cThreads + pure ( Succeeded ctx { cThreads = threads' } + , TryReadMVar mvarId success + , const (pure ()) + ) - -- read from a @CRef@. - AReadCRef cref@(CRef crid _) c -> do - val <- readCRef cref tid - simple (goto (c val) tid (cThreads ctx)) $ ReadCRef crid +-- take the value from a @MVar@, blocking the thread until it's full. +stepThread _ _ _ _ tid (ATakeMVar mvar@ModelMVar{..} c) = synchronised $ \ctx@Context{..} -> do + (success, threads', woken, effect) <- takeFromMVar mvar c tid cThreads + pure ( Succeeded ctx { cThreads = threads' } + , if success then TakeMVar mvarId woken else BlockedTakeMVar mvarId + , const effect + ) - -- read from a @CRef@ for future compare-and-swap operations. - AReadCRefCas cref@(CRef crid _) c -> do - tick <- readForTicket cref tid - simple (goto (c tick) tid (cThreads ctx)) $ ReadCRefCas crid +-- try to take the value from a @MVar@, without blocking. +stepThread _ _ _ _ tid (ATryTakeMVar mvar@ModelMVar{..} c) = synchronised $ \ctx@Context{..} -> do + (success, threads', woken, effect) <- tryTakeFromMVar mvar c tid cThreads + pure ( Succeeded ctx { cThreads = threads' } + , TryTakeMVar mvarId success woken + , const effect + ) - -- modify a @CRef@. - AModCRef cref@(CRef crid _) f c -> synchronised $ do - (new, val) <- f <$> readCRef cref tid - writeImmediate cref new - simple (goto (c val) tid (cThreads ctx)) $ ModCRef crid +-- create a new @IORef@, using the next 'IORefId'. +stepThread _ _ _ _ tid (ANewIORef n a c) = \ctx@Context{..} -> do + let (idSource', newiorid) = nextIORId n cIdSource + let val = (M.empty, 0, a) + ioref <- newRef val + let ref = ModelIORef newiorid ioref + pure ( Succeeded ctx { cThreads = goto (c ref) tid cThreads, cIdSource = idSource' } + , NewIORef newiorid + , const (writeRef ioref val) + ) - -- modify a @CRef@ using a compare-and-swap. - AModCRefCas cref@(CRef crid _) f c -> synchronised $ do - tick@(Ticket _ _ old) <- readForTicket cref tid - let (new, val) = f old - void $ casCRef cref tid tick new - simple (goto (c val) tid (cThreads ctx)) $ ModCRefCas crid +-- read from a @IORef@. +stepThread _ _ _ _ tid (AReadIORef ref@ModelIORef{..} c) = \ctx@Context{..} -> do + val <- readIORef ref tid + pure ( Succeeded ctx { cThreads = goto (c val) tid cThreads } + , ReadIORef iorefId + , const (pure ()) + ) - -- write to a @CRef@ without synchronising. - AWriteCRef cref@(CRef crid _) a c -> case memtype of - -- write immediately. - SequentialConsistency -> do - writeImmediate cref a - simple (goto c tid (cThreads ctx)) $ WriteCRef crid - -- add to buffer using thread id. - TotalStoreOrder -> do - wb' <- bufferWrite (cWriteBuf ctx) (tid, Nothing) cref a - pure (Right ctx { cThreads = goto c tid (cThreads ctx), cWriteBuf = wb' }, Single (WriteCRef crid)) - -- add to buffer using both thread id and cref id - PartialStoreOrder -> do - wb' <- bufferWrite (cWriteBuf ctx) (tid, Just crid) cref a - pure (Right ctx { cThreads = goto c tid (cThreads ctx), cWriteBuf = wb' }, Single (WriteCRef crid)) +-- read from a @IORef@ for future compare-and-swap operations. +stepThread _ _ _ _ tid (AReadIORefCas ref@ModelIORef{..} c) = \ctx@Context{..} -> do + tick <- readForTicket ref tid + pure ( Succeeded ctx { cThreads = goto (c tick) tid cThreads } + , ReadIORefCas iorefId + , const (pure ()) + ) - -- perform a compare-and-swap on a @CRef@. - ACasCRef cref@(CRef crid _) tick a c -> synchronised $ do - (suc, tick') <- casCRef cref tid tick a - simple (goto (c (suc, tick')) tid (cThreads ctx)) $ CasCRef crid suc +-- modify a @IORef@. +stepThread _ _ _ _ tid (AModIORef ref@ModelIORef{..} f c) = synchronised $ \ctx@Context{..} -> do + (new, val) <- f <$> readIORef ref tid + effect <- writeImmediate ref new + pure ( Succeeded ctx { cThreads = goto (c val) tid cThreads } + , ModIORef iorefId + , const effect + ) - -- commit a @CRef@ write - ACommit t c -> do - wb' <- case memtype of - -- shouldn't ever get here - SequentialConsistency -> - fatal "stepThread.ACommit" "Attempting to commit under SequentialConsistency" - -- commit using the thread id. - TotalStoreOrder -> commitWrite (cWriteBuf ctx) (t, Nothing) - -- commit using the cref id. - PartialStoreOrder -> commitWrite (cWriteBuf ctx) (t, Just c) - pure (Right ctx { cWriteBuf = wb' }, Single (CommitCRef t c)) +-- modify a @IORef@ using a compare-and-swap. +stepThread _ _ _ _ tid (AModIORefCas ref@ModelIORef{..} f c) = synchronised $ \ctx@Context{..} -> do + tick@(ModelTicket _ _ old) <- readForTicket ref tid + let (new, val) = f old + (_, _, effect) <- casIORef ref tid tick new + pure ( Succeeded ctx { cThreads = goto (c val) tid cThreads } + , ModIORefCas iorefId + , const effect + ) - -- run a STM transaction atomically. - AAtom stm c -> synchronised $ do - (res, idSource', trace) <- runTransaction stm (cIdSource ctx) - case res of - Success _ written val -> - let (threads', woken) = wake (OnTVar written) (cThreads ctx) - in pure (Right ctx { cThreads = goto (c val) tid threads', cIdSource = idSource' }, Single (STM trace woken)) - Retry touched -> - let threads' = block (OnTVar touched) tid (cThreads ctx) - in pure (Right ctx { cThreads = threads', cIdSource = idSource'}, Single (BlockedSTM trace)) - Exception e -> do - let act = STM trace [] - res' <- stepThrow tid (cThreads ctx) act e - pure $ case res' of - (Right ctx', _) -> (Right ctx' { cIdSource = idSource' }, Single act) - (Left err, _) -> (Left err, Single act) +-- write to a @IORef@ without synchronising. +stepThread _ _ _ memtype tid (AWriteIORef ref@ModelIORef{..} a c) = \ctx@Context{..} -> case memtype of + -- write immediately. + SequentialConsistency -> do + effect <- writeImmediate ref a + pure ( Succeeded ctx { cThreads = goto c tid cThreads } + , WriteIORef iorefId + , const effect + ) + -- add to buffer using thread id. + TotalStoreOrder -> do + wb' <- bufferWrite cWriteBuf (tid, Nothing) ref a + pure ( Succeeded ctx { cThreads = goto c tid cThreads, cWriteBuf = wb' } + , WriteIORef iorefId + , const (pure ()) + ) + -- add to buffer using both thread id and IORef id + PartialStoreOrder -> do + wb' <- bufferWrite cWriteBuf (tid, Just iorefId) ref a + pure ( Succeeded ctx { cThreads = goto c tid cThreads, cWriteBuf = wb' } + , WriteIORef iorefId + , const (pure ()) + ) - -- lift an action from the underlying monad into the @Conc@ - -- computation. - ALift na -> do - a <- na - simple (goto a tid (cThreads ctx)) LiftIO +-- perform a compare-and-swap on a @IORef@. +stepThread _ _ _ _ tid (ACasIORef ref@ModelIORef{..} tick a c) = synchronised $ \ctx@Context{..} -> do + (suc, tick', effect) <- casIORef ref tid tick a + pure ( Succeeded ctx { cThreads = goto (c (suc, tick')) tid cThreads } + , CasIORef iorefId suc + , const effect + ) - -- throw an exception, and propagate it to the appropriate - -- handler. - AThrow e -> stepThrow tid (cThreads ctx) Throw e +-- commit a @IORef@ write +stepThread _ _ _ memtype _ (ACommit t c) = \ctx@Context{..} -> do + wb' <- case memtype of + -- shouldn't ever get here + SequentialConsistency -> + fatal "stepThread.ACommit" "Attempting to commit under SequentialConsistency" + -- commit using the thread id. + TotalStoreOrder -> + commitWrite cWriteBuf (t, Nothing) + -- commit using the IORef id. + PartialStoreOrder -> + commitWrite cWriteBuf (t, Just c) + pure ( Succeeded ctx { cWriteBuf = wb' } + , CommitIORef t c + , const (pure ()) + ) - -- throw an exception to the target thread, and propagate it to - -- the appropriate handler. - AThrowTo t e c -> synchronised $ - let threads' = goto c tid (cThreads ctx) - blocked = block (OnMask t) tid (cThreads ctx) - in case M.lookup t (cThreads ctx) of - Just thread - | interruptible thread -> stepThrow t threads' (ThrowTo t) e - | otherwise -> simple blocked $ BlockedThrowTo t - Nothing -> simple threads' $ ThrowTo t +-- run a STM transaction atomically. +stepThread _ _ _ _ tid (AAtom stm c) = synchronised $ \ctx@Context{..} -> do + (res, effect, idSource', trace) <- runTransaction stm cIdSource + case res of + Success _ written val -> do + let (threads', woken) = wake (OnTVar written) cThreads + pure ( Succeeded ctx { cThreads = goto (c val) tid threads', cIdSource = idSource' } + , STM trace woken + , const effect + ) + Retry touched -> do + let threads' = block (OnTVar touched) tid cThreads + pure ( Succeeded ctx { cThreads = threads', cIdSource = idSource'} + , BlockedSTM trace + , const effect + ) + Exception e -> do + res' <- stepThrow (ThrownSTM trace) tid e ctx + pure $ case res' of + (Succeeded ctx', act, effect') -> (Succeeded ctx' { cIdSource = idSource' }, act, effect') + (Failed err, act, effect') -> (Failed err, act, effect') - -- run a subcomputation in an exception-catching context. - ACatching h ma c -> - let a = runCont ma (APopCatching . c) - e exc = runCont (h exc) c - threads' = goto a tid (catching e tid (cThreads ctx)) - in simple threads' Catching +-- lift an action from the underlying monad into the @Conc@ +-- computation. +stepThread _ _ _ _ tid (ALift na) = \ctx@Context{..} -> do + let effect threads = runLiftedAct tid threads na + a <- effect cThreads + pure (Succeeded ctx { cThreads = goto a tid cThreads } + , LiftIO + , void <$> effect + ) - -- pop the top exception handler from the thread's stack. - APopCatching a -> - let threads' = goto a tid (uncatching tid (cThreads ctx)) - in simple threads' PopCatching +-- throw an exception, and propagate it to the appropriate handler. +stepThread _ _ _ _ tid (AThrow e) = stepThrow Throw tid e - -- execute a subcomputation with a new masking state, and give it - -- a function to run a computation with the current masking state. - AMasking m ma c -> - let a = runCont (ma umask) (AResetMask False False m' . c) - m' = _masking . efromJust "stepThread.AMasking" $ M.lookup tid (cThreads ctx) - umask mb = resetMask True m' >> mb >>= \b -> resetMask False m >> pure b - resetMask typ ms = cont $ \k -> AResetMask typ True ms $ k () - threads' = goto a tid (mask m tid (cThreads ctx)) - in simple threads' $ SetMasking False m +-- throw an exception to the target thread, and propagate it to the +-- appropriate handler. +stepThread _ _ _ _ tid (AThrowTo t e c) = synchronised $ \ctx@Context{..} -> + let threads' = goto c tid cThreads + blocked = block (OnMask t) tid cThreads + in case M.lookup t cThreads of + Just thread + | interruptible thread || t == tid -> stepThrow (ThrowTo t) t e ctx { cThreads = threads' } + | otherwise -> pure + ( Succeeded ctx { cThreads = blocked } + , BlockedThrowTo t + , const (pure ()) + ) + Nothing -> pure + (Succeeded ctx { cThreads = threads' } + , ThrowTo t Nothing + , const (pure ()) + ) +-- run a subcomputation in an exception-catching context. +stepThread _ _ _ _ tid (ACatching h ma c) = \ctx@Context{..} -> pure $ + let a = runModelConc ma (APopCatching . c) + e exc = runModelConc (h exc) c + in ( Succeeded ctx { cThreads = goto a tid (catching e tid cThreads) } + , Catching + , const (pure ()) + ) - -- reset the masking thread of the state. - AResetMask b1 b2 m c -> - let act = (if b1 then SetMasking else ResetMasking) b2 m - threads' = goto c tid (mask m tid (cThreads ctx)) - in simple threads' act +-- pop the top exception handler from the thread's stack. +stepThread _ _ _ _ tid (APopCatching a) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto a tid (uncatching tid cThreads) } + , PopCatching + , const (pure ()) + ) - -- execute a 'return' or 'pure'. - AReturn c -> simple (goto c tid (cThreads ctx)) Return +-- execute a subcomputation with a new masking state, and give it a +-- function to run a computation with the current masking state. +stepThread _ _ _ _ tid (AMasking m ma c) = \ctx@Context{..} -> pure $ + let resetMask typ ms = ModelConc $ \k -> AResetMask typ True ms $ k () + umask mb = resetMask True m' >> mb >>= \b -> resetMask False m >> pure b + m' = _masking $ elookup tid cThreads + a = runModelConc (ma umask) (AResetMask False False m' . c) + in ( Succeeded ctx { cThreads = goto a tid (mask m tid cThreads) } + , SetMasking False m + , const (pure ()) + ) - -- kill the current thread. - AStop na -> na >> simple (kill tid (cThreads ctx)) Stop +-- reset the masking thread of the state. +stepThread _ _ _ _ tid (AResetMask b1 b2 m c) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto c tid (mask m tid cThreads) } + , (if b1 then SetMasking else ResetMasking) b2 m + , const (pure ()) + ) - -- run a subconcurrent computation. - ASub ma c - | M.size (cThreads ctx) > 1 -> pure (Left IllegalSubconcurrency, Single Subconcurrency) - | otherwise -> do - (res, ctx', trace, finalDecision) <- - runConcurrency sched memtype (cSchedState ctx) (cIdSource ctx) (cCaps ctx) ma - pure (Right ctx { cThreads = goto (AStopSub (c res)) tid (cThreads ctx) - , cIdSource = cIdSource ctx' - , cSchedState = cSchedState ctx' }, SubC trace finalDecision) +-- get the current masking state. +stepThread _ _ _ _ tid (AGetMasking c) = \ctx@Context{..} -> pure $ + let m = _masking $ elookup tid cThreads + in ( Succeeded ctx { cThreads = goto (c m) tid cThreads } + , GetMaskingState m + , const (pure ()) + ) - -- after the end of a subconcurrent computation. does nothing, - -- only exists so that: there is an entry in the trace for - -- returning to normal computation; and every item in the trace - -- corresponds to a scheduling point. - AStopSub c -> simple (goto c tid (cThreads ctx)) StopSubconcurrency +-- execute a 'return' or 'pure'. +stepThread _ _ _ _ tid (AReturn c) = \ctx@Context{..} -> + pure ( Succeeded ctx { cThreads = goto c tid cThreads } + , Return + , const (pure ()) + ) + +-- kill the current thread. +stepThread _ _ _ _ tid (AStop na) = \ctx@Context{..} -> do + na + threads' <- kill tid cThreads + pure ( Succeeded ctx { cThreads = threads' } + , Stop + , const (pure ()) + ) + +-- register an invariant to be checked in the next execution +stepThread _ _ _ _ tid (ANewInvariant inv c) = \ctx@Context{..} -> + pure ( Succeeded ctx + { cThreads = goto c tid cThreads + , cNewInvariants = inv : cNewInvariants + } + , RegisterInvariant + , const (pure ()) + ) + +-- | Handle an exception being thrown from an @AAtom@, @AThrow@, or +-- @AThrowTo@. +stepThrow :: (MonadDejaFu n, Exception e) + => (Maybe MaskingState -> ThreadAction) + -- ^ Action to include in the trace. + -> ThreadId + -- ^ The thread receiving the exception. + -> e + -- ^ Exception to raise. + -> Context n g + -- ^ The execution context. + -> n (What n g, ThreadAction, Threads n -> n ()) +stepThrow act tid e ctx@Context{..} = case propagate some tid cThreads of + Just ts' -> pure + ( Succeeded ctx { cThreads = ts' } + , act (Just . _masking $ elookup tid ts') + , const (pure ()) + ) + Nothing + | tid == initialThread -> pure + ( Failed (UncaughtException some) + , act Nothing + , const (pure ()) + ) + | otherwise -> do + ts' <- kill tid cThreads + pure ( Succeeded ctx { cThreads = ts' } + , act Nothing + , const (pure ()) + ) where + some = toException e - -- this is not inline in the long @case@ above as it's needed by - -- @AAtom@, @AThrow@, and @AThrowTo@. - stepThrow t ts act e = - let some = toException e - in case propagate some t ts of - Just ts' -> simple ts' act - Nothing - | t == initialThread -> pure (Left (UncaughtException some), Single act) - | otherwise -> simple (kill t ts) act +-- | Helper for actions impose a write barrier. +synchronised :: MonadDejaFu n + => (Context n g -> n x) + -- ^ Action to run after the write barrier. + -> Context n g + -- ^ The original execution context. + -> n x +synchronised ma ctx@Context{..} = do + writeBarrier cWriteBuf + ma ctx { cWriteBuf = emptyBuffer } - -- helper for actions which only change the threads. - simple threads' act = pure (Right ctx { cThreads = threads' }, Single act) +-------------------------------------------------------------------------------- +-- * Invariants - -- helper for actions impose a write barrier. - synchronised ma = do - writeBarrier (cWriteBuf ctx) - res <- ma +-- | The state of the invariants +data InvariantContext n = InvariantContext + { icActive :: [Invariant n ()] + , icBlocked :: [(Invariant n (), ([IORefId], [MVarId], [TVarId]))] + } - pure $ case res of - (Right ctx', act) -> (Right ctx' { cWriteBuf = emptyBuffer }, act) - _ -> res +-- | @unblockInvariants act@ unblocks every invariant which could have +-- its result changed by @act@. +unblockInvariants :: ThreadAction -> InvariantContext n -> InvariantContext n +unblockInvariants act ic = InvariantContext active blocked where + active = map fst unblocked ++ icActive ic + + (unblocked, blocked) = (`partition` icBlocked ic) $ + \(_, (ioridsB, mvidsB, tvidsB)) -> + maybe False (`elem` ioridsB) (iorefOf (simplifyAction act)) || + maybe False (`elem` mvidsB) (mvarOf (simplifyAction act)) || + any (`elem` tvidsB) (tvarsOf act) + +-- | Check all active invariants, returning an arbitrary failure if +-- multiple ones fail. +checkInvariants :: MonadDejaFu n + => InvariantContext n + -> n (Either E.SomeException (InvariantContext n)) +checkInvariants ic = go (icActive ic) >>= \case + Right blocked -> pure (Right (InvariantContext [] (blocked ++ icBlocked ic))) + Left exc -> pure (Left exc) + where + go (inv:is) = checkInvariant inv >>= \case + Right o -> fmap ((inv,o):) <$> go is + Left exc -> pure (Left exc) + go [] = pure (Right []) + +-- | Check an invariant. +checkInvariant :: MonadDejaFu n + => Invariant n a + -> n (Either E.SomeException ([IORefId], [MVarId], [TVarId])) +checkInvariant inv = doInvariant inv >>= \case + (Right _, iorefs, mvars, tvars) -> pure (Right (iorefs, mvars, tvars)) + (Left exc, _, _, _) -> pure (Left exc) + +-- | Run an invariant (more primitive) +doInvariant :: MonadDejaFu n + => Invariant n a + -> n (Either E.SomeException a, [IORefId], [MVarId], [TVarId]) +doInvariant inv = do + (c, ref) <- runRefCont IStop (Just . Right) (runInvariant inv) + (iorefs, mvars, tvars) <- go ref c [] [] [] + val <- readRef ref + pure (efromJust val, nub iorefs, nub mvars, nub tvars) + where + go ref act iorefs mvars tvars = do + (res, iorefs', mvars', tvars') <- stepInvariant act + let newIORefs = iorefs' ++ iorefs + let newMVars = mvars' ++ mvars + let newTVars = tvars' ++ tvars + case res of + Right (Just act') -> + go ref act' newIORefs newMVars newTVars + Right Nothing -> + pure (newIORefs, newMVars, newTVars) + Left exc -> do + writeRef ref (Just (Left exc)) + pure (newIORefs, newMVars, newTVars) + +-- | Run an invariant for one step +stepInvariant :: MonadDejaFu n + => IAction n + -> n (Either E.SomeException (Maybe (IAction n)), [IORefId], [MVarId], [TVarId]) +stepInvariant (IInspectIORef ioref@ModelIORef{..} k) = do + a <- readIORefGlobal ioref + pure (Right (Just (k a)), [iorefId], [], []) +stepInvariant (IInspectMVar ModelMVar{..} k) = do + a <- readRef mvarRef + pure (Right (Just (k a)), [], [mvarId], []) +stepInvariant (IInspectTVar ModelTVar{..} k) = do + a <- readRef tvarRef + pure (Right (Just (k a)), [], [], [tvarId]) +stepInvariant (ICatch h nx k) = doInvariant nx >>= \case + (Right a, iorefs, mvars, tvars) -> + pure (Right (Just (k a)), iorefs, mvars, tvars) + (Left exc, iorefs, mvars, tvars) -> case E.fromException exc of + Just exc' -> doInvariant (h exc') >>= \case + (Right a, iorefs', mvars', tvars') -> + pure (Right (Just (k a)), iorefs' ++ iorefs, mvars' ++ mvars, tvars' ++ tvars) + (Left exc'', iorefs', mvars', tvars') -> + pure (Left exc'', iorefs' ++ iorefs, mvars' ++ mvars, tvars' ++ tvars) + Nothing -> pure (Left exc, iorefs, mvars, tvars) +stepInvariant (IThrow exc) = + pure (Left (toException exc), [], [], []) +stepInvariant (IStop finalise) = do + finalise + pure (Right Nothing, [], [], []) diff --git a/Test/DejaFu/Conc/Internal/Common.hs b/Test/DejaFu/Conc/Internal/Common.hs --- a/Test/DejaFu/Conc/Internal/Common.hs +++ b/Test/DejaFu/Conc/Internal/Common.hs @@ -1,30 +1,32 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Test.DejaFu.Conc.Internal.Common --- Copyright : (c) 2016 Michael Walker +-- Copyright : (c) 2016--2020 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : CPP, ExistentialQuantification, RankNTypes +-- Portability : CPP, ExistentialQuantification, GADTs, RankNTypes -- -- Common types and utility functions for deterministic execution of -- 'MonadConc' implementations. This module is NOT considered to form +-- part of the public interface of this library. module Test.DejaFu.Conc.Internal.Common where -import Control.Exception (Exception, MaskingState(..)) -import Data.Map.Strict (Map) -import Test.DejaFu.Common -import Test.DejaFu.STM (STMLike) +import Control.Exception (Exception, MaskingState(..)) +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import qualified Control.Monad.Fail as Fail +import Data.Map.Strict (Map) -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif +import Test.DejaFu.Conc.Internal.STM (ModelSTM, ModelTVar) +import Test.DejaFu.Types -------------------------------------------------------------------------------- --- * The @Conc@ Monad +-- * Types for Modelling Concurrency -- | The underlying monad is based on continuations over 'Action's. -- @@ -34,145 +36,180 @@ -- current expression of threads and exception handlers very difficult -- (perhaps even not possible without significant reworking), so I -- abandoned the attempt. -newtype M n r a = M { runM :: (a -> Action n r) -> Action n r } +type ModelConc = Program Basic -instance Functor (M n r) where - fmap f m = M $ \ c -> runM m (c . f) +-- | A representation of a concurrent program for testing. +-- +-- To construct these, use the 'C.MonadConc' instance, or see +-- 'Test.DejaFu.Conc.withSetup', 'Test.DejaFu.Conc.withTeardown', and +-- 'Test.DejaFu.Conc.withSetupAndTeardown'. +-- +-- @since 2.0.0.0 +data Program pty n a where + ModelConc :: + { runModelConc :: (a -> Action n) -> Action n + } -> Program Basic n a + WithSetup :: + { wsSetup :: ModelConc n x + , wsProgram :: x -> ModelConc n a + } -> Program (WithSetup x) n a + WithSetupAndTeardown :: + { wstSetup :: ModelConc n x + , wstProgram :: x -> ModelConc n y + , wstTeardown :: x -> Either Condition y -> ModelConc n a + } -> Program (WithSetupAndTeardown x y) n a -instance Applicative (M n r) where - -- without the @AReturn@, a thread could lock up testing by - -- entering an infinite loop (eg: @forever (return ())@) - pure x = M $ \c -> AReturn $ c x - f <*> v = M $ \c -> runM f (\g -> runM v (c . g)) +-- | A type used to constrain 'Program': a @Program Basic@ is a +-- \"basic\" program with no set-up or teardown. +-- +-- Construct with the 'MonadConc' instance. +-- +-- @since 2.0.0.0 +data Basic -instance Monad (M n r) where - return = pure - m >>= k = M $ \c -> runM m (\x -> runM (k x) c) +-- | A type used to constrain 'Program': a @Program (WithSetup x)@ is +-- a program with some set-up action producing a value of type @x@. +-- +-- Construct with 'Test.DejaFu.Conc.withSetup'. +-- +-- @since 2.0.0.0 +data WithSetup x -#if MIN_VERSION_base(4,9,0) - fail = Fail.fail +-- | A type used to constrain 'Program': a @Program +-- (WithSetupAndTeardown x y)@ is a program producing a value of type +-- @y@ with some set-up action producing a value of type @x@ and a +-- teardown action producing the final result. +-- +-- Construct with 'Test.DejaFu.Conc.withTeardown' or +-- 'Test.DejaFu.Conc.withSetupAndTeardown'. +-- +-- @since 2.0.0.0 +data WithSetupAndTeardown x y --- | @since 0.7.1.2 -instance Fail.MonadFail (M n r) where +instance (pty ~ Basic) => Functor (Program pty n) where + fmap f m = ModelConc $ \c -> runModelConc m (c . f) + +instance (pty ~ Basic) => Applicative (Program pty n) where + -- without the @AReturn@, a thread could lock up testing by entering + -- an infinite loop (eg: @forever (return ())@) + pure x = ModelConc $ \c -> AReturn $ c x + f <*> v = ModelConc $ \c -> runModelConc f (\g -> runModelConc v (c . g)) + +instance (pty ~ Basic) => Monad (Program pty n) where + return = pure + m >>= k = ModelConc $ \c -> runModelConc m (\x -> runModelConc (k x) c) + +#if MIN_VERSION_base(4,13,0) +#else + fail = Fail.fail #endif - fail e = cont (\_ -> AThrow (MonadFailException e)) --- | The concurrent variable type used with the 'Conc' monad. One --- notable difference between these and 'MVar's is that 'MVar's are --- single-wakeup, and wake up in a FIFO order. Writing to a @MVar@ --- wakes up all threads blocked on reading it, and it is up to the --- scheduler which one runs next. Taking from a @MVar@ behaves --- analogously. -data MVar r a = MVar - { _cvarId :: MVarId - , _cvarVal :: r (Maybe a) - } +instance (pty ~ Basic) => Fail.MonadFail (Program pty n) where + fail e = ModelConc $ \_ -> AThrow (MonadFailException e) --- | The mutable non-blocking reference type. These are like 'IORef's. --- --- @CRef@s are represented as a unique numeric identifier and a --- reference containing (a) any thread-local non-synchronised writes --- (so each thread sees its latest write), (b) a commit count (used in --- compare-and-swaps), and (c) the current value visible to all --- threads. -data CRef r a = CRef - { _crefId :: CRefId - , _crefVal :: r (Map ThreadId a, Integer, a) +-- | An @MVar@ is modelled as a unique ID and a reference holding a +-- @Maybe@ value. +data ModelMVar n a = ModelMVar + { mvarId :: MVarId + , mvarRef :: Ref n (Maybe a) } --- | The compare-and-swap proof type. --- --- @Ticket@s are represented as just a wrapper around the identifier --- of the 'CRef' it came from, the commit count at the time it was --- produced, and an @a@ value. This doesn't work in the source package --- (atomic-primops) because of the need to use pointer equality. Here --- we can just pack extra information into 'CRef' to avoid that need. -data Ticket a = Ticket - { _ticketCRef :: CRefId - , _ticketWrites :: Integer - , _ticketVal :: a +-- | A @IORef@ is modelled as a unique ID and a reference holding +-- thread-local values, the number of commits, and the most recent +-- committed value. +data ModelIORef n a = ModelIORef + { iorefId :: IORefId + , iorefRef :: Ref n (Map ThreadId a, Integer, a) } --- | Construct a continuation-passing operation from a function. -cont :: ((a -> Action n r) -> Action n r) -> M n r a -cont = M - --- | Run a CPS computation with the given final computation. -runCont :: M n r a -> (a -> Action n r) -> Action n r -runCont = runM +-- | A @Ticket@ is modelled as the ID of the @ModelIORef@ it came from, +-- the commits to the @ModelIORef@ at the time it was produced, and the +-- value observed. +data ModelTicket a = ModelTicket + { ticketIORef :: IORefId + , ticketWrites :: Integer + , ticketVal :: a + } -------------------------------------------------------------------------------- --- * Primitive Actions +-- ** Primitive Actions -- | Scheduling is done in terms of a trace of 'Action's. Blocking can -- only occur as a result of an action, and they cover (most of) the -- primitives of the concurrency. 'spawn' is absent as it is -- implemented in terms of 'newEmptyMVar', 'fork', and 'putMVar'. -data Action n r = - AFork String ((forall b. M n r b -> M n r b) -> Action n r) (ThreadId -> Action n r) - | AMyTId (ThreadId -> Action n r) +data Action n = + AFork String ((forall b. ModelConc n b -> ModelConc n b) -> Action n) (ThreadId -> Action n) + | AForkOS String ((forall b. ModelConc n b -> ModelConc n b) -> Action n) (ThreadId -> Action n) - | AGetNumCapabilities (Int -> Action n r) - | ASetNumCapabilities Int (Action n r) + | ASupportsBoundThreads (Bool -> Action n) + | AIsBound (Bool -> Action n) + | AMyTId (ThreadId -> Action n) - | forall a. ANewMVar String (MVar r a -> Action n r) - | forall a. APutMVar (MVar r a) a (Action n r) - | forall a. ATryPutMVar (MVar r a) a (Bool -> Action n r) - | forall a. AReadMVar (MVar r a) (a -> Action n r) - | forall a. ATryReadMVar (MVar r a) (Maybe a -> Action n r) - | forall a. ATakeMVar (MVar r a) (a -> Action n r) - | forall a. ATryTakeMVar (MVar r a) (Maybe a -> Action n r) + | AGetNumCapabilities (Int -> Action n) + | ASetNumCapabilities Int (Action n) - | forall a. ANewCRef String a (CRef r a -> Action n r) - | forall a. AReadCRef (CRef r a) (a -> Action n r) - | forall a. AReadCRefCas (CRef r a) (Ticket a -> Action n r) - | forall a b. AModCRef (CRef r a) (a -> (a, b)) (b -> Action n r) - | forall a b. AModCRefCas (CRef r a) (a -> (a, b)) (b -> Action n r) - | forall a. AWriteCRef (CRef r a) a (Action n r) - | forall a. ACasCRef (CRef r a) (Ticket a) a ((Bool, Ticket a) -> Action n r) + | forall a. ANewMVar String (ModelMVar n a -> Action n) + | forall a. APutMVar (ModelMVar n a) a (Action n) + | forall a. ATryPutMVar (ModelMVar n a) a (Bool -> Action n) + | forall a. AReadMVar (ModelMVar n a) (a -> Action n) + | forall a. ATryReadMVar (ModelMVar n a) (Maybe a -> Action n) + | forall a. ATakeMVar (ModelMVar n a) (a -> Action n) + | forall a. ATryTakeMVar (ModelMVar n a) (Maybe a -> Action n) + | forall a. ANewIORef String a (ModelIORef n a -> Action n) + | forall a. AReadIORef (ModelIORef n a) (a -> Action n) + | forall a. AReadIORefCas (ModelIORef n a) (ModelTicket a -> Action n) + | forall a b. AModIORef (ModelIORef n a) (a -> (a, b)) (b -> Action n) + | forall a b. AModIORefCas (ModelIORef n a) (a -> (a, b)) (b -> Action n) + | forall a. AWriteIORef (ModelIORef n a) a (Action n) + | forall a. ACasIORef (ModelIORef n a) (ModelTicket a) a ((Bool, ModelTicket a) -> Action n) + | forall e. Exception e => AThrow e - | forall e. Exception e => AThrowTo ThreadId e (Action n r) - | forall a e. Exception e => ACatching (e -> M n r a) (M n r a) (a -> Action n r) - | APopCatching (Action n r) - | forall a. AMasking MaskingState ((forall b. M n r b -> M n r b) -> M n r a) (a -> Action n r) - | AResetMask Bool Bool MaskingState (Action n r) + | forall e. Exception e => AThrowTo ThreadId e (Action n) + | forall a e. Exception e => ACatching (e -> ModelConc n a) (ModelConc n a) (a -> Action n) + | APopCatching (Action n) + | forall a. AMasking MaskingState ((forall b. ModelConc n b -> ModelConc n b) -> ModelConc n a) (a -> Action n) + | AResetMask Bool Bool MaskingState (Action n) + | AGetMasking (MaskingState -> Action n) - | forall a. AAtom (STMLike n r a) (a -> Action n r) - | ALift (n (Action n r)) - | AYield (Action n r) - | ADelay Int (Action n r) - | AReturn (Action n r) - | ACommit ThreadId CRefId + | forall a. AAtom (ModelSTM n a) (a -> Action n) + | ALift (n (Action n)) + | AYield (Action n) + | ADelay Int (Action n) + | AReturn (Action n) + | ACommit ThreadId IORefId | AStop (n ()) - | forall a. ASub (M n r a) (Either Failure a -> Action n r) - | AStopSub (Action n r) + | ANewInvariant (Invariant n ()) (Action n) -------------------------------------------------------------------------------- --- * Scheduling & Traces +-- ** Scheduling & Traces -- | Look as far ahead in the given continuation as possible. -lookahead :: Action n r -> Lookahead +lookahead :: Action n -> Lookahead lookahead (AFork _ _ _) = WillFork +lookahead (AForkOS _ _ _) = WillForkOS +lookahead (ASupportsBoundThreads _) = WillSupportsBoundThreads +lookahead (AIsBound _) = WillIsCurrentThreadBound lookahead (AMyTId _) = WillMyThreadId lookahead (AGetNumCapabilities _) = WillGetNumCapabilities lookahead (ASetNumCapabilities i _) = WillSetNumCapabilities i lookahead (ANewMVar _ _) = WillNewMVar -lookahead (APutMVar (MVar c _) _ _) = WillPutMVar c -lookahead (ATryPutMVar (MVar c _) _ _) = WillTryPutMVar c -lookahead (AReadMVar (MVar c _) _) = WillReadMVar c -lookahead (ATryReadMVar (MVar c _) _) = WillTryReadMVar c -lookahead (ATakeMVar (MVar c _) _) = WillTakeMVar c -lookahead (ATryTakeMVar (MVar c _) _) = WillTryTakeMVar c -lookahead (ANewCRef _ _ _) = WillNewCRef -lookahead (AReadCRef (CRef r _) _) = WillReadCRef r -lookahead (AReadCRefCas (CRef r _) _) = WillReadCRefCas r -lookahead (AModCRef (CRef r _) _ _) = WillModCRef r -lookahead (AModCRefCas (CRef r _) _ _) = WillModCRefCas r -lookahead (AWriteCRef (CRef r _) _ _) = WillWriteCRef r -lookahead (ACasCRef (CRef r _) _ _ _) = WillCasCRef r -lookahead (ACommit t c) = WillCommitCRef t c +lookahead (APutMVar (ModelMVar m _) _ _) = WillPutMVar m +lookahead (ATryPutMVar (ModelMVar m _) _ _) = WillTryPutMVar m +lookahead (AReadMVar (ModelMVar m _) _) = WillReadMVar m +lookahead (ATryReadMVar (ModelMVar m _) _) = WillTryReadMVar m +lookahead (ATakeMVar (ModelMVar m _) _) = WillTakeMVar m +lookahead (ATryTakeMVar (ModelMVar m _) _) = WillTryTakeMVar m +lookahead (ANewIORef _ _ _) = WillNewIORef +lookahead (AReadIORef (ModelIORef r _) _) = WillReadIORef r +lookahead (AReadIORefCas (ModelIORef r _) _) = WillReadIORefCas r +lookahead (AModIORef (ModelIORef r _) _ _) = WillModIORef r +lookahead (AModIORefCas (ModelIORef r _) _ _) = WillModIORefCas r +lookahead (AWriteIORef (ModelIORef r _) _ _) = WillWriteIORef r +lookahead (ACasIORef (ModelIORef r _) _ _ _) = WillCasIORef r +lookahead (ACommit t c) = WillCommitIORef t c lookahead (AAtom _ _) = WillSTM lookahead (AThrow _) = WillThrow lookahead (AThrowTo tid _ _) = WillThrowTo tid @@ -180,10 +217,61 @@ lookahead (APopCatching _) = WillPopCatching lookahead (AMasking ms _ _) = WillSetMasking False ms lookahead (AResetMask b1 b2 ms _) = (if b1 then WillSetMasking else WillResetMasking) b2 ms +lookahead (AGetMasking _) = WillGetMaskingState lookahead (ALift _) = WillLiftIO lookahead (AYield _) = WillYield lookahead (ADelay n _) = WillThreadDelay n lookahead (AReturn _) = WillReturn lookahead (AStop _) = WillStop -lookahead (ASub _ _) = WillSubconcurrency -lookahead (AStopSub _) = WillStopSubconcurrency +lookahead (ANewInvariant _ _) = WillRegisterInvariant + +------------------------------------------------------------------------------- +-- * Invariants + +-- | Invariants are atomic actions which can inspect the shared state +-- of your computation, and terminate it on failure. Invariants have +-- no visible effects, and are checked after each scheduling point. +-- +-- To be checked, an invariant must be created during the setup phase +-- of your 'Program', using 'Test.DejaFu.Conc.registerInvariant'. The +-- invariant will then be checked in the main phase (but not in the +-- setup or teardown phase). As a consequence of this, any shared +-- state you want your invariant to check must also be created in the +-- setup phase, and passed into the main phase as a parameter. +-- +-- @since 2.0.0.0 +newtype Invariant n a = Invariant { runInvariant :: (a -> IAction n) -> IAction n } + +instance Functor (Invariant n) where + fmap f m = Invariant $ \c -> runInvariant m (c . f) + +instance Applicative (Invariant n) where + pure x = Invariant $ \c -> c x + f <*> v = Invariant $ \c -> runInvariant f (\g -> runInvariant v (c . g)) + +instance Monad (Invariant n) where + return = pure + m >>= k = Invariant $ \c -> runInvariant m (\x -> runInvariant (k x) c) + +#if MIN_VERSION_base(4,13,0) +#else + fail = Fail.fail +#endif + +instance Fail.MonadFail (Invariant n) where + fail e = Invariant $ \_ -> IThrow (MonadFailException e) + +instance MonadThrow (Invariant n) where + throwM e = Invariant $ \_ -> IThrow e + +instance MonadCatch (Invariant n) where + catch stm handler = Invariant $ ICatch handler stm + +-- | Invariants are represented as a sequence of primitive actions. +data IAction n + = forall a. IInspectIORef (ModelIORef n a) (a -> IAction n) + | forall a. IInspectMVar (ModelMVar n a) (Maybe a -> IAction n) + | forall a. IInspectTVar (ModelTVar n a) (a -> IAction n) + | forall a e. Exception e => ICatch (e -> Invariant n a) (Invariant n a) (a -> IAction n) + | forall e. Exception e => IThrow e + | IStop (n ()) 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 @@ -1,143 +1,156 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Test.DejaFu.Conc.Internal.Memory --- Copyright : (c) 2016 Michael Walker +-- Copyright : (c) 2016--2019 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : BangPatterns, GADTs, MultiParamTypeClasses +-- Portability : BangPatterns, GADTs, FlexibleContexts, LambdaCase, RecordWildCards -- --- Operations over @CRef@s and @MVar@s. This module is NOT considered +-- Operations over @IORef@s and @MVar@s. This module is NOT considered -- to form part of the public interface of this library. -- --- Relaxed memory operations over @CRef@s are implemented with an +-- Relaxed memory operations over @IORef@s are implemented with an -- explicit write buffer: one per thread for TSO, and one per -- thread/variable combination for PSO. Unsynchronised writes append -- to this buffer, and periodically separate threads commit from these --- buffers to the \"actual\" @CRef@. +-- buffers to the \"actual\" @IORef@. -- -- This model comes from /Dynamic Partial Order Reduction for Relaxed -- Memory Models/, N. Zhang, M. Kusano, and C. Wang (2015). module Test.DejaFu.Conc.Internal.Memory where -import Control.Monad.Ref (MonadRef, readRef, - writeRef) import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe (maybeToList) import Data.Monoid ((<>)) import Data.Sequence (Seq, ViewL(..), singleton, viewl, (><)) +import GHC.Stack (HasCallStack) -import Test.DejaFu.Common import Test.DejaFu.Conc.Internal.Common import Test.DejaFu.Conc.Internal.Threading - -import qualified Data.Map.Strict as M +import Test.DejaFu.Internal +import Test.DejaFu.Types -------------------------------------------------------------------------------- --- * Manipulating @CRef@s +-- * Manipulating @IORef@s -- | In non-sequentially-consistent memory models, non-synchronised -- writes get buffered. -- --- The @CRefId@ parameter is only used under PSO. Under TSO each +-- The @IORefId@ parameter is only used under PSO. Under TSO each -- thread has a single buffer. -newtype WriteBuffer r = WriteBuffer - { buffer :: Map (ThreadId, Maybe CRefId) (Seq (BufferedWrite r)) } +newtype WriteBuffer n = WriteBuffer + { buffer :: Map (ThreadId, Maybe IORefId) (Seq (BufferedWrite n)) } -- | A buffered write is a reference to the variable, and the value to -- write. Universally quantified over the value type so that the only -- thing which can be done with it is to write it to the reference. -data BufferedWrite r where - BufferedWrite :: ThreadId -> CRef r a -> a -> BufferedWrite r +data BufferedWrite n where + BufferedWrite :: ThreadId -> ModelIORef n a -> a -> BufferedWrite n -- | An empty write buffer. -emptyBuffer :: WriteBuffer r +emptyBuffer :: WriteBuffer n emptyBuffer = WriteBuffer M.empty -- | Add a new write to the end of a buffer. -bufferWrite :: MonadRef r n => WriteBuffer r -> (ThreadId, Maybe CRefId) -> CRef r a -> a -> n (WriteBuffer r) -bufferWrite (WriteBuffer wb) k@(tid, _) cref@(CRef _ ref) new = do +bufferWrite :: MonadDejaFu n => WriteBuffer n -> (ThreadId, Maybe IORefId) -> ModelIORef n a -> a -> n (WriteBuffer n) +bufferWrite (WriteBuffer wb) k@(tid, _) ref@ModelIORef{..} new = do -- Construct the new write buffer - let write = singleton $ BufferedWrite tid cref new + let write = singleton $ BufferedWrite tid ref new let buffer' = M.insertWith (flip (><)) k write wb - -- Write the thread-local value to the @CRef@'s update map. - (locals, count, def) <- readRef ref - writeRef ref (M.insert tid new locals, count, def) + -- Write the thread-local value to the @IORef@'s update map. + (locals, count, def) <- readRef iorefRef + writeRef iorefRef (M.insert tid new locals, count, def) pure (WriteBuffer buffer') -- | Commit the write at the head of a buffer. -commitWrite :: MonadRef r n => WriteBuffer r -> (ThreadId, Maybe CRefId) -> n (WriteBuffer r) +commitWrite :: MonadDejaFu n => WriteBuffer n -> (ThreadId, Maybe IORefId) -> n (WriteBuffer n) commitWrite w@(WriteBuffer wb) k = case maybe EmptyL viewl $ M.lookup k wb of - BufferedWrite _ cref a :< rest -> do - writeImmediate cref a + BufferedWrite _ ref a :< rest -> do + _ <- writeImmediate ref a pure . WriteBuffer $ M.insert k rest wb - EmptyL -> pure w --- | Read from a @CRef@, returning a newer thread-local non-committed +-- | Read from a @IORef@, returning a newer thread-local non-committed -- write if there is one. -readCRef :: MonadRef r n => CRef r a -> ThreadId -> n a -readCRef cref tid = do - (val, _) <- readCRefPrim cref tid +readIORef :: MonadDejaFu n => ModelIORef n a -> ThreadId -> n a +readIORef ref tid = do + (val, _) <- readIORefPrim ref tid pure val --- | Read from a @CRef@, returning a @Ticket@ representing the current +-- | Read from a @IORef@, returning a @Ticket@ representing the current -- view of the thread. -readForTicket :: MonadRef r n => CRef r a -> ThreadId -> n (Ticket a) -readForTicket cref@(CRef crid _) tid = do - (val, count) <- readCRefPrim cref tid - pure (Ticket crid count val) +readForTicket :: MonadDejaFu n => ModelIORef n a -> ThreadId -> n (ModelTicket a) +readForTicket ref@ModelIORef{..} tid = do + (val, count) <- readIORefPrim ref tid + pure (ModelTicket iorefId count val) --- | Perform a compare-and-swap on a @CRef@ if the ticket is still +-- | Perform a compare-and-swap on a @IORef@ if the ticket is still -- valid. This is strict in the \"new\" value argument. -casCRef :: MonadRef r n => CRef r a -> ThreadId -> Ticket a -> a -> n (Bool, Ticket a) -casCRef cref tid (Ticket _ cc _) !new = do - tick'@(Ticket _ cc' _) <- readForTicket cref tid +casIORef :: MonadDejaFu n => ModelIORef n a -> ThreadId -> ModelTicket a -> a -> n (Bool, ModelTicket a, n ()) +casIORef ref tid (ModelTicket _ cc _) !new = do + tick'@(ModelTicket _ cc' _) <- readForTicket ref tid if cc == cc' then do - writeImmediate cref new - tick'' <- readForTicket cref tid - pure (True, tick'') - else pure (False, tick') - --- | Read the local state of a @CRef@. -readCRefPrim :: MonadRef r n => CRef r a -> ThreadId -> n (a, Integer) -readCRefPrim (CRef _ ref) tid = do - (vals, count, def) <- readRef ref + effect <- writeImmediate ref new + tick'' <- readForTicket ref tid + pure (True, tick'', effect) + else pure (False, tick', pure ()) +-- | Read the local state of a @IORef@. +readIORefPrim :: MonadDejaFu n => ModelIORef n a -> ThreadId -> n (a, Integer) +readIORefPrim ModelIORef{..} tid = do + (vals, count, def) <- readRef iorefRef pure (M.findWithDefault def tid vals, count) --- | Write and commit to a @CRef@ immediately, clearing the update map +-- | Read the global state of a @IORef@. +readIORefGlobal :: MonadDejaFu n => ModelIORef n a -> n a +readIORefGlobal ModelIORef{..} = do + (_, _, def) <- readRef iorefRef + pure def + +-- | Write and commit to a @IORef@ immediately, clearing the update map -- and incrementing the write count. -writeImmediate :: MonadRef r n => CRef r a -> a -> n () -writeImmediate (CRef _ ref) a = do - (_, count, _) <- readRef ref - writeRef ref (M.empty, count + 1, a) +writeImmediate :: MonadDejaFu n => ModelIORef n a -> a -> n (n ()) +writeImmediate ModelIORef{..} a = do + (_, count, _) <- readRef iorefRef + let effect = writeRef iorefRef (M.empty, count + 1, a) + effect + pure effect -- | Flush all writes in the buffer. -writeBarrier :: MonadRef r n => WriteBuffer r -> n () +writeBarrier :: MonadDejaFu n => WriteBuffer n -> n () writeBarrier (WriteBuffer wb) = mapM_ flush $ M.elems wb where - flush = mapM_ $ \(BufferedWrite _ cref a) -> writeImmediate cref a + flush = mapM_ $ \(BufferedWrite _ ref a) -> writeImmediate ref a -- | Add phantom threads to the thread list to commit pending writes. -addCommitThreads :: WriteBuffer r -> Threads n r -> Threads n r +addCommitThreads :: WriteBuffer n -> Threads n -> Threads n addCommitThreads (WriteBuffer wb) ts = ts <> M.fromList phantoms where - phantoms = [ (ThreadId Nothing $ negate tid, mkthread c) - | ((_, b), tid) <- zip (M.toList wb) [1..] + phantoms = [ (uncurry commitThreadId k, mkthread c) + | (k, b) <- M.toList wb , c <- maybeToList (go $ viewl b) ] - go (BufferedWrite tid (CRef crid _) _ :< _) = Just $ ACommit tid crid + go (BufferedWrite tid ModelIORef{..} _ :< _) = Just $ ACommit tid iorefId go EmptyL = Nothing +-- | The ID of a commit thread. +commitThreadId :: ThreadId -> Maybe IORefId -> ThreadId +commitThreadId (ThreadId (Id _ t)) = ThreadId . Id Nothing . negate . go where + go (Just (IORefId (Id _ c))) = t + 1 + c * 10000 + go Nothing = t + 1 + -- | Remove phantom threads. -delCommitThreads :: Threads n r -> Threads n r +delCommitThreads :: Threads n -> Threads n delCommitThreads = M.filterWithKey $ \k _ -> k >= initialThread -------------------------------------------------------------------------------- @@ -148,74 +161,104 @@ data Emptying = Emptying | NonEmptying -- | Put into a @MVar@, blocking if full. -putIntoMVar :: MonadRef r n => MVar r a -> a -> Action n r - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) +putIntoMVar :: MonadDejaFu n + => ModelMVar n a + -> a + -> Action n + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) putIntoMVar cvar a c = mutMVar Blocking cvar a (const c) -- | Try to put into a @MVar@, not blocking if full. -tryPutIntoMVar :: MonadRef r n => MVar r a -> a -> (Bool -> Action n r) - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) +tryPutIntoMVar :: MonadDejaFu n + => ModelMVar n a + -> a + -> (Bool -> Action n) + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) tryPutIntoMVar = mutMVar NonBlocking -- | Read from a @MVar@, blocking if empty. -readFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r) - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) -readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . efromJust "readFromMVar") +readFromMVar :: (MonadDejaFu n, HasCallStack) + => ModelMVar n a + -> (a -> Action n) + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) +readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . efromJust) -- | Try to read from a @MVar@, not blocking if empty. -tryReadFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r) - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) +tryReadFromMVar :: MonadDejaFu n + => ModelMVar n a + -> (Maybe a -> Action n) + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) tryReadFromMVar = seeMVar NonEmptying NonBlocking -- | Take from a @MVar@, blocking if empty. -takeFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r) - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) -takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . efromJust "takeFromMVar") +takeFromMVar :: (MonadDejaFu n, HasCallStack) + => ModelMVar n a + -> (a -> Action n) + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) +takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . efromJust) -- | Try to take from a @MVar@, not blocking if empty. -tryTakeFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r) - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) +tryTakeFromMVar :: MonadDejaFu n + => ModelMVar n a + -> (Maybe a -> Action n) + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) tryTakeFromMVar = seeMVar Emptying NonBlocking -- | Mutate a @MVar@, in either a blocking or nonblocking way. -mutMVar :: MonadRef r n - => Blocking -> MVar r a -> a -> (Bool -> Action n r) - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) -mutMVar blocking (MVar cvid ref) a c threadid threads = do - val <- readRef ref - - case val of - Just _ -> case blocking of - Blocking -> - let threads' = block (OnMVarEmpty cvid) threadid threads - in pure (False, threads', []) - NonBlocking -> - pure (False, goto (c False) threadid threads, []) - - Nothing -> do - writeRef ref $ Just a - let (threads', woken) = wake (OnMVarFull cvid) threads - pure (True, goto (c True) threadid threads', woken) +mutMVar :: MonadDejaFu n + => Blocking + -> ModelMVar n a + -> a + -> (Bool -> Action n) + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) +mutMVar blocking ModelMVar{..} a c threadid threads = readRef mvarRef >>= \case + Just _ -> case blocking of + Blocking -> + let threads' = block (OnMVarEmpty mvarId) threadid threads + in pure (False, threads', [], pure ()) + NonBlocking -> + pure (False, goto (c False) threadid threads, [], pure ()) + Nothing -> do + let effect = writeRef mvarRef $ Just a + let (threads', woken) = wake (OnMVarFull mvarId) threads + effect + pure (True, goto (c True) threadid threads', woken, effect) -- | Read a @MVar@, in either a blocking or nonblocking -- way. -seeMVar :: MonadRef r n - => Emptying -> Blocking -> MVar r a -> (Maybe a -> Action n r) - -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId]) -seeMVar emptying blocking (MVar cvid ref) c threadid threads = do - val <- readRef ref - - case val of - Just _ -> do - case emptying of - Emptying -> writeRef ref Nothing - NonEmptying -> pure () - let (threads', woken) = wake (OnMVarEmpty cvid) threads - pure (True, goto (c val) threadid threads', woken) - - Nothing -> case blocking of - Blocking -> - let threads' = block (OnMVarFull cvid) threadid threads - in pure (False, threads', []) - NonBlocking -> - pure (False, goto (c Nothing) threadid threads, []) +seeMVar :: MonadDejaFu n + => Emptying + -> Blocking + -> ModelMVar n a + -> (Maybe a -> Action n) + -> ThreadId + -> Threads n + -> n (Bool, Threads n, [ThreadId], n ()) +seeMVar emptying blocking ModelMVar{..} c threadid threads = readRef mvarRef >>= \case + val@(Just _) -> do + let effect = case emptying of + Emptying -> writeRef mvarRef Nothing + NonEmptying -> pure () + let (threads', woken) = wake (OnMVarEmpty mvarId) threads + effect + pure (True, goto (c val) threadid threads', woken, effect) + Nothing -> case blocking of + Blocking -> + let threads' = block (OnMVarFull mvarId) threadid threads + in pure (False, threads', [], pure ()) + NonBlocking -> + pure (False, goto (c Nothing) threadid threads, [], pure ()) diff --git a/Test/DejaFu/Conc/Internal/Program.hs b/Test/DejaFu/Conc/Internal/Program.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/Conc/Internal/Program.hs @@ -0,0 +1,377 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- GHC doesn't need this to compile the module, but stylish-haskell +-- does to format it. +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Test.DejaFu.Conc.Internal.Program +-- Copyright : (c) 2019--2021 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, FlexibleContexts, FlexibleInstances, GADTs, LambdaCase, RecordWildCards, TypeFamilies +-- +-- Representations of concurrent programs with setup, teardown, and +-- snapshotting. This module is NOT considered to form part of the +-- public interface of this library. +-- +-- This module defines orphan instances for the 'Program' type which +-- lives in "Test.DejaFu.Conc.Internal.Common", to avoid needing to +-- pull a bunch more stuff into that module. +module Test.DejaFu.Conc.Internal.Program where + +import Control.Applicative (Applicative(..)) +import Control.Exception (MaskingState(..)) +import qualified Control.Monad.Catch as Ca +import qualified Control.Monad.IO.Class as IO +import Control.Monad.Trans.Class (MonadTrans(..)) +import qualified Data.Foldable as F +import Data.List (partition) +import qualified Data.Map.Strict as M +import Data.Maybe (isNothing) +import GHC.Stack (HasCallStack) + +import qualified Control.Monad.Conc.Class as C +import Test.DejaFu.Conc.Internal +import Test.DejaFu.Conc.Internal.Common +import Test.DejaFu.Conc.Internal.STM (ModelSTM) +import Test.DejaFu.Conc.Internal.Threading (Threads, _blocking) +import Test.DejaFu.Internal +import Test.DejaFu.Schedule +import Test.DejaFu.Types + +------------------------------------------------------------------------------- +-- Expressing concurrent programs + +instance (pty ~ Basic, IO.MonadIO n) => IO.MonadIO (Program pty n) where + liftIO ma = ModelConc (\c -> ALift (fmap c (IO.liftIO ma))) + +instance (pty ~ Basic) => MonadTrans (Program pty) where + lift ma = ModelConc (\c -> ALift (fmap c ma)) + +instance (pty ~ Basic) => Ca.MonadCatch (Program pty n) where + catch ma h = ModelConc (ACatching h ma) + +instance (pty ~ Basic) => Ca.MonadThrow (Program pty n) where + throwM e = ModelConc (\_ -> AThrow e) + +instance (pty ~ Basic) => Ca.MonadMask (Program pty n) where + mask mb = ModelConc (AMasking MaskedInterruptible (\f -> mb f)) + uninterruptibleMask mb = ModelConc (AMasking MaskedUninterruptible (\f -> mb f)) + +#if MIN_VERSION_exceptions(0,10,0) + generalBracket acquire release use = Ca.mask $ \unmasked -> do + resource <- acquire + b <- unmasked (use resource) `Ca.catch` (\e -> release resource (Ca.ExitCaseException e) >> Ca.throwM e) + c <- release resource (Ca.ExitCaseSuccess b) + pure (b, c) +#elif MIN_VERSION_exceptions(0,9,0) + -- from https://github.com/fpco/stackage/issues/3315#issuecomment-368583481 + generalBracket acquire release cleanup use = Ca.mask $ \unmasked -> do + resource <- acquire + result <- unmasked (use resource) `Ca.catch` (\e -> cleanup resource e >> Ca.throwM e) + _ <- release resource + pure result +#endif + +instance (pty ~ Basic, Monad n) => C.MonadConc (Program pty n) where + type MVar (Program pty n) = ModelMVar n + type IORef (Program pty n) = ModelIORef n + type Ticket (Program pty n) = ModelTicket + type STM (Program pty n) = ModelSTM n + type ThreadId (Program pty n) = ThreadId + + -- ---------- + + forkWithUnmaskN n ma = ModelConc (AFork n (\umask -> runModelConc (ma umask) (\_ -> AStop (pure ())))) + forkOnWithUnmaskN n _ = C.forkWithUnmaskN n + forkOSWithUnmaskN n ma = ModelConc (AForkOS n (\umask -> runModelConc (ma umask) (\_ -> AStop (pure ())))) + + supportsBoundThreads = ModelConc ASupportsBoundThreads + isCurrentThreadBound = ModelConc AIsBound + + -- This implementation lies and returns 2 until a value is set. This + -- will potentially avoid special-case behaviour for 1 capability, + -- so it seems a sane choice. + getNumCapabilities = ModelConc AGetNumCapabilities + setNumCapabilities caps = ModelConc (\c -> ASetNumCapabilities caps (c ())) + + myThreadId = ModelConc AMyTId + + yield = ModelConc (\c -> AYield (c ())) + threadDelay n = ModelConc (\c -> ADelay n (c ())) + + -- ---------- + + newIORefN n a = ModelConc (ANewIORef n a) + + readIORef ref = ModelConc (AReadIORef ref) + readForCAS ref = ModelConc (AReadIORefCas ref) + + peekTicket' _ = ticketVal + + writeIORef ref a = ModelConc (\c -> AWriteIORef ref a (c ())) + casIORef ref tick a = ModelConc (ACasIORef ref tick a) + + atomicModifyIORef ref f = ModelConc (AModIORef ref f) + modifyIORefCAS ref f = ModelConc (AModIORefCas ref f) + + -- ---------- + + newEmptyMVarN n = ModelConc (ANewMVar n) + + putMVar var a = ModelConc (\c -> APutMVar var a (c ())) + readMVar var = ModelConc (AReadMVar var) + takeMVar var = ModelConc (ATakeMVar var) + + tryPutMVar var a = ModelConc (ATryPutMVar var a) + tryReadMVar var = ModelConc (ATryReadMVar var) + tryTakeMVar var = ModelConc (ATryTakeMVar var) + + -- ---------- + + throwTo tid e = ModelConc (\c -> AThrowTo tid e (c ())) + + getMaskingState = ModelConc (\c -> AGetMasking c) + + unsafeUnmask ma = ModelConc (AMasking Unmasked (\_ -> ma)) + + -- ---------- + + atomically = ModelConc . AAtom + +------------------------------------------------------------------------------- +-- Executing concurrent programs + +-- | Run a concurrent computation with a given 'Scheduler' and initial +-- state, returning either the final result or the condition which +-- prevented that. Also returned is the final state of the scheduler, +-- and an execution trace. +-- +-- If the RTS supports bound threads (ghc -threaded when linking) then +-- the main thread of the concurrent computation will be bound, and +-- @forkOS@ / @forkOSN@ will work during execution. If not, then the +-- main thread will not be found, and attempting to fork a bound +-- thread will raise an error. +-- +-- __Warning:__ Blocking on the action of another thread in 'liftIO' +-- cannot be detected! So if you perform some potentially blocking +-- action in a 'liftIO' the entire collection of threads may deadlock! +-- You should therefore keep @IO@ blocks small, and only perform +-- blocking operations with the supplied primitives, insofar as +-- possible. +-- +-- __Note:__ In order to prevent computation from hanging, the runtime +-- will assume that a deadlock situation has arisen if the scheduler +-- attempts to (a) schedule a blocked thread, or (b) schedule a +-- nonexistent thread. In either of those cases, the computation will +-- be halted. +-- +-- @since 2.1.0.0 +runConcurrent :: MonadDejaFu n + => Scheduler s + -> MemType + -> s + -> Program pty n a + -> n (Either Condition a, s, Trace) +runConcurrent sched memtype s ma@(ModelConc _) = do + res <- runConcurrency [] False sched memtype s initialIdSource 2 ma + out <- efromJust <$> readRef (finalRef res) + pure ( out + , cSchedState (finalContext res) + , F.toList (finalTrace res) + ) +runConcurrent sched memtype s ma = recordSnapshot ma >>= \case + Just (Left cond, trc) -> pure (Left cond, s, trc) + Just (Right snap, _) -> runSnapshot sched memtype s snap + Nothing -> fatal "failed to record snapshot!" + +-- | Runs any setup action and returns a 'Snapshot' which can be +-- passed to 'runSnapshot'. If there is no setup action (this is a +-- @Program Basic@, then @Nothing@ is returned. The snapshot captures +-- the state at the end of the setup, so the full program can be run +-- multiple times without repeating the setup. +-- +-- The setup action is executed atomically with a deterministic +-- scheduler under sequential consistency. Any forked threads +-- continue to exist in the main program. +-- +-- If the setup action does not successfully produce a value +-- (deadlock, uncaught exception, etc), no snapshot is produced. +-- +-- __Snapshotting @IO@:__ A snapshot captures entire state of your +-- concurrent program: the state of every thread, the number of +-- capabilities, the values of any @IORef@s, @MVar@s, and @TVar@s, and +-- records any @IO@ that you performed. +-- +-- When restoring a snapshot this @IO@ is replayed, in order. But the +-- whole snapshotted computation is not. So the effects of the @IO@ +-- take place again, but any return values are ignored. For example, +-- this program will not do what you want: +-- +-- @ +-- bad_snapshot = withSetup +-- (do r <- liftIO (newIORef 0) +-- liftIO (modifyIORef r (+1)) +-- pure r) +-- (liftIO . readIORef) +-- @ +-- +-- When the snapshot is taken, the value in the @IORef@ will be 1. +-- When the snapshot is restored for the first time, those @IO@ +-- actions will be run again, /but their return values will be +-- discarded/. The value in the @IORef@ will be 2. When the snapshot +-- is restored for the second time, the value in the @IORef@ will be +-- 3. And so on. +-- +-- To safely use @IO@ in a snapshotted computation, __the combined +-- effect must be idempotent__. You should either use actions which +-- set the state to the final value directly, rather than modifying it +-- (eg, using a combination of @liftIO . readIORef@ and @liftIO +-- . writeIORef@ here), or reset the state to a known value. Both of +-- these approaches will work: +-- +-- @ +-- good_snapshot1 = withSetup +-- (do let modify r f = liftIO (readIORef r) >>= liftIO . writeIORef r . f +-- r <- liftIO (newIORef 0) +-- modify r (+1) +-- pure r) +-- (liftIO . readIORef) +-- +-- good_snapshot2 = withSetup +-- (do r <- liftIO (newIORef 0) +-- liftIO (writeIORef r 0) +-- liftIO (modifyIORef r (+1)) +-- pure r) +-- (liftIO . readIORef) +-- @ +-- +-- @since 2.1.0.0 +recordSnapshot + :: MonadDejaFu n + => Program pty n a + -> n (Maybe (Either Condition (Snapshot pty n a), Trace)) +recordSnapshot ModelConc{} = pure Nothing +recordSnapshot WithSetup{..} = + let mkSnapshot snap _ = WS snap + in defaultRecordSnapshot mkSnapshot wsSetup wsProgram +recordSnapshot WithSetupAndTeardown{..} = + let mkSnapshot snap = WSAT snap . wstTeardown + in defaultRecordSnapshot mkSnapshot wstSetup wstProgram + +-- | Runs a program with snapshotted setup to completion. +-- +-- @since 2.1.0.0 +runSnapshot + :: MonadDejaFu n + => Scheduler s + -> MemType + -> s + -> Snapshot pty n a + -> n (Either Condition a, s, Trace) +runSnapshot sched memtype s (WS SimpleSnapshot{..}) = do + let context = fromSnapContext s snapContext + CResult{..} <- runConcurrencyWithSnapshot sched memtype context snapRestore snapNext + out <- efromJust <$> readRef finalRef + pure ( out + , cSchedState finalContext + , F.toList finalTrace + ) +runSnapshot sched memtype s (WSAT SimpleSnapshot{..} teardown) = do + let context = fromSnapContext s snapContext + intermediateResult <- runConcurrencyWithSnapshot sched memtype context snapRestore snapNext + let idsrc = cIdSource (finalContext intermediateResult) + out1 <- efromJust <$> readRef (finalRef intermediateResult) + teardownResult <- simpleRunConcurrency False idsrc (teardown out1) + out2 <- efromJust <$> readRef (finalRef teardownResult) + pure ( out2 + , cSchedState (finalContext intermediateResult) + , F.toList (finalTrace intermediateResult) + ) + +------------------------------------------------------------------------------- +-- Snapshotting + +-- | A record of the state of a concurrent program immediately after +-- completing the setup action. +-- +-- @since 2.0.0.0 +data Snapshot pty n a where + WS :: SimpleSnapshot n a -> Snapshot (WithSetup x) n a + WSAT :: SimpleSnapshot n a -> (Either Condition a -> ModelConc n y) -> Snapshot (WithSetupAndTeardown x a) n y + +data SimpleSnapshot n a = SimpleSnapshot + { snapContext :: Context n () + , snapRestore :: Threads n -> n () + , snapNext :: ModelConc n a + } + +-- | Get the 'Context' from a 'Snapshot'. +contextFromSnapshot :: Snapshot p n a -> Context n () +contextFromSnapshot (WS SimpleSnapshot{..}) = snapContext +contextFromSnapshot (WSAT SimpleSnapshot{..} _) = snapContext + +-- | Get the threads which exist in a snapshot, partitioned into +-- runnable and not runnable. +threadsFromSnapshot :: Snapshot p n a -> ([ThreadId], [ThreadId]) +threadsFromSnapshot snap = (initialThread : runnable, blocked) where + (runnable, blocked) = partition isRunnable (M.keys threads) + threads = cThreads (contextFromSnapshot snap) + isRunnable tid = isNothing (_blocking =<< M.lookup tid threads) + +-- | 'recordSnapshot' implemented generically. +-- +-- Throws an error if the snapshot could not be produced. +defaultRecordSnapshot :: MonadDejaFu n + => (SimpleSnapshot n a -> x -> snap) + -> ModelConc n x + -> (x -> ModelConc n a) + -> n (Maybe (Either Condition snap, Trace)) +defaultRecordSnapshot mkSnapshot setup program = do + CResult{..} <- simpleRunConcurrency True initialIdSource setup + let trc = F.toList finalTrace + out <- readRef finalRef + pure . Just $ case out of + Just (Right a) -> + let snap = mkSnapshot (SimpleSnapshot finalContext finalRestore (program a)) a + in (Right snap, trc) + Just (Left f) -> (Left f, trc) + -- alternative behaviour: return @Nothing@ here. but this should + -- never fail, so it should be an error if it does. + Nothing -> fatal "failed to produce snapshot" + +------------------------------------------------------------------------------- +-- Utilities + +-- | Run a concurrent program with a deterministic scheduler in +-- snapshotting or non-snapshotting mode. +simpleRunConcurrency ::(MonadDejaFu n, HasCallStack) + => Bool + -> IdSource + -> ModelConc n a + -> n (CResult n () a) +simpleRunConcurrency forSnapshot idsrc = + runConcurrency [] forSnapshot roundRobinSchedNP SequentialConsistency () idsrc 2 + +-- | Make a new context from a snapshot context. +fromSnapContext :: g -> Context n s -> Context n g +fromSnapContext g ctx@Context{..} = ctx + { cSchedState = g + , cInvariants = InvariantContext + { icActive = cNewInvariants + , icBlocked = [] + } + , cNewInvariants = [] + } + +wrap :: (((a -> Action n) -> Action n) -> ((a -> Action n) -> Action n)) -> ModelConc n a -> ModelConc n a +wrap f = ModelConc . f . runModelConc diff --git a/Test/DejaFu/Conc/Internal/STM.hs b/Test/DejaFu/Conc/Internal/STM.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/Conc/Internal/STM.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- Must come after TypeFamilies +{-# LANGUAGE NoMonoLocalBinds #-} + +-- | +-- Module : Test.DejaFu.Conc.Internal.STM +-- Copyright : (c) 2017--2019 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, ExistentialQuantification, NoMonoLocalBinds, RecordWildCards, TypeFamilies +-- +-- 'MonadSTM' testing implementation, internal types and definitions. +-- This module is NOT considered to form part of the public interface +-- of this library. +module Test.DejaFu.Conc.Internal.STM where + +import Control.Applicative (Alternative(..)) +import Control.Exception (Exception, SomeException, + fromException, toException) +import Control.Monad (MonadPlus(..)) +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import qualified Control.Monad.Fail as Fail +import qualified Control.Monad.STM.Class as S +import Data.List (nub) + +import Test.DejaFu.Internal +import Test.DejaFu.Types + +-------------------------------------------------------------------------------- +-- * The @ModelSTM@ monad + +-- | The underlying monad is based on continuations over primitive +-- actions. +-- +-- This is not @Cont@ because we want to give it a custom @MonadFail@ +-- instance. +newtype ModelSTM n a = ModelSTM { runModelSTM :: (a -> STMAction n) -> STMAction n } + +instance Functor (ModelSTM n) where + fmap f m = ModelSTM $ \c -> runModelSTM m (c . f) + +instance Applicative (ModelSTM n) where + pure x = ModelSTM $ \c -> c x + f <*> v = ModelSTM $ \c -> runModelSTM f (\g -> runModelSTM v (c . g)) + +instance Monad (ModelSTM n) where + return = pure + m >>= k = ModelSTM $ \c -> runModelSTM m (\x -> runModelSTM (k x) c) + +#if MIN_VERSION_base(4,13,0) +#else + fail = Fail.fail +#endif + +instance Fail.MonadFail (ModelSTM n) where + fail e = ModelSTM $ \_ -> SThrow (MonadFailException e) + +instance MonadThrow (ModelSTM n) where + throwM e = ModelSTM $ \_ -> SThrow e + +instance MonadCatch (ModelSTM n) where + catch stm handler = ModelSTM $ SCatch handler stm + +instance Alternative (ModelSTM n) where + a <|> b = ModelSTM $ SOrElse a b + empty = ModelSTM $ const SRetry + +instance MonadPlus (ModelSTM n) + +instance S.MonadSTM (ModelSTM n) where + type TVar (ModelSTM n) = ModelTVar n + + newTVarN n = ModelSTM . SNew n + + readTVar = ModelSTM . SRead + + writeTVar tvar a = ModelSTM $ \c -> SWrite tvar a (c ()) + +-------------------------------------------------------------------------------- +-- * Primitive actions + +-- | STM transactions are represented as a sequence of primitive +-- actions. +data STMAction n + = forall a e. Exception e => SCatch (e -> ModelSTM n a) (ModelSTM n a) (a -> STMAction n) + | forall a. SRead (ModelTVar n a) (a -> STMAction n) + | forall a. SWrite (ModelTVar n a) a (STMAction n) + | forall a. SOrElse (ModelSTM n a) (ModelSTM n a) (a -> STMAction n) + | forall a. SNew String a (ModelTVar n a -> STMAction n) + | forall e. Exception e => SThrow e + | SRetry + | SStop (n ()) + +-------------------------------------------------------------------------------- +-- * @TVar@s + +-- | A @TVar@ is modelled as a unique ID and a reference holding a +-- value. +data ModelTVar n a = ModelTVar + { tvarId :: TVarId + , tvarRef :: Ref n a + } + +-------------------------------------------------------------------------------- +-- * Output + +-- | The result of an STM transaction, along with which 'TVar's it +-- touched whilst executing. +data Result a = + Success [TVarId] [TVarId] a + -- ^ The transaction completed successfully, reading the first list + -- 'TVar's and writing to the second. + | Retry [TVarId] + -- ^ The transaction aborted by calling 'retry', and read the + -- returned 'TVar's. It should be retried when at least one of the + -- 'TVar's has been mutated. + | Exception SomeException + -- ^ The transaction aborted by throwing an exception. + deriving Show + + +-------------------------------------------------------------------------------- +-- * Execution + +-- | Run a transaction, returning the result and new initial 'TVarId'. +-- If the transaction failed, any effects are undone. +runTransaction :: MonadDejaFu n + => ModelSTM n a + -> IdSource + -> n (Result a, n (), IdSource, [TAction]) +runTransaction ma tvid = do + (res, effect, _, tvid', trace) <- doTransaction ma tvid + pure (res, effect, tvid', trace) + +-- | Run a STM transaction, returning an action to undo its effects. +-- +-- If the transaction fails, its effects will automatically be undone, +-- so the undo action returned will be @pure ()@. +doTransaction :: MonadDejaFu n + => ModelSTM n a + -> IdSource + -> n (Result a, n (), n (), IdSource, [TAction]) +doTransaction ma idsource = do + (c, ref) <- runRefCont SStop (Just . Right) (runModelSTM ma) + (idsource', effect, undo, readen, written, trace) <- go ref c (pure ()) (pure ()) idsource [] [] [] + res <- readRef ref + + case res of + Just (Right val) -> pure (Success (nub readen) (nub written) val, effect, undo, idsource', reverse trace) + Just (Left exc) -> undo >> pure (Exception exc, pure (), pure (), idsource, reverse trace) + Nothing -> undo >> pure (Retry $ nub readen, pure (), pure (), idsource, reverse trace) + + where + go ref act effect undo nidsrc readen written sofar = do + (act', effect', undo', nidsrc', readen', written', tact) <- stepTrans act nidsrc + + let newIDSource = nidsrc' + newAct = act' + newEffect = effect >> effect' + newUndo = undo' >> undo + newReaden = readen' ++ readen + newWritten = written' ++ written + newSofar = tact : sofar + + case tact of + TStop -> pure (newIDSource, newEffect, newUndo, newReaden, newWritten, TStop:newSofar) + TRetry -> do + writeRef ref Nothing + pure (newIDSource, newEffect, newUndo, newReaden, newWritten, TRetry:newSofar) + TThrow -> do + writeRef ref (Just . Left $ case act of SThrow e -> toException e; _ -> undefined) + pure (newIDSource, newEffect, newUndo, newReaden, newWritten, TThrow:newSofar) + _ -> go ref newAct newEffect newUndo newIDSource newReaden newWritten newSofar + +-- | Run a transaction for one step. +stepTrans :: MonadDejaFu n + => STMAction n + -> IdSource + -> n (STMAction n, n (), n (), IdSource, [TVarId], [TVarId], TAction) +stepTrans act idsource = case act of + SCatch h stm c -> stepCatch h stm c + SRead ref c -> stepRead ref c + SWrite ref a c -> stepWrite ref a c + SNew n a c -> stepNew n a c + SOrElse a b c -> stepOrElse a b c + SStop na -> stepStop na + + SThrow e -> pure (SThrow e, nothing, nothing, idsource, [], [], TThrow) + SRetry -> pure (SRetry, nothing, nothing, idsource, [], [], TRetry) + + where + nothing = pure () + + stepCatch h stm c = cases TCatch stm c + (\trace -> pure (SRetry, nothing, nothing, idsource, [], [], TCatch trace Nothing)) + (\trace exc -> case fromException exc of + Just exc' -> transaction (TCatch trace . Just) (h exc') c + Nothing -> pure (SThrow exc, nothing, nothing, idsource, [], [], TCatch trace Nothing)) + + stepRead ModelTVar{..} c = do + val <- readRef tvarRef + pure (c val, nothing, nothing, idsource, [tvarId], [], TRead tvarId) + + stepWrite ModelTVar{..} a c = do + old <- readRef tvarRef + writeRef tvarRef a + pure (c, writeRef tvarRef a, writeRef tvarRef old, idsource, [], [tvarId], TWrite tvarId) + + stepNew n a c = do + let (idsource', tvid) = nextTVId n idsource + ref <- newRef a + let tvar = ModelTVar tvid ref + pure (c tvar, writeRef ref a, nothing, idsource', [], [tvid], TNew tvid) + + stepOrElse a b c = cases TOrElse a c + (\trace -> transaction (TOrElse trace . Just) b c) + (\trace exc -> pure (SThrow exc, nothing, nothing, idsource, [], [], TOrElse trace Nothing)) + + stepStop na = do + na + pure (SStop na, nothing, nothing, idsource, [], [], TStop) + + cases tact stm onSuccess onRetry onException = do + (res, effect, undo, idsource', trace) <- doTransaction stm idsource + case res of + Success readen written val -> pure (onSuccess val, effect, undo, idsource', readen, written, tact trace Nothing) + Retry readen -> do + (res', effect', undo', idsource'', readen', written', trace') <- onRetry trace + pure (res', effect', undo', idsource'', readen ++ readen', written', trace') + Exception exc -> onException trace exc + + transaction tact stm onSuccess = cases (\t _ -> tact t) stm onSuccess + (\trace -> pure (SRetry, nothing, nothing, idsource, [], [], tact trace)) + (\trace exc -> pure (SThrow exc, nothing, nothing, idsource, [], [], tact trace)) diff --git a/Test/DejaFu/Conc/Internal/Threading.hs b/Test/DejaFu/Conc/Internal/Threading.hs --- a/Test/DejaFu/Conc/Internal/Threading.hs +++ b/Test/DejaFu/Conc/Internal/Threading.hs @@ -1,13 +1,14 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.DejaFu.Conc.Internal.Threading --- Copyright : (c) 2016 Michael Walker +-- Copyright : (c) 2016--2020 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : ExistentialQuantification, RankNTypes +-- Portability : ExistentialQuantification, FlexibleContexts, RankNTypes -- -- Operations and types for threads. This module is NOT considered to -- form part of the public interface of this library. @@ -17,34 +18,37 @@ SomeException, fromException) import Data.List (intersect) import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe (isJust) +import GHC.Stack (HasCallStack) -import Test.DejaFu.Common import Test.DejaFu.Conc.Internal.Common - -import qualified Data.Map.Strict as M +import Test.DejaFu.Internal +import Test.DejaFu.Types -------------------------------------------------------------------------------- -- * Threads -- | Threads are stored in a map index by 'ThreadId'. -type Threads n r = Map ThreadId (Thread n r) +type Threads n = Map ThreadId (Thread n) -- | All the state of a thread. -data Thread n r = Thread - { _continuation :: Action n r +data Thread n = Thread + { _continuation :: Action n -- ^ The next action to execute. , _blocking :: Maybe BlockedOn -- ^ The state of any blocks. - , _handlers :: [Handler n r] + , _handlers :: [Handler n] -- ^ Stack of exception handlers , _masking :: MaskingState -- ^ The exception masking state. + , _bound :: Maybe (BoundThread n (Action n)) + -- ^ State for the associated bound thread, if it exists. } -- | Construct a thread with just one action -mkthread :: Action n r -> Thread n r -mkthread c = Thread c Nothing [] Unmasked +mkthread :: Action n -> Thread n +mkthread c = Thread c Nothing [] Unmasked Nothing -------------------------------------------------------------------------------- -- * Blocking @@ -54,7 +58,7 @@ data BlockedOn = OnMVarFull MVarId | OnMVarEmpty MVarId | OnTVar [TVarId] | OnMask ThreadId deriving Eq -- | Determine if a thread is blocked in a certain way. -(~=) :: Thread n r -> BlockedOn -> Bool +(~=) :: Thread n -> BlockedOn -> Bool thread ~= theblock = case (_blocking thread, theblock) of (Just (OnMVarFull _), OnMVarFull _) -> True (Just (OnMVarEmpty _), OnMVarEmpty _) -> True @@ -66,79 +70,79 @@ -- * Exceptions -- | An exception handler. -data Handler n r = forall e. Exception e => Handler (e -> MaskingState -> Action n r) +data Handler n = forall e. Exception e => Handler MaskingState (e -> Action n) -- | Propagate an exception upwards, finding the closest handler -- which can deal with it. -propagate :: SomeException -> ThreadId -> Threads n r -> Maybe (Threads n r) -propagate e tid threads = case M.lookup tid threads >>= go . _handlers of - Just (act, hs) -> Just $ except act hs tid threads - Nothing -> Nothing +propagate :: HasCallStack => SomeException -> ThreadId -> Threads n -> Maybe (Threads n) +propagate e tid threads = raise <$> propagate' handlers where + handlers = _handlers (elookup tid threads) - where - go [] = Nothing - go (Handler h:hs) = maybe (go hs) (\act -> Just (act, hs)) $ h <$> fromException e + raise (ms, act, hs) = except ms act hs tid threads + propagate' [] = Nothing + propagate' (Handler ms h:hs) = maybe (propagate' hs) ((\act -> Just (ms, act, hs)) . h) (fromException e) + -- | Check if a thread can be interrupted by an exception. -interruptible :: Thread n r -> Bool -interruptible thread = _masking thread == Unmasked || (_masking thread == MaskedInterruptible && isJust (_blocking thread)) +interruptible :: Thread n -> Bool +interruptible thread = + _masking thread == Unmasked || + (_masking thread == MaskedInterruptible && isJust (_blocking thread)) -- | Register a new exception handler. -catching :: Exception e => (e -> Action n r) -> ThreadId -> Threads n r -> Threads n r -catching h = M.adjust $ \thread -> +catching :: (Exception e, HasCallStack) => (e -> Action n) -> ThreadId -> Threads n -> Threads n +catching h = eadjust $ \thread -> let ms0 = _masking thread - h' = Handler $ \e ms -> (if ms /= ms0 then AResetMask False False ms0 else id) (h e) + h' = Handler ms0 h in thread { _handlers = h' : _handlers thread } -- | Remove the most recent exception handler. -uncatching :: ThreadId -> Threads n r -> Threads n r -uncatching = M.adjust $ \thread -> thread { _handlers = etail "uncatching" (_handlers thread) } +uncatching :: HasCallStack => ThreadId -> Threads n -> Threads n +uncatching = eadjust $ \thread -> + thread { _handlers = etail (_handlers thread) } -- | Raise an exception in a thread. -except :: (MaskingState -> Action n r) -> [Handler n r] -> ThreadId -> Threads n r -> Threads n r -except actf hs = M.adjust $ \thread -> thread - { _continuation = actf (_masking thread) +except :: HasCallStack => MaskingState -> Action n -> [Handler n] -> ThreadId -> Threads n -> Threads n +except ms act hs = eadjust $ \thread -> thread + { _continuation = act + , _masking = ms , _handlers = hs , _blocking = Nothing } -- | Set the masking state of a thread. -mask :: MaskingState -> ThreadId -> Threads n r -> Threads n r -mask ms = M.adjust $ \thread -> thread { _masking = ms } +mask :: HasCallStack => MaskingState -> ThreadId -> Threads n -> Threads n +mask ms = eadjust $ \thread -> thread { _masking = ms } -------------------------------------------------------------------------------- -- * Manipulating threads -- | Replace the @Action@ of a thread. -goto :: Action n r -> ThreadId -> Threads n r -> Threads n r -goto a = M.adjust $ \thread -> thread { _continuation = a } +goto :: HasCallStack => Action n -> ThreadId -> Threads n -> Threads n +goto a = eadjust $ \thread -> thread { _continuation = a } -- | Start a thread with the given ID, inheriting the masking state -- from the parent thread. This ID must not already be in use! -launch :: ThreadId -> ThreadId -> ((forall b. M n r b -> M n r b) -> Action n r) -> Threads n r -> Threads n r +launch :: HasCallStack => ThreadId -> ThreadId -> ((forall b. ModelConc n b -> ModelConc n b) -> Action n) -> Threads n -> Threads n launch parent tid a threads = launch' ms tid a threads where - ms = maybe Unmasked _masking (M.lookup parent threads) + ms = _masking (elookup parent threads) -- | Start a thread with the given ID and masking state. This must not already be in use! -launch' :: MaskingState -> ThreadId -> ((forall b. M n r b -> M n r b) -> Action n r) -> Threads n r -> Threads n r -launch' ms tid a = M.insert tid thread where - thread = Thread { _continuation = a umask, _blocking = Nothing, _handlers = [], _masking = ms } +launch' :: HasCallStack => MaskingState -> ThreadId -> ((forall b. ModelConc n b -> ModelConc n b) -> Action n) -> Threads n -> Threads n +launch' ms tid a = einsert tid thread where + thread = Thread (a umask) Nothing [] ms Nothing umask mb = resetMask True Unmasked >> mb >>= \b -> resetMask False ms >> pure b - resetMask typ m = cont $ \k -> AResetMask typ True m $ k () - --- | Kill a thread. -kill :: ThreadId -> Threads n r -> Threads n r -kill = M.delete + resetMask typ m = ModelConc $ \k -> AResetMask typ True m $ k () -- | Block a thread. -block :: BlockedOn -> ThreadId -> Threads n r -> Threads n r -block blockedOn = M.adjust $ \thread -> thread { _blocking = Just blockedOn } +block :: HasCallStack => BlockedOn -> ThreadId -> Threads n -> Threads n +block blockedOn = eadjust $ \thread -> thread { _blocking = Just blockedOn } -- | Unblock all threads waiting on the appropriate block. For 'TVar' -- blocks, this will wake all threads waiting on at least one of the -- given 'TVar's. -wake :: BlockedOn -> Threads n r -> (Threads n r, [ThreadId]) +wake :: BlockedOn -> Threads n -> (Threads n, [ThreadId]) wake blockedOn threads = (unblock <$> threads, M.keys $ M.filter isBlocked threads) where unblock thread | isBlocked thread = thread { _blocking = Nothing } @@ -147,3 +151,29 @@ isBlocked thread = case (_blocking thread, blockedOn) of (Just (OnTVar tvids), OnTVar blockedOn') -> tvids `intersect` blockedOn' /= [] (theblock, _) -> theblock == Just blockedOn + +------------------------------------------------------------------------------- +-- ** Bound threads + +-- | Turn a thread into a bound thread. +makeBound :: (MonadDejaFu n, HasCallStack) + => n (BoundThread n (Action n)) -> ThreadId -> Threads n -> n (Threads n) +makeBound fbt tid threads = do + bt <- fbt + pure (eadjust (\t -> t { _bound = Just bt }) tid threads) + +-- | Kill a thread and remove it from the thread map. +-- +-- If the thread is bound, the worker thread is cleaned up. +kill :: (MonadDejaFu n, HasCallStack) => ThreadId -> Threads n -> n (Threads n) +kill tid threads = do + let thread = elookup tid threads + maybe (pure ()) killBoundThread (_bound thread) + pure (M.delete tid threads) +-- | Run an action. +-- +-- If the thread is bound, the action is run in the worker thread. +runLiftedAct :: MonadDejaFu n => ThreadId -> Threads n -> n (Action n) -> n (Action n) +runLiftedAct tid threads ma = case _bound =<< M.lookup tid threads of + Just bt -> runInBoundThread bt ma + Nothing -> ma diff --git a/Test/DejaFu/Defaults.hs b/Test/DejaFu/Defaults.hs deleted file mode 100644 --- a/Test/DejaFu/Defaults.hs +++ /dev/null @@ -1,69 +0,0 @@ --- | --- Module : Test.DejaFu.Defaults --- Copyright : (c) 2017 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : portable --- --- Default parameters for test execution. -module Test.DejaFu.Defaults where - -import Test.DejaFu.Common -import Test.DejaFu.SCT - --- | A default way to execute concurrent programs: systematically --- using 'defaultBounds'. --- --- @since 0.6.0.0 -defaultWay :: Way -defaultWay = systematically defaultBounds - --- | Do not discard any results. --- --- @since 0.7.1.0 -defaultDiscarder :: Either Failure a -> Maybe Discard -defaultDiscarder = const Nothing - --- | The default memory model: @TotalStoreOrder@ --- --- @since 0.2.0.0 -defaultMemType :: MemType -defaultMemType = TotalStoreOrder - --- | All bounds enabled, using their default values. --- --- @since 0.2.0.0 -defaultBounds :: Bounds -defaultBounds = Bounds - { boundPreemp = Just defaultPreemptionBound - , boundFair = Just defaultFairBound - , boundLength = Just defaultLengthBound - } - --- | A sensible default preemption bound: 2. --- --- See /Concurrency Testing Using Schedule Bounding: an Empirical Study/, --- P. Thomson, A. F. Donaldson, A. Betts for justification. --- --- @since 0.2.0.0 -defaultPreemptionBound :: PreemptionBound -defaultPreemptionBound = 2 - --- | A sensible default fair bound: 5. --- --- This comes from playing around myself, but there is probably a --- better default. --- --- @since 0.2.0.0 -defaultFairBound :: FairBound -defaultFairBound = 5 - --- | A sensible default length bound: 250. --- --- Based on the assumption that anything which executes for much --- longer (or even this long) will take ages to test. --- --- @since 0.2.0.0 -defaultLengthBound :: LengthBound -defaultLengthBound = 250 diff --git a/Test/DejaFu/Internal.hs b/Test/DejaFu/Internal.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/Internal.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module : Test.DejaFu.Internal +-- Copyright : (c) 2017--2020 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : DeriveAnyClass, DeriveGeneric, FlexibleContexts, GADTs, LambdaCase +-- +-- Internal types and functions used throughout DejaFu. This module +-- is NOT considered to form part of the public interface of this +-- library. +module Test.DejaFu.Internal where + +import Control.DeepSeq (NFData(..)) +import Control.Exception (MaskingState(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import System.Random (RandomGen) + +import Test.DejaFu.Types + +------------------------------------------------------------------------------- +-- * SCT settings + +-- | SCT configuration record. +-- +-- @since 1.2.0.0 +data Settings n a = Settings + { _way :: Way + , _lengthBound :: Maybe LengthBound + , _memtype :: MemType + , _discard :: Maybe (Either Condition a -> Maybe Discard) + , _debugShow :: Maybe (a -> String) + , _debugPrint :: Maybe (String -> n ()) + , _debugFatal :: Bool + , _earlyExit :: Maybe (Either Condition a -> Bool) + , _equality :: Maybe (a -> a -> Bool) + , _simplify :: Bool + , _safeIO :: Bool + , _showAborts :: Bool + } + +-- | How to explore the possible executions of a concurrent program. +-- +-- @since 0.7.0.0 +data Way where + Systematic :: Bounds -> Way + Randomly :: RandomGen g => (g -> (Int, g)) -> g -> Int -> Way + +instance Show Way where + show (Systematic bs) = "Systematic (" ++ show bs ++ ")" + show (Randomly _ _ n) = "Randomly " ++ show n + +------------------------------------------------------------------------------- +-- * Identifiers + +-- | The number of ID parameters was getting a bit unwieldy, so this +-- hides them all away. +data IdSource = IdSource + { _iorids :: (Int, [String]) + , _mvids :: (Int, [String]) + , _tvids :: (Int, [String]) + , _tids :: (Int, [String]) + } deriving (Eq, Ord, Show, Generic, NFData) + +-- | Get the next free 'IORefId'. +nextIORId :: String -> IdSource -> (IdSource, IORefId) +nextIORId name idsource = + let (iorid, iorids') = nextId name (_iorids idsource) + in (idsource { _iorids = iorids' }, IORefId iorid) + +-- | Get the next free 'MVarId'. +nextMVId :: String -> IdSource -> (IdSource, MVarId) +nextMVId name idsource = + let (mvid, mvids') = nextId name (_mvids idsource) + in (idsource { _mvids = mvids' }, MVarId mvid) + +-- | Get the next free 'TVarId'. +nextTVId :: String -> IdSource -> (IdSource, TVarId) +nextTVId name idsource = + let (tvid, tvids') = nextId name (_tvids idsource) + in (idsource { _tvids = tvids' }, TVarId tvid) + +-- | Get the next free 'ThreadId'. +nextTId :: String -> IdSource -> (IdSource, ThreadId) +nextTId name idsource = + let (tid, tids') = nextId name (_tids idsource) + in (idsource { _tids = tids' }, ThreadId tid) + +-- | Helper for @next*@ +nextId :: String -> (Int, [String]) -> (Id, (Int, [String])) +nextId name (num, used) = (Id newName (num+1), (num+1, newUsed)) where + newName + | null name = Nothing + | occurrences > 0 = Just (name ++ "-" ++ show occurrences) + | otherwise = Just name + newUsed + | null name = used + | otherwise = name : used + occurrences = length (filter (==name) used) + +-- | The initial ID source. +initialIdSource :: IdSource +initialIdSource = IdSource (0, []) (0, []) (0, []) (0, []) + +------------------------------------------------------------------------------- +-- * Actions + +-- | Check if a @ThreadAction@ immediately blocks. +isBlock :: ThreadAction -> Bool +isBlock (BlockedThrowTo _) = True +isBlock (BlockedTakeMVar _) = True +isBlock (BlockedReadMVar _) = True +isBlock (BlockedPutMVar _) = True +isBlock (BlockedSTM _) = True +isBlock _ = False + +-- | Get the @TVar@s affected by a @ThreadAction@. +tvarsOf :: ThreadAction -> Set TVarId +tvarsOf act = tvarsRead act `S.union` tvarsWritten act + +-- | Get the @TVar@s a transaction wrote to (or would have, if it +-- didn't @retry@). +tvarsWritten :: ThreadAction -> Set TVarId +tvarsWritten act = S.fromList $ case act of + STM trc _ -> concatMap tvarsOf' trc + ThrownSTM trc _ -> concatMap tvarsOf' trc + BlockedSTM trc -> concatMap tvarsOf' trc + _ -> [] + + where + tvarsOf' (TNew tv) = [tv] + tvarsOf' (TWrite tv) = [tv] + tvarsOf' (TOrElse ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) + tvarsOf' (TCatch ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) + tvarsOf' _ = [] + +-- | Get the @TVar@s a transaction read from. +tvarsRead :: ThreadAction -> Set TVarId +tvarsRead act = S.fromList $ case act of + STM trc _ -> concatMap tvarsOf' trc + ThrownSTM trc _ -> concatMap tvarsOf' trc + BlockedSTM trc -> concatMap tvarsOf' trc + _ -> [] + + where + tvarsOf' (TRead tv) = [tv] + tvarsOf' (TOrElse ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) + tvarsOf' (TCatch ta tb) = concatMap tvarsOf' (ta ++ fromMaybe [] tb) + tvarsOf' _ = [] + +-- | Convert a 'ThreadAction' into a 'Lookahead': \"rewind\" what has +-- happened. +rewind :: ThreadAction -> Lookahead +rewind (Fork _) = WillFork +rewind (ForkOS _) = WillForkOS +rewind (SupportsBoundThreads _) = WillSupportsBoundThreads +rewind (IsCurrentThreadBound _) = WillIsCurrentThreadBound +rewind MyThreadId = WillMyThreadId +rewind (GetNumCapabilities _) = WillGetNumCapabilities +rewind (SetNumCapabilities i) = WillSetNumCapabilities i +rewind Yield = WillYield +rewind (ThreadDelay n) = WillThreadDelay n +rewind (NewMVar _) = WillNewMVar +rewind (PutMVar c _) = WillPutMVar c +rewind (BlockedPutMVar c) = WillPutMVar c +rewind (TryPutMVar c _ _) = WillTryPutMVar c +rewind (ReadMVar c) = WillReadMVar c +rewind (BlockedReadMVar c) = WillReadMVar c +rewind (TryReadMVar c _) = WillTryReadMVar c +rewind (TakeMVar c _) = WillTakeMVar c +rewind (BlockedTakeMVar c) = WillTakeMVar c +rewind (TryTakeMVar c _ _) = WillTryTakeMVar c +rewind (NewIORef _) = WillNewIORef +rewind (ReadIORef c) = WillReadIORef c +rewind (ReadIORefCas c) = WillReadIORefCas c +rewind (ModIORef c) = WillModIORef c +rewind (ModIORefCas c) = WillModIORefCas c +rewind (WriteIORef c) = WillWriteIORef c +rewind (CasIORef c _) = WillCasIORef c +rewind (CommitIORef t c) = WillCommitIORef t c +rewind (STM _ _) = WillSTM +rewind (ThrownSTM _ _) = WillSTM +rewind (BlockedSTM _) = WillSTM +rewind Catching = WillCatching +rewind PopCatching = WillPopCatching +rewind (Throw _) = WillThrow +rewind (ThrowTo t _) = WillThrowTo t +rewind (BlockedThrowTo t) = WillThrowTo t +rewind (SetMasking b m) = WillSetMasking b m +rewind (ResetMasking b m) = WillResetMasking b m +rewind (GetMaskingState _) = WillGetMaskingState +rewind LiftIO = WillLiftIO +rewind Return = WillReturn +rewind Stop = WillStop +rewind RegisterInvariant = WillRegisterInvariant + +-- | Check if an operation could enable another thread. +willRelease :: Lookahead -> Bool +willRelease WillFork = True +willRelease WillForkOS = True +willRelease WillYield = True +willRelease (WillThreadDelay _) = True +willRelease (WillPutMVar _) = True +willRelease (WillTryPutMVar _) = True +willRelease (WillReadMVar _) = True +willRelease (WillTakeMVar _) = True +willRelease (WillTryTakeMVar _) = True +willRelease WillSTM = True +willRelease WillThrow = True +willRelease (WillSetMasking _ _) = True +willRelease (WillResetMasking _ _) = True +willRelease WillStop = True +willRelease _ = False + +------------------------------------------------------------------------------- +-- * Simplified actions + +-- | A simplified view of the possible actions a thread can perform. +data ActionType = + UnsynchronisedRead IORefId + -- ^ A 'readIORef' or a 'readForCAS'. + | UnsynchronisedWrite IORefId + -- ^ A 'writeIORef'. + | UnsynchronisedOther + -- ^ Some other action which doesn't require cross-thread + -- communication. + | PartiallySynchronisedCommit IORefId + -- ^ A commit. + | PartiallySynchronisedWrite IORefId + -- ^ A 'casIORef' + | PartiallySynchronisedModify IORefId + -- ^ A 'modifyIORefCAS' + | SynchronisedModify IORefId + -- ^ An 'atomicModifyIORef'. + | SynchronisedRead MVarId + -- ^ A 'readMVar' or 'takeMVar' (or @try@/@blocked@ variants). + | SynchronisedWrite MVarId + -- ^ A 'putMVar' (or @try@/@blocked@ variant). + | SynchronisedOther + -- ^ Some other action which does require cross-thread + -- communication. + deriving (Eq, Show, Generic, NFData) + +-- | Check if an action imposes a write barrier. +isBarrier :: ActionType -> Bool +isBarrier (SynchronisedModify _) = True +isBarrier (SynchronisedRead _) = True +isBarrier (SynchronisedWrite _) = True +isBarrier SynchronisedOther = True +isBarrier _ = False + +-- | Check if an action commits a given 'IORef'. +isCommit :: ActionType -> IORefId -> Bool +isCommit (PartiallySynchronisedCommit c) r = c == r +isCommit (PartiallySynchronisedWrite c) r = c == r +isCommit (PartiallySynchronisedModify c) r = c == r +isCommit _ _ = False + +-- | Check if an action synchronises a given 'IORef'. +synchronises :: ActionType -> IORefId -> Bool +synchronises a r = isCommit a r || isBarrier a + +-- | Get the 'IORef' affected. +iorefOf :: ActionType -> Maybe IORefId +iorefOf (UnsynchronisedRead r) = Just r +iorefOf (UnsynchronisedWrite r) = Just r +iorefOf (SynchronisedModify r) = Just r +iorefOf (PartiallySynchronisedCommit r) = Just r +iorefOf (PartiallySynchronisedWrite r) = Just r +iorefOf (PartiallySynchronisedModify r) = Just r +iorefOf _ = Nothing + +-- | Get the 'MVar' affected. +mvarOf :: ActionType -> Maybe MVarId +mvarOf (SynchronisedRead c) = Just c +mvarOf (SynchronisedWrite c) = Just c +mvarOf _ = Nothing + +-- | Get the @ThreadId@s involved in a @ThreadAction@. +tidsOf :: ThreadAction -> Set ThreadId +tidsOf (Fork tid) = S.singleton tid +tidsOf (ForkOS tid) = S.singleton tid +tidsOf (PutMVar _ tids) = S.fromList tids +tidsOf (TryPutMVar _ _ tids) = S.fromList tids +tidsOf (TakeMVar _ tids) = S.fromList tids +tidsOf (TryTakeMVar _ _ tids) = S.fromList tids +tidsOf (CommitIORef tid _) = S.singleton tid +tidsOf (STM _ tids) = S.fromList tids +tidsOf (ThrowTo tid _) = S.singleton tid +tidsOf (BlockedThrowTo tid) = S.singleton tid +tidsOf _ = S.empty + +-- | Throw away information from a 'ThreadAction' and give a +-- simplified view of what is happening. +-- +-- This is used in the SCT code to help determine interesting +-- alternative scheduling decisions. +simplifyAction :: ThreadAction -> ActionType +simplifyAction = simplifyLookahead . rewind + +-- | Variant of 'simplifyAction' that takes a 'Lookahead'. +simplifyLookahead :: Lookahead -> ActionType +simplifyLookahead (WillPutMVar c) = SynchronisedWrite c +simplifyLookahead (WillTryPutMVar c) = SynchronisedWrite c +simplifyLookahead (WillReadMVar c) = SynchronisedRead c +simplifyLookahead (WillTryReadMVar c) = SynchronisedRead c +simplifyLookahead (WillTakeMVar c) = SynchronisedRead c +simplifyLookahead (WillTryTakeMVar c) = SynchronisedRead c +simplifyLookahead (WillReadIORef r) = UnsynchronisedRead r +simplifyLookahead (WillReadIORefCas r) = UnsynchronisedRead r +simplifyLookahead (WillModIORef r) = SynchronisedModify r +simplifyLookahead (WillModIORefCas r) = PartiallySynchronisedModify r +simplifyLookahead (WillWriteIORef r) = UnsynchronisedWrite r +simplifyLookahead (WillCasIORef r) = PartiallySynchronisedWrite r +simplifyLookahead (WillCommitIORef _ r) = PartiallySynchronisedCommit r +simplifyLookahead WillSTM = SynchronisedOther +simplifyLookahead (WillThrowTo _) = SynchronisedOther +simplifyLookahead _ = UnsynchronisedOther + +------------------------------------------------------------------------------- +-- * Concurrency state + +-- | Initial concurrency state. +initialCState :: ConcurrencyState +initialCState = ConcurrencyState M.empty S.empty M.empty + +-- | Update the concurrency state with the action that has just +-- happened. +updateCState :: MemType -> ConcurrencyState -> ThreadId -> ThreadAction -> ConcurrencyState +updateCState memtype cstate tid act = ConcurrencyState + { concIOState = updateIOState memtype act $ concIOState cstate + , concMVState = updateMVState act $ concMVState cstate + , concMaskState = updateMaskState tid act $ concMaskState cstate + } + +-- | Update the @IORef@ buffer state with the action that has just +-- happened. +updateIOState :: MemType -> ThreadAction -> Map IORefId Int -> Map IORefId Int +updateIOState SequentialConsistency _ = const M.empty +updateIOState _ (CommitIORef _ r) = (`M.alter` r) $ \case + Just 1 -> Nothing + Just n -> Just (n-1) + Nothing -> Nothing +updateIOState _ (WriteIORef r) = M.insertWith (+) r 1 +updateIOState _ ta + | isBarrier $ simplifyAction ta = const M.empty + | otherwise = id + +-- | Update the @MVar@ full/empty state with the action that has just +-- happened. +updateMVState :: ThreadAction -> Set MVarId -> Set MVarId +updateMVState (PutMVar mvid _) = S.insert mvid +updateMVState (TryPutMVar mvid True _) = S.insert mvid +updateMVState (TakeMVar mvid _) = S.delete mvid +updateMVState (TryTakeMVar mvid True _) = S.delete mvid +updateMVState _ = id + +-- | Update the thread masking state with the action that has just +-- happened. +updateMaskState :: ThreadId -> ThreadAction -> Map ThreadId MaskingState -> Map ThreadId MaskingState +updateMaskState tid (Fork tid2) = \masks -> case M.lookup tid masks of + -- A thread inherits the masking state of its parent. + Just ms -> M.insert tid2 ms masks + Nothing -> masks +updateMaskState tid (SetMasking _ ms) = M.insert tid ms +updateMaskState tid (ResetMasking _ ms) = M.insert tid ms +updateMaskState tid (Throw Nothing) = M.delete tid +updateMaskState tid (Throw (Just ms)) = M.insert tid ms +updateMaskState tid (ThrownSTM _ Nothing) = M.delete tid +updateMaskState tid (ThrownSTM _ (Just ms)) = M.insert tid ms +updateMaskState _ (ThrowTo tid Nothing) = M.delete tid +updateMaskState _ (ThrowTo tid (Just ms)) = M.insert tid ms +updateMaskState tid Stop = M.delete tid +updateMaskState _ _ = id + +------------------------------------------------------------------------------- +-- * Error reporting + +-- | 'tail' but with a better error message if it fails. Use this +-- only where it shouldn't fail! +etail :: HasCallStack => [a] -> [a] +etail (_:xs) = xs +etail _ = withFrozenCallStack $ fatal "tail: empty list" + +-- | '(!!)' but with a better error message if it fails. Use this +-- only where it shouldn't fail! +eidx :: HasCallStack => [a] -> Int -> a +eidx xs i + | i < length xs = xs !! i + | otherwise = withFrozenCallStack $ fatal "(!!): index too large" + +-- | 'fromJust' but with a better error message if it fails. Use this +-- only where it shouldn't fail! +efromJust :: HasCallStack => Maybe a -> a +efromJust (Just x) = x +efromJust _ = withFrozenCallStack $ fatal "fromJust: Nothing" + +-- | 'fromList' but with a better error message if it fails. Use this +-- only where it shouldn't fail! +efromList :: HasCallStack => [a] -> NonEmpty a +efromList (x:xs) = x:|xs +efromList _ = withFrozenCallStack $ fatal "fromList: empty list" + +-- | 'fromRight' but with a better error message if it fails. Use +-- this only where it shouldn't fail! +efromRight :: HasCallStack => Either a b -> b +efromRight (Right b) = b +efromRight _ = withFrozenCallStack $ fatal "fromRight: Left" + +-- | 'fromLeft' but with a better error message if it fails. Use +-- this only where it shouldn't fail! +efromLeft :: HasCallStack => Either a b -> a +efromLeft (Left a) = a +efromLeft _ = withFrozenCallStack $ fatal "fromLeft: Right" + +-- | 'M.adjust' but which errors if the key is not present. Use this +-- only where it shouldn't fail! +eadjust :: (Ord k, Show k, HasCallStack) => (v -> v) -> k -> M.Map k v -> M.Map k v +eadjust f k m = case M.lookup k m of + Just v -> M.insert k (f v) m + Nothing -> withFrozenCallStack $ fatal ("adjust: key '" ++ show k ++ "' not found") + +-- | 'M.insert' but which errors if the key is already present. Use +-- this only where it shouldn't fail! +einsert :: (Ord k, Show k, HasCallStack) => k -> v -> M.Map k v -> M.Map k v +einsert k v m + | M.member k m = withFrozenCallStack $ fatal ("insert: key '" ++ show k ++ "' already present") + | otherwise = M.insert k v m + +-- | 'M.lookup' but which errors if the key is not present. Use this +-- only where it shouldn't fail! +elookup :: (Ord k, Show k, HasCallStack) => k -> M.Map k v -> v +elookup k = + fromMaybe (withFrozenCallStack $ fatal ("lookup: key '" ++ show k ++ "' not found")) . + M.lookup k + +-- | 'error' but saying where it came from +fatal :: HasCallStack => String -> a +fatal msg = withFrozenCallStack $ error ("(dejafu) " ++ msg) + +------------------------------------------------------------------------------- +-- * Miscellaneous + +-- | Run with a continuation that writes its value into a reference, +-- returning the computation and the reference. Using the reference +-- is non-blocking, it is up to you to ensure you wait sufficiently. +runRefCont :: MonadDejaFu n + => (n () -> x) + -> (a -> Maybe b) + -> ((a -> x) -> x) + -> n (x, Ref n (Maybe b)) +runRefCont act f k = do + ref <- newRef Nothing + let c = k (act . writeRef ref . f) + pure (c, ref) diff --git a/Test/DejaFu/Refinement.hs b/Test/DejaFu/Refinement.hs --- a/Test/DejaFu/Refinement.hs +++ b/Test/DejaFu/Refinement.hs @@ -7,7 +7,7 @@ -- | -- Module : Test.DejaFu.Refinement --- Copyright : (c) 2017 Michael Walker +-- Copyright : (c) 2017--2021 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental @@ -22,19 +22,21 @@ -- -- This module can test properties like that: -- --- @ --- sig e = Sig --- { initialise = maybe newEmptyMVar newMVar --- , observe = \\v _ -> tryReadMVar v --- , interfere = \\v s -> tryTakeMVar v >> maybe (pure ()) (void . tryPutMVar v) s --- , expression = e --- } +-- >>> import Control.Monad (void) +-- >>> :{ +-- let sig e = Sig +-- { initialise = maybe newEmptyMVar newMVar +-- , observe = \v _ -> tryReadMVar v +-- , interfere = \v _ -> putMVar v 42 +-- , expression = void . e +-- } +-- :} -- --- > check $ sig (void . readMVar) \`equivalentTo\` sig (\\v -> takeMVar v >>= putMVar v) --- *** Failure: (seed Just ()) --- left: [(Nothing,Just ())] --- right: [(Nothing,Just ()),(Just Deadlock,Just ())] --- @ +-- >>> check $ sig readMVar === sig (\v -> takeMVar v >>= putMVar v) +-- *** Failure: (seed Just 0) +-- left: [(Nothing,Just 0)] +-- right: [(Nothing,Just 0),(Just Deadlock,Just 42)] +-- False -- -- The two expressions are not equivalent, and we get given the -- counterexample! @@ -106,17 +108,21 @@ ) where import Control.Arrow (first) -import Control.Monad (void) -import Control.Monad.Conc.Class (readMVar, spawn) +import Control.Monad.Conc.Class (fork) +import Data.Kind (Type) import Data.Maybe (isNothing) import Data.Set (Set) import qualified Data.Set as S import Test.LeanCheck (Listable(..), concatMapT, mapT) -import Test.DejaFu.Conc (ConcIO, Failure, subconcurrency) -import Test.DejaFu.Defaults (defaultMemType, defaultWay) +import Test.DejaFu.Conc (ConcIO, Condition, + withSetupAndTeardown) import Test.DejaFu.SCT (runSCT) +import Test.DejaFu.Settings (defaultMemType, defaultWay) +-- $setup +-- >>> import Control.Concurrent.Classy hiding (check) + ------------------------------------------------------------------------------- -- Specifying properties @@ -231,11 +237,11 @@ class Testable a where -- | The observation value type. This is used to compare the -- results. - type O a :: * + type O a :: Type -- | The seed value type. This is used to construct the concurrent -- states. - type X a :: * + type X a :: Type rpropTiers :: a -> [[([String], RefinementProperty (O a) (X a))]] @@ -262,9 +268,9 @@ -- ^ The seed for this set of executions. , failingArgs :: [String] -- ^ The values of free variables, as strings. - , leftResults :: Set (Maybe Failure, o) + , leftResults :: Set (Maybe Condition, o) -- ^ The set of results of the left signature. - , rightResults :: Set (Maybe Failure, o) + , rightResults :: Set (Maybe Condition, o) -- ^ The set of results of the right signature. } | NoExpectedFailure @@ -405,14 +411,16 @@ evalSigWithSeed :: Ord o => Sig s o x -> x - -> IO (Set (Maybe Failure, o)) + -> IO (Set (Maybe Condition, o)) evalSigWithSeed sig x = do - results <- runSCT defaultWay defaultMemType $ do - s <- initialise sig x - r <- subconcurrency $ do - j <- spawn (interfere sig s x) - void (expression sig s) - void (readMVar j) - o <- observe sig s x - pure (either Just (const Nothing) r, o) + results <- runSCT defaultWay defaultMemType $ + withSetupAndTeardown + (initialise sig x) + (\s r -> do + o <- observe sig s x + pure (either Just (const Nothing) r, o)) + (\s -> do + _ <- fork (interfere sig s x) + _ <- expression sig s + pure ()) pure . S.fromList $ map (\(Right a, _) -> a) results diff --git a/Test/DejaFu/SCT.hs b/Test/DejaFu/SCT.hs --- a/Test/DejaFu/SCT.hs +++ b/Test/DejaFu/SCT.hs @@ -1,390 +1,248 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- | -- Module : Test.DejaFu.SCT --- Copyright : (c) 2016 Michael Walker +-- Copyright : (c) 2015--2019 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : BangPatterns, GADTs, GeneralizedNewtypeDeriving +-- Portability : portable -- -- Systematic testing for concurrent computations. module Test.DejaFu.SCT ( -- * Running Concurrent Programs - Way - , systematically - , randomly - , uniformly - , swarmy - , runSCT - , resultsSet - - -- ** Discarding variants - , Discard(..) - , runSCTDiscard - , resultsSetDiscard - - -- ** Strict variants + runSCT , runSCT' + , resultsSet , resultsSet' - , runSCTDiscard' - , resultsSetDiscard' - -- * Bounded Partial-order Reduction - - -- | We can characterise the state of a concurrent computation by - -- considering the ordering of dependent events. This is a partial - -- order: independent events can be performed in any order without - -- affecting the result, and so are /not/ ordered. - -- - -- Partial-order reduction is a technique for computing these - -- partial orders, and only testing one total order for each partial - -- order. This cuts down the amount of work to be done - -- significantly. /Bounded/ partial-order reduction is a further - -- optimisation, which only considers schedules within some bound. - -- - -- This module provides a combination pre-emption, fair, and length - -- bounding runner: - -- - -- * Pre-emption + fair bounding is useful for programs which use - -- loop/yield control flows but are otherwise terminating. - -- - -- * Pre-emption, fair + length bounding is useful for - -- non-terminating programs, and used by the testing functionality - -- in @Test.DejaFu@. - -- - -- See /Bounded partial-order reduction/, K. Coons, M. Musuvathi, - -- K. McKinley for more details. - - , Bounds(..) - , noBounds - , sctBound - , sctBoundDiscard - - -- ** Pre-emption Bounding - - -- | BPOR using pre-emption bounding. This adds conservative - -- backtracking points at the prior context switch whenever a - -- non-conervative backtracking point is added, as alternative - -- decisions can influence the reachability of different states. - -- - -- See the BPOR paper for more details. - - , PreemptionBound(..) - - -- ** Fair Bounding - - -- | BPOR using fair bounding. This bounds the maximum difference - -- between the number of yield operations different threads have - -- performed. - -- - -- See the BPOR paper for more details. - - , FairBound(..) - - -- ** Length Bounding - - -- | BPOR using length bounding. This bounds the maximum length (in - -- terms of primitive actions) of an execution. - - , LengthBound(..) - - -- * Random Scheduling - - -- | By greatly sacrificing completeness, testing of a large - -- concurrent system can be greatly sped-up. Counter-intuitively, - -- random scheduling has better bug-finding behaviour than just - -- executing a program \"for real\" many times. This is perhaps - -- because a random scheduler is more chaotic than the real - -- scheduler. - - , sctUniformRandom - , sctWeightedRandom - , sctUniformRandomDiscard - , sctWeightedRandomDiscard + -- ** Configuration + , runSCTWithSettings + , runSCTWithSettings' + , resultsSetWithSettings + , resultsSetWithSettings' + , module Test.DejaFu.Settings ) where -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData(..), force) -import Control.Monad.Ref (MonadRef) -import Data.List (foldl') -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as S -import System.Random (RandomGen, randomR) +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData(..), force) +import Data.List (foldl') +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as S -import Test.DejaFu.Common import Test.DejaFu.Conc +import Test.DejaFu.Internal import Test.DejaFu.SCT.Internal +import Test.DejaFu.SCT.Internal.DPOR +import Test.DejaFu.SCT.Internal.Weighted +import Test.DejaFu.Settings +import Test.DejaFu.Types +import Test.DejaFu.Utils ------------------------------------------------------------------------------- -- Running Concurrent Programs --- | How to explore the possible executions of a concurrent program. --- --- @since 0.7.0.0 -data Way where - Systematic :: Bounds -> Way - Weighted :: RandomGen g => g -> Int -> Int -> Way - Uniform :: RandomGen g => g -> Int -> Way - -instance Show Way where - show (Systematic bs) = "Systematic (" ++ show bs ++ ")" - show (Weighted _ n t) = "Weighted " ++ show (n, t) - show (Uniform _ n) = "Uniform " ++ show n - --- | Systematically execute a program, trying all distinct executions --- within the bounds. --- --- This corresponds to 'sctBound'. --- --- @since 0.7.0.0 -systematically - :: Bounds - -- ^ The bounds to constrain the exploration. - -> Way -systematically = Systematic - --- | Randomly execute a program, exploring a fixed number of --- executions. --- --- Threads are scheduled by a weighted random selection, where weights --- are assigned randomly on thread creation. --- --- This corresponds to 'sctWeightedRandom' with weight re-use --- disabled, and is not guaranteed to find all distinct results --- (unlike 'systematically' / 'sctBound'). --- --- @since 0.7.0.0 -randomly :: RandomGen g - => g - -- ^ The random generator to drive the scheduling. - -> Int - -- ^ The number of executions to try. - -> Way -randomly g lim = swarmy g lim 1 - --- | Randomly execute a program, exploring a fixed number of --- executions. --- --- Threads are scheduled by a uniform random selection. --- --- This corresponds to 'sctUniformRandom', and is not guaranteed to --- find all distinct results (unlike 'systematically' / 'sctBound'). --- --- @since 0.7.0.0 -uniformly :: RandomGen g - => g - -- ^ The random generator to drive the scheduling. - -> Int - -- ^ The number of executions to try. - -> Way -uniformly = Uniform - --- | Randomly execute a program, exploring a fixed number of --- executions. --- --- Threads are scheduled by a weighted random selection, where weights --- are assigned randomly on thread creation. --- --- This corresponds to 'sctWeightedRandom', and is not guaranteed to --- find all distinct results (unlike 'systematically' / 'sctBound'). --- --- @since 0.7.0.0 -swarmy :: RandomGen g - => g - -- ^ The random generator to drive the scheduling. - -> Int - -- ^ The number of executions to try. - -> Int - -- ^ The number of executions to use the thread weights for. - -> Way -swarmy = Weighted - -- | Explore possible executions of a concurrent program according to -- the given 'Way'. -- --- @since 0.6.0.0 -runSCT :: MonadRef r n +-- The exact executions tried, and the order in which results are +-- found, is unspecified and may change between releases. +-- +-- @since 2.1.0.0 +runSCT :: MonadDejaFu n => Way -- ^ How to run the concurrent program. -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> ConcT r n a + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> Program pty n a -- ^ The computation to run many times. - -> n [(Either Failure a, Trace)] -runSCT = runSCTDiscard (const Nothing) + -> n [(Either Condition a, Trace)] +runSCT way = runSCTWithSettings . fromWayAndMemType way -- | Return the set of results of a concurrent program. -- --- @since 0.6.0.0 -resultsSet :: (MonadRef r n, Ord a) +-- @since 2.1.0.0 +resultsSet :: (MonadDejaFu n, Ord a) => Way -- ^ How to run the concurrent program. -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> ConcT r n a + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> Program pty n a -- ^ The computation to run many times. - -> n (Set (Either Failure a)) -resultsSet = resultsSetDiscard (const Nothing) + -> n (Set (Either Condition a)) +resultsSet way = resultsSetWithSettings . fromWayAndMemType way --- | An @Either Failure a -> Maybe Discard@ value can be used to --- selectively discard results. +-- | A strict variant of 'runSCT'. -- --- @since 0.7.1.0 -data Discard - = DiscardTrace - -- ^ Discard the trace but keep the result. The result will appear - -- to have an empty trace. - | DiscardResultAndTrace - -- ^ Discard the result and the trace. It will simply not be - -- reported as a possible behaviour of the program. - deriving (Eq, Show, Read, Ord, Enum, Bounded) - -instance NFData Discard where - rnf d = d `seq` () - --- | A variant of 'runSCT' which can selectively discard results. +-- Demanding the result of this will force it to normal form, which +-- may be more efficient in some situations. -- --- @since 0.7.1.0 -runSCTDiscard :: MonadRef r n - => (Either Failure a -> Maybe Discard) - -- ^ Selectively discard results. - -> Way +-- The exact executions tried, and the order in which results are +-- found, is unspecified and may change between releases. +-- +-- @since 2.1.0.0 +runSCT' :: (MonadDejaFu n, NFData a) + => Way -- ^ How to run the concurrent program. -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> ConcT r n a + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> Program pty n a -- ^ The computation to run many times. - -> n [(Either Failure a, Trace)] -runSCTDiscard discard (Systematic cb) memtype = sctBoundDiscard discard memtype cb -runSCTDiscard discard (Weighted g lim use) memtype = sctWeightedRandomDiscard discard memtype g lim use -runSCTDiscard discard (Uniform g lim) memtype = sctUniformRandomDiscard discard memtype g lim + -> n [(Either Condition a, Trace)] +runSCT' way = runSCTWithSettings' . fromWayAndMemType way --- | A variant of 'resultsSet' which can selectively discard results. +-- | A strict variant of 'resultsSet'. -- --- @since 0.7.1.0 -resultsSetDiscard :: (MonadRef r n, Ord a) - => (Either Failure a -> Maybe Discard) - -- ^ Selectively discard results. Traces are always discarded. - -> Way +-- Demanding the result of this will force it to normal form, which +-- may be more efficient in some situations. +-- +-- @since 2.1.0.0 +resultsSet' :: (MonadDejaFu n, Ord a, NFData a) + => Way -- ^ How to run the concurrent program. -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> ConcT r n a + -- ^ The memory model to use for non-synchronised @IORef@ operations. + -> Program pty n a -- ^ The computation to run many times. - -> n (Set (Either Failure a)) -resultsSetDiscard discard way memtype conc = - let discard' efa = discard efa <|> Just DiscardTrace - in S.fromList . map fst <$> runSCTDiscard discard' way memtype conc + -> n (Set (Either Condition a)) +resultsSet' way = resultsSetWithSettings' . fromWayAndMemType way --- | A strict variant of 'runSCT'. +------------------------------------------------------------------------------- +-- Configuration + +-- | A variant of 'runSCT' which takes a 'Settings' record. -- --- Demanding the result of this will force it to normal form, which --- may be more efficient in some situations. +-- The exact executions tried, and the order in which results are +-- found, is unspecified and may change between releases. -- --- @since 0.6.0.0 -runSCT' :: (MonadRef r n, NFData a) - => Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)] -runSCT' = runSCTDiscard' (const Nothing) +-- @since 2.1.0.0 +runSCTWithSettings :: MonadDejaFu n + => Settings n a + -- ^ The SCT settings. + -> Program pty n a + -- ^ The computation to run many times. + -> n [(Either Condition a, Trace)] +runSCTWithSettings settings conc = case _way settings of + Systematic cb0 -> + let initial = initialState --- | A strict variant of 'resultsSet'. --- --- Demanding the result of this will force it to normal form, which --- may be more efficient in some situations. + check = findSchedulePrefix + + step cstate0 run dp (prefix, conservative, sleep) = do + (res, s, trace) <- run + (dporSched (_safeIO settings) (cBound (_lengthBound settings) cb0)) + (initialDPORSchedState sleep prefix cstate0) + + let bpoints = findBacktrackSteps (_safeIO settings) (_memtype settings) (cBacktrack cb0) (schedBoundKill s) cstate0 (schedBPoints s) trace + let newDPOR = incorporateTrace (_safeIO settings) (_memtype settings) conservative trace cstate0 dp + + pure $ if schedIgnore s + then (force newDPOR, Nothing) + else (force (incorporateBacktrackSteps bpoints newDPOR), Just (res, trace)) + in sct settings initial check step conc + + Randomly gen g0 lim0 -> + let initial _ = (g0, max 0 lim0) + + check (_, 0) = Nothing + check s = Just s + + step _ run _ (g, n) = do + (res, s, trace) <- run + (randSched gen) + (initialRandSchedState (_lengthBound settings) g) + pure ((schedGen s, n-1), Just (res, trace)) + in sct settings initial check step conc + +-- | A variant of 'resultsSet' which takes a 'Settings' record. -- --- @since 0.6.0.0 -resultsSet' :: (MonadRef r n, Ord a, NFData a) - => Way -> MemType -> ConcT r n a -> n (Set (Either Failure a)) -resultsSet' = resultsSetDiscard' (const Nothing) +-- @since 2.1.0.0 +resultsSetWithSettings :: (MonadDejaFu n, Ord a) + => Settings n a + -- ^ The SCT settings. + -> Program pty n a + -- ^ The computation to run many times. + -> n (Set (Either Condition a)) +resultsSetWithSettings settings conc = + let settings' = settings { _discard = Just $ \efa -> fromMaybe (const Nothing) (_discard settings) efa <|> Just DiscardTrace } + in S.fromList . map fst <$> runSCTWithSettings settings' conc --- | A strict variant of 'runSCTDiscard'. +-- | A strict variant of 'runSCTWithSettings'. -- -- Demanding the result of this will force it to normal form, which -- may be more efficient in some situations. -- --- @since 0.7.1.0 -runSCTDiscard' :: (MonadRef r n, NFData a) - => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)] -runSCTDiscard' discard way memtype conc = do - res <- runSCTDiscard discard way memtype conc +-- The exact executions tried, and the order in which results are +-- found, is unspecified and may change between releases. +-- +-- @since 2.1.0.0 +runSCTWithSettings' :: (MonadDejaFu n, NFData a) + => Settings n a + -- ^ The SCT settings. + -> Program pty n a + -- ^ The computation to run many times. + -> n [(Either Condition a, Trace)] +runSCTWithSettings' settings conc = do + res <- runSCTWithSettings settings conc rnf res `seq` pure res --- | A strict variant of 'resultsSetDiscard'. +-- | A strict variant of 'resultsSetWithSettings'. -- -- Demanding the result of this will force it to normal form, which -- may be more efficient in some situations. -- --- @since 0.7.1.0 -resultsSetDiscard' :: (MonadRef r n, Ord a, NFData a) - => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n (Set (Either Failure a)) -resultsSetDiscard' discard way memtype conc = do - res <- resultsSetDiscard discard way memtype conc +-- @since 2.1.0.0 +resultsSetWithSettings' :: (MonadDejaFu n, Ord a, NFData a) + => Settings n a + -- ^ The SCT settings. + -> Program pty n a + -- ^ The computation to run many times. + -> n (Set (Either Condition a)) +resultsSetWithSettings' settings conc = do + res <- resultsSetWithSettings settings conc rnf res `seq` pure res ------------------------------------------------------------------------------- -- Combined Bounds --- | @since 0.2.0.0 -data Bounds = Bounds - { boundPreemp :: Maybe PreemptionBound - , boundFair :: Maybe FairBound - , boundLength :: Maybe LengthBound - } deriving (Eq, Ord, Read, Show) - --- | @since 0.5.1.0 -instance NFData Bounds where - rnf bs = rnf ( boundPreemp bs - , boundFair bs - , boundLength bs - ) - --- | No bounds enabled. This forces the scheduler to just use --- partial-order reduction and sleep sets to prune the search --- space. This will /ONLY/ work if your computation always terminates! --- --- @since 0.3.0.0 -noBounds :: Bounds -noBounds = Bounds - { boundPreemp = Nothing - , boundFair = Nothing - , boundLength = Nothing - } - -- | Combination bound function -cBound :: Bounds -> IncrementalBoundFunc ((Int, Maybe ThreadId), M.Map ThreadId Int, Int) -cBound (Bounds pb fb lb) (Just (k1, k2, k3)) prior lh = +cBound :: Maybe LengthBound -> Bounds -> IncrementalBoundFunc ((Int, Maybe ThreadId), M.Map ThreadId Int, Int) +cBound lb (Bounds pb fb) (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) +cBound _ _ Nothing _ _ = Just ((0, Nothing), M.empty, 1) --- | Combination backtracking function. Add all backtracking points --- corresponding to enabled bound functions. +-- | Backtracks to the given point. -- --- If no bounds are enabled, just backtrack to the given point. +-- If pre-emption bounding is enabled, also conservatively adds a +-- backtracking point prior to the most recent transition before that +-- point. This may result in the same state being reached multiple +-- times, but is needed because of the artificial dependency imposed +-- by the bound. cBacktrack :: Bounds -> BacktrackFunc -cBacktrack (Bounds (Just _) _ _) = pBacktrack -cBacktrack (Bounds _ (Just _) _) = fBacktrack -cBacktrack (Bounds _ _ (Just _)) = lBacktrack -cBacktrack _ = backtrackAt (\_ _ -> False) +cBacktrack (Bounds (Just _) _) bs = + backtrackAt (\_ _ -> False) bs . concatMap addConservative + where + addConservative o@(i, _, tid) = o : case conservative i of + Just j -> [(j, True, tid)] + Nothing -> [] + -- index of conservative point + conservative i = go (reverse (take (i-1) bs)) (i-1) where + go _ (-1) = Nothing + go (b1:rest@(b2:_)) j + | bcktThreadid b1 /= bcktThreadid b2 + && not (isCommitRef $ bcktAction b1) + && not (isCommitRef $ bcktAction b2) = Just j + | otherwise = go rest (j-1) + go _ _ = Nothing +cBacktrack _ bs = backtrackAt (\_ _ -> False) bs + ------------------------------------------------------------------------------- -- Pre-emption bounding --- | @since 0.2.0.0 -newtype PreemptionBound = PreemptionBound Int - deriving (Enum, Eq, Ord, Num, Real, Integral, Read, Show) - --- | @since 0.5.1.0 -instance NFData PreemptionBound where - -- not derived, so it can have a separate @since annotation - rnf (PreemptionBound i) = rnf i - -- | Pre-emption bound function. This does not count pre-emptive -- context switches to a commit thread. pBound :: PreemptionBound -> IncrementalBoundFunc (Int, Maybe ThreadId) @@ -392,38 +250,9 @@ let k'@(pcount, _) = preEmpCountInc (fromMaybe (0, Nothing) k) prior lhead in if pcount <= pb then Just k' else Nothing --- | Add a backtrack point, and also conservatively add one prior to --- the most recent transition before that point. This may result in --- the same state being reached multiple times, but is needed because --- of the artificial dependency imposed by the bound. -pBacktrack :: BacktrackFunc -pBacktrack bs = backtrackAt (\_ _ -> False) bs . concatMap addConservative where - addConservative o@(i, _, tid) = o : case conservative i of - Just j -> [(j, True, tid)] - Nothing -> [] - - -- index of conservative point - conservative i = go (reverse (take (i-1) bs)) (i-1) where - go _ (-1) = Nothing - go (b1:rest@(b2:_)) j - | bcktThreadid b1 /= bcktThreadid b2 - && not (isCommitRef $ bcktAction b1) - && not (isCommitRef $ bcktAction b2) = Just j - | otherwise = go rest (j-1) - go _ _ = Nothing - ------------------------------------------------------------------------------- -- Fair bounding --- | @since 0.2.0.0 -newtype FairBound = FairBound Int - deriving (Enum, Eq, Ord, Num, Real, Integral, Read, Show) - --- | @since 0.5.1.0 -instance NFData FairBound where - -- not derived, so it can have a separate @since annotation - rnf (FairBound i) = rnf i - -- | Fair bound function fBound :: FairBound -> IncrementalBoundFunc (M.Map ThreadId Int) fBound (FairBound fb) k prior lhead = @@ -432,196 +261,16 @@ then Just k' else Nothing --- | Add a backtrack point. If the thread isn't runnable, or performs --- a release operation, add all runnable threads. -fBacktrack :: BacktrackFunc -fBacktrack = backtrackAt check where - -- True if a release operation is performed. - check t b = Just True == (willRelease <$> M.lookup t (bcktRunnable b)) - ------------------------------------------------------------------------------- -- Length bounding --- | @since 0.2.0.0 -newtype LengthBound = LengthBound Int - deriving (Enum, Eq, Ord, Num, Real, Integral, Read, Show) - --- | @since 0.5.1.0 -instance NFData LengthBound where - -- not derived, so it can have a separate @since annotation - rnf (LengthBound i) = rnf i - -- | Length bound function lBound :: LengthBound -> IncrementalBoundFunc Int lBound (LengthBound lb) len _ _ = let len' = maybe 1 (+1) len in if len' < lb then Just len' else Nothing --- | Add a backtrack point. If the thread isn't runnable, add all --- runnable threads. -lBacktrack :: BacktrackFunc -lBacktrack = backtrackAt (\_ _ -> False) - ------------------------------------------------------------------------------- --- Systematic concurrency testing - --- | SCT via BPOR. --- --- Schedules are generated by running the computation with a --- deterministic scheduler with some initial list of decisions. At --- each step of execution, possible-conflicting actions are looked --- for, if any are found, \"backtracking points\" are added, to cause --- the events to happen in a different order in a future execution. --- --- Note that unlike with non-bounded partial-order reduction, this may --- do some redundant work as the introduction of a bound can make --- previously non-interfering events interfere with each other. --- --- @since 0.5.0.0 -sctBound :: MonadRef r n - => MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> Bounds - -- ^ The combined bounds. - -> ConcT r n a - -- ^ The computation to run many times - -> n [(Either Failure a, Trace)] -sctBound = sctBoundDiscard (const Nothing) - --- | A variant of 'sctBound' which can selectively discard results. --- --- @since 0.7.1.0 -sctBoundDiscard :: MonadRef r n - => (Either Failure a -> Maybe Discard) - -- ^ Selectively discard results. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> Bounds - -- ^ The combined bounds. - -> ConcT r n a - -- ^ The computation to run many times - -> n [(Either Failure a, Trace)] -sctBoundDiscard discard memtype cb conc = go initialState where - -- Repeatedly run the computation gathering all the results and - -- traces into a list until there are no schedules remaining to try. - go !dp = case findSchedulePrefix dp of - Just (prefix, conservative, sleep) -> do - (res, s, trace) <- runConcurrent scheduler - memtype - (initialDPORSchedState sleep prefix) - conc - - let bpoints = findBacktracks (schedBoundKill s) (schedBPoints s) trace - let newDPOR = incorporateTrace conservative trace dp - - if schedIgnore s - then go (force newDPOR) - else checkDiscard discard res trace $ go (force (incorporateBacktrackSteps bpoints newDPOR)) - - Nothing -> pure [] - - -- The DPOR scheduler. - scheduler = dporSched (cBound cb) - - -- Find the new backtracking steps. - findBacktracks = findBacktrackSteps (cBacktrack cb) - --- | SCT via uniform random scheduling. --- --- Schedules are generated by assigning to each new thread a random --- weight. Threads are then scheduled by a weighted random selection. --- --- This is not guaranteed to find all distinct results. --- --- @since 0.7.0.0 -sctUniformRandom :: (MonadRef r n, RandomGen g) - => MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> g - -- ^ The random number generator. - -> Int - -- ^ The number of executions to perform. - -> ConcT r n a - -- ^ The computation to run many times. - -> n [(Either Failure a, Trace)] -sctUniformRandom = sctUniformRandomDiscard (const Nothing) - --- | A variant of 'sctUniformRandom' which can selectively discard --- results. --- --- @since 0.7.1.0 -sctUniformRandomDiscard :: (MonadRef r n, RandomGen g) - => (Either Failure a -> Maybe Discard) - -- ^ Selectively discard results. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> g - -- ^ The random number generator. - -> Int - -- ^ The number of executions to perform. - -> ConcT r n a - -- ^ The computation to run many times. - -> n [(Either Failure a, Trace)] -sctUniformRandomDiscard discard memtype g0 lim0 conc = go g0 (max 0 lim0) where - go _ 0 = pure [] - go g n = do - (res, s, trace) <- runConcurrent (randSched $ \g' -> (1, g')) - memtype - (initialRandSchedState Nothing g) - conc - checkDiscard discard res trace $ go (schedGen s) (n-1) - --- | SCT via weighted random scheduling. --- --- Schedules are generated by assigning to each new thread a random --- weight. Threads are then scheduled by a weighted random selection. --- --- This is not guaranteed to find all distinct results. --- --- @since 0.7.0.0 -sctWeightedRandom :: (MonadRef r n, RandomGen g) - => MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> g - -- ^ The random number generator. - -> Int - -- ^ The number of executions to perform. - -> Int - -- ^ The number of executions to use the same set of weights for. - -> ConcT r n a - -- ^ The computation to run many times. - -> n [(Either Failure a, Trace)] -sctWeightedRandom = sctWeightedRandomDiscard (const Nothing) - --- | A variant of 'sctWeightedRandom' which can selectively discard --- results. --- --- @since 0.7.1.0 -sctWeightedRandomDiscard :: (MonadRef r n, RandomGen g) - => (Either Failure a -> Maybe Discard) - -- ^ Selectively discard results. - -> MemType - -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> g - -- ^ The random number generator. - -> Int - -- ^ The number of executions to perform. - -> Int - -- ^ The number of executions to use the same set of weights for. - -> ConcT r n a - -- ^ The computation to run many times. - -> n [(Either Failure a, Trace)] -sctWeightedRandomDiscard discard memtype g0 lim0 use0 conc = go g0 (max 0 lim0) (max 1 use0) M.empty where - go _ 0 _ _ = pure [] - go g n 0 _ = go g n (max 1 use0) M.empty - go g n use ws = do - (res, s, trace) <- runConcurrent (randSched $ randomR (1, 50)) - memtype - (initialRandSchedState (Just ws) g) - conc - checkDiscard discard res trace $ go (schedGen s) (n-1) (use-1) (schedWeights s) - -------------------------------------------------------------------------------- -- Utilities -- | An incremental version of 'preEmpCount', going one step at a time. @@ -666,7 +315,7 @@ -- | Determine if an action is a commit or not. isCommitRef :: ThreadAction -> Bool -isCommitRef (CommitCRef _ _) = True +isCommitRef (CommitIORef _ _) = True isCommitRef _ = False -- | Get the maximum difference between two ints in a list. @@ -677,10 +326,3 @@ in go m' xs go m [] = m go' x0 m x = m `max` abs (x0 - x) - --- | Apply the discard function. -checkDiscard :: Functor f => (a -> Maybe Discard) -> a -> [b] -> f [(a, [b])] -> f [(a, [b])] -checkDiscard discard res trace rest = case discard res of - Just DiscardResultAndTrace -> rest - Just DiscardTrace -> ((res, []):) <$> rest - Nothing -> ((res, trace):) <$> rest 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 @@ -1,816 +1,420 @@ -{-# LANGUAGE TupleSections #-} - --- | --- Module : Test.DejaFu.SCT.Internal --- Copyright : (c) 2016 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : TupleSections --- --- Internal types and functions for dynamic partial-order --- reduction. This module is NOT considered to form part of the public --- interface of this library. -module Test.DejaFu.SCT.Internal where - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData(..)) -import Control.Exception (MaskingState(..)) -import qualified Data.Foldable as F -import Data.Function (on) -import Data.List (nubBy, partition, sortOn) -import Data.List.NonEmpty (toList) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isJust, isNothing, - listToMaybe) -import Data.Sequence (Seq, (|>)) -import qualified Data.Sequence as Sq -import Data.Set (Set) -import qualified Data.Set as S -import System.Random (RandomGen, randomR) - -import Test.DejaFu.Common -import Test.DejaFu.Schedule (Scheduler(..), decisionOf, tidOf) - -------------------------------------------------------------------------------- --- * Dynamic partial-order reduction - --- | DPOR execution is represented as a tree of states, characterised --- by the decisions that lead to that state. -data DPOR = DPOR - { dporRunnable :: Set ThreadId - -- ^ What threads are runnable at this step. - , dporTodo :: Map ThreadId Bool - -- ^ Follow-on decisions still to make, and whether that decision - -- was added conservatively due to the bound. - , dporNext :: Maybe (ThreadId, DPOR) - -- ^ The next decision made. Executions are explored in a - -- depth-first fashion, so this changes as old subtrees are - -- exhausted and new ones explored. - , dporDone :: Set ThreadId - -- ^ All transitions which have been taken from this point, - -- including conservatively-added ones. - , dporSleep :: Map ThreadId ThreadAction - -- ^ Transitions to ignore (in this node and children) until a - -- dependent transition happens. - , dporTaken :: Map ThreadId ThreadAction - -- ^ Transitions which have been taken, excluding - -- conservatively-added ones. This is used in implementing sleep - -- sets. - } deriving (Eq, Show) - -instance NFData DPOR where - rnf dpor = rnf ( dporRunnable dpor - , dporTodo dpor - , dporNext dpor - , dporDone dpor - , dporSleep dpor - , dporTaken dpor - ) - --- | One step of the execution, including information for backtracking --- purposes. This backtracking information is used to generate new --- schedules. -data BacktrackStep = BacktrackStep - { bcktThreadid :: ThreadId - -- ^ The thread running at this step - , bcktDecision :: Decision - -- ^ What was decided at this step. - , bcktAction :: ThreadAction - -- ^ What happened at this step. - , bcktRunnable :: Map ThreadId Lookahead - -- ^ The threads runnable at this step - , bcktBacktracks :: Map ThreadId Bool - -- ^ The list of alternative threads to run, and whether those - -- alternatives were added conservatively due to the bound. - , bcktState :: DepState - -- ^ Some domain-specific state at this point. - } deriving (Eq, Show) - -instance NFData BacktrackStep where - rnf bs = rnf ( bcktThreadid bs - , bcktDecision bs - , bcktAction bs - , bcktRunnable bs - , bcktBacktracks bs - , bcktState bs - ) - --- | Initial DPOR state, given an initial thread ID. This initial --- thread should exist and be runnable at the start of execution. -initialState :: DPOR -initialState = DPOR - { dporRunnable = S.singleton initialThread - , dporTodo = M.singleton initialThread False - , dporNext = Nothing - , dporDone = S.empty - , dporSleep = M.empty - , dporTaken = M.empty - } - --- | Produce a new schedule prefix from a @DPOR@ tree. If there are no new --- prefixes remaining, return 'Nothing'. Also returns whether the --- decision was added conservatively, and the sleep set at the point --- where divergence happens. --- --- A schedule prefix is a possibly empty sequence of decisions that --- have already been made, terminated by a single decision from the --- to-do set. The intent is to put the system into a new state when --- executed with this initial sequence of scheduling decisions. -findSchedulePrefix - :: DPOR - -> Maybe ([ThreadId], Bool, Map ThreadId ThreadAction) -findSchedulePrefix dpor = case dporNext dpor of - Just (tid, child) -> go tid child <|> here - Nothing -> here - where - go tid child = (\(ts,c,slp) -> (tid:ts,c,slp)) <$> findSchedulePrefix child - - -- Prefix traces terminating with a to-do decision at this point. - here = - let todos = [([t], c, sleeps) | (t, c) <- M.toList $ dporTodo dpor] - (best, worst) = partition (\([t],_,_) -> t >= initialThread) todos - in listToMaybe best <|> listToMaybe worst - - -- The new sleep set is the union of the sleep set of the node - -- we're branching from, plus all the decisions we've already - -- explored. - sleeps = dporSleep dpor `M.union` dporTaken dpor - --- | Add a new trace to the stack. This won't work if to-dos aren't explored depth-first. -incorporateTrace - :: Bool - -- ^ Whether the \"to-do\" point which was used to create this new - -- execution was conservative or not. - -> Trace - -- ^ The execution trace: the decision made, the runnable threads, - -- and the action performed. - -> DPOR - -> DPOR -incorporateTrace conservative trace dpor0 = grow initialDepState (initialDPORThread dpor0) trace dpor0 where - grow state tid trc@((d, _, a):rest) dpor = - let tid' = tidOf tid d - state' = updateDepState state tid' a - in case dporNext dpor of - Just (t, child) - | t == tid' -> dpor { dporNext = Just (tid', grow state' tid' rest child) } - | hasTodos child -> fatal "incorporateTrace" "replacing child with todos!" - _ -> - let taken = M.insert tid' a (dporTaken dpor) - sleep = dporSleep dpor `M.union` dporTaken dpor - in dpor { dporTaken = if conservative then dporTaken dpor else taken - , dporTodo = M.delete tid' (dporTodo dpor) - , dporNext = Just (tid', subtree state' tid' sleep trc) - , dporDone = S.insert tid' (dporDone dpor) - } - grow _ _ [] _ = fatal "incorporateTrace" "trace exhausted without reading a to-do point!" - - -- check if there are to-do points in a tree - hasTodos dpor = not (M.null (dporTodo dpor)) || (case dporNext dpor of Just (_, dpor') -> hasTodos dpor'; _ -> False) - - -- Construct a new subtree corresponding to a trace suffix. - subtree state tid sleep ((_, _, a):rest) = - let state' = updateDepState state tid a - sleep' = M.filterWithKey (\t a' -> not $ dependent state' tid a t a') sleep - in DPOR - { dporRunnable = S.fromList $ case rest of - ((_, runnable, _):_) -> map fst runnable - [] -> [] - , dporTodo = M.empty - , dporNext = case rest of - ((d', _, _):_) -> - let tid' = tidOf tid d' - in Just (tid', subtree state' tid' sleep' rest) - [] -> Nothing - , dporDone = case rest of - ((d', _, _):_) -> S.singleton (tidOf tid d') - [] -> S.empty - , dporSleep = sleep' - , dporTaken = case rest of - ((d', _, a'):_) -> M.singleton (tidOf tid d') a' - [] -> M.empty - } - subtree _ _ _ [] = fatal "incorporateTrace" "subtree suffix empty!" - --- | Produce a list of new backtracking points from an execution --- trace. These are then used to inform new \"to-do\" points in the --- @DPOR@ tree. --- --- Two traces are passed in to this function: the first is generated --- from the special DPOR scheduler, the other from the execution of --- the concurrent program. --- --- If the trace ends with any threads other than the initial one still --- runnable, a dependency is imposed between this final action and --- everything else. -findBacktrackSteps - :: BacktrackFunc - -- ^ Backtracking function. Given a list of backtracking points, and - -- a thread to backtrack to at a specific point in that list, add - -- the new backtracking points. There will be at least one: this - -- chosen one, but the function may add others. - -> Bool - -- ^ Whether the computation was aborted due to no decisions being - -- in-bounds. - -> Seq ([(ThreadId, Lookahead)], [ThreadId]) - -- ^ A sequence of threads at each step: the list of runnable - -- in-bound threads (with lookahead values), and the list of threads - -- still to try. The reason for the two separate lists is because - -- the threads chosen to try will be dependent on the specific - -- domain. - -> Trace - -- ^ The execution trace. - -> [BacktrackStep] -findBacktrackSteps backtrack boundKill = go initialDepState S.empty initialThread [] . F.toList where - -- Walk through the traces one step at a time, building up a list of - -- new backtracking points. - go state allThreads tid bs ((e,i):is) ((d,_,a):ts) = - let tid' = tidOf tid d - state' = updateDepState state tid' a - this = BacktrackStep - { bcktThreadid = tid' - , bcktDecision = d - , bcktAction = a - , bcktRunnable = M.fromList e - , bcktBacktracks = M.fromList $ map (\i' -> (i', False)) i - , bcktState = state - } - bs' = doBacktrack killsEarly allThreads' e (bs++[this]) - runnable = S.fromList (M.keys $ bcktRunnable this) - allThreads' = allThreads `S.union` runnable - killsEarly = null ts && boundKill - in go state' allThreads' tid' bs' is ts - go _ _ _ bs _ _ = bs - - -- Find the prior actions dependent with this one and add - -- backtracking points. - doBacktrack killsEarly allThreads enabledThreads bs = - let tagged = reverse $ zip [0..] bs - idxs = [ (ehead "doBacktrack.idxs" is, False, u) - | (u, n) <- enabledThreads - , v <- S.toList allThreads - , u /= v - , let is = idxs' u n v tagged - , not $ null is] - - idxs' u n v = go' True where - {-# INLINE go' #-} - go' final ((i,b):rest) - -- Don't cross subconcurrency boundaries - | isSubC final b = [] - -- 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) = i : go' False rest - | otherwise = go' False rest - go' _ [] = [] - - {-# INLINE isSubC #-} - isSubC final b = case bcktAction b of - Stop -> not final && bcktThreadid b == initialThread - Subconcurrency -> bcktThreadid b == initialThread - _ -> False - - {-# INLINE isDependent #-} - isDependent b - -- Don't impose a dependency if the other thread will - -- immediately block already. This is safe because a - -- context switch will occur anyway so there's no point - -- pre-empting the action UNLESS the pre-emption would - -- possibly allow for a different relaxed memory stage. - | isBlock (bcktAction b) && isBarrier (simplifyLookahead n) = False - | otherwise = dependent' (bcktState b) (bcktThreadid b) (bcktAction b) u n - in backtrack bs idxs - --- | Add new backtracking points, if they have not already been --- visited and aren't in the sleep set. -incorporateBacktrackSteps :: [BacktrackStep] -> DPOR -> DPOR -incorporateBacktrackSteps (b:bs) dpor = dpor' where - tid = bcktThreadid b - - dpor' = dpor - { dporTodo = dporTodo dpor `M.union` M.fromList todo - , dporNext = Just (tid, child) - } - - todo = - [ x - | x@(t,c) <- M.toList $ bcktBacktracks b - , Just t /= (fst <$> dporNext dpor) - , S.notMember t (dporDone dpor) - , c || M.notMember t (dporSleep dpor) - ] - - child = case dporNext dpor of - Just (t, d) - | t /= tid -> fatal "incorporateBacktrackSteps" "incorporating wrong trace!" - | otherwise -> incorporateBacktrackSteps bs d - Nothing -> fatal "incorporateBacktrackSteps" "child is missing!" -incorporateBacktrackSteps [] dpor = dpor - -------------------------------------------------------------------------------- --- * DPOR scheduler - --- | The scheduler state -data DPORSchedState k = DPORSchedState - { schedSleep :: Map ThreadId ThreadAction - -- ^ The sleep set: decisions not to make until something dependent - -- with them happens. - , schedPrefix :: [ThreadId] - -- ^ Decisions still to make - , schedBPoints :: Seq ([(ThreadId, Lookahead)], [ThreadId]) - -- ^ Which threads are runnable and in-bound at each step, and the - -- alternative decisions still to make. - , schedIgnore :: Bool - -- ^ Whether to ignore this execution or not: @True@ if the - -- execution is aborted due to all possible decisions being in the - -- sleep set, as then everything in this execution is covered by - -- another. - , schedBoundKill :: Bool - -- ^ Whether the execution was terminated due to all decisions being - -- out of bounds. - , schedDepState :: DepState - -- ^ State used by the dependency function to determine when to - -- remove decisions from the sleep set. - , schedBState :: Maybe k - -- ^ State used by the incremental bounding function. - } deriving (Eq, Show) - -instance NFData k => NFData (DPORSchedState k) where - rnf s = rnf ( schedSleep s - , schedPrefix s - , schedBPoints s - , schedIgnore s - , schedBoundKill s - , schedDepState s - , schedBState s - ) - --- | Initial DPOR scheduler state for a given prefix -initialDPORSchedState :: Map ThreadId ThreadAction - -- ^ The initial sleep set. - -> [ThreadId] - -- ^ The schedule prefix. - -> DPORSchedState k -initialDPORSchedState sleep prefix = DPORSchedState - { schedSleep = sleep - , schedPrefix = prefix - , schedBPoints = Sq.empty - , schedIgnore = False - , schedBoundKill = False - , schedDepState = initialDepState - , schedBState = Nothing - } - --- | An incremental bounding function is a stateful function that --- takes the last and next decisions, and returns a new state only if --- the next decision is within the bound. -type IncrementalBoundFunc k - = Maybe k -> Maybe (ThreadId, ThreadAction) -> (Decision, Lookahead) -> Maybe k - --- | A backtracking step is a point in the execution where another --- decision needs to be made, in order to explore interesting new --- schedules. A backtracking /function/ takes the steps identified so --- far and a list of points and thread at that point to backtrack --- to. More points be added to compensate for the effects of the --- bounding function. For example, under pre-emption bounding a --- conservative backtracking point is added at the prior context --- switch. The bool is whether the point is conservative. Conservative --- points are always explored, whereas non-conservative ones might be --- skipped based on future information. --- --- In general, a backtracking function should identify one or more --- backtracking points, and then use @backtrackAt@ to do the actual --- work. -type BacktrackFunc - = [BacktrackStep] -> [(Int, Bool, ThreadId)] -> [BacktrackStep] - --- | Add a backtracking point. If the thread isn't runnable, add all --- runnable threads. If the backtracking point is already present, --- don't re-add it UNLESS this would make it conservative. -backtrackAt - :: (ThreadId -> BacktrackStep -> Bool) - -- ^ If this returns @True@, backtrack to all runnable threads, - -- rather than just the given thread. - -> BacktrackFunc -backtrackAt toAll bs0 = backtrackAt' . nubBy ((==) `on` fst') . sortOn fst' where - fst' (x,_,_) = x - - backtrackAt' ((i,c,t):is) = go i bs0 i c t is - backtrackAt' [] = bs0 - - go i0 (b:bs) 0 c tid is - -- If the backtracking point is already present, don't re-add it, - -- UNLESS this would force it to backtrack (it's conservative) - -- where before it might not. - | not (toAll tid b) && tid `M.member` bcktRunnable b = - let val = M.lookup tid $ bcktBacktracks b - b' = if isNothing val || (val == Just False && c) - then b { bcktBacktracks = backtrackTo tid c b } - else b - in b' : case is of - ((i',c',t'):is') -> go i' bs (i'-i0-1) c' t' is' - [] -> bs - -- Otherwise just backtrack to everything runnable. - | otherwise = - let b' = b { bcktBacktracks = backtrackAll c b } - in b' : case is of - ((i',c',t'):is') -> go i' bs (i'-i0-1) c' t' is' - [] -> bs - go i0 (b:bs) i c tid is = b : go i0 bs (i-1) c tid is - go _ [] _ _ _ _ = fatal "backtrackAt" "ran out of schedule whilst backtracking!" - - -- Backtrack to a single thread - backtrackTo tid c = M.insert tid c . bcktBacktracks - - -- Backtrack to all runnable threads - backtrackAll c = M.map (const c) . bcktRunnable - --- | DPOR scheduler: takes a list of decisions, and maintains a trace --- including the runnable threads, and the alternative choices allowed --- by the bound-specific initialise function. --- --- After the initial decisions are exhausted, this prefers choosing --- the prior thread if it's (1) still runnable and (2) hasn't just --- yielded. Furthermore, threads which /will/ yield are ignored in --- preference of those which will not. -dporSched - :: IncrementalBoundFunc k - -- ^ Bound function: returns true if that schedule prefix terminated - -- with the lookahead decision fits within the bound. - -> Scheduler (DPORSchedState k) -dporSched boundf = Scheduler $ \prior threads s -> - let - -- The next scheduler state - nextState rest = s - { schedBPoints = schedBPoints s |> (restrictToBound fst threads', rest) - , schedDepState = nextDepState - } - nextDepState = let ds = schedDepState s in maybe ds (uncurry $ updateDepState ds) prior - - -- Pick a new thread to run, not considering bounds. Choose the - -- current thread if available and it hasn't just yielded, - -- otherwise add all runnable threads. - initialise = tryDaemons . yieldsToEnd $ case prior of - Just (tid, act) - | not (didYield act) && tid `elem` tids && isInBound tid -> [tid] - _ -> tids - - -- If one of the chosen actions will kill the computation, and - -- there are daemon threads, try them instead. - -- - -- This is necessary if the killing action is NOT dependent with - -- every other action, according to the dependency function. This - -- is, strictly speaking, wrong; an action that kills another - -- thread is definitely dependent with everything in that - -- thread. HOWEVER, implementing it that way leads to an explosion - -- of schedules tried. Really, all that needs to happen is for the - -- thread-that-would-be-killed to be executed fully ONCE, and then - -- the normal dependency mechanism will identify any other - -- backtracking points that should be tried. This is achieved by - -- adding every thread that would be killed to the to-do list. - -- Furthermore, these threads MUST be ahead of the killing thread, - -- or the killing thread will end up in the sleep set and so the - -- killing action not performed. This is, again, because of the - -- lack of the dependency messing things up in the name of - -- performance. - -- - -- See commits a056f54 and 8554ce9, and my 4th June comment in - -- issue #52. - tryDaemons ts - | any doesKill ts = case partition doesKill tids of - (kills, nokills) -> nokills ++ kills - | otherwise = ts - doesKill t = killsDaemons t (action t) - - -- Restrict the possible decisions to those in the bound. - restrictToBound f = filter (isInBound . f) - isInBound t = isJust $ boundf (schedBState s) prior (decision t, action t) - - -- Move the threads which will immediately yield to the end of the list - yieldsToEnd ts = case partition (willYield . action) ts of - (yields, noyields) -> noyields ++ yields - - -- Get the decision that will lead to a thread being scheduled. - decision = decisionOf (fst <$> prior) (S.fromList tids) - - -- Get the action of a thread - action t = efromJust "dporSched.action" (lookup t threads') - - -- The runnable thread IDs - tids = map fst threads' - - -- The runnable threads as a normal list. - threads' = toList threads - in case schedPrefix s of - -- If there is a decision available, make it - (t:ts) -> - let bstate' = boundf (schedBState s) prior (decision t, action t) - in (Just t, (nextState []) { schedPrefix = ts, schedBState = bstate' }) - - -- Otherwise query the initialise function for a list of possible - -- choices, filter out anything in the sleep set, and make one of - -- them arbitrarily (recording the others). - [] -> - let choices = restrictToBound id initialise - checkDep t a = case prior of - Just (tid, act) -> dependent (schedDepState s) tid act t a - Nothing -> False - ssleep' = M.filterWithKey (\t a -> not $ checkDep t a) $ schedSleep s - choices' = filter (`notElem` M.keys ssleep') choices - signore' = not (null choices) && all (`elem` M.keys ssleep') choices - sbkill' = not (null initialise) && null choices - in case choices' of - (nextTid:rest) -> - let bstate' = boundf (schedBState s) prior (decision nextTid, action nextTid) - in (Just nextTid, (nextState rest) { schedSleep = ssleep', schedBState = bstate' }) - [] -> - (Nothing, (nextState []) { schedIgnore = signore', schedBoundKill = sbkill', schedBState = Nothing }) - -------------------------------------------------------------------------------- --- Weighted random scheduler - --- | The scheduler state -data RandSchedState g = RandSchedState - { schedWeights :: Map ThreadId Int - -- ^ The thread weights: used in determining which to run. - , schedGen :: g - -- ^ The random number generator. - } deriving (Eq, Show) - -instance NFData g => NFData (RandSchedState g) where - rnf s = rnf ( schedWeights s - , schedGen s - ) - --- | Initial weighted random scheduler state. -initialRandSchedState :: Maybe (Map ThreadId Int) -> g -> RandSchedState g -initialRandSchedState = RandSchedState . fromMaybe M.empty - --- | Weighted random scheduler: assigns to each new thread a weight, --- and makes a weighted random choice out of the runnable threads at --- every step. -randSched :: RandomGen g => (g -> (Int, g)) -> Scheduler (RandSchedState g) -randSched weightf = Scheduler $ \_ threads s -> - let - -- Select a thread - pick idx ((x, f):xs) - | idx < f = Just x - | otherwise = pick (idx - f) xs - pick _ [] = Nothing - (choice, g'') = randomR (0, sum (map snd enabled) - 1) g' - enabled = M.toList $ M.filterWithKey (\tid _ -> tid `elem` tids) weights' - - -- The weights, with any new threads added. - (weights', g') = foldr assignWeight (M.empty, schedGen s) tids - assignWeight tid ~(ws, g0) = - 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) - in (pick choice enabled, RandSchedState weights' g'') - -------------------------------------------------------------------------------- --- Dependency function - --- | Check if an action is dependent on another. --- --- This is basically the same as 'dependent'', but can make use of the --- additional information in a 'ThreadAction' to make better decisions --- in a few cases. -dependent :: DepState -> ThreadId -> ThreadAction -> ThreadId -> ThreadAction -> Bool -dependent ds t1 a1 t2 a2 = case (a1, a2) of - -- @SetNumCapabilities@ and @GetNumCapabilities@ are NOT dependent - -- IF the value read is the same as the value written. 'dependent'' - -- can not see the value read (as it hasn't happened yet!), and so - -- is more pessimistic here. - (SetNumCapabilities a, GetNumCapabilities b) | a == b -> False - (GetNumCapabilities a, SetNumCapabilities b) | a == b -> False - - -- When masked interruptible, a thread can only be interrupted when - -- actually blocked. 'dependent'' has to assume that all - -- potentially-blocking operations can block, and so is more - -- pessimistic in this case. - (ThrowTo t, _) | t == t2 -> canInterrupt ds t2 a2 && a2 /= Stop - (_, ThrowTo t) | t == t1 -> canInterrupt ds t1 a1 && a1 /= Stop - - -- Dependency of STM transactions can be /greatly/ improved here, as - -- the 'Lookahead' does not know which @TVar@s will be touched, and - -- so has to assume all transactions are dependent. - (STM _ _, STM _ _) -> checkSTM - (STM _ _, BlockedSTM _) -> checkSTM - (BlockedSTM _, STM _ _) -> checkSTM - (BlockedSTM _, BlockedSTM _) -> checkSTM - - _ -> case (,) <$> rewind a1 <*> rewind a2 of - Just (l1, l2) -> dependent' ds t1 a1 t2 l2 && dependent' ds t2 a2 t1 l1 - _ -> dependentActions ds (simplifyAction a1) (simplifyAction a2) - - where - -- STM actions A and B are dependent if A wrote to anything B - -- touched, or vice versa. - checkSTM = checkSTM' a1 a2 || checkSTM' a2 a1 - checkSTM' a b = not . S.null $ tvarsWritten a `S.intersection` tvarsOf b - --- | Variant of 'dependent' to handle 'Lookahead'. --- --- Termination of the initial thread is handled specially in the DPOR --- implementation. -dependent' :: DepState -> ThreadId -> ThreadAction -> ThreadId -> Lookahead -> Bool -dependent' ds t1 a1 t2 l2 = case (a1, l2) of - -- Worst-case assumption: all IO is dependent. - (LiftIO, WillLiftIO) -> True - - -- Throwing an exception is only dependent with actions in that - -- thread and if the actions can be interrupted. We can also - -- slightly improve on that by not considering interrupting the - -- normal termination of a thread: it doesn't make a difference. - (ThrowTo t, WillStop) | t == t2 -> False - (Stop, WillThrowTo t) | t == t1 -> False - (ThrowTo t, _) | t == t2 -> canInterruptL ds t2 l2 - (_, WillThrowTo t) | t == t1 -> canInterrupt ds t1 a1 - - -- Another worst-case: assume all STM is dependent. - (STM _ _, WillSTM) -> True - - -- This is a bit pessimistic: Set/Get are only dependent if the - -- value set is not the same as the value that will be got, but we - -- can't know that here. 'dependent' optimises this case. - (GetNumCapabilities a, WillSetNumCapabilities b) -> a /= b - (SetNumCapabilities _, WillGetNumCapabilities) -> True - (SetNumCapabilities a, WillSetNumCapabilities b) -> a /= b - - _ -> dependentActions ds (simplifyAction a1) (simplifyLookahead l2) - --- | Check if two 'ActionType's are dependent. Note that this is not --- sufficient to know if two 'ThreadAction's are dependent, without --- being so great an over-approximation as to be useless! -dependentActions :: DepState -> ActionType -> ActionType -> Bool -dependentActions ds a1 a2 = case (a1, a2) of - -- Unsynchronised reads and writes are always dependent, even under - -- a relaxed memory model, as an unsynchronised write gives rise to - -- a commit, which synchronises. - (UnsynchronisedRead r1, _) | same crefOf && a2 /= PartiallySynchronisedCommit r1 -> a2 /= UnsynchronisedRead r1 - (UnsynchronisedWrite r1, _) | same crefOf && a2 /= PartiallySynchronisedCommit r1 -> True - (PartiallySynchronisedWrite r1, _) | same crefOf && a2 /= PartiallySynchronisedCommit r1 -> True - (PartiallySynchronisedModify r1, _) | same crefOf && a2 /= PartiallySynchronisedCommit r1 -> True - (SynchronisedModify r1, _) | same crefOf && a2 /= PartiallySynchronisedCommit r1 -> True - - -- Unsynchronised writes and synchronisation where the buffer is not - -- empty. - -- - -- See [RMMVerification], lemma 5.25. - (UnsynchronisedWrite r1, PartiallySynchronisedCommit _) | same crefOf && isBuffered ds r1 -> False - (PartiallySynchronisedCommit _, UnsynchronisedWrite r2) | same crefOf && isBuffered ds r2 -> False - - -- Unsynchronised reads where a memory barrier would flush a - -- buffered write - (UnsynchronisedRead r1, _) | isBarrier a2 -> isBuffered ds r1 - (_, UnsynchronisedRead r2) | isBarrier a1 -> isBuffered ds r2 - - -- Commits and memory barriers must be dependent, as memory barriers - -- (currently) flush in a consistent order. Alternative orders need - -- to be explored as well. Perhaps a better implementation of - -- memory barriers would just block every non-commit thread while - -- any buffer is nonempty. - (PartiallySynchronisedCommit _, _) | isBarrier a2 -> True - (_, PartiallySynchronisedCommit _) | isBarrier a1 -> True - - (_, _) -> case getSame crefOf of - -- Two actions on the same CRef where at least one is synchronised - Just r -> synchronises a1 r || synchronises a2 r - -- Two actions on the same MVar - _ -> same mvarOf - - where - same :: Eq a => (ActionType -> Maybe a) -> Bool - 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 - -data DepState = DepState - { depCRState :: Map CRefId Bool - -- ^ Keep track of which @CRef@s have buffered writes. - , depMaskState :: Map ThreadId MaskingState - -- ^ Keep track of thread masking states. If a thread isn't present, - -- the masking state is assumed to be @Unmasked@. This nicely - -- provides compatibility with dpor-0.1, where the thread IDs are - -- not available. - } deriving (Eq, Show) - -instance NFData DepState where - rnf depstate = rnf ( depCRState depstate - , [(t, m `seq` ()) | (t, m) <- M.toList (depMaskState depstate)] - ) - --- | Initial dependency state. -initialDepState :: DepState -initialDepState = DepState M.empty M.empty - --- | Update the 'CRef' buffer state with the action that has just --- happened. -updateDepState :: DepState -> ThreadId -> ThreadAction -> DepState -updateDepState depstate tid act = DepState - { depCRState = updateCRState act $ depCRState depstate - , depMaskState = updateMaskState tid act $ depMaskState depstate - } - --- | Update the 'CRef' buffer state with the action that has just --- happened. -updateCRState :: ThreadAction -> Map CRefId Bool -> Map CRefId Bool -updateCRState (CommitCRef _ r) = M.delete r -updateCRState (WriteCRef r) = M.insert r True -updateCRState ta - | isBarrier $ simplifyAction ta = const M.empty - | otherwise = id - --- | Update the thread masking state with the action that has just --- happened. -updateMaskState :: ThreadId -> ThreadAction -> Map ThreadId MaskingState -> Map ThreadId MaskingState -updateMaskState tid (Fork tid2) = \masks -> case M.lookup tid masks of - -- A thread inherits the masking state of its parent. - Just ms -> M.insert tid2 ms masks - Nothing -> masks -updateMaskState tid (SetMasking _ ms) = M.insert tid ms -updateMaskState tid (ResetMasking _ ms) = M.insert tid ms -updateMaskState _ _ = id - --- | Check if a 'CRef' has a buffered write pending. -isBuffered :: DepState -> CRefId -> Bool -isBuffered depstate r = M.findWithDefault False r (depCRState depstate) - --- | Check if an exception can interrupt a thread (action). -canInterrupt :: DepState -> ThreadId -> ThreadAction -> Bool -canInterrupt depstate tid act - -- If masked interruptible, blocked actions can be interrupted. - | isMaskedInterruptible depstate tid = case act of - BlockedPutMVar _ -> True - BlockedReadMVar _ -> True - BlockedTakeMVar _ -> True - BlockedSTM _ -> True - BlockedThrowTo _ -> True - _ -> False - -- If masked uninterruptible, nothing can be. - | isMaskedUninterruptible depstate tid = False - -- If no mask, anything can be. - | otherwise = True - --- | Check if an exception can interrupt a thread (lookahead). -canInterruptL :: DepState -> ThreadId -> Lookahead -> Bool -canInterruptL depstate tid lh - -- If masked interruptible, actions which can block may be - -- interrupted. - | isMaskedInterruptible depstate tid = case lh of - WillPutMVar _ -> True - WillReadMVar _ -> True - WillTakeMVar _ -> True - WillSTM -> True - WillThrowTo _ -> True - _ -> False - -- If masked uninterruptible, nothing can be. - | isMaskedUninterruptible depstate tid = False - -- If no mask, anything can be. - | otherwise = True - --- | Check if a thread is masked interruptible. -isMaskedInterruptible :: DepState -> ThreadId -> Bool -isMaskedInterruptible depstate tid = - M.lookup tid (depMaskState depstate) == Just MaskedInterruptible - --- | Check if a thread is masked uninterruptible. -isMaskedUninterruptible :: DepState -> ThreadId -> Bool -isMaskedUninterruptible depstate tid = - M.lookup tid (depMaskState depstate) == Just MaskedUninterruptible - -------------------------------------------------------------------------------- --- * Utilities - --- The initial thread of a DPOR tree. -initialDPORThread :: DPOR -> ThreadId -initialDPORThread = S.elemAt 0 . dporRunnable - --- | Check if a thread yielded. -didYield :: ThreadAction -> Bool -didYield Yield = True -didYield (ThreadDelay _) = True -didYield _ = False - --- | Check if a thread will yield. -willYield :: Lookahead -> Bool -willYield WillYield = True -willYield (WillThreadDelay _) = True -willYield _ = False - --- | Check if an action will kill daemon threads. -killsDaemons :: ThreadId -> Lookahead -> Bool -killsDaemons t WillStop = t == initialThread -killsDaemons _ _ = False +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Test.DejaFu.SCT.Internal +-- Copyright : (c) 2018--2020 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : BangPatterns, FlexibleContexts, LambdaCase, RankNTypes +-- +-- Internal types and functions for SCT. This module is NOT +-- considered to form part of the public interface of this library. +module Test.DejaFu.SCT.Internal where + +import Data.Coerce (Coercible, coerce) +import qualified Data.IntMap.Strict as I +import Data.List (find, mapAccumL) +import Data.Maybe (fromMaybe) +import GHC.Stack (HasCallStack) + +import Test.DejaFu.Conc +import Test.DejaFu.Conc.Internal (Context(..)) +import Test.DejaFu.Conc.Internal.Memory (commitThreadId) +import Test.DejaFu.Conc.Internal.Program +import Test.DejaFu.Internal +import Test.DejaFu.Schedule (Scheduler(..)) +import Test.DejaFu.SCT.Internal.DPOR +import Test.DejaFu.Types +import Test.DejaFu.Utils + +------------------------------------------------------------------------------- +-- * Exploration + +-- | General-purpose SCT function. +sct :: (MonadDejaFu n, HasCallStack) + => Settings n a + -- ^ The SCT settings ('Way' is ignored) + -> ([ThreadId] -> s) + -- ^ Initial state + -> (s -> Maybe t) + -- ^ State predicate + -> (ConcurrencyState -> (Scheduler g -> g -> n (Either Condition a, g, Trace)) -> s -> t -> n (s, Maybe (Either Condition a, Trace))) + -- ^ Run the computation and update the state + -> Program pty n a + -> n [(Either Condition a, Trace)] +sct settings s0 sfun srun conc = recordSnapshot conc >>= \case + Just (Right snap, _) -> sct'Snap snap + Just (Left f, trace) -> pure [(Left f, trace)] + Nothing -> sct'Full + where + sct'Full = sct' + settings + initialCState + (s0 [initialThread]) + sfun + (srun initialCState runFull) + runFull + (toId 1) + (toId 1) + + sct'Snap snap = + let idsrc = cIdSource (contextFromSnapshot snap) + cstate = cCState (contextFromSnapshot snap) + in sct' + settings + cstate + (s0 (fst (threadsFromSnapshot snap))) + sfun + (srun cstate (runSnap snap)) + (runSnap snap) + (toId $ 1 + fst (_tids idsrc)) + (toId $ 1 + fst (_iorids idsrc)) + + runFull sched s = runConcurrent sched (_memtype settings) s conc + runSnap snap sched s = runSnapshot sched (_memtype settings) s snap + +-- | Like 'sct' but given a function to run the computation. +sct' :: (MonadDejaFu n, HasCallStack) + => Settings n a + -- ^ The SCT settings ('Way' is ignored) + -> ConcurrencyState + -- ^ The initial concurrency state + -> s + -- ^ Initial state + -> (s -> Maybe t) + -- ^ State predicate + -> (s -> t -> n (s, Maybe (Either Condition a, Trace))) + -- ^ Run the computation and update the state + -> (forall x. Scheduler x -> x -> n (Either Condition a, x, Trace)) + -- ^ Just run the computation + -> ThreadId + -- ^ The first available @ThreadId@ + -> IORefId + -- ^ The first available @IORefId@ + -> n [(Either Condition a, Trace)] +sct' settings cstate0 s0 sfun srun run nTId nCRId = go Nothing [] s0 where + go (Just res) _ _ | earlyExit res = pure [] + go res0 seen !s = case sfun s of + Just t -> srun s t >>= \case + (s', Just (Left Abort, _)) | hideAborts -> go res0 seen s' + (s', Just (res, trace)) -> case discard res of + Just DiscardResultAndTrace -> go (Just res) seen s' + Just DiscardTrace -> result res [] seen s' + Nothing -> result res trace seen s' + (s', Nothing) -> go Nothing seen s' + Nothing -> pure [] + + -- Sadly, we have to use a list to store the set of unique results, + -- as we don't have an @Ord a@ dict hanging around. I suspect that + -- most test cases will have a relatively small number of unique + -- results, compared to the number of executions, however. + -- Pathological cases (like IORef ones in dejafu-tests which produce + -- a different result on every execution) are probably uncommon. + result = case _equality settings of + Just f -> \res trace seen s -> + let eq cmp (Right a1) (Right a2) = cmp a1 a2 + eq _ (Left e1) (Left e2) = e1 == e2 + eq _ _ _ = False + in if any (eq f res) seen + then go (Just res) seen s + else dosimplify res trace (res:seen) s + Nothing -> dosimplify + + dosimplify res [] seen s = ((res, []) :) <$> go (Just res) seen s + dosimplify res trace seen s + | not (_simplify settings) = ((res, trace) :) <$> go (Just res) seen s + | otherwise = do + shrunk <- simplifyExecution settings cstate0 run nTId nCRId res trace + (shrunk :) <$> go (Just res) seen s + + earlyExit = fromMaybe (const False) (_earlyExit settings) + discard = fromMaybe (const Nothing) (_discard settings) + hideAborts = not (_showAborts settings) + +-- | Given a result and a trace, produce a more minimal trace. +-- +-- In principle, simplification is semantics preserving and can be +-- done without needing to execute the computation again. However, +-- there are two good reasons to do so: +-- +-- * It's a sanity check that there are no bugs. +-- * It's easier to generate a reduced sequence of scheduling +-- decisions and let dejafu generate the full trace, than to +-- generate a reduced trace directly +-- +-- Unlike shrinking in randomised property-testing tools like +-- QuickCheck or Hedgehog, we only run the test case /once/, at the +-- end, rather than after every simplification step. +simplifyExecution :: (MonadDejaFu n, HasCallStack) + => Settings n a + -- ^ The SCT settings ('Way' is ignored) + -> ConcurrencyState + -- ^ The initial concurrency state + -> (forall x. Scheduler x -> x -> n (Either Condition a, x, Trace)) + -- ^ Just run the computation + -> ThreadId + -- ^ The first available @ThreadId@ + -> IORefId + -- ^ The first available @IORefId@ + -> Either Condition a + -- ^ The expected result + -> Trace + -> n (Either Condition a, Trace) +simplifyExecution settings cstate0 run nTId nCRId res trace + | tidTrace == simplifiedTrace = do + debugPrint ("Simplifying new result '" ++ p res ++ "': no simplification possible!") + pure (res, trace) + | otherwise = do + debugPrint ("Simplifying new result '" ++ p res ++ "': OK!") + (res', _, trace') <- replay run (fixup simplifiedTrace) + case (_equality settings, res, res') of + (Just f, Right a1, Right a2) | f a1 a2 -> pure (res', trace') + (_, Left e1, Left e2) | e1 == e2 -> pure (res', trace') + (Nothing, Right _, Right _) -> pure (res', trace') -- this is a risky case! + _ -> do + debugFatal ("Got a different result after simplifying: '" ++ p res ++ "' /= '" ++ p res' ++ "'") + pure (res, trace) + where + tidTrace = toTIdTrace trace + simplifiedTrace = simplify (_safeIO settings) (_memtype settings) cstate0 tidTrace + fixup = renumber (_memtype settings) (fromId nTId) (fromId nCRId) + + debugFatal = if _debugFatal settings then fatal else debugPrint + debugPrint = fromMaybe (const (pure ())) (_debugPrint settings) + debugShow = fromMaybe (const "_") (_debugShow settings) + p = either show debugShow + +-- | Replay an execution. +replay :: MonadDejaFu n + => (forall x. Scheduler x -> x -> n (Either Condition a, x, Trace)) + -- ^ Run the computation + -> [(ThreadId, ThreadAction)] + -- ^ The reduced sequence of scheduling decisions + -> n (Either Condition a, [(ThreadId, ThreadAction)], Trace) +replay run = run (Scheduler (const sched)) where + sched runnable cs ((t, Stop):ts) = case findThread t runnable of + Just t' -> (Just t', ts) + Nothing -> sched runnable cs ts + sched runnable _ ((t, _):ts) = (findThread t runnable, ts) + sched _ _ _ = (Nothing, []) + + -- find a thread ignoring names + findThread tid0 = + fmap fst . find (\(tid,_) -> fromId tid == fromId tid0) + +------------------------------------------------------------------------------- +-- * Schedule simplification + +-- | Simplify a trace by permuting adjacent independent actions to +-- reduce context switching. +simplify + :: Bool + -> MemType + -> ConcurrencyState + -> [(ThreadId, ThreadAction)] + -> [(ThreadId, ThreadAction)] +simplify safeIO memtype cstate0 trc0 = loop (length trc0) (prepare trc0) where + prepare = dropCommits safeIO memtype cstate0 . lexicoNormalForm safeIO memtype cstate0 + step = pushForward safeIO memtype cstate0 . pullBack safeIO memtype cstate0 + + loop 0 trc = trc + loop n trc = + let trc' = step trc + in if trc' /= trc then loop (n-1) trc' else trc + +-- | Put a trace into lexicographic (by thread ID) normal form. +lexicoNormalForm + :: Bool + -> MemType + -> ConcurrencyState + -> [(ThreadId, ThreadAction)] + -> [(ThreadId, ThreadAction)] +lexicoNormalForm safeIO memtype cstate0 = go where + go trc = + let trc' = permuteBy safeIO memtype cstate0 (repeat (>)) trc + in if trc == trc' then trc else go trc' + +-- | Swap adjacent independent actions in the trace if a predicate +-- holds. +permuteBy + :: Bool + -> MemType + -> ConcurrencyState + -> [ThreadId -> ThreadId -> Bool] + -> [(ThreadId, ThreadAction)] + -> [(ThreadId, ThreadAction)] +permuteBy safeIO memtype = go where + go ds (p:ps) (t1@(tid1, ta1):t2@(tid2, ta2):trc) + | independent safeIO ds tid1 ta1 tid2 ta2 && p tid1 tid2 = go' ds ps t2 (t1 : trc) + | otherwise = go' ds ps t1 (t2 : trc) + go _ _ trc = trc + + go' ds ps t@(tid, ta) trc = t : go (updateCState memtype ds tid ta) ps trc + +-- | Throw away commit actions which are followed by a memory barrier. +dropCommits + :: Bool + -> MemType + -> ConcurrencyState + -> [(ThreadId, ThreadAction)] + -> [(ThreadId, ThreadAction)] +dropCommits _ SequentialConsistency = const id +dropCommits safeIO memtype = go where + go ds (t1@(tid1, ta1@(CommitIORef _ iorefid)):t2@(tid2, ta2):trc) + | isBarrier (simplifyAction ta2) && numBuffered ds iorefid == 1 = go ds (t2:trc) + | independent safeIO ds tid1 ta1 tid2 ta2 = t2 : go (updateCState memtype ds tid2 ta2) (t1:trc) + go ds (t@(tid,ta):trc) = t : go (updateCState memtype ds tid ta) trc + go _ [] = [] + +-- | Attempt to reduce context switches by \"pulling\" thread actions +-- back to a prior execution of that thread. +-- +-- Simple example, say we have @[(tidA, act1), (tidB, act2), (tidA, +-- act3)]@, where @act2@ and @act3@ are independent. In this case +-- 'pullBack' will swap them, giving the sequence @[(tidA, act1), +-- (tidA, act3), (tidB, act2)]@. It works for arbitrary separations. +pullBack + :: Bool + -> MemType + -> ConcurrencyState + -> [(ThreadId, ThreadAction)] + -> [(ThreadId, ThreadAction)] +pullBack safeIO memtype = go where + go ds (t1@(tid1, ta1):trc@((tid2, _):_)) = + let ds' = updateCState memtype ds tid1 ta1 + trc' = if tid1 /= tid2 + then maybe trc (uncurry (:)) (findAction tid1 ds' trc) + else trc + in t1 : go ds' trc' + go _ trc = trc + + findAction tid0 = fgo where + fgo ds (t@(tid, ta):trc) + | tid == tid0 = Just (t, trc) + | otherwise = case fgo (updateCState memtype ds tid ta) trc of + Just (ft@(ftid, fa), trc') + | independent safeIO ds tid ta ftid fa -> Just (ft, t:trc') + _ -> Nothing + fgo _ _ = Nothing + +-- | Attempt to reduce context switches by \"pushing\" thread actions +-- forward to a future execution of that thread. +-- +-- This is kind of the opposite of 'pullBack', but there are cases +-- where one applies but not the other. +-- +-- Simple example, say we have @[(tidA, act1), (tidB, act2), (tidA, +-- act3)]@, where @act1@ and @act2@ are independent. In this case +-- 'pushForward' will swap them, giving the sequence @[(tidB, act2), +-- (tidA, act1), (tidA, act3)]@. It works for arbitrary separations. +pushForward + :: Bool + -> MemType + -> ConcurrencyState + -> [(ThreadId, ThreadAction)] + -> [(ThreadId, ThreadAction)] +pushForward safeIO memtype = go where + go ds (t1@(tid1, ta1):trc@((tid2, _):_)) = + let ds' = updateCState memtype ds tid1 ta1 + in if tid1 /= tid2 + then maybe (t1 : go ds' trc) (go ds) (findAction tid1 ta1 ds trc) + else t1 : go ds' trc + go _ trc = trc + + findAction tid0 ta0 = fgo where + fgo ds (t@(tid, ta):trc) + | tid == tid0 = Just ((tid0, ta0) : t : trc) + | independent safeIO ds tid0 ta0 tid ta = (t:) <$> fgo (updateCState memtype ds tid ta) trc + | otherwise = Nothing + fgo _ _ = Nothing + +-- | Re-number threads and IORefs. +-- +-- Permuting forks or newIORefs makes the existing numbering invalid, +-- which then causes problems for scheduling. Just re-numbering +-- threads isn't enough, as IORef IDs are used to determine commit +-- thread IDs. +-- +-- Renumbered things will not fix their names, so don't rely on those +-- at all. +renumber + :: MemType + -- ^ The memory model determines how commit threads are numbered. + -> Int + -- ^ First free thread ID. + -> Int + -- ^ First free @IORef@ ID. + -> [(ThreadId, ThreadAction)] + -> [(ThreadId, ThreadAction)] +renumber memtype tid0 crid0 = snd . mapAccumL go (I.empty, tid0, I.empty, crid0) where + go s@(tidmap, _, cridmap, _) (_, CommitIORef tid crid) = + let tid' = renumbered tidmap tid + crid' = renumbered cridmap crid + act' = CommitIORef tid' crid' + in case memtype of + PartialStoreOrder -> (s, (commitThreadId tid' (Just crid'), act')) + _ -> (s, (commitThreadId tid' Nothing, act')) + go s@(tidmap, _, _, _) (tid, act) = + let (s', act') = updateAction s act + in (s', (renumbered tidmap tid, act')) + + -- I can't help but feel there should be some generic programming + -- solution to this sort of thing (and to the many other functions + -- operating over @ThreadAction@s / @Lookahead@s) + updateAction (tidmap, nTId, cridmap, nCRId) (Fork old) = + let tidmap' = I.insert (fromId old) nTId tidmap + nTId' = nTId + 1 + in ((tidmap', nTId', cridmap, nCRId), Fork (toId nTId)) + updateAction (tidmap, nTId, cridmap, nCRId) (ForkOS old) = + let tidmap' = I.insert (fromId old) nTId tidmap + nTId' = nTId + 1 + in ((tidmap', nTId', cridmap, nCRId), ForkOS (toId nTId)) + updateAction s@(tidmap, _, _, _) (PutMVar mvid olds) = + (s, PutMVar mvid (map (renumbered tidmap) olds)) + updateAction s@(tidmap, _, _, _) (TryPutMVar mvid b olds) = + (s, TryPutMVar mvid b (map (renumbered tidmap) olds)) + updateAction s@(tidmap, _, _, _) (TakeMVar mvid olds) = + (s, TakeMVar mvid (map (renumbered tidmap) olds)) + updateAction s@(tidmap, _, _, _) (TryTakeMVar mvid b olds) = + (s, TryTakeMVar mvid b (map (renumbered tidmap) olds)) + updateAction (tidmap, nTId, cridmap, nCRId) (NewIORef old) = + let cridmap' = I.insert (fromId old) nCRId cridmap + nCRId' = nCRId + 1 + in ((tidmap, nTId, cridmap', nCRId'), NewIORef (toId nCRId)) + updateAction s@(_, _, cridmap, _) (ReadIORef old) = + (s, ReadIORef (renumbered cridmap old)) + updateAction s@(_, _, cridmap, _) (ReadIORefCas old) = + (s, ReadIORefCas (renumbered cridmap old)) + updateAction s@(_, _, cridmap, _) (ModIORef old) = + (s, ModIORef (renumbered cridmap old)) + updateAction s@(_, _, cridmap, _) (ModIORefCas old) = + (s, ModIORefCas (renumbered cridmap old)) + updateAction s@(_, _, cridmap, _) (WriteIORef old) = + (s, WriteIORef (renumbered cridmap old)) + updateAction s@(_, _, cridmap, _) (CasIORef old b) = + (s, CasIORef (renumbered cridmap old) b) + updateAction s@(tidmap, _, _, _) (STM tas olds) = + (s, STM tas (map (renumbered tidmap) olds)) + updateAction s@(tidmap, _, _, _) (ThrowTo old ms) = + (s, ThrowTo (renumbered tidmap old) ms) + updateAction s@(tidmap, _, _, _) (BlockedThrowTo old) = + (s, BlockedThrowTo (renumbered tidmap old)) + updateAction s act = (s, act) + + renumbered :: (Coercible a Id, Coercible Id a) => I.IntMap Int -> a -> a + renumbered idmap id_ = toId $ I.findWithDefault (fromId id_) (fromId id_) idmap + +------------------------------------------------------------------------------- +-- * Utilities + +-- | Helper function for constructing IDs of any sort. +toId :: Coercible Id a => Int -> a +toId = coerce . Id Nothing + +-- | Helper function for deconstructing IDs of any sort. +fromId :: Coercible a Id => a -> Int +fromId a = let (Id _ id_) = coerce a in id_ diff --git a/Test/DejaFu/SCT/Internal/DPOR.hs b/Test/DejaFu/SCT/Internal/DPOR.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/SCT/Internal/DPOR.hs @@ -0,0 +1,698 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Test.DejaFu.SCT.Internal.DPOR +-- Copyright : (c) 2015--2020 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : DeriveAnyClass, DeriveGeneric, FlexibleContexts, ViewPatterns +-- +-- Internal types and functions for SCT via dynamic partial-order +-- reduction. This module is NOT considered to form part of the +-- public interface of this library. +module Test.DejaFu.SCT.Internal.DPOR where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData) +import qualified Data.Foldable as F +import Data.Function (on) +import Data.List (nubBy, partition, sortOn) +import Data.List.NonEmpty (toList) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (isJust, isNothing, listToMaybe, + maybeToList) +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as Sq +import Data.Set (Set) +import qualified Data.Set as S +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) + +import Test.DejaFu.Internal +import Test.DejaFu.Schedule (Scheduler(..)) +import Test.DejaFu.Types +import Test.DejaFu.Utils (decisionOf, tidOf) + +------------------------------------------------------------------------------- +-- * Dynamic partial-order reduction + +-- | DPOR execution is represented as a tree of states, characterised +-- by the decisions that lead to that state. +data DPOR = DPOR + { dporRunnable :: Set ThreadId + -- ^ What threads are runnable at this step. + , dporTodo :: Map ThreadId Bool + -- ^ Follow-on decisions still to make, and whether that decision + -- was added conservatively due to the bound. + , dporNext :: Maybe (ThreadId, DPOR) + -- ^ The next decision made. Executions are explored in a + -- depth-first fashion, so this changes as old subtrees are + -- exhausted and new ones explored. + , dporDone :: Set ThreadId + -- ^ All transitions which have been taken from this point, + -- including conservatively-added ones. + , dporSleep :: Map ThreadId ThreadAction + -- ^ Transitions to ignore (in this node and children) until a + -- dependent transition happens. + , dporTaken :: Map ThreadId ThreadAction + -- ^ Transitions which have been taken, excluding + -- conservatively-added ones. This is used in implementing sleep + -- sets. + } deriving (Eq, Show, Generic, NFData) + +-- | Check the DPOR data invariants and raise an error if any are +-- broken. +-- +-- This is a reasonable thing to do, because if the state is corrupted +-- then nothing sensible can happen anyway. +validateDPOR :: HasCallStack => DPOR -> DPOR +validateDPOR dpor + | not (todo `S.isSubsetOf` runnable) = fatal "thread exists in todo set but not runnable set" + | not (done `S.isSubsetOf` runnable) = fatal "thread exists in done set but not runnable set" + | not (taken `S.isSubsetOf` done) = fatal "thread exists in taken set but not done set" + | not (todo `disjoint` done) = fatal "thread exists in both todo set and done set" + | not (maybe True (`S.member` done) next) = fatal "taken thread does not exist in done set" + | otherwise = dpor + where + done = dporDone dpor + next = fst <$> dporNext dpor + runnable = dporRunnable dpor + taken = S.fromList (M.keys (dporTaken dpor)) + todo = S.fromList (M.keys (dporTodo dpor)) + + disjoint s1 s2 = S.null (S.intersection s1 s2) + +-- | One step of the execution, including information for backtracking +-- purposes. This backtracking information is used to generate new +-- schedules. +data BacktrackStep = BacktrackStep + { bcktThreadid :: ThreadId + -- ^ The thread running at this step + , bcktDecision :: Decision + -- ^ What was decided at this step. + , bcktAction :: ThreadAction + -- ^ What happened at this step. + , bcktRunnable :: Map ThreadId Lookahead + -- ^ The threads runnable at this step + , bcktBacktracks :: Map ThreadId Bool + -- ^ The list of alternative threads to run, and whether those + -- alternatives were added conservatively due to the bound. + , bcktState :: ConcurrencyState + -- ^ Some domain-specific state at this point. + } deriving (Eq, Show, Generic, NFData) + +-- | Initial DPOR state, given an initial thread ID. This initial +-- thread should exist and be runnable at the start of execution. +-- +-- The main thread must be in the list of initially runnable threads. +initialState :: [ThreadId] -> DPOR +initialState threads + | initialThread `elem` threads = DPOR + { dporRunnable = S.fromList threads + , dporTodo = M.singleton initialThread False + , dporNext = Nothing + , dporDone = S.empty + , dporSleep = M.empty + , dporTaken = M.empty + } + | otherwise = fatal "initialState" "Initial thread is not in initially runnable set" + +-- | Produce a new schedule prefix from a @DPOR@ tree. If there are no new +-- prefixes remaining, return 'Nothing'. Also returns whether the +-- decision was added conservatively, and the sleep set at the point +-- where divergence happens. +-- +-- A schedule prefix is a possibly empty sequence of decisions that +-- have already been made, terminated by a single decision from the +-- to-do set. The intent is to put the system into a new state when +-- executed with this initial sequence of scheduling decisions. +findSchedulePrefix + :: DPOR + -> Maybe ([ThreadId], Bool, Map ThreadId ThreadAction) +findSchedulePrefix dpor = case dporNext dpor of + Just (tid, child) -> go tid child <|> here + Nothing -> here + where + go tid child = (\(ts,c,slp) -> (tid:ts,c,slp)) <$> findSchedulePrefix child + + -- Prefix traces terminating with a to-do decision at this point. + here = + let todos = [([t], c, sleeps) | (t, c) <- M.toList $ dporTodo dpor] + (best, worst) = partition (\([t],_,_) -> t >= initialThread) todos + in listToMaybe best <|> listToMaybe worst + + -- The new sleep set is the union of the sleep set of the node + -- we're branching from, plus all the decisions we've already + -- explored. + sleeps = dporSleep dpor `M.union` dporTaken dpor + +-- | Add a new trace to the stack. This won't work if to-dos aren't explored depth-first. +incorporateTrace :: HasCallStack + => Bool + -- ^ True if all IO is thread-safe. + -> MemType + -> Bool + -- ^ Whether the \"to-do\" point which was used to create this new + -- execution was conservative or not. + -> Trace + -- ^ The execution trace: the decision made, the runnable threads, + -- and the action performed. + -> ConcurrencyState + -- ^ The initial concurrency state + -> DPOR + -> DPOR +incorporateTrace safeIO memtype conservative = grow initialThread where + grow tid trc@((d, _, a):rest) state dpor = + let tid' = tidOf tid d + state' = updateCState memtype state tid' a + in case dporNext dpor of + Just (t, child) + | t == tid' -> + validateDPOR $ dpor { dporNext = Just (tid', grow tid' rest state' child) } + | hasTodos child -> fatal "replacing child with todos!" + _ -> validateDPOR $ + let taken = M.insert tid' a (dporTaken dpor) + sleep = dporSleep dpor `M.union` dporTaken dpor + in dpor { dporTaken = if conservative then dporTaken dpor else taken + , dporTodo = M.delete tid' (dporTodo dpor) + , dporNext = Just (tid', subtree state' tid' sleep trc) + , dporDone = S.insert tid' (dporDone dpor) + } + grow _ _ _ _ = fatal "trace exhausted without reading a to-do point!" + + -- check if there are to-do points in a tree + hasTodos dpor = not (M.null (dporTodo dpor)) || (case dporNext dpor of Just (_, dpor') -> hasTodos dpor'; _ -> False) + + -- Construct a new subtree corresponding to a trace suffix. + subtree state tid sleep ((_, _, a):rest) = validateDPOR $ + let state' = updateCState memtype state tid a + sleep' = M.filterWithKey (\t a' -> not $ dependent safeIO state' tid a t a') sleep + in DPOR + { dporRunnable = S.fromList $ case rest of + ((d', runnable, _):_) -> tidOf tid d' : map fst runnable + [] -> [] + , dporTodo = M.empty + , dporNext = case rest of + ((d', _, _):_) -> + let tid' = tidOf tid d' + in Just (tid', subtree state' tid' sleep' rest) + [] -> Nothing + , dporDone = case rest of + ((d', _, _):_) -> S.singleton (tidOf tid d') + [] -> S.empty + , dporSleep = sleep' + , dporTaken = case rest of + ((d', _, a'):_) -> M.singleton (tidOf tid d') a' + [] -> M.empty + } + subtree _ _ _ _ = fatal "subtree suffix empty!" + +-- | Produce a list of new backtracking points from an execution +-- trace. These are then used to inform new \"to-do\" points in the +-- @DPOR@ tree. +-- +-- Two traces are passed in to this function: the first is generated +-- from the special DPOR scheduler, the other from the execution of +-- the concurrent program. +-- +-- If the trace ends with any threads other than the initial one still +-- runnable, a dependency is imposed between this final action and +-- everything else. +findBacktrackSteps + :: Bool + -- ^ True if all IO is thread-safe + -> MemType + -> BacktrackFunc + -- ^ Backtracking function. Given a list of backtracking points, and + -- a thread to backtrack to at a specific point in that list, add + -- the new backtracking points. There will be at least one: this + -- chosen one, but the function may add others. + -> Bool + -- ^ Whether the computation was aborted due to no decisions being + -- in-bounds. + -> ConcurrencyState + -- ^ The initial concurrency state. + -> Seq ([(ThreadId, Lookahead)], [ThreadId]) + -- ^ A sequence of threads at each step: the list of runnable + -- in-bound threads (with lookahead values), and the list of threads + -- still to try. The reason for the two separate lists is because + -- the threads chosen to try will be dependent on the specific + -- domain. + -> Trace + -- ^ The execution trace. + -> [BacktrackStep] +findBacktrackSteps safeIO memtype backtrack boundKill state0 = go state0 S.empty initialThread [] . F.toList where + -- Walk through the traces one step at a time, building up a list of + -- new backtracking points. + go state allThreads tid bs ((e,i):is) ((d,_,a):ts) = + let tid' = tidOf tid d + state' = updateCState memtype state tid' a + this = BacktrackStep + { bcktThreadid = tid' + , bcktDecision = d + , bcktAction = a + , bcktRunnable = M.fromList e + , bcktBacktracks = M.fromList $ map (\i' -> (i', False)) i + , bcktState = state + } + bs' = doBacktrack killsEarly allThreads' e (bs++[this]) + runnable = S.fromList (M.keys $ bcktRunnable this) + allThreads' = allThreads `S.union` runnable + killsEarly = null ts && boundKill + in go state' allThreads' tid' bs' is ts + go _ _ _ bs _ _ = bs + + -- Find the prior actions dependent with this one and add + -- backtracking points. + doBacktrack killsEarly allThreads enabledThreads bs = + let tagged = reverse $ zip [0..] bs + idxs = [ (i, False, u) + | (u, n) <- enabledThreads + , v <- S.toList allThreads + , u /= v + , i <- maybeToList (findIndex u n v tagged)] + + findIndex u n v = go' where + {-# INLINE go' #-} + go' ((i,b):rest) + -- 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 + | otherwise = go' rest + go' [] = Nothing + + {-# INLINE isDependent #-} + isDependent b + -- Don't impose a dependency if the other thread will + -- immediately block already. This is safe because a + -- context switch will occur anyway so there's no point + -- pre-empting the action UNLESS the pre-emption would + -- possibly allow for a different relaxed memory stage. + | isBlock (bcktAction b) && isBarrier (simplifyLookahead n) = False + | otherwise = dependent' safeIO (bcktState b) (bcktThreadid b) (bcktAction b) u n + in backtrack bs idxs + +-- | Add new backtracking points, if they have not already been +-- visited and aren't in the sleep set. +incorporateBacktrackSteps :: HasCallStack + => [BacktrackStep] -> DPOR -> DPOR +incorporateBacktrackSteps (b:bs) dpor = validateDPOR dpor' where + tid = bcktThreadid b + + dpor' = dpor + { dporTodo = dporTodo dpor `M.union` M.fromList todo + , dporNext = Just (tid, child) + } + + todo = + [ x + | x@(t,c) <- M.toList $ bcktBacktracks b + , Just t /= (fst <$> dporNext dpor) + , S.notMember t (dporDone dpor) + , c || M.notMember t (dporSleep dpor) + ] + + child = case dporNext dpor of + Just (t, d) + | t /= tid -> fatal "incorporating wrong trace!" + | otherwise -> incorporateBacktrackSteps bs d + Nothing -> fatal "child is missing!" +incorporateBacktrackSteps [] dpor = dpor + +------------------------------------------------------------------------------- +-- * DPOR scheduler + +-- | The scheduler state +data DPORSchedState k = DPORSchedState + { schedSleep :: Map ThreadId ThreadAction + -- ^ The sleep set: decisions not to make until something dependent + -- with them happens. + , schedPrefix :: [ThreadId] + -- ^ Decisions still to make + , schedBPoints :: Seq ([(ThreadId, Lookahead)], [ThreadId]) + -- ^ Which threads are runnable and in-bound at each step, and the + -- alternative decisions still to make. + , schedIgnore :: Bool + -- ^ Whether to ignore this execution or not: @True@ if the + -- execution is aborted due to all possible decisions being in the + -- sleep set, as then everything in this execution is covered by + -- another. + , schedBoundKill :: Bool + -- ^ Whether the execution was terminated due to all decisions being + -- out of bounds. + , schedCState :: ConcurrencyState + -- ^ State used by the dependency function to determine when to + -- remove decisions from the sleep set. + , schedBState :: Maybe k + -- ^ State used by the incremental bounding function. + } deriving (Eq, Show, Generic, NFData) + +-- | Initial DPOR scheduler state for a given prefix +initialDPORSchedState :: Map ThreadId ThreadAction + -- ^ The initial sleep set. + -> [ThreadId] + -- ^ The schedule prefix. + -> ConcurrencyState + -- ^ The initial concurrency state. + -> DPORSchedState k +initialDPORSchedState sleep prefix state0 = DPORSchedState + { schedSleep = sleep + , schedPrefix = prefix + , schedBPoints = Sq.empty + , schedIgnore = False + , schedBoundKill = False + , schedCState = state0 + , schedBState = Nothing + } + +-- | An incremental bounding function is a stateful function that +-- takes the last and next decisions, and returns a new state only if +-- the next decision is within the bound. +type IncrementalBoundFunc k + = Maybe k -> Maybe (ThreadId, ThreadAction) -> (Decision, Lookahead) -> Maybe k + +-- | A backtracking step is a point in the execution where another +-- decision needs to be made, in order to explore interesting new +-- schedules. A backtracking /function/ takes the steps identified so +-- far and a list of points and thread at that point to backtrack +-- to. More points be added to compensate for the effects of the +-- bounding function. For example, under pre-emption bounding a +-- conservative backtracking point is added at the prior context +-- switch. The bool is whether the point is conservative. Conservative +-- points are always explored, whereas non-conservative ones might be +-- skipped based on future information. +-- +-- In general, a backtracking function should identify one or more +-- backtracking points, and then use @backtrackAt@ to do the actual +-- work. +type BacktrackFunc + = [BacktrackStep] -> [(Int, Bool, ThreadId)] -> [BacktrackStep] + +-- | Add a backtracking point. If the thread isn't runnable, add all +-- runnable threads. If the backtracking point is already present, +-- don't re-add it UNLESS this would make it conservative. +backtrackAt :: HasCallStack + => (ThreadId -> BacktrackStep -> Bool) + -- ^ If this returns @True@, backtrack to all runnable threads, + -- rather than just the given thread. + -> BacktrackFunc +backtrackAt toAll bs0 = backtrackAt' . nubBy ((==) `on` fst') . sortOn fst' where + fst' (x,_,_) = x + + backtrackAt' ((i,c,t):is) = go i bs0 i c t is + backtrackAt' [] = bs0 + + go i0 (b:bs) 0 c tid is + -- If the backtracking point is already present, don't re-add it, + -- UNLESS this would force it to backtrack (it's conservative) + -- where before it might not. + | not (toAll tid b) && tid `M.member` bcktRunnable b = + let val = M.lookup tid $ bcktBacktracks b + b' = if isNothing val || (val == Just False && c) + then b { bcktBacktracks = backtrackTo tid c b } + else b + in b' : case is of + ((i',c',t'):is') -> go i' bs (i'-i0-1) c' t' is' + [] -> bs + -- Otherwise just backtrack to everything runnable. + | otherwise = + let b' = b { bcktBacktracks = backtrackAll c b } + in b' : case is of + ((i',c',t'):is') -> go i' bs (i'-i0-1) c' t' is' + [] -> bs + go i0 (b:bs) i c tid is = b : go i0 bs (i-1) c tid is + go _ [] _ _ _ _ = fatal "ran out of schedule whilst backtracking!" + + -- Backtrack to a single thread + backtrackTo tid c = M.insert tid c . bcktBacktracks + + -- Backtrack to all runnable threads + backtrackAll c = M.map (const c) . bcktRunnable + +-- | DPOR scheduler: takes a list of decisions, and maintains a trace +-- including the runnable threads, and the alternative choices allowed +-- by the bound-specific initialise function. +-- +-- After the initial decisions are exhausted, this prefers choosing +-- the prior thread if it's (1) still runnable and (2) hasn't just +-- yielded. Furthermore, threads which /will/ yield are ignored in +-- preference of those which will not. +dporSched :: HasCallStack + => Bool + -- ^ True if all IO is thread safe. + -> IncrementalBoundFunc k + -- ^ Bound function: returns true if that schedule prefix terminated + -- with the lookahead decision fits within the bound. + -> Scheduler (DPORSchedState k) +dporSched safeIO boundf = Scheduler $ \prior threads cstate s -> + let + -- The next scheduler state + nextState rest = s + { schedBPoints = schedBPoints s |> (restrictToBound fst threads', rest) + -- we only update this after using the current value; so in + -- effect this field is the depstate *before* the action which + -- just happened, we need this because we need to know if the + -- prior action (in the state we did it from) is dependent with + -- anything in the sleep set. + , schedCState = cstate + } + + -- Pick a new thread to run, not considering bounds. Choose the + -- current thread if available and it hasn't just yielded, + -- otherwise add all runnable threads. + initialise = tryDaemons . yieldsToEnd $ case prior of + Just (tid, act) + | not (didYield act) && tid `elem` tids && isInBound tid -> [tid] + _ -> tids + + -- If one of the chosen actions will kill the computation, and + -- there are daemon threads, try them instead. + -- + -- This is necessary if the killing action is NOT dependent with + -- every other action, according to the dependency function. This + -- is, strictly speaking, wrong; an action that kills another + -- thread is definitely dependent with everything in that + -- thread. HOWEVER, implementing it that way leads to an explosion + -- of schedules tried. Really, all that needs to happen is for the + -- thread-that-would-be-killed to be executed fully ONCE, and then + -- the normal dependency mechanism will identify any other + -- backtracking points that should be tried. This is achieved by + -- adding every thread that would be killed to the to-do list. + -- Furthermore, these threads MUST be ahead of the killing thread, + -- or the killing thread will end up in the sleep set and so the + -- killing action not performed. This is, again, because of the + -- lack of the dependency messing things up in the name of + -- performance. + -- + -- See commits a056f54 and 8554ce9, and my 4th June comment in + -- issue #52. + tryDaemons ts + | any doesKill ts = case partition doesKill tids of + (kills, nokills) -> nokills ++ kills + | otherwise = ts + doesKill t = killsDaemons t (action t) + + -- Restrict the possible decisions to those in the bound. + restrictToBound f = filter (isInBound . f) + isInBound t = isJust $ boundf (schedBState s) prior (decision t, action t) + + -- Move the threads which will immediately yield to the end of the list + yieldsToEnd ts = case partition (willYield . action) ts of + (yields, noyields) -> noyields ++ yields + + -- Get the decision that will lead to a thread being scheduled. + decision = decisionOf (fst <$> prior) (S.fromList tids) + + -- Get the action of a thread + action t = efromJust (lookup t threads') + + -- The runnable thread IDs + tids = map fst threads' + + -- The runnable threads as a normal list. + threads' = toList threads + in case schedPrefix s of + -- If there is a decision available, make it + (t:ts) -> + let bstate' = boundf (schedBState s) prior (decision t, action t) + in (Just t, (nextState []) { schedPrefix = ts, schedBState = bstate' }) + + -- Otherwise query the initialise function for a list of possible + -- choices, filter out anything in the sleep set, and make one of + -- them arbitrarily (recording the others). + [] -> + let choices = restrictToBound id initialise + checkDep t a = case prior of + Just (tid, act) -> dependent safeIO (schedCState s) tid act t a + Nothing -> False + ssleep' = M.filterWithKey (\t a -> not $ checkDep t a) $ schedSleep s + choices' = filter (`notElem` M.keys ssleep') choices + signore' = not (null choices) && all (`elem` M.keys ssleep') choices + sbkill' = not (null initialise) && null choices + in case choices' of + (nextTid:rest) -> + let bstate' = boundf (schedBState s) prior (decision nextTid, action nextTid) + in (Just nextTid, (nextState rest) { schedSleep = ssleep', schedBState = bstate' }) + [] -> + (Nothing, (nextState []) { schedIgnore = signore', schedBoundKill = sbkill', schedBState = Nothing }) + +------------------------------------------------------------------------------- +-- * Dependency function + +-- | Check if two actions commute. +-- +-- This implements a stronger check that @not (dependent ...)@, as it +-- handles some cases which 'dependent' doesn't need to care about. +independent :: Bool -> ConcurrencyState -> ThreadId -> ThreadAction -> ThreadId -> ThreadAction -> Bool +independent safeIO ds t1 a1 t2 a2 + | t1 == t2 = False + | check t1 a1 t2 a2 = False + | check t2 a2 t1 a1 = False + | otherwise = not (dependent safeIO ds t1 a1 t2 a2) + where + -- can't re-order any action of a thread with the fork which + -- created it. + check _ (Fork t) tid _ | t == tid = True + check _ (ForkOS t) tid _ | t == tid = True + -- because we can't easily tell if this will terminate the other + -- thread, we just can't re-order asynchronous exceptions at all + -- :( + -- + -- See #191 / #190 + check _ (ThrowTo t _) tid _ | t == tid = True + check _ (BlockedThrowTo t) tid _ | t == tid = True + -- can't re-order an unsynchronised write with something which synchronises that IORef. + check _ (simplifyAction -> UnsynchronisedWrite r) _ (simplifyAction -> a) | synchronises a r = True + check _ _ _ _ = False + +-- | Check if an action is dependent on another. +-- +-- This is basically the same as 'dependent'', but can make use of the +-- additional information in a 'ThreadAction' to make better decisions +-- in a few cases. +dependent :: Bool -> ConcurrencyState -> ThreadId -> ThreadAction -> ThreadId -> ThreadAction -> Bool +dependent safeIO ds t1 a1 t2 a2 = case (a1, a2) of + -- When masked interruptible, a thread can only be interrupted when + -- actually blocked. 'dependent'' has to assume that all + -- potentially-blocking operations can block, and so is more + -- pessimistic in this case. + (ThrowTo t _, ThrowTo u _) + | t == t2 && u == t1 -> canInterrupt ds t1 a1 || canInterrupt ds t2 a2 + (ThrowTo t _, _) | t == t2 -> canInterrupt ds t2 a2 && a2 /= Stop + (_, ThrowTo t _) | t == t1 -> canInterrupt ds t1 a1 && a1 /= Stop + + -- Dependency of STM transactions can be /greatly/ improved here, as + -- the 'Lookahead' does not know which @TVar@s will be touched, and + -- so has to assume all transactions are dependent. + (STM _ _, STM _ _) -> checkSTM + (STM _ _, BlockedSTM _) -> checkSTM + (STM _ _, ThrownSTM _ _) -> checkSTM + (BlockedSTM _, STM _ _) -> checkSTM + (BlockedSTM _, BlockedSTM _) -> checkSTM + (BlockedSTM _, ThrownSTM _ _) -> checkSTM + (ThrownSTM _ _, STM _ _) -> checkSTM + (ThrownSTM _ _, BlockedSTM _) -> checkSTM + (ThrownSTM _ _, ThrownSTM _ _) -> checkSTM + + _ -> dependent' safeIO ds t1 a1 t2 (rewind a2) + && dependent' safeIO ds t2 a2 t1 (rewind a1) + + where + -- STM actions A and B are dependent if A wrote to anything B + -- touched, or vice versa. + checkSTM = checkSTM' a1 a2 || checkSTM' a2 a1 + checkSTM' a b = not . S.null $ tvarsWritten a `S.intersection` tvarsOf b + +-- | Variant of 'dependent' to handle 'Lookahead'. +-- +-- Termination of the initial thread is handled specially in the DPOR +-- implementation. +dependent' :: Bool -> ConcurrencyState -> ThreadId -> ThreadAction -> ThreadId -> Lookahead -> Bool +dependent' safeIO ds t1 a1 t2 l2 = case (a1, l2) of + -- Worst-case assumption: all IO is dependent. + (LiftIO, WillLiftIO) -> not safeIO + + -- Throwing an exception is only dependent with actions in that + -- thread and if the actions can be interrupted. We can also + -- slightly improve on that by not considering interrupting the + -- normal termination of a thread: it doesn't make a difference. + (ThrowTo t _, WillThrowTo u) + | t == t2 && u == t1 -> canInterrupt ds t1 a1 || canInterruptL ds t2 l2 + (ThrowTo t _, _) | t == t2 -> canInterruptL ds t2 l2 && l2 /= WillStop + (_, WillThrowTo t) | t == t1 -> canInterrupt ds t1 a1 && a1 /= Stop + + -- Another worst-case: assume all STM is dependent. + (STM _ _, WillSTM) -> True + (BlockedSTM _, WillSTM) -> True + (ThrownSTM _ _, WillSTM) -> True + + -- the number of capabilities is essentially a global shared + -- variable + (GetNumCapabilities _, WillSetNumCapabilities _) -> True + (SetNumCapabilities _, WillGetNumCapabilities) -> True + (SetNumCapabilities _, WillSetNumCapabilities _) -> True + + _ -> dependentActions ds (simplifyAction a1) (simplifyLookahead l2) + +-- | Check if two 'ActionType's are dependent. Note that this is not +-- sufficient to know if two 'ThreadAction's are dependent, without +-- being so great an over-approximation as to be useless! +dependentActions :: ConcurrencyState -> ActionType -> ActionType -> Bool +dependentActions ds a1 a2 = case (a1, a2) of + (UnsynchronisedRead _, UnsynchronisedRead _) -> False + + -- Unsynchronised writes and synchronisation where the buffer is not + -- empty. + -- + -- See [RMMVerification], lemma 5.25. + (UnsynchronisedWrite r1, PartiallySynchronisedCommit r2) | r1 == r2 && isBuffered ds r1 -> False + (PartiallySynchronisedCommit r1, UnsynchronisedWrite r2) | r1 == r2 && isBuffered ds r1 -> False + + -- Unsynchronised reads where a memory barrier would flush a + -- buffered write + (UnsynchronisedRead r1, _) | isBarrier a2 && isBuffered ds r1 -> True + (_, UnsynchronisedRead r2) | isBarrier a1 && isBuffered ds r2 -> True + + -- Commits and memory barriers must be dependent, as memory barriers + -- (currently) flush in a consistent order. Alternative orders need + -- to be explored as well. Perhaps a better implementation of + -- memory barriers would just block every non-commit thread while + -- any buffer is nonempty. + (PartiallySynchronisedCommit r1, _) | synchronises a2 r1 -> True + (_, PartiallySynchronisedCommit r2) | synchronises a1 r2 -> True + + -- Two @MVar@ puts are dependent if they're to the same empty + -- @MVar@, and two takes are dependent if they're to the same full + -- @MVar@. + (SynchronisedWrite v1, SynchronisedWrite v2) | v1 == v2 -> not (isFull ds v1) + (SynchronisedRead v1, SynchronisedRead v2) | v1 == v2 -> isFull ds v1 + (SynchronisedWrite v1, SynchronisedRead v2) | v1 == v2 -> True + (SynchronisedRead v1, SynchronisedWrite v2) | v1 == v2 -> True + + (_, _) -> maybe False (\r -> Just r == iorefOf a2) (iorefOf a1) + +------------------------------------------------------------------------------- +-- * Utilities + +-- | Check if a thread yielded. +didYield :: ThreadAction -> Bool +didYield Yield = True +didYield (ThreadDelay _) = True +didYield _ = False + +-- | Check if a thread will yield. +willYield :: Lookahead -> Bool +willYield WillYield = True +willYield (WillThreadDelay _) = True +willYield _ = False + +-- | Check if an action will kill daemon threads. +killsDaemons :: ThreadId -> Lookahead -> Bool +killsDaemons t WillStop = t == initialThread +killsDaemons _ _ = False diff --git a/Test/DejaFu/SCT/Internal/Weighted.hs b/Test/DejaFu/SCT/Internal/Weighted.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/SCT/Internal/Weighted.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module : Test.DejaFu.SCT.Internal.Weighted +-- Copyright : (c) 2015--2019 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : DeriveAnyClass, DeriveGeneric +-- +-- Internal types and functions for SCT via weighted random +-- scheduling. This module is NOT considered to form part of the +-- public interface of this library. +module Test.DejaFu.SCT.Internal.Weighted where + +import Control.DeepSeq (NFData) +import Data.List.NonEmpty (toList) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import GHC.Generics (Generic) +import System.Random (RandomGen, randomR) + +import Test.DejaFu.Schedule (Scheduler(..)) +import Test.DejaFu.Types + +------------------------------------------------------------------------------- +-- * Weighted random scheduler + +-- | The scheduler state +data RandSchedState g = RandSchedState + { schedWeights :: Map ThreadId Int + -- ^ The thread weights: used in determining which to run. + , schedLengthBound :: Maybe LengthBound + -- ^ The optional length bound. + , schedGen :: g + -- ^ The random number generator. + } deriving (Eq, Show, Generic, NFData) + +-- | Initial weighted random scheduler state. +initialRandSchedState :: Maybe LengthBound -> g -> RandSchedState g +initialRandSchedState = RandSchedState M.empty + +-- | Weighted random scheduler: assigns to each new thread a weight, +-- and makes a weighted random choice out of the runnable threads at +-- every step. +randSched :: RandomGen g => (g -> (Int, g)) -> Scheduler (RandSchedState g) +randSched weightf = Scheduler $ \_ threads _ s -> + let + -- Select a thread + pick idx ((x, f):xs) + | idx < f = Just x + | otherwise = pick (idx - f) xs + pick _ [] = Nothing + (choice, g'') = randomR (0, sum (map snd enabled) - 1) g' + enabled = M.toList $ M.filterWithKey (\tid _ -> tid `elem` tids) weights' + + -- The weights, with any new threads added. + (weights', g') = foldr assignWeight (M.empty, schedGen s) tids + assignWeight tid ~(ws, g0) = + let (w, g) = maybe (weightf g0) (\w0 -> (w0, g0)) (M.lookup tid (schedWeights s)) + in (M.insert tid w ws, g) + + -- The runnable threads. + tids = map fst (toList threads) + in case schedLengthBound s of + Just 0 -> (Nothing, s) + Just n -> (pick choice enabled, RandSchedState weights' (Just (n - 1)) g'') + Nothing -> (pick choice enabled, RandSchedState weights' Nothing g'') diff --git a/Test/DejaFu/STM.hs b/Test/DejaFu/STM.hs deleted file mode 100644 --- a/Test/DejaFu/STM.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Test.DejaFu.STM --- Copyright : (c) 2016 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : CPP, GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies --- --- A 'MonadSTM' implementation, which can be run on top of 'IO' or --- 'ST'. -module Test.DejaFu.STM - ( -- * The @STMLike@ Monad - STMLike - , STMST - , STMIO - - -- * Executing Transactions - , Result(..) - , TTrace - , TAction(..) - , TVarId - , runTransaction - ) where - -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) -import Data.IORef (IORef) -import Data.STRef (STRef) - -import qualified Control.Monad.STM.Class as C -import Test.DejaFu.Common -import Test.DejaFu.STM.Internal - -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif - --- | @since 0.3.0.0 -newtype STMLike n r a = S { runSTM :: M n r a } deriving (Functor, Applicative, Monad) - -#if MIN_VERSION_base(4,9,0) --- | @since 0.9.1.0 -instance Fail.MonadFail (STMLike r n) where - fail = S . fail -#endif - --- | Create a new STM continuation. -toSTM :: ((a -> STMAction n r) -> STMAction n r) -> STMLike n r a -toSTM = S . cont - --- | A 'MonadSTM' implementation using @ST@, it encapsulates a single --- atomic transaction. The environment, that is, the collection of --- defined 'TVar's is implicit, there is no list of them, they exist --- purely as references. This makes the types simpler, but means you --- can't really get an aggregate of them (if you ever wanted to for --- some reason). --- --- @since 0.3.0.0 -type STMST t = STMLike (ST t) (STRef t) - --- | A 'MonadSTM' implementation using @ST@, it encapsulates a single --- atomic transaction. The environment, that is, the collection of --- defined 'TVar's is implicit, there is no list of them, they exist --- purely as references. This makes the types simpler, but means you --- can't really get an aggregate of them (if you ever wanted to for --- some reason). --- --- @since 0.3.0.0 -type STMIO = STMLike IO IORef - -instance MonadThrow (STMLike n r) where - throwM = toSTM . const . SThrow - -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 - -#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 - - readTVar = toSTM . SRead - - writeTVar tvar a = toSTM (\c -> SWrite tvar a (c ())) - --- | Run a transaction, returning the result and new initial --- 'TVarId'. If the transaction ended by calling 'retry', any 'TVar' --- modifications are undone. --- --- @since 0.4.0.0 -runTransaction :: MonadRef r n - => STMLike n r a -> IdSource -> n (Result a, IdSource, TTrace) -runTransaction ma tvid = do - (res, undo, tvid', trace) <- doTransaction (runSTM ma) tvid - - unless (isSTMSuccess res) undo - - pure (res, tvid', trace) diff --git a/Test/DejaFu/STM/Internal.hs b/Test/DejaFu/STM/Internal.hs deleted file mode 100644 --- a/Test/DejaFu/STM/Internal.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Module : Test.DejaFu.STM.Internal --- Copyright : (c) 2016 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : CPP, ExistentialQuantification, MultiParamTypeClasses, RankNTypes --- --- 'MonadSTM' testing implementation, internal types and --- definitions. This module is NOT considered to form part of the --- public interface of this library. -module Test.DejaFu.STM.Internal where - -import Control.DeepSeq (NFData(..)) -import Control.Exception (Exception, SomeException, fromException, - toException) -import Control.Monad.Ref (MonadRef, newRef, readRef, writeRef) -import Data.List (nub) - -import Test.DejaFu.Common - -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif - --------------------------------------------------------------------------------- --- The @STMLike@ monad - --- | The underlying monad is based on continuations over primitive --- actions. --- --- This is not @Cont@ because we want to give it a custom @MonadFail@ --- instance. -newtype M n r a = M { runM :: (a -> STMAction n r) -> STMAction n r } - -instance Functor (M n r) where - fmap f m = M $ \ c -> runM m (c . f) - -instance Applicative (M n r) where - pure x = M $ \c -> c x - f <*> v = M $ \c -> runM f (\g -> runM v (c . g)) - -instance Monad (M n r) where - return = pure - m >>= k = M $ \c -> runM m (\x -> runM (k x) c) - -#if MIN_VERSION_base(4,9,0) - fail = Fail.fail - --- | @since 0.7.1.2 -instance Fail.MonadFail (M n r) where -#endif - fail e = cont (\_ -> SThrow (MonadFailException e)) - --- | Construct a continuation-passing operation from a function. -cont :: ((a -> STMAction n r) -> STMAction n r) -> M n r a -cont = M - --- | Run a CPS computation with the given final computation. -runCont :: M n r a -> (a -> STMAction n r) -> STMAction n r -runCont = runM - --------------------------------------------------------------------------------- --- * Primitive actions - --- | STM transactions are represented as a sequence of primitive --- actions. -data STMAction n r - = forall a e. Exception e => SCatch (e -> M n r a) (M n r a) (a -> STMAction n r) - | forall a. SRead (TVar r a) (a -> STMAction n r) - | forall a. SWrite (TVar r a) a (STMAction n r) - | forall a. SOrElse (M n r a) (M n r a) (a -> STMAction n r) - | forall a. SNew String a (TVar r a -> STMAction n r) - | forall e. Exception e => SThrow e - | SRetry - | SStop (n ()) - --------------------------------------------------------------------------------- --- * @TVar@s - --- | A 'TVar' is a tuple of a unique ID and the value contained. The --- ID is so that blocked transactions can be re-run when a 'TVar' they --- depend on has changed. -newtype TVar r a = TVar (TVarId, r a) - --------------------------------------------------------------------------------- --- * Output - --- | The result of an STM transaction, along with which 'TVar's it --- touched whilst executing. --- --- @since 0.1.0.0 -data Result a = - Success [TVarId] [TVarId] a - -- ^ The transaction completed successfully, reading the first list - -- 'TVar's and writing to the second. - | Retry [TVarId] - -- ^ The transaction aborted by calling 'retry', and read the - -- returned 'TVar's. It should be retried when at least one of the - -- 'TVar's has been mutated. - | Exception SomeException - -- ^ The transaction aborted by throwing an exception. - deriving Show - --- | This only reduces a 'SomeException' to WHNF. --- --- @since 0.5.1.0 -instance NFData a => NFData (Result a) where - rnf (Success tr1 tr2 a) = rnf (tr1, tr2, a) - rnf (Retry tr) = rnf tr - rnf (Exception e) = e `seq` () - --- | Check if a 'Result' is a @Success@. -isSTMSuccess :: Result a -> Bool -isSTMSuccess (Success _ _ _) = True -isSTMSuccess _ = False - -instance Functor Result where - fmap f (Success rs ws a) = Success rs ws $ f a - fmap _ (Retry rs) = Retry rs - fmap _ (Exception e) = Exception e - -instance Foldable Result where - foldMap f (Success _ _ a) = f a - foldMap _ _ = mempty - --------------------------------------------------------------------------------- --- * Execution - --- | Run a STM transaction, returning an action to undo its effects. -doTransaction :: MonadRef r n => M n r a -> IdSource -> n (Result a, n (), IdSource, TTrace) -doTransaction ma idsource = do - (c, ref) <- runRefCont SStop (Just . Right) (runCont ma) - (idsource', undo, readen, written, trace) <- go ref c (pure ()) idsource [] [] [] - res <- readRef ref - - case res of - Just (Right val) -> pure (Success (nub readen) (nub written) val, undo, idsource', reverse trace) - - Just (Left exc) -> undo >> pure (Exception exc, pure (), idsource, reverse trace) - Nothing -> undo >> pure (Retry $ nub readen, pure (), idsource, reverse trace) - - where - go ref act undo nidsrc readen written sofar = do - (act', undo', nidsrc', readen', written', tact) <- stepTrans act nidsrc - - let newIDSource = nidsrc' - newAct = act' - newUndo = undo' >> undo - newReaden = readen' ++ readen - newWritten = written' ++ written - newSofar = tact : sofar - - case tact of - TStop -> pure (newIDSource, newUndo, newReaden, newWritten, TStop:newSofar) - TRetry -> do - writeRef ref Nothing - pure (newIDSource, newUndo, newReaden, newWritten, TRetry:newSofar) - TThrow -> do - writeRef ref (Just . Left $ case act of SThrow e -> toException e; _ -> undefined) - pure (newIDSource, newUndo, newReaden, newWritten, TThrow:newSofar) - _ -> go ref newAct newUndo newIDSource newReaden newWritten newSofar - --- | Run a transaction for one step. -stepTrans :: MonadRef r n => STMAction n r -> IdSource -> n (STMAction n r, n (), IdSource, [TVarId], [TVarId], TAction) -stepTrans act idsource = case act of - SCatch h stm c -> stepCatch h stm c - SRead ref c -> stepRead ref c - SWrite ref a c -> stepWrite ref a c - SNew n a c -> stepNew n a c - SOrElse a b c -> stepOrElse a b c - SStop na -> stepStop na - - SThrow e -> pure (SThrow e, nothing, idsource, [], [], TThrow) - SRetry -> pure (SRetry, nothing, idsource, [], [], TRetry) - - where - nothing = pure () - - stepCatch h stm c = cases TCatch stm c - (\trace -> pure (SRetry, nothing, idsource, [], [], TCatch trace Nothing)) - (\trace exc -> case fromException exc of - Just exc' -> transaction (TCatch trace . Just) (h exc') c - Nothing -> pure (SThrow exc, nothing, idsource, [], [], TCatch trace Nothing)) - - stepRead (TVar (tvid, ref)) c = do - val <- readRef ref - pure (c val, nothing, idsource, [tvid], [], TRead tvid) - - stepWrite (TVar (tvid, ref)) a c = do - old <- readRef ref - writeRef ref a - pure (c, writeRef ref old, idsource, [], [tvid], TWrite tvid) - - stepNew n a c = do - let (idsource', tvid) = nextTVId n idsource - ref <- newRef a - let tvar = TVar (tvid, ref) - pure (c tvar, nothing, idsource', [], [tvid], TNew tvid) - - stepOrElse a b c = cases TOrElse a c - (\trace -> transaction (TOrElse trace . Just) b c) - (\trace exc -> pure (SThrow exc, nothing, idsource, [], [], TOrElse trace Nothing)) - - stepStop na = do - na - pure (SStop na, nothing, idsource, [], [], TStop) - - cases tact stm onSuccess onRetry onException = do - (res, undo, idsource', trace) <- doTransaction stm idsource - case res of - Success readen written val -> pure (onSuccess val, undo, idsource', readen, written, tact trace Nothing) - Retry readen -> do - (res', undo', idsource'', readen', written', trace') <- onRetry trace - pure (res', undo', idsource'', readen ++ readen', written', trace') - Exception exc -> onException trace exc - - transaction tact stm onSuccess = cases (\t _ -> tact t) stm onSuccess - (\trace -> pure (SRetry, nothing, idsource, [], [], tact trace)) - (\trace exc -> pure (SThrow exc, nothing, idsource, [], [], tact trace)) diff --git a/Test/DejaFu/Schedule.hs b/Test/DejaFu/Schedule.hs --- a/Test/DejaFu/Schedule.hs +++ b/Test/DejaFu/Schedule.hs @@ -1,6 +1,6 @@ -- | -- Module : Test.DejaFu.Schedule --- Copyright : (c) 2016 Michael Walker +-- Copyright : (c) 2016--2018 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental @@ -11,12 +11,6 @@ ( -- * Scheduling Scheduler(..) - , Decision(..) - , tidOf - , decisionOf - - , NonEmpty(..) - -- ** Preemptive , randomSched , roundRobinSched @@ -29,10 +23,11 @@ , makeNonPreemptive ) where -import Data.List.NonEmpty (NonEmpty(..), toList) -import System.Random (RandomGen, randomR) +import Data.List.NonEmpty (NonEmpty(..), toList) +import System.Random (RandomGen, randomR) -import Test.DejaFu.Common +import Test.DejaFu.Internal +import Test.DejaFu.Types -- | A @Scheduler@ drives the execution of a concurrent program. The -- parameters it takes are: @@ -40,53 +35,26 @@ -- 1. The last thread executed (if this is the first invocation, this -- is @Nothing@). -- --- 2. The runnable threads at this point. +-- 2. The unblocked threads. -- --- 3. The state. +-- 3. The concurrency state. -- +-- 4. The scheduler state. +-- -- It returns a thread to execute, or @Nothing@ if execution should -- abort here, and also a new state. -- --- @since 0.8.0.0 +-- @since 2.0.0.0 newtype Scheduler state = Scheduler { scheduleThread :: Maybe (ThreadId, ThreadAction) -> NonEmpty (ThreadId, Lookahead) + -> ConcurrencyState -> state -> (Maybe ThreadId, state) } ------------------------------------------------------------------------------- --- Scheduling decisions - --- | Get the resultant thread identifier of a 'Decision', with a default case --- for 'Continue'. --- --- @since 0.5.0.0 -tidOf :: ThreadId -> Decision -> ThreadId -tidOf _ (Start t) = t -tidOf _ (SwitchTo t) = t -tidOf tid _ = tid - --- | Get the 'Decision' that would have resulted in this thread identifier, --- given a prior thread (if any) and list of runnable threads. --- --- @since 0.5.0.0 -decisionOf :: Foldable f - => Maybe ThreadId - -- ^ The prior thread. - -> f ThreadId - -- ^ The runnable threads. - -> ThreadId - -- ^ The current thread. - -> Decision -decisionOf Nothing _ chosen = Start chosen -decisionOf (Just prior) runnable chosen - | prior == chosen = Continue - | prior `elem` runnable = SwitchTo chosen - | otherwise = Start chosen - -------------------------------------------------------------------------------- -- Preemptive -- | A simple random scheduler which, at every step, picks a random @@ -95,10 +63,10 @@ -- @since 0.8.0.0 randomSched :: RandomGen g => Scheduler g randomSched = Scheduler go where - go _ threads g = + go _ threads _ g = let threads' = map fst (toList threads) (choice, g') = randomR (0, length threads' - 1) g - in (Just $ eidx "randomSched" threads' choice, g') + in (Just $ eidx threads' choice, g') -- | A round-robin scheduler which, at every step, schedules the -- thread with the next 'ThreadId'. @@ -106,8 +74,8 @@ -- @since 0.8.0.0 roundRobinSched :: Scheduler () roundRobinSched = Scheduler go where - go Nothing ((tid,_):|_) _ = (Just tid, ()) - go (Just (prior, _)) threads _ = + go Nothing ((tid,_):|_) _ _ = (Just tid, ()) + go (Just (prior, _)) threads _ _ = let threads' = map fst (toList threads) candidates = if prior >= maximum threads' @@ -118,16 +86,18 @@ ------------------------------------------------------------------------------- -- Non-preemptive --- | A random scheduler which doesn't preempt the running --- thread. That is, if the last thread scheduled is still runnable, --- run that, otherwise schedule randomly. +-- | A random scheduler which doesn't preempt the running thread. That +-- is, if the previously scheduled thread is not blocked, it is picked +-- again, otherwise schedule randomly. -- -- @since 0.8.0.0 randomSchedNP :: RandomGen g => Scheduler g randomSchedNP = makeNonPreemptive randomSched -- | A round-robin scheduler which doesn't preempt the running --- thread. +-- thread. That is, if the previously scheduled thread is not blocked, +-- it is picked again, otherwise schedule the thread with the next +-- 'ThreadId'. -- -- @since 0.8.0.0 roundRobinSchedNP :: Scheduler () @@ -142,7 +112,7 @@ -- @since 0.8.0.0 makeNonPreemptive :: Scheduler s -> Scheduler s makeNonPreemptive sched = Scheduler newsched where - newsched p@(Just (prior, _)) threads s + newsched p@(Just (prior, _)) threads cs s | prior `elem` map fst (toList threads) = (Just prior, s) - | otherwise = scheduleThread sched p threads s - newsched Nothing threads s = scheduleThread sched Nothing threads s + | otherwise = scheduleThread sched p threads cs s + newsched Nothing threads cs s = scheduleThread sched Nothing threads cs s diff --git a/Test/DejaFu/Settings.hs b/Test/DejaFu/Settings.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/Settings.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Test.DejaFu.Settings +-- Copyright : (c) 2018 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : RankNTypes +-- +-- Configuration for the SCT functions. +module Test.DejaFu.Settings + ( -- * SCT configuration + Settings + , defaultSettings + , fromWayAndMemType + + -- ** The @Way@ + , Way + , defaultWay + , lway + , systematically + , randomly + , uniformly + + -- *** Schedule bounding + + -- | Schedule bounding is used by the 'systematically' approach to + -- limit the search-space, which in general will be huge. + -- + -- There are three types of bound: + -- + -- * The 'PreemptionBound', which bounds the number of pre-emptive + -- context switches. Empirical evidence suggests @2@ is a good + -- value for this, if you have a small test case. + -- + -- * The 'FairBound', which bounds the difference between how many + -- times threads can yield. This is necessary to test certain + -- kinds of potentially non-terminating behaviour, such as + -- spinlocks. + -- + -- * The 'LengthBound', which bounds how long a test case can run, + -- in terms of scheduling decisions. This is necessary to test + -- certain kinds of potentially non-terminating behaviour, such + -- as livelocks. + -- + -- Schedule bounding is not used by the non-systematic exploration + -- behaviours. + + , Bounds(..) + , PreemptionBound(..) + , FairBound(..) + , defaultBounds + , defaultPreemptionBound + , defaultFairBound + , noBounds + + -- *** Length bounding + + -- | Length bounding can be used to test potentially nonterminating + -- computations. Any execution exceeding the length bound gets + -- discarded. + -- + -- While 'PreemptionBound' and 'FairBound' are only used by + -- 'systematically', all 'Way's use the length bound. + + , LengthBound(..) + , llengthBound + + -- ** The @MemType@ + + -- | When executed on a multi-core processor some @IORef@ / @IORef@ + -- programs can exhibit \"relaxed memory\" behaviours, where the + -- apparent behaviour of the program is not a simple interleaving of + -- the actions of each thread. + -- + -- __Example:__ This is a simple program which creates two @IORef@s + -- containing @False@, and forks two threads. Each thread writes + -- @True@ to one of the @IORef@s and reads the other. The value that + -- each thread reads is communicated back through an @MVar@: + -- + -- > >>> :{ + -- > let relaxed = do + -- > r1 <- newIORef False + -- > r2 <- newIORef False + -- > x <- spawn $ writeIORef r1 True >> readIORef r2 + -- > y <- spawn $ writeIORef r2 True >> readIORef r1 + -- > (,) <$> readMVar x <*> readMVar y + -- > :} + -- + -- We see something surprising if we ask for the results: + -- + -- > >>> autocheck relaxed + -- > [pass] Never Deadlocks + -- > [pass] No Exceptions + -- > [fail] Consistent Result + -- > (False,True) S0---------S1----S0--S2----S0-- + -- > + -- > (False,False) S0---------S1--P2----S1--S0--- + -- > + -- > (True,False) S0---------S2----S1----S0--- + -- > + -- > (True,True) S0---------S1-C-S2----S1---S0--- + -- > False + -- + -- It's possible for both threads to read the value @False@, even + -- though each writes @True@ to the other @IORef@ before reading. + -- This is because processors are free to re-order reads and writes + -- to independent memory addresses in the name of performance. + -- + -- Execution traces for relaxed memory computations can include + -- \"C\" actions, as above, which show where @IORef@ writes were + -- explicitly /committed/, and made visible to other threads. + -- + -- However, modelling this behaviour can require more executions. + -- If you do not care about the relaxed-memory behaviour of your + -- program, use the 'SequentialConsistency' model. + + , MemType(..) + , defaultMemType + , lmemtype + + -- ** Discard functions + + -- | Sometimes we know that a result is uninteresting and cannot + -- affect the result of a test, in which case there is no point in + -- keeping it around. Execution traces can be large, so any + -- opportunity to get rid of them early is possibly a great saving + -- of memory. + -- + -- A discard function, which has type @Either Condition a -> Maybe + -- Discard@, can selectively discard results or execution traces + -- before the schedule exploration finishes, allowing them to be + -- garbage collected sooner. + -- + -- __Note:__ The predicates and helper functions in Test.DejaFu come + -- with discard functions built in, to discard results and traces + -- wherever possible. + + , Discard(..) + , ldiscard + + -- ** Early exit + + -- | Sometimes we don't want to wait for all executions to be + -- explored, we just want to stop as soon as a particular result is + -- found. An early-exit predicate, which has type @Either Condition + -- a -> Bool@, can opt to halt execution when such a result is + -- found. + -- + -- All results found up to, and including, the one which terminates + -- the exploration are reported. + -- + -- __Usage in combination with a discard function:__ A discard + -- function can be used in combination with early-exit. As usual, + -- results or traces will be discarded as appropriate. If a single + -- result causes the early-exit function to return @True@ and the + -- discard function to return @Just DiscardResultAndTrace@, the + -- exploration will end early, but the result will not be included + -- in the output. + + , learlyExit + + -- ** Representative traces + + -- | There may be many different execution traces which give rise to + -- the same result, but some traces can be more complex than others. + -- + -- By supplying an equality predicate on results, all but the + -- simplest trace for each distinct result can be thrown away. + -- + -- __Slippage:__ Just comparing results can lead to different errors + -- which happen to have the same result comparing as equal. For + -- example, all deadlocks have the same result (@Left Deadlock@), + -- but may have different causes. See issue @#241@. + + , lequality + + -- ** Trace simplification + + -- | There may be many ways to reveal the same bug, and dejafu is + -- not guaranteed to find the simplest way first. This is + -- particularly problematic with random testing, where the schedules + -- generated tend to involve a lot of context switching. + -- Simplification produces smaller traces, which still have the same + -- essential behaviour. + -- + -- __Performance:__ Simplification in dejafu, unlike shrinking in + -- most random testing tools, is quite cheap. Simplification is + -- guaranteed to preserve semantics, so the test case does not need + -- to be re-run repeatedly during the simplification process. The + -- test case is re-run only /once/, after the process completes, for + -- implementation reasons. + -- + -- Concurrency tests can be rather large, however. So + -- simplification is disabled by default, and it is /highly/ + -- recommended to also use 'lequality', to reduce the number of + -- traces to simplify. + + , lsimplify + + -- ** Safe IO + + -- | Normally, dejafu has to assume any IO action can influence any + -- other IO action, as there is no way to peek inside them. + -- However, this adds considerable overhead to systematic testing. + -- A perfectly legitimate use of IO is in managing thread-local + -- state, such as a PRNG; in this case, there is no point in + -- exploring interleavings of IO actions from other threads. + -- + -- __Warning:__ Enabling this option is /unsound/ if your IO is not + -- thread safe! + + , lsafeIO + + -- ** Abort conditions + + -- | Occasionally in an execution dejafu will discover that no + -- available scheduling decisions are within the specified bounds, + -- and aborts the execution to move onto the next. This is + -- signalled by an 'Abort' condition. By default, abort conditions + -- are /not/ returned from the SCT functions. + + , lshowAborts + + -- ** Debug output + + -- | You can opt to receive debugging messages by setting debugging + -- print and show functions. Enabling debugging doesn't change any + -- behaviour, it just causes messages to be printed. These options + -- are most likely not useful for anyone not developing dejafu. + + , ldebugShow + , ldebugPrint + + -- | The debugging output includes both recoverable errors and + -- informative messages. Those recoverable errors can be made fatal + -- instead. + + , ldebugFatal + + -- * Lens helpers + , get + , set + ) where + +import Control.Applicative (Const(..)) +import Data.Functor.Identity (Identity(..)) +import System.Random (RandomGen, randomR) + +import Test.DejaFu.Internal (Settings(..), Way(..)) +import Test.DejaFu.Types + +------------------------------------------------------------------------------- +-- SCT configuration + +-- | Default SCT settings: just combine all the other defaults. +-- +-- @since 1.2.0.0 +defaultSettings :: Applicative n => Settings n a +defaultSettings = fromWayAndMemType defaultWay defaultMemType + +-- | Construct a 'Settings' record from a 'Way' and a 'MemType'. +-- +-- All other settings take on their default values. +-- +-- @since 1.2.0.0 +fromWayAndMemType :: Applicative n => Way -> MemType -> Settings n a +fromWayAndMemType way memtype = Settings + { _way = way + , _lengthBound = Nothing + , _memtype = memtype + , _discard = Nothing + , _debugShow = Nothing + , _debugPrint = Nothing + , _debugFatal = False + , _earlyExit = Nothing + , _equality = Nothing + , _simplify = False + , _safeIO = False + , _showAborts = False + } + +------------------------------------------------------------------------------- +-- The @Way@ + +-- | A default way to execute concurrent programs: systematically +-- using 'defaultBounds'. +-- +-- @since 0.6.0.0 +defaultWay :: Way +defaultWay = systematically defaultBounds + +-- | A lens into the 'Way'. +-- +-- @since 1.2.0.0 +lway :: Lens' (Settings n a) Way +lway afb s = (\b -> s {_way = b}) <$> afb (_way s) + +-- | Systematically execute a program, trying all distinct executions +-- within the bounds. +-- +-- @since 0.7.0.0 +systematically + :: Bounds + -- ^ The bounds to constrain the exploration. + -> Way +systematically = Systematic + +-- | Randomly execute a program, exploring a fixed number of +-- executions. +-- +-- Threads are scheduled by a weighted random selection, where weights +-- are assigned randomly on thread creation. +-- +-- This is not guaranteed to find all distinct results (unlike +-- 'systematically'). +-- +-- @since 0.7.0.0 +randomly :: RandomGen g + => g + -- ^ The random generator to drive the scheduling. + -> Int + -- ^ The number of executions to try. + -> Way +randomly = Randomly $ randomR (1, 50) + +-- | Randomly execute a program, exploring a fixed number of +-- executions. +-- +-- Threads are scheduled by a uniform random selection. +-- +-- This is not guaranteed to find all distinct results (unlike +-- 'systematically'). +-- +-- @since 0.7.0.0 +uniformly :: RandomGen g + => g + -- ^ The random generator to drive the scheduling. + -> Int + -- ^ The number of executions to try. + -> Way +uniformly = Randomly $ \g -> (1, g) + +------------------------------------------------------------------------------- +-- Schedule bounding + +-- | All bounds enabled, using their default values. +-- +-- There is no default length bound, so set one if your computation +-- may not terminate! +-- +-- @since 1.8.0.0 +defaultBounds :: Bounds +defaultBounds = Bounds + { boundPreemp = Just defaultPreemptionBound + , boundFair = Just defaultFairBound + } + +-- | A sensible default preemption bound: 2. +-- +-- See /Concurrency Testing Using Schedule Bounding: an Empirical Study/, +-- P. Thomson, A. F. Donaldson, A. Betts for justification. +-- +-- @since 0.2.0.0 +defaultPreemptionBound :: PreemptionBound +defaultPreemptionBound = 2 + +-- | A sensible default fair bound: 5. +-- +-- This comes from playing around myself, but there is probably a +-- better default. +-- +-- @since 0.2.0.0 +defaultFairBound :: FairBound +defaultFairBound = 5 + +-- | No bounds enabled. This forces the scheduler to just use +-- partial-order reduction and sleep sets to prune the search +-- space. This will /ONLY/ work if your computation always terminates! +-- +-- @since 0.3.0.0 +noBounds :: Bounds +noBounds = Bounds + { boundPreemp = Nothing + , boundFair = Nothing + } + +------------------------------------------------------------------------------- +-- Length bounding + +-- | A lens into the length bound. +-- +-- @since 2.0.0.0 +llengthBound :: Lens' (Settings n a) (Maybe LengthBound) +llengthBound afb s = (\b -> s {_lengthBound = b}) <$> afb (_lengthBound s) + +------------------------------------------------------------------------------- +-- The @MemType@ + +-- | The default memory model: @TotalStoreOrder@ +-- +-- @since 0.2.0.0 +defaultMemType :: MemType +defaultMemType = TotalStoreOrder + +-- | A lens into the 'MemType'. +-- +-- @since 1.2.0.0 +lmemtype :: Lens' (Settings n a) MemType +lmemtype afb s = (\b -> s {_memtype = b}) <$> afb (_memtype s) + +------------------------------------------------------------------------------- +-- Discard functions + +-- | A lens into the discard function. +-- +-- @since 1.2.0.0 +ldiscard :: Lens' (Settings n a) (Maybe (Either Condition a -> Maybe Discard)) +ldiscard afb s = (\b -> s {_discard = b}) <$> afb (_discard s) + +------------------------------------------------------------------------------- +-- Early exit + +-- | A lens into the early-exit predicate. +-- +-- @since 1.2.0.0 +learlyExit :: Lens' (Settings n a) (Maybe (Either Condition a -> Bool)) +learlyExit afb s = (\b -> s {_earlyExit = b}) <$> afb (_earlyExit s) + +------------------------------------------------------------------------------- +-- Representative traces + +-- | A lens into the equality predicate. +-- +-- @since 1.3.2.0 +lequality :: Lens' (Settings n a) (Maybe (a -> a -> Bool)) +lequality afb s = (\b -> s {_equality = b}) <$> afb (_equality s) + +------------------------------------------------------------------------------- +-- Simplification + +-- | A lens into the simplify flag. +-- +-- @since 1.3.2.0 +lsimplify :: Lens' (Settings n a) Bool +lsimplify afb s = (\b -> s {_simplify = b}) <$> afb (_simplify s) + +------------------------------------------------------------------------------- +-- Safe IO + +-- | A lens into the safe IO flag. +-- +-- @since 1.10.1.0 +lsafeIO :: Lens' (Settings n a) Bool +lsafeIO afb s = (\b -> s {_safeIO = b}) <$> afb (_safeIO s) + +------------------------------------------------------------------------------- +-- Abort conditions + +-- | A lens into the show-aborts flag. +-- +-- @since 1.12.0.0 +lshowAborts :: Lens' (Settings n a) Bool +lshowAborts afb s = (\b -> s {_showAborts = b}) <$> afb (_showAborts s) + +------------------------------------------------------------------------------- +-- Debug output + +-- | A lens into the debug 'show' function. +-- +-- @since 1.2.0.0 +ldebugShow :: Lens' (Settings n a) (Maybe (a -> String)) +ldebugShow afb s = (\b -> s {_debugShow = b}) <$> afb (_debugShow s) + +-- | A lens into the debug 'print' function. +-- +-- @since 1.2.0.0 +ldebugPrint :: Lens' (Settings n a) (Maybe (String -> n ())) +ldebugPrint afb s = (\b -> s {_debugPrint = b}) <$> afb (_debugPrint s) + +-- | A lens into the make-recoverable-errors-fatal flag. +-- +-- @since 1.3.2.0 +ldebugFatal :: Lens' (Settings n a) Bool +ldebugFatal afb s = (\b -> s {_debugFatal = b}) <$> afb (_debugFatal s) + +------------------------------------------------------------------------------- +-- Lens helpers + +-- lens type synonyms, unexported +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +type Lens' s a = Lens s s a a + +-- | Get a value from a lens. +-- +-- @since 1.2.0.0 +get :: Lens' s a -> s -> a +get lens = getConst . lens Const + +-- | Set a value in a lens. +-- +-- @since 1.2.0.0 +set :: Lens' s a -> a -> s -> s +set lens a = runIdentity . lens (\_ -> Identity a) diff --git a/Test/DejaFu/Types.hs b/Test/DejaFu/Types.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/Types.hs @@ -0,0 +1,962 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Test.DejaFu.Types +-- Copyright : (c) 2017--2021 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, RankNTypes, StandaloneDeriving, TypeFamilies +-- +-- Common types and functions used throughout DejaFu. +module Test.DejaFu.Types where + +import qualified Control.Concurrent as IO +import Control.DeepSeq (NFData(..)) +import Control.Exception (Exception(..), + MaskingState(..), + SomeException) +import Control.Monad (forever) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Catch.Pure (CatchT) +import qualified Control.Monad.ST as ST +import Control.Monad.Trans.Class (lift) +import Data.Function (on) +import Data.Functor.Contravariant (Contravariant(..)) +import Data.Functor.Contravariant.Divisible (Divisible(..)) +import qualified Data.IORef as IO +import Data.Kind (Type) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Semigroup (Semigroup(..)) +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.STRef as ST +import GHC.Generics (Generic, V1) + +------------------------------------------------------------------------------- +-- * The @MonadDejaFu@ typeclass + +-- | The @MonadDejaFu@ class captures the two things needed to run a +-- concurrent program which we can't implement in normal Haskell: +-- mutable references, and the ability to create a bound thread in +-- @IO@. +-- +-- In addition to needing the operations in this class, dejafu also +-- needs the ability to throw exceptions, as these are used to +-- communicate 'Error's, so there is a 'MonadThrow' constraint. +-- +-- @since 2.1.0.0 +class MonadThrow m => MonadDejaFu m where + -- | The type of mutable references. These references will always + -- contain a value, and so don't need to handle emptiness (like + -- @MVar@ does). + -- + -- These references are always used from the same Haskell thread, so + -- it's safe to implement these using unsynchronised primitives with + -- relaxed-memory behaviours (like @IORef@s). + type Ref m :: Type -> Type + + -- | Create a new reference holding a given initial value. + newRef :: a -> m (Ref m a) + + -- | Read the current value in the reference. + readRef :: Ref m a -> m a + + -- | Replace the value in the reference. + writeRef :: Ref m a -> a -> m () + + -- | A handle to a bound thread. If the monad doesn't support bound + -- threads (for example, if it's not based on @IO@), then this + -- should be some type which can't be constructed, like 'V1'. + type BoundThread m :: Type -> Type + + -- | Fork a new bound thread, if the monad supports them. + forkBoundThread :: Maybe (m (BoundThread m a)) + + -- | Run an action in a previously created bound thread. + runInBoundThread :: BoundThread m a -> m a -> m a + + -- | Terminate a previously created bound thread. + -- + -- After termination, 'runInBoundThread' and 'killBoundThread' will + -- never be called on this @BoundThread m a@ value again. + killBoundThread :: BoundThread m a -> m () + +-- | A bound thread in @IO@. +-- +-- @since 2.1.0.0 +data IOBoundThread a = IOBoundThread + { iobtRunInBoundThread :: IO a -> IO a + -- ^ Pass an action to the bound thread, run it, and return the + -- result to this thread. + , iobtKillBoundThread :: IO () + -- ^ Terminate the bound thread. + } + +-- | @since 2.1.0.0 +instance MonadDejaFu IO where + type Ref IO = IO.IORef + + newRef = IO.newIORef + readRef = IO.readIORef + writeRef = IO.writeIORef + + type BoundThread IO = IOBoundThread + + forkBoundThread = Just $ do + runboundIO <- IO.newEmptyMVar + getboundIO <- IO.newEmptyMVar + tid <- IO.forkOS (go runboundIO getboundIO) + pure IOBoundThread + { iobtRunInBoundThread = run runboundIO getboundIO + , iobtKillBoundThread = IO.killThread tid + } + where + go runboundIO getboundIO = forever $ do + na <- IO.takeMVar runboundIO + IO.putMVar getboundIO =<< na + + run runboundIO getboundIO ma = do + IO.putMVar runboundIO ma + IO.takeMVar getboundIO + + runInBoundThread = iobtRunInBoundThread + killBoundThread = iobtKillBoundThread + +-- | This instance does not support bound threads. +-- +-- @since 2.1.0.0 +instance MonadDejaFu (CatchT (ST.ST t)) where + type Ref (CatchT (ST.ST t)) = ST.STRef t + + newRef = lift . ST.newSTRef + readRef = lift . ST.readSTRef + writeRef r = lift . ST.writeSTRef r + + -- V1 has no constructors + type BoundThread (CatchT (ST.ST t)) = V1 + + forkBoundThread = Nothing + runInBoundThread = undefined + killBoundThread = undefined + +------------------------------------------------------------------------------- +-- * Identifiers + +-- | Every thread has a unique identitifer. +-- +-- @since 1.0.0.0 +newtype ThreadId = ThreadId Id + deriving (Eq, Ord, NFData) + +instance Show ThreadId where + show (ThreadId id_) = show id_ + +-- | @since 1.3.1.0 +deriving instance Generic ThreadId + +-- | Every @IORef@ has a unique identifier. +-- +-- @since 1.11.0.0 +newtype IORefId = IORefId Id + deriving (Eq, Ord, NFData, Generic) + +instance Show IORefId where + show (IORefId id_) = show id_ + +-- | Every @MVar@ has a unique identifier. +-- +-- @since 1.0.0.0 +newtype MVarId = MVarId Id + deriving (Eq, Ord, NFData) + +instance Show MVarId where + show (MVarId id_) = show id_ + +-- | @since 1.3.1.0 +deriving instance Generic MVarId + +-- | Every @TVar@ has a unique identifier. +-- +-- @since 1.0.0.0 +newtype TVarId = TVarId Id + deriving (Eq, Ord, NFData) + +instance Show TVarId where + show (TVarId id_) = show id_ + +-- | @since 1.3.1.0 +deriving instance Generic TVarId + +-- | An identifier for a thread, @MVar@, @IORef@, or @TVar@. +-- +-- The number is the important bit. The string is to make execution +-- traces easier to read, but is meaningless. +-- +-- @since 1.0.0.0 +data Id = Id (Maybe String) {-# UNPACK #-} !Int + +instance Eq Id where + (Id _ i) == (Id _ j) = i == j + +instance Ord Id where + compare (Id _ i) (Id _ j) = compare i j + +instance Show Id where + show (Id (Just n) _) = n + show (Id _ i) = show i + +-- | @since 1.3.1.0 +deriving instance Generic Id + +instance NFData Id + +-- | The ID of the initial thread. +-- +-- @since 0.4.0.0 +initialThread :: ThreadId +initialThread = ThreadId (Id (Just "main") 0) + +------------------------------------------------------------------------------- +-- * Actions + +-- | All the actions that a thread can perform. +-- +-- @since 2.2.0.0 +data ThreadAction = + Fork ThreadId + -- ^ Start a new thread. + | ForkOS ThreadId + -- ^ Start a new bound thread. + | SupportsBoundThreads Bool + -- ^ Check if bound threads are supported. + | IsCurrentThreadBound Bool + -- ^ Check if the current thread is bound. + | MyThreadId + -- ^ Get the 'ThreadId' of the current thread. + | GetNumCapabilities Int + -- ^ Get the number of Haskell threads that can run simultaneously. + | SetNumCapabilities Int + -- ^ Set the number of Haskell threads that can run simultaneously. + | Yield + -- ^ Yield the current thread. + | ThreadDelay Int + -- ^ Yield/delay the current thread. + | NewMVar MVarId + -- ^ Create a new 'MVar'. + | PutMVar MVarId [ThreadId] + -- ^ Put into a 'MVar', possibly waking up some threads. + | BlockedPutMVar MVarId + -- ^ Get blocked on a put. + | TryPutMVar MVarId Bool [ThreadId] + -- ^ Try to put into a 'MVar', possibly waking up some threads. + | ReadMVar MVarId + -- ^ Read from a 'MVar'. + | TryReadMVar MVarId Bool + -- ^ Try to read from a 'MVar'. + | BlockedReadMVar MVarId + -- ^ Get blocked on a read. + | TakeMVar MVarId [ThreadId] + -- ^ Take from a 'MVar', possibly waking up some threads. + | BlockedTakeMVar MVarId + -- ^ Get blocked on a take. + | TryTakeMVar MVarId Bool [ThreadId] + -- ^ Try to take from a 'MVar', possibly waking up some threads. + | NewIORef IORefId + -- ^ Create a new 'IORef'. + | ReadIORef IORefId + -- ^ Read from a 'IORef'. + | ReadIORefCas IORefId + -- ^ Read from a 'IORef' for a future compare-and-swap. + | ModIORef IORefId + -- ^ Modify a 'IORef'. + | ModIORefCas IORefId + -- ^ Modify a 'IORef' using a compare-and-swap. + | WriteIORef IORefId + -- ^ Write to a 'IORef' without synchronising. + | CasIORef IORefId Bool + -- ^ Attempt to to a 'IORef' using a compare-and-swap, synchronising + -- it. + | CommitIORef ThreadId IORefId + -- ^ Commit the last write to the given 'IORef' by the given thread, + -- so that all threads can see the updated value. + | STM [TAction] [ThreadId] + -- ^ An STM transaction was executed, possibly waking up some + -- threads. + | ThrownSTM [TAction] (Maybe MaskingState) + -- ^ An STM transaction threw an exception. Give the resultant + -- masking state after jumping to the exception handler (if the + -- thread is still alive). + | BlockedSTM [TAction] + -- ^ Got blocked in an STM transaction. + | Catching + -- ^ Register a new exception handler + | PopCatching + -- ^ Pop the innermost exception handler from the stack. + | Throw (Maybe MaskingState) + -- ^ Throw an exception, and give the resultant masking state after + -- jumping to the exception handler (if the thread is still alive). + | ThrowTo ThreadId (Maybe MaskingState) + -- ^ Throw an exception to a thread, and give the resultant masking + -- state after jumping to the exception handler (if the thread is + -- still alive). + | BlockedThrowTo ThreadId + -- ^ Get blocked on a 'throwTo'. + | SetMasking Bool MaskingState + -- ^ Set the masking state. If 'True', this is being used to set the + -- masking state to the original state in the argument passed to a + -- 'mask'ed function. + | ResetMasking Bool MaskingState + -- ^ Return to an earlier masking state. If 'True', this is being + -- used to return to the state of the masked block in the argument + -- passed to a 'mask'ed function. + | GetMaskingState MaskingState + -- ^ Get the current masking state. + | LiftIO + -- ^ Lift an IO action. Note that this can only happen with + -- 'ConcIO'. + | Return + -- ^ A 'return' or 'pure' action was executed. + | Stop + -- ^ Cease execution and terminate. + | RegisterInvariant + -- ^ Register an invariant. + deriving (Eq, Generic, Show) + +-- this makes me sad +instance NFData ThreadAction where + rnf (Fork t) = rnf t + rnf (ForkOS t) = rnf t + rnf (SupportsBoundThreads b) = rnf b + rnf (IsCurrentThreadBound b) = rnf b + rnf MyThreadId = () + rnf (GetNumCapabilities i) = rnf i + rnf (SetNumCapabilities i) = rnf i + rnf Yield = () + rnf (ThreadDelay i) = rnf i + rnf (NewMVar m) = rnf m + rnf (PutMVar m ts) = rnf (m, ts) + rnf (BlockedPutMVar m) = rnf m + rnf (TryPutMVar m b ts) = rnf (m, b, ts) + rnf (ReadMVar m) = rnf m + rnf (TryReadMVar m b) = rnf (m, b) + rnf (BlockedReadMVar m) = rnf m + rnf (TakeMVar m ts) = rnf (m, ts) + rnf (BlockedTakeMVar m) = rnf m + rnf (TryTakeMVar m b ts) = rnf (m, b, ts) + rnf (NewIORef c) = rnf c + rnf (ReadIORef c) = rnf c + rnf (ReadIORefCas c) = rnf c + rnf (ModIORef c) = rnf c + rnf (ModIORefCas c) = rnf c + rnf (WriteIORef c) = rnf c + rnf (CasIORef c b) = rnf (c, b) + rnf (CommitIORef t c) = rnf (t, c) + rnf (STM as ts) = rnf (as, ts) + rnf (ThrownSTM as (Just m)) = m `seq` rnf as + rnf (ThrownSTM as Nothing) = rnf as + rnf (BlockedSTM as) = rnf as + rnf Catching = () + rnf PopCatching = () + rnf (Throw (Just m)) = m `seq` () + rnf (Throw Nothing) = () + rnf (ThrowTo t (Just m)) = m `seq` rnf t + rnf (ThrowTo t Nothing) = rnf t + rnf (BlockedThrowTo t) = rnf t + rnf (SetMasking b m) = rnf (b, show m) + rnf (ResetMasking b m) = rnf (b, show m) + -- deepseq<1.4.4.0 doesn't have an instance for MaskingState + rnf (GetMaskingState m) = m `seq` () + rnf LiftIO = () + rnf Return = () + rnf Stop = () + rnf RegisterInvariant = () + +-- | A one-step look-ahead at what a thread will do next. +-- +-- @since 2.2.0.0 +data Lookahead = + WillFork + -- ^ Will start a new thread. + | WillForkOS + -- ^ Will start a new bound thread. + | WillSupportsBoundThreads + -- ^ Will check if bound threads are supported. + | WillIsCurrentThreadBound + -- ^ Will check if the current thread is bound. + | WillMyThreadId + -- ^ Will get the 'ThreadId'. + | WillGetNumCapabilities + -- ^ Will get the number of Haskell threads that can run + -- simultaneously. + | WillSetNumCapabilities Int + -- ^ Will set the number of Haskell threads that can run + -- simultaneously. + | WillYield + -- ^ Will yield the current thread. + | WillThreadDelay Int + -- ^ Will yield/delay the current thread. + | WillNewMVar + -- ^ Will create a new 'MVar'. + | WillPutMVar MVarId + -- ^ Will put into a 'MVar', possibly waking up some threads. + | WillTryPutMVar MVarId + -- ^ Will try to put into a 'MVar', possibly waking up some threads. + | WillReadMVar MVarId + -- ^ Will read from a 'MVar'. + | WillTryReadMVar MVarId + -- ^ Will try to read from a 'MVar'. + | WillTakeMVar MVarId + -- ^ Will take from a 'MVar', possibly waking up some threads. + | WillTryTakeMVar MVarId + -- ^ Will try to take from a 'MVar', possibly waking up some threads. + | WillNewIORef + -- ^ Will create a new 'IORef'. + | WillReadIORef IORefId + -- ^ Will read from a 'IORef'. + | WillReadIORefCas IORefId + -- ^ Will read from a 'IORef' for a future compare-and-swap. + | WillModIORef IORefId + -- ^ Will modify a 'IORef'. + | WillModIORefCas IORefId + -- ^ Will modify a 'IORef' using a compare-and-swap. + | WillWriteIORef IORefId + -- ^ Will write to a 'IORef' without synchronising. + | WillCasIORef IORefId + -- ^ Will attempt to to a 'IORef' using a compare-and-swap, + -- synchronising it. + | WillCommitIORef ThreadId IORefId + -- ^ Will commit the last write by the given thread to the 'IORef'. + | WillSTM + -- ^ Will execute an STM transaction, possibly waking up some + -- threads. + | WillCatching + -- ^ Will register a new exception handler + | WillPopCatching + -- ^ Will pop the innermost exception handler from the stack. + | WillThrow + -- ^ Will throw an exception. + | WillThrowTo ThreadId + -- ^ Will throw an exception to a thread. + | WillSetMasking Bool MaskingState + -- ^ Will set the masking state. If 'True', this is being used to + -- set the masking state to the original state in the argument + -- passed to a 'mask'ed function. + | WillResetMasking Bool MaskingState + -- ^ Will return to an earlier masking state. If 'True', this is + -- being used to return to the state of the masked block in the + -- argument passed to a 'mask'ed function. + | WillGetMaskingState + -- ^ Will get the masking state. + | WillLiftIO + -- ^ Will lift an IO action. Note that this can only happen with + -- 'ConcIO'. + | WillReturn + -- ^ Will execute a 'return' or 'pure' action. + | WillStop + -- ^ Will cease execution and terminate. + | WillRegisterInvariant + -- ^ Will register an invariant + deriving (Eq, Generic, Show) + +-- this also makes me sad +instance NFData Lookahead where + rnf WillFork = () + rnf WillForkOS = () + rnf WillSupportsBoundThreads = () + rnf WillIsCurrentThreadBound = () + rnf WillMyThreadId = () + rnf WillGetNumCapabilities = () + rnf (WillSetNumCapabilities i) = rnf i + rnf WillYield = () + rnf (WillThreadDelay i) = rnf i + rnf WillNewMVar = () + rnf (WillPutMVar m) = rnf m + rnf (WillTryPutMVar m) = rnf m + rnf (WillReadMVar m) = rnf m + rnf (WillTryReadMVar m) = rnf m + rnf (WillTakeMVar m) = rnf m + rnf (WillTryTakeMVar m) = rnf m + rnf WillNewIORef = () + rnf (WillReadIORef c) = rnf c + rnf (WillReadIORefCas c) = rnf c + rnf (WillModIORef c) = rnf c + rnf (WillModIORefCas c) = rnf c + rnf (WillWriteIORef c) = rnf c + rnf (WillCasIORef c) = rnf c + rnf (WillCommitIORef t c) = rnf (t, c) + rnf WillSTM = () + rnf WillCatching = () + rnf WillPopCatching = () + rnf WillThrow = () + rnf (WillThrowTo t) = rnf t + rnf (WillSetMasking b m) = rnf (b, show m) + rnf (WillResetMasking b m) = rnf (b, show m) + rnf WillGetMaskingState = () + rnf WillLiftIO = () + rnf WillReturn = () + rnf WillStop = () + rnf WillRegisterInvariant = () + +-- | All the actions that an STM transaction can perform. +-- +-- @since 0.8.0.0 +data TAction = + TNew TVarId + -- ^ Create a new @TVar@ + | TRead TVarId + -- ^ Read from a @TVar@. + | TWrite TVarId + -- ^ Write to a @TVar@. + | TRetry + -- ^ Abort and discard effects. + | TOrElse [TAction] (Maybe [TAction]) + -- ^ Execute a transaction. If the transaction aborts by calling + -- @retry@, execute the other transaction. + | TThrow + -- ^ Throw an exception, abort, and discard effects. + | TCatch [TAction] (Maybe [TAction]) + -- ^ Execute a transaction. If the transaction aborts by throwing + -- an exception of the appropriate type, it is handled and execution + -- continues; otherwise aborts, propagating the exception upwards. + | TStop + -- ^ Terminate successfully and commit effects. + deriving (Eq, Show) + +-- | @since 1.3.1.0 +deriving instance Generic TAction + +-- | @since 0.5.1.0 +instance NFData TAction + +------------------------------------------------------------------------------- +-- * Traces + +-- | One of the outputs of the runner is a @Trace@, which is a log of +-- decisions made, all the alternative unblocked threads and what they +-- would do, and the action a thread took in its step. +-- +-- @since 0.8.0.0 +type Trace + = [(Decision, [(ThreadId, Lookahead)], ThreadAction)] + +-- | Scheduling decisions are based on the state of the running +-- program, and so we can capture some of that state in recording what +-- specific decision we made. +-- +-- @since 0.5.0.0 +data Decision = + Start ThreadId + -- ^ Start a new thread, because the last was blocked (or it's the + -- start of computation). + | Continue + -- ^ Continue running the last thread for another step. + | SwitchTo ThreadId + -- ^ Pre-empt the running thread, and switch to another. + deriving (Eq, Show) + +-- | @since 1.3.1.0 +deriving instance Generic Decision + +-- | @since 0.5.1.0 +instance NFData Decision + +------------------------------------------------------------------------------- +-- * Conditions + +-- | An indication of how a concurrent computation terminated, if it +-- didn't produce a value. +-- +-- The @Eq@, @Ord@, and @NFData@ instances compare/evaluate the +-- exception with @show@ in the @UncaughtException@ and +-- @InvariantFailure@ cases. +-- +-- @since 2.0.0.0 +data Condition + = Abort + -- ^ The scheduler chose to abort execution. This will be produced + -- if, for example, all possible decisions exceed the specified + -- bounds (there have been too many pre-emptions, the computation + -- has executed for too long, or there have been too many yields). + | Deadlock + -- ^ Every thread is blocked + | UncaughtException SomeException + -- ^ An uncaught exception bubbled to the top of the computation. + | InvariantFailure SomeException + -- ^ An uncaught exception caused an invariant to fail. + deriving (Show, Generic) + +instance Eq Condition where + Abort == Abort = True + Deadlock == Deadlock = True + (UncaughtException e1) == (UncaughtException e2) = show e1 == show e2 + (InvariantFailure e1) == (InvariantFailure e2) = show e1 == show e2 + _ == _ = False + +instance Ord Condition where + compare = compare `on` transform where + transform :: Condition -> (Int, Maybe String) + transform Abort = (1, Nothing) + transform Deadlock = (2, Nothing) + transform (UncaughtException e) = (3, Just (show e)) + transform (InvariantFailure e) = (4, Just (show e)) + +instance NFData Condition where + rnf (UncaughtException e) = rnf (show e) + rnf (InvariantFailure e) = rnf (show e) + rnf f = f `seq` () + +-- | Check if a condition is an @Abort@. +-- +-- @since 0.9.0.0 +isAbort :: Condition -> Bool +isAbort Abort = True +isAbort _ = False + +-- | Check if a condition is a @Deadlock@. +-- +-- @since 0.9.0.0 +isDeadlock :: Condition -> Bool +isDeadlock Deadlock = True +isDeadlock _ = False + +-- | Check if a condition is an @UncaughtException@ +-- +-- @since 0.9.0.0 +isUncaughtException :: Condition -> Bool +isUncaughtException (UncaughtException _) = True +isUncaughtException _ = False + +-- | Check if a condition is an @InvariantFailure@ +-- +-- @since 2.0.0.0 +isInvariantFailure :: Condition -> Bool +isInvariantFailure (InvariantFailure _) = True +isInvariantFailure _ = False + +------------------------------------------------------------------------------- +-- * Errors + +-- | An indication that there is a bug in dejafu or you are using it +-- incorrectly. +-- +-- @since 2.0.0.0 +data Error + = ScheduledBlockedThread + -- ^ Raised as an exception if the scheduler attempts to schedule a + -- blocked thread. + | ScheduledMissingThread + -- ^ Raised as an exception if the scheduler attempts to schedule a + -- nonexistent thread. + deriving (Show, Eq, Ord, Bounded, Enum, Generic) + +instance Exception Error + +-- | Check if an error is a scheduler error. +-- +-- @since 1.12.0.0 +isSchedulerError :: Error -> Bool +isSchedulerError _ = True + +------------------------------------------------------------------------------- +-- * Schedule bounding + +-- | @since 2.0.0.0 +data Bounds = Bounds + { boundPreemp :: Maybe PreemptionBound + , boundFair :: Maybe FairBound + } deriving (Eq, Ord, Read, Show, Generic) + +instance NFData Bounds + +-- | Restrict the number of pre-emptive context switches allowed in an +-- execution. +-- +-- A pre-emption bound of zero disables pre-emptions entirely. +-- +-- @since 0.2.0.0 +newtype PreemptionBound = PreemptionBound Int + deriving (Enum, Eq, Ord, Num, Real, Integral, Read, Show) + +-- | @since 1.3.1.0 +deriving instance Generic PreemptionBound + +-- | @since 0.5.1.0 +instance NFData PreemptionBound + +-- | Restrict the maximum difference between the number of yield or +-- delay operations different threads have performed. +-- +-- A fair bound of zero disables yields and delays entirely. +-- +-- @since 0.2.0.0 +newtype FairBound = FairBound Int + deriving (Enum, Eq, Ord, Num, Real, Integral, Read, Show) + +-- | @since 1.3.1.0 +deriving instance Generic FairBound + +-- | @since 0.5.1.0 +instance NFData FairBound + +-- | Restrict the maximum length (in terms of primitive actions) of an +-- execution. +-- +-- A length bound of zero immediately aborts the execution. +-- +-- @since 0.2.0.0 +newtype LengthBound = LengthBound Int + deriving (Enum, Eq, Ord, Num, Real, Integral, Read, Show) + +-- | @since 1.3.1.0 +deriving instance Generic LengthBound + +-- | @since 0.5.1.0 +instance NFData LengthBound + +------------------------------------------------------------------------------- +-- * Discarding results and traces + +-- | An @Either Condition a -> Maybe Discard@ value can be used to +-- selectively discard results. +-- +-- @since 0.7.1.0 +data Discard + = DiscardTrace + -- ^ Discard the trace but keep the result. The result will appear + -- to have an empty trace. + | DiscardResultAndTrace + -- ^ Discard the result and the trace. It will simply not be + -- reported as a possible behaviour of the program. + deriving (Eq, Show, Read, Ord, Enum, Bounded) + +-- | @since 1.3.1.0 +deriving instance Generic Discard + +instance NFData Discard + +-- | A monoid for discard functions: combines two functions, keeping +-- the weaker. +-- +-- @Nothing@ is weaker than @Just DiscardTrace@, which is weaker than +-- @Just DiscardResultAndTrace@. This forms a commutative monoid +-- where the unit is @const (Just DiscardResultAndTrace)@. +-- +-- @since 1.5.1.0 +newtype Weaken a = Weaken + { getWeakDiscarder :: Either Condition a -> Maybe Discard } + +instance Semigroup (Weaken a) where + (<>) = divide (\efa -> (efa, efa)) + +instance Monoid (Weaken a) where + mempty = conquer + mappend = (<>) + +instance Contravariant Weaken where + contramap f (Weaken d) = Weaken (d . fmap f) + +instance Divisible Weaken where + divide f (Weaken d1) (Weaken d2) = Weaken $ \case + Right a -> + let (b, c) = f a + in min (d1 (Right b)) (d2 (Right c)) + Left e -> min (d1 (Left e)) (d2 (Left e)) + + conquer = Weaken (const (Just DiscardResultAndTrace)) + +-- | Combine two discard functions, keeping the weaker. +-- +-- @since 1.0.0.0 +weakenDiscard :: + (Either Condition a -> Maybe Discard) + -> (Either Condition a -> Maybe Discard) + -> Either Condition a -> Maybe Discard +weakenDiscard d1 d2 = + getWeakDiscarder (Weaken d1 <> Weaken d2) + +-- | A monoid for discard functions: combines two functions, keeping +-- the stronger. +-- +-- @Just DiscardResultAndTrace@ is stronger than @Just DiscardTrace@, +-- which is stronger than @Nothing@. This forms a commutative monoid +-- where the unit is @const Nothing@. +-- +-- @since 1.5.1.0 +newtype Strengthen a = Strengthen + { getStrongDiscarder :: Either Condition a -> Maybe Discard } + +instance Semigroup (Strengthen a) where + (<>) = divide (\efa -> (efa, efa)) + +instance Monoid (Strengthen a) where + mempty = conquer + mappend = (<>) + +instance Contravariant Strengthen where + contramap f (Strengthen d) = Strengthen (d . fmap f) + +instance Divisible Strengthen where + divide f (Strengthen d1) (Strengthen d2) = Strengthen $ \case + Right a -> + let (b, c) = f a + in max (d1 (Right b)) (d2 (Right c)) + Left e -> max (d1 (Left e)) (d2 (Left e)) + + conquer = Strengthen (const Nothing) + +-- | Combine two discard functions, keeping the stronger. +-- +-- @since 1.0.0.0 +strengthenDiscard :: + (Either Condition a -> Maybe Discard) + -> (Either Condition a -> Maybe Discard) + -> Either Condition a -> Maybe Discard +strengthenDiscard d1 d2 = + getStrongDiscarder (Strengthen d1 <> Strengthen d2) + +------------------------------------------------------------------------------- +-- * Memory Models + +-- | The memory model to use for non-synchronised 'IORef' operations. +-- +-- @since 0.4.0.0 +data MemType = + SequentialConsistency + -- ^ The most intuitive model: a program behaves as a simple + -- interleaving of the actions in different threads. When a 'IORef' + -- is written to, that write is immediately visible to all threads. + | TotalStoreOrder + -- ^ Each thread has a write buffer. A thread sees its writes + -- immediately, but other threads will only see writes when they are + -- committed, which may happen later. Writes are committed in the + -- same order that they are created. + | PartialStoreOrder + -- ^ Each 'IORef' has a write buffer. A thread sees its writes + -- immediately, but other threads will only see writes when they are + -- committed, which may happen later. Writes to different 'IORef's + -- are not necessarily committed in the same order that they are + -- created. + deriving (Eq, Show, Read, Ord, Enum, Bounded) + +-- | @since 1.3.1.0 +deriving instance Generic MemType + +-- | @since 0.5.1.0 +instance NFData MemType + +------------------------------------------------------------------------------- +-- * @MonadFail@ + +-- | An exception for errors in testing caused by use of 'fail'. +newtype MonadFailException = MonadFailException String + deriving Show + +instance Exception MonadFailException + +-- | @since 1.3.1.0 +deriving instance Generic MonadFailException + +-- | @since 1.3.1.0 +instance NFData MonadFailException + +------------------------------------------------------------------------------- +-- ** Concurrency state + +-- | A summary of the concurrency state of the program. +-- +-- @since 2.0.0.0 +data ConcurrencyState = ConcurrencyState + { concIOState :: Map IORefId Int + -- ^ Keep track of which @IORef@s have buffered writes. + , concMVState :: Set MVarId + -- ^ Keep track of which @MVar@s are full. + , concMaskState :: Map ThreadId MaskingState + -- ^ Keep track of thread masking states. If a thread isn't present, + -- the masking state is assumed to be @Unmasked@. This nicely + -- provides compatibility with dpor-0.1, where the thread IDs are + -- not available. + } deriving (Eq, Show) + +instance NFData ConcurrencyState where + rnf cstate = rnf + ( concIOState cstate + , concMVState cstate + , [(t, show m) | (t, m) <- M.toList (concMaskState cstate)] + ) + +-- | Check if a @IORef@ has a buffered write pending. +-- +-- @since 2.0.0.0 +isBuffered :: ConcurrencyState -> IORefId -> Bool +isBuffered cstate r = numBuffered cstate r /= 0 + +-- | Check how many buffered writes an @IORef@ has. +-- +-- @since 2.0.0.0 +numBuffered :: ConcurrencyState -> IORefId -> Int +numBuffered cstate r = M.findWithDefault 0 r (concIOState cstate) + +-- | Check if an @MVar@ is full. +-- +-- @since 2.0.0.0 +isFull :: ConcurrencyState -> MVarId -> Bool +isFull cstate v = S.member v (concMVState cstate) + +-- | Check if an exception can interrupt a thread (action). +-- +-- @since 2.0.0.0 +canInterrupt :: ConcurrencyState -> ThreadId -> ThreadAction -> Bool +canInterrupt cstate tid act + -- If masked interruptible, blocked actions can be interrupted. + | isMaskedInterruptible cstate tid = case act of + BlockedPutMVar _ -> True + BlockedReadMVar _ -> True + BlockedTakeMVar _ -> True + BlockedSTM _ -> True + BlockedThrowTo _ -> True + _ -> False + -- If masked uninterruptible, nothing can be. + | isMaskedUninterruptible cstate tid = False + -- If no mask, anything can be. + | otherwise = True + +-- | Check if an exception can interrupt a thread (lookahead). +-- +-- @since 2.0.0.0 +canInterruptL :: ConcurrencyState -> ThreadId -> Lookahead -> Bool +canInterruptL cstate tid lh + -- If masked interruptible, actions which can block may be + -- interrupted. + | isMaskedInterruptible cstate tid = case lh of + WillPutMVar _ -> True + WillReadMVar _ -> True + WillTakeMVar _ -> True + WillSTM -> True + WillThrowTo _ -> True + _ -> False + -- If masked uninterruptible, nothing can be. + | isMaskedUninterruptible cstate tid = False + -- If no mask, anything can be. + | otherwise = True + +-- | Check if a thread is masked interruptible. +-- +-- @since 2.0.0.0 +isMaskedInterruptible :: ConcurrencyState -> ThreadId -> Bool +isMaskedInterruptible cstate tid = + M.lookup tid (concMaskState cstate) == Just MaskedInterruptible + +-- | Check if a thread is masked uninterruptible. +-- +-- @since 2.0.0.0 +isMaskedUninterruptible :: ConcurrencyState -> ThreadId -> Bool +isMaskedUninterruptible cstate tid = + M.lookup tid (concMaskState cstate) == Just MaskedUninterruptible diff --git a/Test/DejaFu/Utils.hs b/Test/DejaFu/Utils.hs new file mode 100644 --- /dev/null +++ b/Test/DejaFu/Utils.hs @@ -0,0 +1,119 @@ +-- | +-- Module : Test.DejaFu.Utils +-- Copyright : (c) 2017--2018 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : portable +-- +-- Utility functions for users of dejafu. +module Test.DejaFu.Utils where + +import Control.Exception (Exception(..), displayException) +import Data.List (intercalate, minimumBy) +import Data.Maybe (mapMaybe) +import Data.Ord (comparing) + +import Test.DejaFu.Types + +------------------------------------------------------------------------------- +-- * Traces + +-- | Turn a 'Trace' into an abbreviated form. +-- +-- @since 1.3.2.0 +toTIdTrace :: Trace -> [(ThreadId, ThreadAction)] +toTIdTrace = + drop 1 . scanl (\(t, _) (d, _, a) -> (tidOf t d, a)) (initialThread, undefined) + +-- | Pretty-print a trace, including a key of the thread IDs (not +-- including thread 0). Each line of the key is indented by two +-- spaces. +-- +-- @since 0.5.0.0 +showTrace :: Trace -> String +showTrace [] = "" +showTrace trc = intercalate "\n" $ go False trc : strkey where + go _ ((_,_,CommitIORef _ _):rest) = "C-" ++ go False rest + go _ ((Start (ThreadId (Id _ i)),_,a):rest) = "S" ++ show i ++ "-" ++ go (didYield a) rest + go y ((SwitchTo (ThreadId (Id _ i)),_,a):rest) = (if y then "p" else "P") ++ show i ++ "-" ++ go (didYield a) rest + go _ ((Continue,_,a):rest) = '-' : go (didYield a) rest + go _ _ = "" + + strkey = + [" " ++ show i ++ ": " ++ name | (i, name) <- threadNames trc] + + didYield Yield = True + didYield (ThreadDelay _) = True + didYield _ = False + +-- | Get all named threads in the trace. +-- +-- @since 0.7.3.0 +threadNames :: Trace -> [(Int, String)] +threadNames = mapMaybe go where + go (_, _, Fork (ThreadId (Id (Just name) i))) = Just (i, name) + go (_, _, ForkOS (ThreadId (Id (Just name) i))) = Just (i, name) + go _ = Nothing + +-- | Find the \"simplest\" trace leading to each result. +simplestsBy :: (x -> x -> Bool) -> [(x, Trace)] -> [(x, Trace)] +simplestsBy f = map choose . collect where + collect = groupBy' [] (\(a,_) (b,_) -> f a b) + choose = minimumBy . comparing $ \(_, trc) -> + let switchTos = length . filter (\(d,_,_) -> case d of SwitchTo _ -> True; _ -> False) + starts = length . filter (\(d,_,_) -> case d of Start _ -> True; _ -> False) + commits = length . filter (\(_,_,a) -> case a of CommitIORef _ _ -> True; _ -> False) + in (switchTos trc, commits trc, length trc, starts trc) + + groupBy' res _ [] = res + groupBy' res eq (y:ys) = groupBy' (insert' eq y res) eq ys + + insert' _ x [] = [[x]] + insert' eq x (ys@(y:_):yss) + | x `eq` y = (x:ys) : yss + | otherwise = ys : insert' eq x yss + insert' _ _ ([]:_) = undefined + +------------------------------------------------------------------------------- +-- * Conditions + +-- | Pretty-print a condition +-- +-- @since 1.12.0.0 +showCondition :: Condition -> String +showCondition Abort = "[abort]" +showCondition Deadlock = "[deadlock]" +showCondition (UncaughtException exc) = "[" ++ displayException exc ++ "]" +showCondition (InvariantFailure _) = "[invariant failure]" + +------------------------------------------------------------------------------- +-- * Scheduling + +-- | Get the resultant thread identifier of a 'Decision', with a default case +-- for 'Continue'. +-- +-- @since 0.5.0.0 +tidOf :: ThreadId -> Decision -> ThreadId +tidOf _ (Start t) = t +tidOf _ (SwitchTo t) = t +tidOf tid _ = tid + +-- | Get the 'Decision' that would have resulted in this thread +-- identifier, given a prior thread (if any) and collection of threads +-- which are unblocked at this point. +-- +-- @since 0.5.0.0 +decisionOf :: Foldable f + => Maybe ThreadId + -- ^ The prior thread. + -> f ThreadId + -- ^ The threads. + -> ThreadId + -- ^ The current thread. + -> Decision +decisionOf Nothing _ chosen = Start chosen +decisionOf (Just prior) runnable chosen + | prior == chosen = Continue + | prior `elem` runnable = SwitchTo chosen + | otherwise = Start chosen diff --git a/dejafu.cabal b/dejafu.cabal --- a/dejafu.cabal +++ b/dejafu.cabal @@ -1,33 +1,29 @@ --- Initial monad-conc.cabal generated by cabal init. For further +-- Initial monad-conc.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: dejafu -version: 0.9.1.2 -synopsis: Systematic testing for Haskell concurrency. +version: 2.4.0.8 +synopsis: A library for unit-testing concurrent programs. description: /[Déjà Fu is] A martial art in which the user's limbs move in time as well as space, […] It is best described as "the feeling that you have been kicked in the head this way before"/ -- Terry Pratchett, Thief of Time . - Concurrency is nice, deadlocks and race conditions not so much. The - @Par@ monad family, as defined in - - provides deterministic parallelism, but sometimes we can tolerate a - bit of nondeterminism. - . This package builds on the - package by enabling you to systematically and deterministically test - your concurrent programs. + package by enabling you to deterministically test your concurrent + programs. + . + See the or README for more. homepage: https://github.com/barrucadu/dejafu license: MIT license-file: LICENSE author: Michael Walker maintainer: mike@barrucadu.co.uk --- copyright: +copyright: (c) 2015--2020 Michael Walker category: Concurrency build-type: Simple -extra-source-files: README.markdown CHANGELOG.markdown +extra-source-files: README.markdown CHANGELOG.rst cabal-version: >=1.10 source-repository head @@ -37,39 +33,41 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: dejafu-0.9.1.2 + tag: dejafu-2.4.0.8 library exposed-modules: Test.DejaFu , Test.DejaFu.Conc - , Test.DejaFu.Common - , Test.DejaFu.Defaults , Test.DejaFu.Refinement - , Test.DejaFu.Schedule , Test.DejaFu.SCT - , Test.DejaFu.STM + , Test.DejaFu.Settings + , Test.DejaFu.Schedule + , Test.DejaFu.Types + , Test.DejaFu.Utils , Test.DejaFu.Conc.Internal , Test.DejaFu.Conc.Internal.Common , Test.DejaFu.Conc.Internal.Memory + , Test.DejaFu.Conc.Internal.Program + , Test.DejaFu.Conc.Internal.STM , Test.DejaFu.Conc.Internal.Threading + , Test.DejaFu.Internal , Test.DejaFu.SCT.Internal - , Test.DejaFu.STM.Internal + , Test.DejaFu.SCT.Internal.DPOR + , Test.DejaFu.SCT.Internal.Weighted - -- other-modules: - -- other-extensions: - build-depends: base >=4.8 && <5 - , concurrency >=1.1 && <1.3 - , containers >=0.5 && <0.6 + -- other-modules: + -- other-extensions: + build-depends: base >=4.9 && <5 + , concurrency >=1.11 && <1.12 + , containers >=0.5 && <0.9 + , contravariant >=1.2 && <1.6 , deepseq >=1.1 && <2 - , exceptions >=0.7 && <0.9 - , leancheck >=0.6 && <0.8 - , random >=1.0 && <1.2 - , ref-fd >=0.4 && <0.5 - , transformers >=0.4 && <0.6 - , transformers-base >=0.4 && <0.5 - -- hs-source-dirs: + , exceptions >=0.7 && <0.11 + , leancheck >=0.6 && <2 + , profunctors >=4.0 && <6 + , random >=1.0 && <1.4 + , transformers >=0.5 && <0.7 + -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall - if impl(ghc < 8.0.1) - build-depends: semigroups >=0.16 && <0.19