dejafu 0.9.1.2 → 2.4.0.8
raw patch · 27 files changed
Files
- CHANGELOG.markdown +0/−805
- CHANGELOG.rst +1910/−0
- LICENSE +1/−1
- README.markdown +107/−44
- Test/DejaFu.hs +1038/−802
- Test/DejaFu/Common.hs +0/−1070
- Test/DejaFu/Conc.hs +146/−177
- Test/DejaFu/Conc/Internal.hs +660/−301
- Test/DejaFu/Conc/Internal/Common.hs +203/−115
- Test/DejaFu/Conc/Internal/Memory.hs +157/−114
- Test/DejaFu/Conc/Internal/Program.hs +377/−0
- Test/DejaFu/Conc/Internal/STM.hs +239/−0
- Test/DejaFu/Conc/Internal/Threading.hs +77/−47
- Test/DejaFu/Defaults.hs +0/−69
- Test/DejaFu/Internal.hs +468/−0
- Test/DejaFu/Refinement.hs +38/−30
- Test/DejaFu/SCT.hs +167/−525
- Test/DejaFu/SCT/Internal.hs +420/−816
- Test/DejaFu/SCT/Internal/DPOR.hs +698/−0
- Test/DejaFu/SCT/Internal/Weighted.hs +69/−0
- Test/DejaFu/STM.hs +0/−122
- Test/DejaFu/STM/Internal.hs +0/−225
- Test/DejaFu/Schedule.hs +24/−54
- Test/DejaFu/Settings.hs +505/−0
- Test/DejaFu/Types.hs +962/−0
- Test/DejaFu/Utils.hs +119/−0
- dejafu.cabal +31/−33
− CHANGELOG.markdown
@@ -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
+ CHANGELOG.rst view
@@ -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.
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015, Michael Walker <mike@barrucadu.co.uk>+Copyright (c) 2015--2018, Michael Walker <mike@barrucadu.co.uk> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
README.markdown view
@@ -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).
Test/DejaFu.hs view
@@ -1,802 +1,1038 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}---- |--- Module : Test.DejaFu--- Copyright : (c) 2016 Michael Walker--- License : MIT--- Maintainer : Michael Walker <mike@barrucadu.co.uk>--- 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 <mike@barrucadu.co.uk>+Stability : experimental+Portability : TupleSections++dejafu is a library for unit-testing concurrent Haskell programs which+are written using the <https://hackage.haskell.org/package/concurrency+concurrency> package's 'MonadConc' typeclass.++For more in-depth documentation, including migration guides from+earlier versions of dejafu, see the <https://dejafu.docs.barrucadu.co.uk/+website>.++__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--+<BLANKLINE>+ "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--+<BLANKLINE>+ (True,True) S0---------S1-P2----S1---S0---+<BLANKLINE>+ (True,False) S0---------S2----S1----S0---+False++>>> autocheckWay defaultWay TotalStoreOrder relaxed+[pass] Successful+[fail] Deterministic+ (False,True) S0---------S1----S0--S2----S0--+<BLANKLINE>+ (False,False) S0---------S1--P2----S1--S0---+<BLANKLINE>+ (True,False) S0---------S2----S1----S0---+<BLANKLINE>+ (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+<https://hackage.haskell.org/package/leancheck leancheck> 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--+-- <BLANKLINE>+-- "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--+-- <BLANKLINE>+-- (False,False) S0---------S1--P2----S1--S0---+-- <BLANKLINE>+-- (True,False) S0---------S2----S1----S0---+-- <BLANKLINE>+-- (True,True) S0---------S1-C-S2----S1---S0---+-- False+--+-- >>> autocheckWay defaultWay SequentialConsistency relaxed+-- [pass] Successful+-- [fail] Deterministic+-- (False,True) S0---------S1----S0--S2----S0--+-- <BLANKLINE>+-- (True,True) S0---------S1-P2----S1---S0---+-- <BLANKLINE>+-- (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--+-- <BLANKLINE>+-- (False,False) S0---------S1--P2----S1--S0---+-- <BLANKLINE>+-- (True,False) S0---------S2----S1----S0---+-- <BLANKLINE>+-- (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--+-- <BLANKLINE>+-- (True,True) S0---------S1-P2----S1---S0---+-- <BLANKLINE>+-- (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--+-- <BLANKLINE>+-- "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--+-- <BLANKLINE>+-- "world" S0----S2--S0--+-- False+--+-- >>> dejafuWay (randomly (mkStdGen 1) 100) defaultMemType "Randomly!" alwaysSame example+-- [fail] Randomly!+-- "hello" S0----S1--S0--+-- <BLANKLINE>+-- "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--+-- <BLANKLINE>+-- "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--+-- <BLANKLINE>+-- "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--+-- <BLANKLINE>+-- (True,True) S0---------S1-P2----S1---S0---+-- <BLANKLINE>+-- (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--+-- <BLANKLINE>+-- (True,True) S0---------S1-P2----S1---S0---+-- <BLANKLINE>+-- (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
− Test/DejaFu/Common.hs
@@ -1,1070 +0,0 @@--- |--- Module : Test.DejaFu.Common--- Copyright : (c) 2016 Michael Walker--- License : MIT--- Maintainer : Michael Walker <mike@barrucadu.co.uk>--- 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 [] = "<trace discarded>"-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)
Test/DejaFu/Conc.hs view
@@ -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 <mike@barrucadu.co.uk> -- 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
Test/DejaFu/Conc/Internal.hs view
@@ -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 <mike@barrucadu.co.uk> -- 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, [], [], [])
Test/DejaFu/Conc/Internal/Common.hs view
@@ -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 <mike@barrucadu.co.uk> -- 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 ())
Test/DejaFu/Conc/Internal/Memory.hs view
@@ -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 <mike@barrucadu.co.uk> -- 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 ())
+ Test/DejaFu/Conc/Internal/Program.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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
+ Test/DejaFu/Conc/Internal/STM.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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))
Test/DejaFu/Conc/Internal/Threading.hs view
@@ -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 <mike@barrucadu.co.uk> -- 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
− Test/DejaFu/Defaults.hs
@@ -1,69 +0,0 @@--- |--- Module : Test.DejaFu.Defaults--- Copyright : (c) 2017 Michael Walker--- License : MIT--- Maintainer : Michael Walker <mike@barrucadu.co.uk>--- 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
+ Test/DejaFu/Internal.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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 <f> <gen> " ++ 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)
Test/DejaFu/Refinement.hs view
@@ -7,7 +7,7 @@ -- | -- Module : Test.DejaFu.Refinement--- Copyright : (c) 2017 Michael Walker+-- Copyright : (c) 2017--2021 Michael Walker -- License : MIT -- Maintainer : Michael Walker <mike@barrucadu.co.uk> -- 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
Test/DejaFu/SCT.hs view
@@ -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 <mike@barrucadu.co.uk> -- 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 <gen> " ++ show (n, t)- show (Uniform _ n) = "Uniform <gen> " ++ 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
Test/DejaFu/SCT/Internal.hs view
@@ -1,816 +1,420 @@-{-# LANGUAGE TupleSections #-}---- |--- Module : Test.DejaFu.SCT.Internal--- Copyright : (c) 2016 Michael Walker--- License : MIT--- Maintainer : Michael Walker <mike@barrucadu.co.uk>--- 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 <mike@barrucadu.co.uk>+-- 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_
+ Test/DejaFu/SCT/Internal/DPOR.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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
+ Test/DejaFu/SCT/Internal/Weighted.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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'')
− Test/DejaFu/STM.hs
@@ -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 <mike@barrucadu.co.uk>--- 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)
− Test/DejaFu/STM/Internal.hs
@@ -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 <mike@barrucadu.co.uk>--- 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))
Test/DejaFu/Schedule.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Test.DejaFu.Schedule--- Copyright : (c) 2016 Michael Walker+-- Copyright : (c) 2016--2018 Michael Walker -- License : MIT -- Maintainer : Michael Walker <mike@barrucadu.co.uk> -- 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
+ Test/DejaFu/Settings.hs view
@@ -0,0 +1,505 @@+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Test.DejaFu.Settings+-- Copyright : (c) 2018 Michael Walker+-- License : MIT+-- Maintainer : Michael Walker <mike@barrucadu.co.uk>+-- 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)
+ Test/DejaFu/Types.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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
+ Test/DejaFu/Utils.hs view
@@ -0,0 +1,119 @@+-- |+-- Module : Test.DejaFu.Utils+-- Copyright : (c) 2017--2018 Michael Walker+-- License : MIT+-- Maintainer : Michael Walker <mike@barrucadu.co.uk>+-- 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 [] = "<trace discarded>"+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
dejafu.cabal view
@@ -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- <https://hackage.haskell.org/package/abstract-par/docs/Control-Monad-Par-Class.html abstract-par>- provides deterministic parallelism, but sometimes we can tolerate a- bit of nondeterminism.- . This package builds on the <https://hackage.haskell.org/package/concurrency concurrency>- package by enabling you to systematically and deterministically test- your concurrent programs.+ package by enabling you to deterministically test your concurrent+ programs.+ .+ See the <https://dejafu.docs.barrucadu.co.uk/ website> 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