io-sim (empty) → 1.0.0.0
raw patch · 23 files changed
+10917/−0 lines, 23 filesdep +QuickCheckdep +arraydep +base
Dependencies added: QuickCheck, array, base, containers, criterion, deque, exceptions, io-classes, io-sim, nothunks, parallel, psqueues, quiet, si-timers, strict-stm, tasty, tasty-hunit, tasty-quickcheck, time
Files
- CHANGELOG.md +51/−0
- LICENSE +177/−0
- NOTICE +14/−0
- README.md +44/−0
- bench/Main.hs +117/−0
- io-sim.cabal +139/−0
- src/Control/Monad/IOSim.hs +614/−0
- src/Control/Monad/IOSim/CommonTypes.hs +104/−0
- src/Control/Monad/IOSim/Internal.hs +1394/−0
- src/Control/Monad/IOSim/InternalTypes.hs +91/−0
- src/Control/Monad/IOSim/STM.hs +496/−0
- src/Control/Monad/IOSim/Types.hs +1211/−0
- src/Control/Monad/IOSimPOR/Internal.hs +1958/−0
- src/Control/Monad/IOSimPOR/QuickCheckUtils.hs +118/−0
- src/Control/Monad/IOSimPOR/Timeout.hs +67/−0
- src/Control/Monad/IOSimPOR/Types.hs +70/−0
- src/Data/List/Trace.hs +148/−0
- test/Main.hs +18/−0
- test/Test/Control/Monad/Class/MonadMVar.hs +330/−0
- test/Test/Control/Monad/IOSim.hs +1344/−0
- test/Test/Control/Monad/IOSimPOR.hs +1031/−0
- test/Test/Control/Monad/STM.hs +867/−0
- test/Test/Control/Monad/Utils.hs +514/−0
+ CHANGELOG.md view
@@ -0,0 +1,51 @@+# Revsion history of io-sim++## next version++## 1.0.0.0++### Breaking changes++* Support refactored `MonadTimer`, and new `MonadTimerFancy`, `MonadTimeNSec`+ monad classes.++## 0.6.0.0++### Breaking changes++* Added `TimeoutId` to `EventThreadDelay` and `EventThreadFired` events.++### Non breaking changes++* Fixed `threadDelay` in presence of asynchronous exceptions (in `IOSim` and `IOSimPOR`) (#80).+* Fixed bug in `IOSim` & `IOSimPOR` which resulted in reusing existing+ `ThreadId`s (#80).++## 0.5.0.0++* `MVar` type family is not injective anymore.+* Removed default implementation of `readMVar` in the `MonadMVar` type class.+* Moved `MVarDefault` to `io-sim` package.++## 0.4.0.0++* support `ghc-9.4` (except on Windows input-output-hk/io-sim#51)+* `MonadCatch` instance for `STM (IOSim s)` monad+* fixed `isEmptyTBQueeuDefault` (thanks to @EMQ-YangM)+* refactored internal implementation of timeouts, changed `SimEventType`+ constructors++## 0.3.0.0++* added `Functor` instance for `SimResult`+* added `MonadFix` instance for `STM (IOSim s)`+* support `ghc-9.2` & `ghc-9.4`++## 0.2.0.0++* First version published on Hackage.+* Depends on `io-classes-0.2.0.0`.++## 0.1.0.0++* Initial version, not released on Hackage.
+ LICENSE view
@@ -0,0 +1,177 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS
+ NOTICE view
@@ -0,0 +1,14 @@+Copyright 2019-2023 Input Output Global Inc (IOG)++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+
+ README.md view
@@ -0,0 +1,44 @@+# IOSim - IO Simulator Monad++A pure simulator monad built on top of the lazy `ST` monad which supports:++ * optional dynamic race discovery and schedule exploration+ * synchronous and asynchronous exceptions; including: throwing, catching and+ masking synchronous and asynchronous exceptions;+ * concurrency (using simulated threads), with interfaces shaped by the+ `base` and `async` libraries;+ * software transactional memory (`STM`);+ * simulated time;+ * timeouts;+ * dynamically typed traces and event log tracing;+ * lifting any `ST` computations;+ * inspection of `STM` mutable data structures;+ * deadlock detection;+ * `MonadFix` instances for both `IOSim` and its corresponding `STM` monad.++`io-sim` together with [`io-classes`] is a drop-in replacement for the `IO`+monad (with some ramifications). It was designed to write easily testable+Haskell code (including simulating socket programming or disk IO). Using+[`io-classes`] and [`si-timers`] libraries one can write code that can run in+both: the real `IO` and the `IOSim` monad provided by this package. One of the+design goals was to keep the API as close as possible to `base`, `exceptions`,+`async`, and `stm` packages.++`io-sim` package also provides two interpreters, a standard one and `IOSimPOR`+which supports dynamic discovery or race conditions and schedule exploration+with partial order reduction.++`io-sim` provides API to explore traces produced by a simulation. It can+contain arbitrary Haskell terms, a feature that is very useful to build+property-based tests using `QuickCheck`.++The package contains thorough tests, including tests of `STM` against the+original specification (as described in [Composable Memory+Transactions](https://research.microsoft.com/en-us/um/people/simonpj/papers/stm/stm.pdf)+and its `GHC` implementation. This can be seen in both ways: as a check that+our implementation matches the specification and the `GHC` implementation, but+also the other way around: that `GHC`s `STM` implementation meets the+specification.++[`io-classes`]: https://hackage.haskell.org/package/io-classes+[`si-timers`]: https://hackage.haskell.org/package/si-timers
+ bench/Main.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Control.Concurrent.Class.MonadSTM+import Control.Monad (forever, replicateM)+import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadTimer+import Control.Monad.IOSim++import Criterion+import Criterion.Main++import Control.Exception (AsyncException (..))+import Data.Foldable (traverse_)+++--+-- timers, delays, timeouts+--++prop_threadDelay :: forall m. MonadDelay m => m ()+prop_threadDelay = threadDelay 1++prop_registerDelay :: forall m. MonadTimer m => m ()+prop_registerDelay = registerDelay 1 >>= \v -> atomically (readTVar v >>= check)++prop_timeout_fail :: forall m. MonadTimer m => m (Maybe ())+prop_timeout_fail = timeout 1 (threadDelay 2)++prop_timeout_succeed :: forall m. MonadTimer m => m (Maybe ())+prop_timeout_succeed = timeout 2 (threadDelay 1)++prop_timeout_race :: forall m. MonadTimer m => m (Maybe ())+prop_timeout_race = timeout 1 (threadDelay 1)+++--+-- threads, async+--++prop_threads :: forall m. (MonadFork m, MonadDelay m, MonadSay m) => Int -> m ()+prop_threads n = do+ threads <- replicateM n (forkIO $ threadDelay 2+ >> say ""+ )+ threadDelay 1+ traverse_ (\tid -> throwTo tid ThreadKilled) threads+++prop_async :: forall m. (MonadAsync m, MonadDelay m, MonadSay m) => Int -> m ()+prop_async n = do+ threads <- replicateM n (async $ threadDelay 1+ >> say ""+ )+ traverse_ wait threads++prop_threadDelay_bottleneck :: forall m. (MonadTimer m, MonadSay m)+ => m (Maybe ())+prop_threadDelay_bottleneck =+ timeout 1000000 $ do+ forever $ do+ threadDelay 1+ say ""++main :: IO ()+main = defaultMain+ [ env (pure ()) $ \_ ->+ bgroup "delays"+ [ bench "threadDelay" $+ whnf id (runSimOrThrow prop_threadDelay)+ , bench "registerDelay" $+ whnf id (runSimOrThrow prop_registerDelay)+ , bgroup "timeout"+ [ bench "fail" $+ whnf id (runSimOrThrow prop_timeout_fail)+ , bench "succeed" $+ whnf id (runSimOrThrow prop_timeout_succeed)+ , bench "race" $+ whnf id (runSimOrThrow prop_timeout_race)+ ]+ ]+ ,+ bgroup "threads"+ [ env (pure 50) $ \n ->+ bgroup "50"+ [ bench "async silent" $+ whnf id (runSimOrThrow (prop_async n))+ , bench "forkIO silent" $+ whnf id (runSimOrThrow (prop_threads n))+ , bench "threadDelay bottleneck silent" $+ whnf id (runSimOrThrow prop_threadDelay_bottleneck)+ , bench "async say" $+ nf id ( selectTraceEventsSay+ $ runSimTrace+ $ prop_async n)+ , bench "forkIO say" $+ nf id ( selectTraceEventsSay+ $ runSimTrace+ $ prop_threads n)+ , bench "threadDelay bottleneck say" $+ nf id ( selectTraceEventsSay+ $ runSimTrace+ $ prop_threadDelay_bottleneck)+ ]+ , env (pure 250) $ \n ->+ bgroup "250"+ [ bench "async" $+ whnf id (runSimOrThrow (prop_async n))+ , bench "forkIO" $+ whnf id (runSimOrThrow (prop_threads n))+ ]+ ]+ ]
+ io-sim.cabal view
@@ -0,0 +1,139 @@+cabal-version: 3.0+name: io-sim+version: 1.0.0.0+synopsis: A pure simulator for monadic concurrency with STM.+description:+ A pure simulator monad with support of concurency (base, async), stm,+ synchronous and asynchronous exceptions, timeouts & delays, dynamic traces,+ and more.+license: Apache-2.0+license-files:+ LICENSE+ NOTICE+copyright: 2022-2023 Input Output Global Inc (IOG)+author: Alexander Vieth, Duncan Coutts, John Hughes, Marcin Szamotulski+maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me+category: Testing+build-type: Simple+extra-source-files: CHANGELOG.md+ README.md+tested-with: GHC == { 8.10, 9.2, 9.4 }++flag asserts+ description: Enable assertions+ manual: False+ default: False++source-repository head+ type: git+ location: https://github.com/input-output-hk/io-sim+ subdir: io-sim++common test-warnings+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Widentities+ -Wunused-packages+ -Wredundant-constraints+ -Wno-unticked-promoted-constructors++common warnings+ import: test-warnings+ ghc-options: -Wincomplete-record-updates+ -Wpartial-fields++library+ import: warnings+ hs-source-dirs: src+ exposed-modules: Data.List.Trace,+ Control.Monad.IOSim+ other-modules: Control.Monad.IOSim.CommonTypes,+ Control.Monad.IOSim.Types,+ Control.Monad.IOSim.Internal,+ Control.Monad.IOSim.InternalTypes,+ Control.Monad.IOSim.STM,+ Control.Monad.IOSimPOR.Internal,+ Control.Monad.IOSimPOR.Types,+ Control.Monad.IOSimPOR.QuickCheckUtils,+ Control.Monad.IOSimPOR.Timeout+ default-language: Haskell2010+ other-extensions: BangPatterns,+ CPP,+ DeriveFunctor,+ DeriveGeneric,+ DerivingVia,+ ExistentialQuantification,+ ExplicitNamespaces,+ FlexibleContexts,+ FlexibleInstances,+ GADTSyntax,+ GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ NamedFieldPuns,+ NumericUnderscores,+ RankNTypes,+ ScopedTypeVariables,+ TypeFamilies+ build-depends: base >=4.9 && <4.18,+ io-classes ^>=1.0,+ exceptions >=0.10,+ containers,+ deque,+ nothunks,+ parallel,+ psqueues >=0.2 && <0.3,+ strict-stm ^>=1.0,+ si-timers ^>=1.0,+ time >=1.9.1 && <1.13,+ quiet,+ QuickCheck,+++ if flag(asserts)+ ghc-options: -fno-ignore-asserts++test-suite test+ import: test-warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Test.Control.Monad.STM+ Test.Control.Monad.Utils+ Test.Control.Monad.IOSim+ Test.Control.Monad.IOSimPOR+ Test.Control.Monad.Class.MonadMVar+ default-language: Haskell2010+ build-depends: base,+ array,+ containers,+ io-classes,+ io-sim,+ parallel,+ QuickCheck,+ si-timers,+ strict-stm,+ tasty,+ tasty-quickcheck,+ tasty-hunit,+ time+ ghc-options: -fno-ignore-asserts++benchmark bench+ import: warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs+ default-language: Haskell2010+ build-depends: base,+ criterion,++ io-classes,+ io-sim,+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wpartial-fields+ -Widentities+ -Wredundant-constraints
+ src/Control/Monad/IOSim.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}+module Control.Monad.IOSim+ ( -- * Simulation monad+ IOSim+ , STMSim+ -- ** Run simulation+ , runSim+ , runSimOrThrow+ , runSimStrictShutdown+ , Failure (..)+ , runSimTrace+ , runSimTraceST+ -- ** Explore races using /IOSimPOR/+ -- $iosimpor+ , exploreSimTrace+ , controlSimTrace+ , ScheduleMod (..)+ , ScheduleControl (..)+ -- *** Exploration options+ , ExplorationSpec+ , ExplorationOptions (..)+ , stdExplorationOptions+ , withScheduleBound+ , withBranching+ , withStepTimelimit+ , withReplay+ -- * Lift ST computations+ , liftST+ -- * Simulation time+ , setCurrentTime+ , unshareClock+ -- * Simulation trace+ , type SimTrace+ , Trace (Cons, Nil, SimTrace, SimPORTrace, TraceDeadlock, TraceLoop, TraceMainReturn, TraceMainException, TraceRacesFound)+ , SimResult (..)+ , SimEvent (..)+ , SimEventType (..)+ , ThreadLabel+ , Labelled (..)+ -- ** Dynamic Tracing+ , traceM+ , traceSTM+ -- ** Pretty printers+ , ppTrace+ , ppTrace_+ , ppEvents+ , ppSimEvent+ , ppDebug+ -- ** Selectors+ , traceEvents+ , traceResult+ -- *** list selectors+ , selectTraceEvents+ , selectTraceEvents'+ , selectTraceEventsDynamic+ , selectTraceEventsDynamic'+ , selectTraceEventsSay+ , selectTraceEventsSay'+ , selectTraceRaces+ -- *** trace selectors+ , traceSelectTraceEvents+ , traceSelectTraceEventsDynamic+ , traceSelectTraceEventsSay+ -- ** IO printer+ , printTraceEventsSay+ -- * Eventlog+ , EventlogEvent (..)+ , EventlogMarker (..)+ -- * Low-level API+ , newTimeout+ , readTimeout+ , cancelTimeout+ , awaitTimeout+ ) where++import Prelude++import Data.Bifoldable+import Data.Dynamic (fromDynamic)+import Data.List (intercalate)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Typeable (Typeable)++import Data.List.Trace (Trace (..))++import Control.Exception (throw)++import Control.Monad.ST.Lazy++import Control.Monad.Class.MonadThrow as MonadThrow++import Control.Monad.IOSim.Internal (runSimTraceST)+import Control.Monad.IOSim.Types+import Control.Monad.IOSimPOR.Internal (controlSimTraceST)+import Control.Monad.IOSimPOR.QuickCheckUtils++import Test.QuickCheck+++import Data.IORef+import System.IO.Unsafe+++selectTraceEvents+ :: (SimEventType -> Maybe b)+ -> SimTrace a+ -> [b]+selectTraceEvents fn =+ bifoldr ( \ v _+ -> case v of+ MainException _ e _ -> throw (FailureException e)+ Deadlock _ threads -> throw (FailureDeadlock threads)+ MainReturn _ _ _ -> []+ Loop -> error "Impossible: selectTraceEvents _ TraceLoop{}"+ )+ ( \ b acc -> b : acc )+ []+ . traceSelectTraceEvents fn++selectTraceEvents'+ :: (SimEventType -> Maybe b)+ -> SimTrace a+ -> [b]+selectTraceEvents' fn =+ bifoldr ( \ _ _ -> [] )+ ( \ b acc -> b : acc )+ []+ . traceSelectTraceEvents fn++selectTraceRaces :: SimTrace a -> [ScheduleControl]+selectTraceRaces = go+ where+ go (SimTrace _ _ _ _ trace) = go trace+ go (SimPORTrace _ _ _ _ _ trace) = go trace+ go (TraceRacesFound races trace) =+ races ++ go trace+ go _ = []++-- Extracting races from a trace. There is a subtlety in doing so: we+-- must return a defined list of races even in the case where the+-- trace is infinite, and there are no races occurring in it! For+-- example, if the system falls into a deterministic infinite loop,+-- then there will be no races to find.++-- In reality we only want to extract races from *the part of the+-- trace used in a test*. We can only observe that by tracking lazy+-- evaluation: only races that were found in the evaluated prefix of+-- an infinite trace should contribute to the "races found". Hence we+-- return a function that returns the races found "so far". This is+-- unsafe, of course, since that function may return different results+-- at different times.++detachTraceRaces :: SimTrace a -> (() -> [ScheduleControl], SimTrace a)+detachTraceRaces trace = unsafePerformIO $ do+ races <- newIORef []+ let readRaces () = concat . reverse . unsafePerformIO $ readIORef races+ saveRaces r t = unsafePerformIO $ do+ modifyIORef races (r:)+ return t+ let go (SimTrace a b c d trace) = SimTrace a b c d $ go trace+ go (SimPORTrace a b c d e trace) = SimPORTrace a b c d e $ go trace+ go (TraceRacesFound r trace) = saveRaces r $ go trace+ go t = t+ return (readRaces, go trace)++-- | Select all the traced values matching the expected type. This relies on+-- the sim's dynamic trace facility.+--+-- For convenience, this throws exceptions for abnormal sim termination.+--+selectTraceEventsDynamic :: forall a b. Typeable b => SimTrace a -> [b]+selectTraceEventsDynamic = selectTraceEvents fn+ where+ fn :: SimEventType -> Maybe b+ fn (EventLog dyn) = fromDynamic dyn+ fn _ = Nothing++-- | Like 'selectTraceEventsDynamic' but returns partial trace if an exception+-- is found in it.+--+selectTraceEventsDynamic' :: forall a b. Typeable b => SimTrace a -> [b]+selectTraceEventsDynamic' = selectTraceEvents' fn+ where+ fn :: SimEventType -> Maybe b+ fn (EventLog dyn) = fromDynamic dyn+ fn _ = Nothing++-- | Get a trace of 'EventSay'.+--+-- For convenience, this throws exceptions for abnormal sim termination.+--+selectTraceEventsSay :: SimTrace a -> [String]+selectTraceEventsSay = selectTraceEvents fn+ where+ fn :: SimEventType -> Maybe String+ fn (EventSay s) = Just s+ fn _ = Nothing++-- | Like 'selectTraceEventsSay' but return partial trace if an exception is+-- found in it.+--+selectTraceEventsSay' :: SimTrace a -> [String]+selectTraceEventsSay' = selectTraceEvents' fn+ where+ fn :: SimEventType -> Maybe String+ fn (EventSay s) = Just s+ fn _ = Nothing++-- | Print all 'EventSay' to the console.+--+-- For convenience, this throws exceptions for abnormal sim termination.+--+printTraceEventsSay :: SimTrace a -> IO ()+printTraceEventsSay = mapM_ print . selectTraceEventsSay+++-- | The most general select function. It is a _total_ function.+--+traceSelectTraceEvents+ :: (SimEventType -> Maybe b)+ -> SimTrace a+ -> Trace (SimResult a) b+traceSelectTraceEvents fn = bifoldr ( \ v _acc -> Nil v )+ ( \ eventCtx acc+ -> case eventCtx of+ SimRacesFound _ -> acc+ SimEvent{} ->+ case fn (seType eventCtx) of+ Nothing -> acc+ Just b -> Cons b acc+ SimPOREvent{} ->+ case fn (seType eventCtx) of+ Nothing -> acc+ Just b -> Cons b acc+ )+ undefined -- it is ignored++-- | Select dynamic events. It is a _total_ function.+--+traceSelectTraceEventsDynamic :: forall a b. Typeable b+ => SimTrace a -> Trace (SimResult a) b+traceSelectTraceEventsDynamic = traceSelectTraceEvents fn+ where+ fn :: SimEventType -> Maybe b+ fn (EventLog dyn) = fromDynamic dyn+ fn _ = Nothing+++-- | Select say events. It is a _total_ function.+--+traceSelectTraceEventsSay :: forall a. SimTrace a -> Trace (SimResult a) String+traceSelectTraceEventsSay = traceSelectTraceEvents fn+ where+ fn :: SimEventType -> Maybe String+ fn (EventSay s) = Just s+ fn _ = Nothing++-- | Simulation terminated a failure.+--+data Failure =+ -- | The main thread terminated with an exception.+ FailureException SomeException++ -- | The threads all deadlocked.+ | FailureDeadlock ![Labelled ThreadId]++ -- | The main thread terminated normally but other threads were still+ -- alive, and strict shutdown checking was requested.+ -- See 'runSimStrictShutdown'.+ | FailureSloppyShutdown [Labelled ThreadId]++ -- | An exception was thrown while evaluation the trace.+ -- This could be an internal assertion failure of `io-sim` or an+ -- unhandled exception in the simulation.+ | FailureEvaluation SomeException+ deriving Show++instance Exception Failure where+ displayException (FailureException err) = displayException err+ displayException (FailureDeadlock threads) =+ concat [ "<<io-sim deadlock: "+ , intercalate ", " (show `map` threads)+ , ">>"+ ]+ displayException (FailureSloppyShutdown threads) =+ concat [ "<<io-sim sloppy shutdown: "+ , intercalate ", " (show `map` threads)+ , ">>"+ ]+ displayException (FailureEvaluation err) = "evaluation error:" ++ displayException err+ ++-- | 'IOSim' is a pure monad.+--+runSim :: forall a. (forall s. IOSim s a) -> Either Failure a+runSim mainAction = traceResult False (runSimTrace mainAction)++-- | For quick experiments and tests it is often appropriate and convenient to+-- simply throw failures as exceptions.+--+runSimOrThrow :: forall a. (forall s. IOSim s a) -> a+runSimOrThrow mainAction =+ case runSim mainAction of+ Left e -> throw e+ Right x -> x++-- | Like 'runSim' but fail when the main thread terminates if there are other+-- threads still running or blocked. If one is trying to follow a strict thread+-- cleanup policy then this helps testing for that.+--+runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a+runSimStrictShutdown mainAction = traceResult True (runSimTrace mainAction)++-- | Fold through the trace and return either a 'Failure' or the simulation+-- result, i.e. the return value of the main thread.+--+traceResult :: Bool+ -- ^ if True the simulation will fail if there are any threads which+ -- didn't terminated when the main thread terminated.+ -> SimTrace a+ -- ^ simulation trace+ -> Either Failure a+traceResult strict = unsafePerformIO . eval+ where+ eval :: SimTrace a -> IO (Either Failure a)+ eval a = do+ r <- try (evaluate a)+ case r of+ Left e -> return (Left (FailureEvaluation e))+ Right _ -> go a++ go :: SimTrace a -> IO (Either Failure a)+ go (SimTrace _ _ _ _ t) = eval t+ go (SimPORTrace _ _ _ _ _ t) = eval t+ go (TraceRacesFound _ t) = eval t+ go (TraceMainReturn _ _ tids@(_:_))+ | strict = pure $ Left (FailureSloppyShutdown tids)+ go (TraceMainReturn _ x _) = pure $ Right x+ go (TraceMainException _ e _) = pure $ Left (FailureException e)+ go (TraceDeadlock _ threads) = pure $ Left (FailureDeadlock threads)+ go TraceLoop{} = error "Impossible: traceResult TraceLoop{}"++-- | Turn 'SimTrace' into a list of timestamped events.+--+traceEvents :: SimTrace a -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]+traceEvents (SimTrace time tid tlbl event t) = (time, tid, tlbl, event)+ : traceEvents t+traceEvents (SimPORTrace time tid _ tlbl event t) = (time, tid, tlbl, event)+ : traceEvents t+traceEvents _ = []+++-- | Pretty print a timestamped event.+--+ppEvents :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]+ -> String+ppEvents events =+ intercalate "\n"+ [ ppSimEvent timeWidth tidWidth width+ SimEvent {seTime, seThreadId, seThreadLabel, seType }+ | (seTime, seThreadId, seThreadLabel, seType) <- events+ ]+ where+ timeWidth = maximum+ [ length (show t)+ | (t, _, _, _) <- events+ ]+ tidWidth = maximum+ [ length (show tid)+ | (_, tid, _, _) <- events+ ]+ width = maximum+ [ maybe 0 length threadLabel+ | (_, _, threadLabel, _) <- events+ ]+++-- | See 'runSimTraceST' below.+--+runSimTrace :: forall a. (forall s. IOSim s a) -> SimTrace a+runSimTrace mainAction = runST (runSimTraceST mainAction)++--+-- IOSimPOR+--+--+-- $iosimpor+--+-- /IOSimPOR/ is a different interpreter of 'IOSim' which has the ability to+-- discover race conditions and replay the simulation using a schedule which+-- reverts them. For extended documentation how to use it see+-- [here](https://github.com/input-output-hk/io-sim/blob/main/io-sim/how-to-use-IOSimPOR.md).+--+-- /IOSimPOR/ only discovers races between events which happen in the same time+-- slot. In /IOSim/ and /IOSimPOR/ time only moves explicitly through timer+-- events, e.g. things like `Control.Monad.Class.MonadTimer.SI.threadDelay`,+-- `Control.Monad.Class.MonadTimer.SI.registerDelay` or the+-- `Control.Monad.Class.MonadTimer.NonStandard.MonadTimeout` api. The usual+-- quickcheck techniques can help explore different schedules of+-- threads too.++-- | Execute a simulation, discover & revert races. Note that this will execute+-- the simulation multiple times with different schedules, and thus it's much+-- more costly than a simple `runSimTrace` (also the simulation environments has+-- much more state to track and hence is slower).+--+-- On property failure it will show the failing schedule (`ScheduleControl`)+-- which can be plugged to `controlSimTrace`.+--+exploreSimTrace+ :: forall a test. Testable test+ => (ExplorationOptions -> ExplorationOptions)+ -- ^ modify default exploration options+ -> (forall s. IOSim s a)+ -- ^ a simulation to run+ -> (Maybe (SimTrace a) -> SimTrace a -> test)+ -- ^ a callback which receives the previous trace (e.g. before reverting+ -- a race condition) and current trace+ -> Property+exploreSimTrace optsf mainAction k =+ case explorationReplay opts of+ Nothing ->+ explore (explorationScheduleBound opts) (explorationBranching opts) ControlDefault Nothing .&&.+ let size = cacheSize() in size `seq`+ tabulate "Modified schedules explored" [bucket size] True+ Just control ->+ replaySimTrace opts mainAction control (k Nothing)+ where+ opts = optsf stdExplorationOptions++ explore :: Int -> Int -> ScheduleControl -> Maybe (SimTrace a) -> Property+ explore n m control passingTrace =++ -- ALERT!!! Impure code: readRaces must be called *after* we have+ -- finished with trace.+ let (readRaces, trace0) = detachTraceRaces $+ controlSimTrace+ (explorationStepTimelimit opts) control mainAction+ (sleeper,trace) = compareTraces passingTrace trace0+ in ( counterexample ("Schedule control: " ++ show control)+ $ counterexample+ (case sleeper of+ Nothing -> "No thread delayed"+ Just ((t,tid,lab),racing) ->+ showThread (tid,lab) +++ " delayed at time "+++ show t +++ "\n until after:\n" +++ unlines (map ((" "++).showThread) $ Set.toList racing)+ )+ $ k passingTrace trace+ )+ .&&| let limit = (n+m-1) `div` m+ -- To ensure the set of schedules explored is deterministic, we+ -- filter out cached ones *after* selecting the children of this+ -- node.+ races = filter (not . cached) . take limit $ readRaces ()+ branching = length races+ in -- tabulate "Races explored" (map show races) $+ tabulate "Branching factor" [bucket branching] $+ tabulate "Race reversals per schedule" [bucket (raceReversals control)] $+ conjoinPar+ [ --Debug.trace "New schedule:" $+ --Debug.trace (" "++show r) $+ --counterexample ("Schedule control: " ++ show r) $+ explore n' ((m-1) `max` 1) r (Just trace0)+ | (r,n') <- zip races (divide (n-branching) branching) ]++ bucket :: Int -> String+ bucket n | n<10 = show n+ | n>=10 = buck n 1+ | otherwise = error "Ord Int is not a total order!" -- GHC made me do it!+ buck n t | n<10 = show (n*t) ++ "-" ++ show ((n+1)*t-1)+ | n>=10 = buck (n `div` 10) (t*10)+ | otherwise = error "Ord Int is not a total order!" -- GHC made me do it!++ divide :: Int -> Int -> [Int]+ divide n k =+ [ n `div` k + if i<n `mod` k then 1 else 0+ | i <- [0..k-1] ]++ showThread :: (ThreadId,Maybe ThreadLabel) -> String+ showThread (tid,lab) =+ show tid ++ (case lab of Nothing -> ""+ Just l -> " ("++l++")")++ -- cache of explored schedules+ cache :: IORef (Set ScheduleControl)+ cache = unsafePerformIO cacheIO++ -- insert a schedule into the cache+ cached :: ScheduleControl -> Bool+ cached = unsafePerformIO . cachedIO++ -- compute cache size; it's a function to make sure that `GHC` does not+ -- inline it (and share the same thunk).+ cacheSize :: () -> Int+ cacheSize = unsafePerformIO . cacheSizeIO++ --+ -- Caching in IO monad+ --++ -- It is possible for the same control to be generated several times.+ -- To avoid exploring them twice, we keep a cache of explored schedules.+ cacheIO :: IO (IORef (Set ScheduleControl))+ cacheIO = newIORef $+ -- we use opts here just to be sure the reference cannot be+ -- lifted out of exploreSimTrace+ if explorationScheduleBound opts >=0+ then Set.empty+ else error "exploreSimTrace: negative schedule bound"++ cachedIO :: ScheduleControl -> IO Bool+ cachedIO m = atomicModifyIORef' cache $ \set ->+ (Set.insert m set, Set.member m set)+++ cacheSizeIO :: () -> IO Int+ cacheSizeIO () = Set.size <$> readIORef cache+++-- | A specialised version of `controlSimTrace'.+--+-- An internal function.+--+replaySimTrace :: forall a test. (Testable test)+ => ExplorationOptions+ -- ^ race exploration options+ -> (forall s. IOSim s a)+ -> ScheduleControl+ -- ^ a schedule control to reproduce+ -> (SimTrace a -> test)+ -- ^ a callback which receives the simulation trace. The trace+ -- will not contain any race events+ -> Property+replaySimTrace opts mainAction control k =+ let (_,trace) = detachTraceRaces $+ controlSimTrace (explorationStepTimelimit opts) control mainAction+ in property (k trace)++-- | Run a simulation using a given schedule. This is useful to reproduce+-- failing cases without exploring the races.+--+controlSimTrace :: forall a.+ Maybe Int+ -- ^ limit on the computation time allowed per scheduling step, for+ -- catching infinite loops etc.+ -> ScheduleControl+ -- ^ a schedule to replay+ --+ -- /note/: must be either `ControlDefault` or `ControlAwait`.+ -> (forall s. IOSim s a)+ -- ^ a simulation to run+ -> SimTrace a+controlSimTrace limit control mainAction =+ runST (controlSimTraceST limit control mainAction)++raceReversals :: ScheduleControl -> Int+raceReversals ControlDefault = 0+raceReversals (ControlAwait mods) = length mods+raceReversals ControlFollow{} = error "Impossible: raceReversals ControlFollow{}"++-- compareTraces is given (maybe) a passing trace and a failing trace,+-- and identifies the point at which they diverge, where it inserts a+-- "sleep" event for the thread that is delayed in the failing case,+-- and a "wake" event before its next action. It also returns the+-- identity and time of the sleeping thread. Since we expect the trace+-- to be consumed lazily (and perhaps only partially), and since the+-- sleeping thread is not of interest unless the trace is consumed+-- this far, then we collect its identity only if it is reached using+-- unsafePerformIO.++compareTraces :: Maybe (SimTrace a1)+ -> SimTrace a2+ -> (Maybe ((Time, ThreadId, Maybe ThreadLabel),+ Set.Set (ThreadId, Maybe ThreadLabel)),+ SimTrace a2)+compareTraces Nothing trace = (Nothing, trace)+compareTraces (Just passing) trace = unsafePerformIO $ do+ sleeper <- newIORef Nothing+ return (unsafePerformIO $ readIORef sleeper,+ go sleeper passing trace)+ where go sleeper (SimPORTrace tpass tidpass _ _ _ pass')+ (SimPORTrace tfail tidfail tstepfail tlfail evfail fail')+ | (tpass,tidpass) == (tfail,tidfail) =+ SimPORTrace tfail tidfail tstepfail tlfail evfail+ $ go sleeper pass' fail'+ go sleeper (SimPORTrace tpass tidpass tsteppass tlpass _ _) fail =+ unsafePerformIO $ do+ writeIORef sleeper $ Just ((tpass, tidpass, tlpass),Set.empty)+ return $ SimPORTrace tpass tidpass tsteppass tlpass EventThreadSleep+ $ wakeup sleeper tidpass fail+ go _ SimTrace {} _ = error "compareTraces: invariant violation"+ go _ _ SimTrace {} = error "compareTraces: invariant violation"+ go _ _ fail = fail++ wakeup sleeper tidpass+ fail@(SimPORTrace tfail tidfail tstepfail tlfail evfail fail')+ | tidpass == tidfail =+ SimPORTrace tfail tidfail tstepfail tlfail EventThreadWake fail+ | otherwise = unsafePerformIO $ do+ Just (slp,racing) <- readIORef sleeper+ writeIORef sleeper $ Just (slp,Set.insert (tidfail,tlfail) racing)+ return $ SimPORTrace tfail tidfail tstepfail tlfail evfail+ $ wakeup sleeper tidpass fail'+ wakeup _ _ SimTrace {} = error "compareTraces: invariant violation"+ wakeup _ _ fail = fail
+ src/Control/Monad/IOSim/CommonTypes.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Common types shared between `IOSim` and `IOSimPOR`.+--+module Control.Monad.IOSim.CommonTypes where++import Control.Monad.Class.MonadSTM (TraceValue)+import Control.Monad.ST.Lazy++import Data.Map (Map)+import Data.STRef.Lazy+import Data.Set (Set)+++-- | A thread id.+--+-- /IOSimPOR/: 'RacyThreadId' indicates that this thread is taken into account+-- when discovering races. A thread is marked as racy iff+-- `Control.Monad.Class.MonadTest.exploreRaces` was+-- executed in it or it's a thread forked by a racy thread.+--+data ThreadId = RacyThreadId [Int]+ | ThreadId [Int] -- non racy threads have higher priority+ deriving (Eq, Ord, Show)++childThreadId :: ThreadId -> Int -> ThreadId+childThreadId (RacyThreadId is) i = RacyThreadId (is ++ [i])+childThreadId (ThreadId is) i = ThreadId (is ++ [i])++setRacyThread :: ThreadId -> ThreadId+setRacyThread (ThreadId is) = RacyThreadId is+setRacyThread tid@RacyThreadId{} = tid+++newtype TVarId = TVarId Int deriving (Eq, Ord, Enum, Show)+newtype TimeoutId = TimeoutId Int deriving (Eq, Ord, Enum, Show)+newtype ClockId = ClockId [Int] deriving (Eq, Ord, Show)+newtype VectorClock = VectorClock { getVectorClock :: Map ThreadId Int }+ deriving Show++unTimeoutId :: TimeoutId -> Int+unTimeoutId (TimeoutId a) = a++type ThreadLabel = String+type TVarLabel = String++data TVar s a = TVar {++ -- | The identifier of this var.+ --+ tvarId :: !TVarId,++ -- | Label.+ tvarLabel :: !(STRef s (Maybe TVarLabel)),++ -- | The var's current value+ --+ tvarCurrent :: !(STRef s a),++ -- | A stack of undo values. This is only used while executing a+ -- transaction.+ --+ tvarUndo :: !(STRef s [a]),++ -- | Thread Ids of threads blocked on a read of this var. It is+ -- represented in reverse order of thread wakeup, without duplicates.+ --+ -- To avoid duplicates efficiently, the operations rely on a copy of the+ -- thread Ids represented as a set.+ --+ tvarBlocked :: !(STRef s ([ThreadId], Set ThreadId)),++ -- | The vector clock of the current value.+ --+ tvarVClock :: !(STRef s VectorClock),++ -- | Callback to construct a trace which will be attached to the dynamic+ -- trace.+ tvarTrace :: !(STRef s (Maybe (Maybe a -> a -> ST s TraceValue)))+ }++instance Eq (TVar s a) where+ TVar {tvarId = a} == TVar {tvarId = b} = a == b++data SomeTVar s where+ SomeTVar :: !(TVar s a) -> SomeTVar s++data Deschedule = Yield+ | Interruptable+ | Blocked BlockedReason+ | Terminated+ | Sleep+ deriving Show++data ThreadStatus = ThreadRunning+ | ThreadBlocked BlockedReason+ | ThreadDone+ deriving (Eq, Show)++data BlockedReason = BlockedOnSTM+ | BlockedOnOther+ deriving (Eq, Show)
+ src/Control/Monad/IOSim/Internal.hs view
@@ -0,0 +1,1394 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted')+-- and 'reschedule'.+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Control.Monad.IOSim.Internal+ ( IOSim (..)+ , runIOSim+ , runSimTraceST+ , traceM+ , traceSTM+ , STM+ , STMSim+ , setCurrentTime+ , unshareClock+ , TimeoutException (..)+ , EventlogEvent (..)+ , EventlogMarker (..)+ , ThreadId+ , ThreadLabel+ , Labelled (..)+ , SimTrace+ , Trace.Trace (SimTrace, TraceMainReturn, TraceMainException, TraceDeadlock)+ , SimEvent (..)+ , SimResult (..)+ , SimEventType (..)+ , ppTrace+ , ppTrace_+ , ppSimEvent+ , liftST+ , execReadTVar+ ) where++import Prelude hiding (read)++import Data.Dynamic+import Data.Foldable (foldlM, toList, traverse_)+import qualified Data.List as List+import qualified Data.List.Trace as Trace+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Time (UTCTime (..), fromGregorian)+import Deque.Strict (Deque)+import qualified Deque.Strict as Deque++import GHC.Exts (fromList)++import Control.Exception (NonTermination (..), assert, throw)+import Control.Monad (join, when)+import Control.Monad.ST.Lazy+import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)+import Data.STRef.Lazy++import Control.Concurrent.Class.MonadSTM.TMVar+import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)+import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)+import Control.Monad.Class.MonadSTM hiding (STM)+import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))+import Control.Monad.Class.MonadThrow hiding (getMaskingState)+import Control.Monad.Class.MonadTime+import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))++import Control.Monad.IOSim.InternalTypes+import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent),+ Trace (SimPORTrace))+import Control.Monad.IOSim.Types (SimEvent)++--+-- Simulation interpreter+--++data Thread s a = Thread {+ threadId :: !ThreadId,+ threadControl :: !(ThreadControl s a),+ threadStatus :: !ThreadStatus,+ threadMasking :: !MaskingState,+ -- other threads blocked in a ThrowTo to us because we are or were masked+ threadThrowTo :: ![(SomeException, Labelled ThreadId)],+ threadClockId :: !ClockId,+ threadLabel :: Maybe ThreadLabel,+ threadNextTId :: !Int+ }++isThreadBlocked :: Thread s a -> Bool+isThreadBlocked t = case threadStatus t of+ ThreadBlocked {} -> True+ _ -> False++labelledTVarId :: TVar s a -> ST s (Labelled TVarId)+labelledTVarId TVar { tvarId, tvarLabel } = (Labelled tvarId) <$> readSTRef tvarLabel++labelledThreads :: Map ThreadId (Thread s a) -> [Labelled ThreadId]+labelledThreads threadMap =+ -- @Map.foldr'@ (and alikes) are not strict enough, to not ratain the+ -- original thread map we need to evaluate the spine of the list.+ -- TODO: https://github.com/haskell/containers/issues/749+ Map.foldr'+ (\Thread { threadId, threadLabel } !acc -> Labelled threadId threadLabel : acc)+ [] threadMap+++-- | Timers mutable variables. Supports 'newTimeout' api, the second+-- one 'Control.Monad.Class.MonadTimer.SI.registerDelay', the third one+-- 'Control.Monad.Class.MonadTimer.SI.threadDelay'.+--+data TimerCompletionInfo s =+ Timer !(TVar s TimeoutState)+ -- ^ `newTimeout` timer.+ | TimerRegisterDelay !(TVar s Bool)+ -- ^ `registerDelay` timer.+ | TimerThreadDelay !ThreadId !TimeoutId+ -- ^ `threadDelay` timer run by `ThreadId` which was assigned the given+ -- `TimeoutId` (only used to report in a trace).+ | TimerTimeout !ThreadId !TimeoutId !(TMVar (IOSim s) ThreadId)+ -- ^ `timeout` timer run by `ThreadId` which was assigned the given+ -- `TimeoutId` (only used to report in a trace).+++type Timeouts s = OrdPSQ TimeoutId Time (TimerCompletionInfo s)++-- | Internal state.+--+data SimState s a = SimState {+ runqueue :: !(Deque ThreadId),+ -- | All threads other than the currently running thread: both running+ -- and blocked threads.+ threads :: !(Map ThreadId (Thread s a)),+ -- | current time+ curTime :: !Time,+ -- | ordered list of timers and timeouts+ timers :: !(Timeouts s),+ -- | list of clocks+ clocks :: !(Map ClockId UTCTime),+ nextVid :: !TVarId, -- ^ next unused 'TVarId'+ nextTmid :: !TimeoutId -- ^ next unused 'TimeoutId'+ }++initialState :: SimState s a+initialState =+ SimState {+ runqueue = mempty,+ threads = Map.empty,+ curTime = Time 0,+ timers = PSQ.empty,+ clocks = Map.singleton (ClockId []) epoch1970,+ nextVid = TVarId 0,+ nextTmid = TimeoutId 0+ }+ where+ epoch1970 = UTCTime (fromGregorian 1970 1 1) 0++invariant :: Maybe (Thread s a) -> SimState s a -> x -> x++invariant (Just running) simstate@SimState{runqueue,threads,clocks} =+ assert (not (isThreadBlocked running))+ . assert (threadId running `Map.notMember` threads)+ . assert (threadId running `List.notElem` runqueue)+ . assert (threadClockId running `Map.member` clocks)+ . invariant Nothing simstate++invariant Nothing SimState{runqueue,threads,clocks} =+ assert (all (`Map.member` threads) runqueue)+ . assert (and [ isThreadBlocked t == (threadId t `notElem` runqueue)+ | t <- Map.elems threads ])+ . assert (toList runqueue == List.nub (toList runqueue))+ . assert (and [ threadClockId t `Map.member` clocks+ | t <- Map.elems threads ])++-- | Interpret the simulation monotonic time as a 'NominalDiffTime' since+-- the start.+timeSinceEpoch :: Time -> NominalDiffTime+timeSinceEpoch (Time t) = fromRational (toRational t)+++-- | Schedule / run a thread.+--+schedule :: forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)+schedule !thread@Thread{+ threadId = tid,+ threadControl = ThreadControl action ctl,+ threadMasking = maskst,+ threadLabel = tlbl+ }+ !simstate@SimState {+ runqueue,+ threads,+ timers,+ clocks,+ nextVid, nextTmid,+ curTime = time+ } =+ invariant (Just thread) simstate $+ case action of++ Return x -> {-# SCC "schedule.Return" #-}+ case ctl of+ MainFrame ->+ -- the main thread is done, so we're done+ -- even if other threads are still running+ return $ SimTrace time tid tlbl EventThreadFinished+ $ TraceMainReturn time x (labelledThreads threads)++ ForkFrame -> do+ -- this thread is done+ !trace <- deschedule Terminated thread simstate+ return $ SimTrace time tid tlbl EventThreadFinished+ $ SimTrace time tid tlbl (EventDeschedule Terminated)+ $ trace++ MaskFrame k maskst' ctl' -> do+ -- pop the control stack, restore thread-local state+ let thread' = thread { threadControl = ThreadControl (k x) ctl'+ , threadMasking = maskst' }+ -- but if we're now unmasked, check for any pending async exceptions+ !trace <- deschedule Interruptable thread' simstate+ return $ SimTrace time tid tlbl (EventMask maskst')+ $ SimTrace time tid tlbl (EventDeschedule Interruptable)+ $ trace++ CatchFrame _handler k ctl' -> do+ -- pop the control stack and continue+ let thread' = thread { threadControl = ThreadControl (k x) ctl' }+ schedule thread' simstate++ TimeoutFrame tmid lock k ctl' -> do+ -- There is a possible race between timeout action and the timeout expiration.+ -- We use a lock to solve the race.++ -- We cannot do `tryPutMVar` in the `treadAction`, because we need to+ -- know if the `lock` is empty right now when we still have the frame.+ v <- execTryPutTMVar lock undefined+ let -- Kill the assassin throwing thread then unmask exceptions and+ -- carry on the continuation+ threadAction :: IOSim s ()+ threadAction =+ if v then unsafeUnregisterTimeout tmid+ else atomically (takeTMVar lock) >>= killThread++ thread' =+ thread { threadControl =+ ThreadControl (case threadAction of+ IOSim k' -> k' (\() -> k (Just x)))+ ctl'+ }+ schedule thread' simstate++ DelayFrame tmid k ctl' -> do+ let thread' = thread { threadControl = ThreadControl k ctl' }+ timers' = PSQ.delete tmid timers+ schedule thread' simstate { timers = timers' }++ Throw e -> {-# SCC "schedule.Throw" #-}+ case unwindControlStack e thread timers of+ -- Found a CatchFrame+ (Right thread'@Thread { threadMasking = maskst' }, timers'') -> do+ -- We found a suitable exception handler, continue with that+ trace <- schedule thread' simstate { timers = timers'' }+ return (SimTrace time tid tlbl (EventThrow e) $+ SimTrace time tid tlbl (EventMask maskst') trace)++ (Left isMain, timers'')+ -- We unwound and did not find any suitable exception handler, so we+ -- have an unhandled exception at the top level of the thread.+ | isMain ->+ -- An unhandled exception in the main thread terminates the program+ return (SimTrace time tid tlbl (EventThrow e) $+ SimTrace time tid tlbl (EventThreadUnhandled e) $+ TraceMainException time e (labelledThreads threads))++ | otherwise -> do+ -- An unhandled exception in any other thread terminates the thread+ !trace <- deschedule Terminated thread simstate { timers = timers'' }+ return $ SimTrace time tid tlbl (EventThrow e)+ $ SimTrace time tid tlbl (EventThreadUnhandled e)+ $ SimTrace time tid tlbl (EventDeschedule Terminated)+ $ trace++ Catch action' handler k ->+ {-# SCC "schedule.Catch" #-} do+ -- push the failure and success continuations onto the control stack+ let thread' = thread { threadControl = ThreadControl action'+ (CatchFrame handler k ctl) }+ schedule thread' simstate++ Evaluate expr k ->+ {-# SCC "schedule.Evaulate" #-} do+ mbWHNF <- unsafeIOToST $ try $ evaluate expr+ case mbWHNF of+ Left e -> do+ -- schedule this thread to immediately raise the exception+ let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+ schedule thread' simstate+ Right whnf -> do+ -- continue with the resulting WHNF+ let thread' = thread { threadControl = ThreadControl (k whnf) ctl }+ schedule thread' simstate++ Say msg k ->+ {-# SCC "schedule.Say" #-} do+ let thread' = thread { threadControl = ThreadControl k ctl }+ trace <- schedule thread' simstate+ return (SimTrace time tid tlbl (EventSay msg) trace)++ Output x k ->+ {-# SCC "schedule.Output" #-} do+ let thread' = thread { threadControl = ThreadControl k ctl }+ trace <- schedule thread' simstate+ return (SimTrace time tid tlbl (EventLog x) trace)++ LiftST st k ->+ {-# SCC "schedule.LiftST" #-} do+ x <- strictToLazyST st+ let thread' = thread { threadControl = ThreadControl (k x) ctl }+ schedule thread' simstate++ GetMonoTime k ->+ {-# SCC "schedule.GetMonoTime" #-} do+ let thread' = thread { threadControl = ThreadControl (k time) ctl }+ schedule thread' simstate++ GetWallTime k ->+ {-# SCC "schedule.GetWallTime" #-} do+ let !clockid = threadClockId thread+ !clockoff = clocks Map.! clockid+ !walltime = timeSinceEpoch time `addUTCTime` clockoff+ !thread' = thread { threadControl = ThreadControl (k walltime) ctl }+ schedule thread' simstate++ SetWallTime walltime' k ->+ {-# SCC "schedule.SetWallTime" #-} do+ let !clockid = threadClockId thread+ !clockoff = clocks Map.! clockid+ !walltime = timeSinceEpoch time `addUTCTime` clockoff+ !clockoff' = addUTCTime (diffUTCTime walltime' walltime) clockoff+ !thread' = thread { threadControl = ThreadControl k ctl }+ !simstate' = simstate { clocks = Map.insert clockid clockoff' clocks }+ schedule thread' simstate'++ UnshareClock k ->+ {-# SCC "schedule.UnshareClock" #-} do+ let !clockid = threadClockId thread+ !clockoff = clocks Map.! clockid+ !clockid' = let ThreadId i = tid in ClockId i -- reuse the thread id+ !thread' = thread { threadControl = ThreadControl k ctl+ , threadClockId = clockid' }+ !simstate' = simstate { clocks = Map.insert clockid' clockoff clocks }+ schedule thread' simstate'++ -- This case is guarded by checks in 'timeout' itself.+ StartTimeout d _ _ | d <= 0 ->+ error "schedule: StartTimeout: Impossible happened"++ StartTimeout d action' k ->+ {-# SCC "schedule.StartTimeout" #-} do+ lock <- TMVar <$> execNewTVar nextVid (Just $ "lock-" ++ show nextTmid) Nothing+ let !expiry = d `addTime` time+ !timers' = PSQ.insert nextTmid expiry (TimerTimeout tid nextTmid lock) timers+ !thread' = thread { threadControl =+ ThreadControl action'+ (TimeoutFrame nextTmid lock k ctl)+ }+ !trace <- deschedule Yield thread' simstate { timers = timers'+ , nextTmid = succ nextTmid+ , nextVid = succ nextVid+ }+ return (SimTrace time tid tlbl (EventTimeoutCreated nextTmid tid expiry) trace)++ UnregisterTimeout tmid k ->+ {-# SCC "schedule.UnregisterTimeout" #-} do+ let thread' = thread { threadControl = ThreadControl k ctl }+ schedule thread' simstate { timers = PSQ.delete tmid timers }++ RegisterDelay d k | d < 0 ->+ {-# SCC "schedule.NewRegisterDelay.1" #-} do+ !tvar <- execNewTVar nextVid+ (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ True+ let !expiry = d `addTime` time+ !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+ trace <- schedule thread' simstate { nextVid = succ nextVid }+ return (SimTrace time tid tlbl (EventRegisterDelayCreated nextTmid nextVid expiry) $+ SimTrace time tid tlbl (EventRegisterDelayFired nextTmid) $+ trace)++ RegisterDelay d k ->+ {-# SCC "schedule.NewRegisterDelay.2" #-} do+ !tvar <- execNewTVar nextVid+ (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ False+ let !expiry = d `addTime` time+ !timers' = PSQ.insert nextTmid expiry (TimerRegisterDelay tvar) timers+ !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+ trace <- schedule thread' simstate { timers = timers'+ , nextVid = succ nextVid+ , nextTmid = succ nextTmid }+ return (SimTrace time tid tlbl+ (EventRegisterDelayCreated nextTmid nextVid expiry) trace)++ ThreadDelay d k | d < 0 ->+ {-# SCC "schedule.NewThreadDelay" #-} do+ let !expiry = d `addTime` time+ !thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) }+ !simstate' = simstate { nextTmid = succ nextTmid }+ trace <- schedule thread' simstate'+ return (SimTrace time tid tlbl (EventThreadDelay nextTmid expiry) $+ SimTrace time tid tlbl (EventThreadDelayFired nextTmid) $+ trace)++ ThreadDelay d k ->+ {-# SCC "schedule.NewThreadDelay" #-} do+ let !expiry = d `addTime` time+ !timers' = PSQ.insert nextTmid expiry (TimerThreadDelay tid nextTmid) timers+ !thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) }+ !trace <- deschedule (Blocked BlockedOnOther) thread' simstate { timers = timers'+ , nextTmid = succ nextTmid }+ return (SimTrace time tid tlbl (EventThreadDelay nextTmid expiry) trace)++ -- we treat negative timers as cancelled ones; for the record we put+ -- `EventTimerCreated` and `EventTimerCancelled` in the trace; This differs+ -- from `GHC.Event` behaviour.+ NewTimeout d k | d < 0 ->+ {-# SCC "schedule.NewTimeout.1" #-} do+ let !t = NegativeTimeout nextTmid+ !expiry = d `addTime` time+ !thread' = thread { threadControl = ThreadControl (k t) ctl }+ trace <- schedule thread' simstate { nextTmid = succ nextTmid }+ return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) $+ SimTrace time tid tlbl (EventTimerCancelled nextTmid) $+ trace)++ NewTimeout d k ->+ {-# SCC "schedule.NewTimeout.2" #-} do+ !tvar <- execNewTVar nextVid+ (Just $ "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")+ TimeoutPending+ let !expiry = d `addTime` time+ !t = Timeout tvar nextTmid+ !timers' = PSQ.insert nextTmid expiry (Timer tvar) timers+ !thread' = thread { threadControl = ThreadControl (k t) ctl }+ trace <- schedule thread' simstate { timers = timers'+ , nextVid = succ nextVid+ , nextTmid = succ nextTmid }+ return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) trace)++ CancelTimeout (Timeout tvar tmid) k ->+ {-# SCC "schedule.CancelTimeout" #-} do+ let !timers' = PSQ.delete tmid timers+ !thread' = thread { threadControl = ThreadControl k ctl }+ !written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)+ (wakeup, wokeby) <- threadsUnblockedByWrites written+ mapM_ (\(SomeTVar var) -> unblockAllThreadsFromTVar var) written+ let (unblocked,+ simstate') = unblockThreads True wakeup simstate+ trace <- schedule thread' simstate' { timers = timers' }+ return $ SimTrace time tid tlbl (EventTimerCancelled tmid)+ $ traceMany+ [ (time, tid', tlbl', EventTxWakeup vids)+ | tid' <- unblocked+ , let tlbl' = lookupThreadLabel tid' threads+ , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]+ $ trace++ -- cancelling a negative timer is a no-op+ CancelTimeout (NegativeTimeout _tmid) k ->+ {-# SCC "schedule.CancelTimeout" #-} do+ -- negative timers are promptly removed from the state+ let thread' = thread { threadControl = ThreadControl k ctl }+ schedule thread' simstate++ Fork a k ->+ {-# SCC "schedule.Fork" #-} do+ let !nextId = threadNextTId thread+ !tid' = childThreadId tid nextId+ !thread' = thread { threadControl = ThreadControl (k tid') ctl+ , threadNextTId = succ nextId }+ !thread'' = Thread { threadId = tid'+ , threadControl = ThreadControl (runIOSim a)+ ForkFrame+ , threadStatus = ThreadRunning+ , threadMasking = threadMasking thread+ , threadThrowTo = []+ , threadClockId = threadClockId thread+ , threadLabel = Nothing+ , threadNextTId = 1+ }+ !threads' = Map.insert tid' thread'' threads+ trace <- schedule thread' simstate { runqueue = Deque.snoc tid' runqueue+ , threads = threads' }+ return (SimTrace time tid tlbl (EventThreadForked tid') trace)++ Atomically a k ->+ {-# SCC "schedule.Atomically" #-} execAtomically time tid tlbl nextVid (runSTM a) $ \res ->+ case res of+ StmTxCommitted x written _read created+ tvarDynamicTraces tvarStringTraces nextVid' -> do+ (!wakeup, wokeby) <- threadsUnblockedByWrites written+ !_ <- mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written+ let thread' = thread { threadControl = ThreadControl (k x) ctl }+ (unblocked,+ simstate') = unblockThreads True wakeup simstate+ written' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written+ created' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) created+ -- We don't interrupt runnable threads to provide fairness+ -- anywhere else. We do it here by putting the tx that committed+ -- a transaction to the back of the runqueue, behind all other+ -- runnable threads, and behind the unblocked threads.+ -- For testing, we should have a more sophisticated policy to show+ -- that algorithms are not sensitive to the exact policy, so long+ -- as it is a fair policy (all runnable threads eventually run).+ !trace <- deschedule Yield thread' simstate' { nextVid = nextVid' }+ return $ SimTrace time tid tlbl (EventTxCommitted+ written' created' Nothing)+ $ traceMany+ [ (time, tid', tlbl', EventTxWakeup vids')+ | tid' <- unblocked+ , let tlbl' = lookupThreadLabel tid' threads+ , let Just vids' = Set.toList <$> Map.lookup tid' wokeby ]+ $ traceMany+ [ (time, tid, tlbl, EventLog tr)+ | tr <- tvarDynamicTraces ]+ $ traceMany+ [ (time, tid, tlbl, EventSay str)+ | str <- tvarStringTraces ]+ $ SimTrace time tid tlbl (EventUnblocked unblocked)+ $ SimTrace time tid tlbl (EventDeschedule Yield)+ $ trace++ StmTxAborted _read e -> do+ -- schedule this thread to immediately raise the exception+ let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+ !trace <- schedule thread' simstate+ return $ SimTrace time tid tlbl (EventTxAborted Nothing) trace++ StmTxBlocked read -> do+ !_ <- mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read+ vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read+ !trace <- deschedule (Blocked BlockedOnSTM) thread simstate+ return $ SimTrace time tid tlbl (EventTxBlocked vids Nothing)+ $ SimTrace time tid tlbl (EventDeschedule (Blocked BlockedOnSTM))+ $ trace++ GetThreadId k ->+ {-# SCC "schedule.GetThreadId" #-} do+ let thread' = thread { threadControl = ThreadControl (k tid) ctl }+ schedule thread' simstate++ LabelThread tid' l k | tid' == tid ->+ {-# SCC "schedule.LabelThread" #-} do+ let thread' = thread { threadControl = ThreadControl k ctl+ , threadLabel = Just l }+ schedule thread' simstate++ LabelThread tid' l k ->+ {-# SCC "schedule.LabelThread" #-} do+ let thread' = thread { threadControl = ThreadControl k ctl }+ threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads+ schedule thread' simstate { threads = threads' }++ GetMaskState k ->+ {-# SCC "schedule.GetMaskState" #-} do+ let thread' = thread { threadControl = ThreadControl (k maskst) ctl }+ schedule thread' simstate++ SetMaskState maskst' action' k ->+ {-# SCC "schedule.SetMaskState" #-} do+ let thread' = thread { threadControl = ThreadControl+ (runIOSim action')+ (MaskFrame k maskst ctl)+ , threadMasking = maskst' }+ trace <-+ case maskst' of+ -- If we're now unmasked then check for any pending async exceptions+ Unmasked -> SimTrace time tid tlbl (EventDeschedule Interruptable)+ <$> deschedule Interruptable thread' simstate+ _ -> schedule thread' simstate+ return $ SimTrace time tid tlbl (EventMask maskst')+ $ trace++ ThrowTo e tid' _ | tid' == tid ->+ {-# SCC "schedule.ThrowTo" #-} do+ -- Throw to ourself is equivalent to a synchronous throw,+ -- and works irrespective of masking state since it does not block.+ let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+ trace <- schedule thread' simstate+ return (SimTrace time tid tlbl (EventThrowTo e tid) trace)++ ThrowTo e tid' k ->+ {-# SCC "schedule.ThrowTo" #-} do+ let thread' = thread { threadControl = ThreadControl k ctl }+ willBlock = case Map.lookup tid' threads of+ Just t -> not (threadInterruptible t)+ _ -> False+ if willBlock+ then do+ -- The target thread has async exceptions masked so we add the+ -- exception and the source thread id to the pending async exceptions.+ let adjustTarget t = t { threadThrowTo = (e, Labelled tid tlbl) : threadThrowTo t }+ threads' = Map.adjust adjustTarget tid' threads+ !trace <- deschedule (Blocked BlockedOnOther) thread' simstate { threads = threads' }+ return $ SimTrace time tid tlbl (EventThrowTo e tid')+ $ SimTrace time tid tlbl EventThrowToBlocked+ $ SimTrace time tid tlbl (EventDeschedule (Blocked BlockedOnOther))+ $ trace+ else do+ -- The target thread has async exceptions unmasked, or is masked but+ -- is blocked (and all blocking operations are interruptible) then we+ -- raise the exception in that thread immediately. This will either+ -- cause it to terminate or enter an exception handler.+ -- In the meantime the thread masks new async exceptions. This will+ -- be resolved if the thread terminates or if it leaves the exception+ -- handler (when restoring the masking state would trigger the any+ -- new pending async exception).+ let adjustTarget t@Thread{ threadControl = ThreadControl _ ctl' } =+ t { threadControl = ThreadControl (Throw e) ctl'+ , threadStatus = ThreadRunning+ }+ simstate'@SimState { threads = threads' }+ = snd (unblockThreads False [tid'] simstate)+ threads'' = Map.adjust adjustTarget tid' threads'+ simstate'' = simstate' { threads = threads'' }++ trace <- schedule thread' simstate''+ return $ SimTrace time tid tlbl (EventThrowTo e tid')+ $ trace++ YieldSim k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ deschedule Yield thread' simstate++ -- ExploreRaces is ignored by this simulator+ ExploreRaces k ->+ {-# SCC "schedule.ExploreRaces" #-}+ schedule thread{ threadControl = ThreadControl k ctl } simstate++ Fix f k ->+ {-# SCC "schedule.Fix" #-} do+ r <- newSTRef (throw NonTermination)+ x <- unsafeInterleaveST $ readSTRef r+ let k' = unIOSim (f x) $ \x' ->+ LiftST (lazyToStrictST (writeSTRef r x')) (\() -> k x')+ thread' = thread { threadControl = ThreadControl k' ctl }+ schedule thread' simstate+++threadInterruptible :: Thread s a -> Bool+threadInterruptible thread =+ case threadMasking thread of+ Unmasked -> True+ MaskedInterruptible+ | isThreadBlocked thread -> True -- blocking operations are interruptible+ | otherwise -> False+ MaskedUninterruptible -> False++deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)+deschedule Yield !thread !simstate@SimState{runqueue, threads} =++ -- We don't interrupt runnable threads to provide fairness anywhere else.+ -- We do it here by putting the thread to the back of the runqueue, behind+ -- all other runnable threads.+ --+ -- For testing, we should have a more sophisticated policy to show that+ -- algorithms are not sensitive to the exact policy, so long as it is a+ -- fair policy (all runnable threads eventually run).++ {-# SCC "deschedule.Yield" #-}+ let runqueue' = Deque.snoc (threadId thread) runqueue+ threads' = Map.insert (threadId thread) thread threads in+ reschedule simstate { runqueue = runqueue', threads = threads' }++deschedule Interruptable !thread@Thread {+ threadId = tid,+ threadControl = ThreadControl _ ctl,+ threadMasking = Unmasked,+ threadThrowTo = (e, tid') : etids,+ threadLabel = tlbl+ }+ !simstate@SimState{ curTime = time, threads } =++ -- We're unmasking, but there are pending blocked async exceptions.+ -- So immediately raise the exception and unblock the blocked thread+ -- if possible.+ {-# SCC "deschedule.Interruptable.Unmasked" #-}+ let thread' = thread { threadControl = ThreadControl (Throw e) ctl+ , threadMasking = MaskedInterruptible+ , threadThrowTo = etids }+ (unblocked,+ simstate') = unblockThreads False [l_labelled tid'] simstate+ in do+ trace <- schedule thread' simstate'+ return $ SimTrace time tid tlbl (EventThrowToUnmasked tid')+ $ traceMany [ (time, tid'', tlbl'', EventThrowToWakeup)+ | tid'' <- unblocked+ , let tlbl'' = lookupThreadLabel tid'' threads ]+ trace++deschedule Interruptable !thread !simstate =+ -- Either masked or unmasked but no pending async exceptions.+ -- Either way, just carry on.+ {-# SCC "deschedule.Interruptable.Masked" #-}+ schedule thread simstate++deschedule (Blocked _blockedReason) !thread@Thread { threadThrowTo = _ : _+ , threadMasking = maskst } !simstate+ | maskst /= MaskedUninterruptible =+ -- We're doing a blocking operation, which is an interrupt point even if+ -- we have async exceptions masked, and there are pending blocked async+ -- exceptions. So immediately raise the exception and unblock the blocked+ -- thread if possible.+ {-# SCC "deschedule.Interruptable.Blocked.1" #-}+ deschedule Interruptable thread { threadMasking = Unmasked } simstate++deschedule (Blocked blockedReason) !thread !simstate@SimState{threads} =+ {-# SCC "deschedule.Interruptable.Blocked.2" #-}+ let thread' = thread { threadStatus = ThreadBlocked blockedReason }+ threads' = Map.insert (threadId thread') thread' threads in+ reschedule simstate { threads = threads' }++deschedule Terminated !thread !simstate@SimState{ curTime = time, threads } =+ -- This thread is done. If there are other threads blocked in a+ -- ThrowTo targeted at this thread then we can wake them up now.+ {-# SCC "deschedule.Terminated" #-}+ let !wakeup = map (l_labelled . snd) (reverse (threadThrowTo thread))+ (unblocked,+ !simstate') = unblockThreads False wakeup simstate+ in do+ !trace <- reschedule simstate'+ return $ traceMany+ [ (time, tid', tlbl', EventThrowToWakeup)+ | tid' <- unblocked+ , let tlbl' = lookupThreadLabel tid' threads ]+ trace++deschedule Sleep _thread _simstate =+ error "IOSim: impossible happend"++-- When there is no current running thread but the runqueue is non-empty then+-- schedule the next one to run.+reschedule :: SimState s a -> ST s (SimTrace a)+reschedule !simstate@SimState{ runqueue, threads }+ | Just (!tid, runqueue') <- Deque.uncons runqueue =+ {-# SCC "reschedule.Just" #-}+ let thread = threads Map.! tid in+ schedule thread simstate { runqueue = runqueue'+ , threads = Map.delete tid threads }++-- But when there are no runnable threads, we advance the time to the next+-- timer event, or stop.+reschedule !simstate@SimState{ threads, timers, curTime = time } =+ {-# SCC "reschedule.Nothing" #-}++ -- important to get all events that expire at this time+ case removeMinimums timers of+ Nothing -> return (TraceDeadlock time (labelledThreads threads))++ Just (tmids, !time', !fired, !timers') -> assert (time' >= time) $ do+ -- Reuse the STM functionality here to write all the timer TVars.+ -- Simplify to a special case that only reads and writes TVars.+ !written <- execAtomically' (runSTM $ mapM_ timeoutSTMAction fired)+ (wakeupSTM, wokeby) <- threadsUnblockedByWrites written+ !_ <- mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written++ -- Check all fired threadDelays+ let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ]+ wakeup = fst `fmap` wakeupThreadDelay ++ wakeupSTM+ (_, !simstate') = unblockThreads False wakeup simstate++ -- For each 'timeout' action where the timeout has fired, start a+ -- new thread to execute throwTo to interrupt the action.+ !timeoutExpired = [ (tid, tmid, lock)+ | TimerTimeout tid tmid lock <- fired ]++ !simstate'' <- forkTimeoutInterruptThreads timeoutExpired simstate'++ !trace <- reschedule simstate'' { curTime = time'+ , timers = timers' }++ return $+ traceMany ([ ( time', ThreadId [-1], Just "timer"+ , EventTimerFired tmid)+ | (tmid, Timer _) <- zip tmids fired ]+ ++ [ ( time', ThreadId [-1], Just "register delay timer"+ , EventRegisterDelayFired tmid)+ | (tmid, TimerRegisterDelay _) <- zip tmids fired ]+ ++ [ (time', tid', tlbl', EventTxWakeup vids)+ | tid' <- wakeupSTM+ , let tlbl' = lookupThreadLabel tid' threads+ , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]+ ++ [ ( time', tid, Just "thread delay timer"+ , EventThreadDelayFired tmid)+ | (tid, tmid) <- wakeupThreadDelay ]+ ++ [ ( time', tid, Just "timeout timer"+ , EventTimeoutFired tmid)+ | (tid, tmid, _) <- timeoutExpired ]+ ++ [ ( time', tid, Just "thread forked"+ , EventThreadForked tid)+ | (tid, _, _) <- timeoutExpired ])+ trace+ where+ timeoutSTMAction (Timer var) = do+ x <- readTVar var+ case x of+ TimeoutPending -> writeTVar var TimeoutFired+ TimeoutFired -> error "MonadTimer(Sim): invariant violation"+ TimeoutCancelled -> return ()+ timeoutSTMAction (TimerRegisterDelay var) = writeTVar var True+ -- Note that 'threadDelay' is not handled via STM style wakeup, but rather+ -- it's handled directly above with 'wakeupThreadDelay' and 'unblockThreads'+ timeoutSTMAction TimerThreadDelay{} = return ()+ timeoutSTMAction TimerTimeout{} = return ()++unblockThreads :: Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)+unblockThreads !onlySTM !wakeup !simstate@SimState {runqueue, threads} =+ -- To preserve our invariants (that threadBlocked is correct)+ -- we update the runqueue and threads together here+ (unblocked, simstate {+ runqueue = runqueue <> fromList unblocked,+ threads = threads'+ })+ where+ -- can only unblock if the thread exists and is blocked (not running)+ !unblocked = [ tid+ | tid <- wakeup+ , case Map.lookup tid threads of+ Just Thread { threadStatus = ThreadBlocked BlockedOnOther }+ -> not onlySTM+ Just Thread { threadStatus = ThreadBlocked BlockedOnSTM }+ -> True+ _ -> False+ ]+ -- and in which case we mark them as now running+ !threads' = List.foldl'+ (flip (Map.adjust (\t -> t { threadStatus = ThreadRunning })))+ threads+ unblocked++-- | This function receives a list of TimerTimeout values that represent threads+-- for which the timeout expired and kills the running thread if needed.+--+-- This function is responsible for the second part of the race condition issue+-- and relates to the 'schedule's 'TimeoutFrame' locking explanation (here is+-- where the assassin threads are launched. So, as explained previously, at this+-- point in code, the timeout expired so we need to interrupt the running+-- thread. If the running thread finished at the same time the timeout expired+-- we have a race condition. To deal with this race condition what we do is+-- look at the lock value. If it is 'Locked' this means that the running thread+-- already finished (or won the race) so we can safely do nothing. Otherwise, if+-- the lock value is 'NotLocked' we need to acquire the lock and launch an+-- assassin thread that is going to interrupt the running one. Note that we+-- should run this interrupting thread in an unmasked state since it might+-- receive a 'ThreadKilled' exception.+--+forkTimeoutInterruptThreads :: forall s a.+ [(ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)]+ -> SimState s a+ -> ST s (SimState s a)+forkTimeoutInterruptThreads timeoutExpired simState =+ foldlM (\st@SimState{ runqueue, threads }+ (t, TMVar lock)+ -> do+ v <- execReadTVar lock+ return $ case v of+ Nothing -> st { runqueue = Deque.snoc (threadId t) runqueue,+ threads = Map.insert (threadId t) t threads+ }+ Just _ -> st+ )+ simState'+ throwToThread++ where+ -- we launch a thread responsible for throwing an AsyncCancelled exception+ -- to the thread which timeout expired+ throwToThread :: [(Thread s a, TMVar (IOSim s) ThreadId)] ++ (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired + where+ fn :: SimState s a+ -> (ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)+ -> (SimState s a, (Thread s a, TMVar (IOSim s) ThreadId))+ fn state@SimState { threads } (tid, tmid, lock) =+ let t = case tid `Map.lookup` threads of+ Just t' -> t'+ Nothing -> error ("IOSim: internal error: unknown thread " ++ show tid)+ nextId = threadNextTId t+ in ( state { threads = Map.insert tid t { threadNextTId = succ nextId } threads }+ , ( Thread { threadId = childThreadId tid nextId,+ threadControl =+ ThreadControl+ (runIOSim $ do+ mtid <- myThreadId+ v2 <- atomically $ tryPutTMVar lock mtid+ when v2 $+ throwTo tid (toException (TimeoutException tmid)))+ ForkFrame,+ threadStatus = ThreadRunning,+ threadMasking = Unmasked,+ threadThrowTo = [],+ threadClockId = threadClockId t,+ threadLabel = Just "timeout-forked-thread",+ threadNextTId = 1+ }+ , lock+ )+ )++-- | Iterate through the control stack to find an enclosing exception handler+-- of the right type, or unwind all the way to the top level for the thread.+--+-- Also return if it's the main thread or a forked thread since we handle the+-- cases differently.+--+-- Also remove timeouts associated to frames we unwind.+--+unwindControlStack :: forall s a.+ SomeException+ -> Thread s a+ -> Timeouts s+ -> ( Either Bool (Thread s a)+ , Timeouts s+ )+unwindControlStack e thread = \timers ->+ case threadControl thread of+ ThreadControl _ ctl ->+ unwind (threadMasking thread) ctl timers+ where+ unwind :: forall s' c. MaskingState+ -> ControlStack s' c a+ -> OrdPSQ TimeoutId Time (TimerCompletionInfo s)+ -> (Either Bool (Thread s' a), OrdPSQ TimeoutId Time (TimerCompletionInfo s))+ unwind _ MainFrame timers = (Left True, timers)+ unwind _ ForkFrame timers = (Left False, timers)+ unwind _ (MaskFrame _k maskst' ctl) timers = unwind maskst' ctl timers++ unwind maskst (CatchFrame handler k ctl) timers =+ case fromException e of+ -- not the right type, unwind to the next containing handler+ Nothing -> unwind maskst ctl timers++ -- Ok! We will be able to continue the thread with the handler+ -- followed by the continuation after the catch+ Just e' -> ( Right thread {+ -- As per async exception rules, the handler is run+ -- masked+ threadControl = ThreadControl (handler e')+ (MaskFrame k maskst ctl),+ threadMasking = atLeastInterruptibleMask maskst+ }+ , timers+ )++ -- Either Timeout fired or the action threw an exception.+ -- - If Timeout fired, then it was possibly during this thread's execution+ -- so we need to run the continuation with a Nothing value.+ -- - If the timeout action threw an exception we need to keep unwinding the+ -- control stack looking for a handler to this exception.+ unwind maskst (TimeoutFrame tmid _ k ctl) timers =+ case fromException e of+ -- Exception came from timeout expiring+ Just (TimeoutException tmid') | tmid == tmid' ->+ (Right thread { threadControl = ThreadControl (k Nothing) ctl }, timers')+ -- Exception came from a different exception+ _ -> unwind maskst ctl timers'+ where+ -- Remove the timeout associated with the 'TimeoutFrame'.+ timers' = PSQ.delete tmid timers++ unwind maskst (DelayFrame tmid _k ctl) timers =+ unwind maskst ctl timers'+ where+ -- Remove the timeout associated with the 'DelayFrame'.+ timers' = PSQ.delete tmid timers+++ atLeastInterruptibleMask :: MaskingState -> MaskingState+ atLeastInterruptibleMask Unmasked = MaskedInterruptible+ atLeastInterruptibleMask ms = ms+++removeMinimums :: (Ord k, Ord p)+ => OrdPSQ k p a+ -> Maybe ([k], p, [a], OrdPSQ k p a)+removeMinimums = \psq ->+ case PSQ.minView psq of+ Nothing -> Nothing+ Just (k, p, x, psq') -> Just (collectAll [k] p [x] psq')+ where+ collectAll !ks !p !xs !psq =+ case PSQ.minView psq of+ Just (k, p', x, psq')+ | p == p' -> collectAll (k:ks) p (x:xs) psq'+ _ -> (reverse ks, p, reverse xs, psq)++traceMany :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]+ -> SimTrace a -> SimTrace a+traceMany [] trace = trace+traceMany ((time, tid, tlbl, event):ts) trace =+ SimTrace time tid tlbl event (traceMany ts trace)++lookupThreadLabel :: ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel+lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads)+++-- | The most general method of running 'IOSim' is in 'ST' monad. One can+-- recover failures or the result from 'SimTrace' with+-- 'Control.Monad.IOSim.traceResult', or access 'SimEventType's generated by the+-- computation with 'Control.Monad.IOSim.traceEvents'. A slightly more+-- convenient way is exposed by 'Control.Monad.IOSim.runSimTrace'.+--+runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a)+runSimTraceST mainAction = schedule mainThread initialState+ where+ mainThread =+ Thread {+ threadId = ThreadId [],+ threadControl = ThreadControl (runIOSim mainAction) MainFrame,+ threadStatus = ThreadRunning,+ threadMasking = Unmasked,+ threadThrowTo = [],+ threadClockId = ClockId [],+ threadLabel = Just "main",+ threadNextTId = 1+ }+++--+-- Executing STM Transactions+--++execAtomically :: forall s a c.+ Time+ -> ThreadId+ -> Maybe ThreadLabel+ -> TVarId+ -> StmA s a+ -> (StmTxResult s a -> ST s (SimTrace c))+ -> ST s (SimTrace c)+execAtomically !time !tid !tlbl !nextVid0 action0 k0 =+ go AtomicallyFrame Map.empty Map.empty [] [] nextVid0 action0+ where+ go :: forall b.+ StmStack s b a+ -> Map TVarId (SomeTVar s) -- set of vars read+ -> Map TVarId (SomeTVar s) -- set of vars written+ -> [SomeTVar s] -- vars written in order (no dups)+ -> [SomeTVar s] -- vars created in order+ -> TVarId -- var fresh name supply+ -> StmA s b+ -> ST s (SimTrace c)+ go !ctl !read !written !writtenSeq !createdSeq !nextVid action = assert localInvariant $+ case action of+ ReturnStm x ->+ {-# SCC "execAtomically.go.ReturnStm" #-}+ case ctl of+ AtomicallyFrame -> do+ -- Trace each created TVar+ !ds <- traverse (\(SomeTVar tvar) -> traceTVarST tvar True) createdSeq+ -- Trace & commit each TVar+ !ds' <- Map.elems <$> traverse+ (\(SomeTVar tvar) -> do+ tr <- traceTVarST tvar False+ !_ <- commitTVar tvar+ -- Also assert the data invariant that outside a tx+ -- the undo stack is empty:+ undos <- readTVarUndos tvar+ assert (null undos) $ return tr+ ) written++ -- Return the vars written, so readers can be unblocked+ k0 $ StmTxCommitted x (reverse writtenSeq)+ []+ (reverse createdSeq)+ (mapMaybe (\TraceValue { traceDynamic }+ -> toDyn <$> traceDynamic)+ $ ds ++ ds')+ (mapMaybe traceString $ ds ++ ds')+ nextVid++ BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do+ -- The branch has successfully completed the transaction. Hence,+ -- the alternative branch can be ignored.+ -- Commit the TVars written in this sub-transaction that are also+ -- in the written set of the outer transaction+ !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)+ (Map.intersection written writtenOuter)+ -- Merge the written set of the inner with the outer+ let written' = Map.union written writtenOuter+ writtenSeq' = filter (\(SomeTVar tvar) ->+ tvarId tvar `Map.notMember` writtenOuter)+ writtenSeq+ ++ writtenOuterSeq+ createdSeq' = createdSeq ++ createdOuterSeq+ -- Skip the right hand alternative and continue with the k continuation+ go ctl' read written' writtenSeq' createdSeq' nextVid (k x)++ ThrowStm e ->+ {-# SCC "execAtomically.go.ThrowStm" #-} do+ -- Rollback `TVar`s written since catch handler was installed+ !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written+ case ctl of+ AtomicallyFrame -> do+ k0 $ StmTxAborted (Map.elems read) (toException e)++ BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ -- Execute the left side in a new frame with an empty written set.+ -- but preserve ones that were set prior to it, as specified in the+ -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.+ let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'+ go ctl'' read Map.empty [] [] nextVid (h e)++ BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)++ BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)++ CatchStm a h k ->+ {-# SCC "execAtomically.go.ThrowStm" #-} do+ -- Execute the catch handler with an empty written set.+ -- but preserve ones that were set prior to it, as specified in the+ -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.+ let ctl' = BranchFrame (CatchStmA h) k written writtenSeq createdSeq ctl+ go ctl' read Map.empty [] [] nextVid a+++ Retry ->+ {-# SCC "execAtomically.go.Retry" #-} do+ -- Always revert all the TVar writes for the retry+ !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written+ case ctl of+ AtomicallyFrame -> do+ -- Return vars read, so the thread can block on them+ k0 $! StmTxBlocked $! Map.elems read++ BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame.OrElseStmA" #-} do+ -- Execute the orElse right hand with an empty written set+ let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'+ go ctl'' read Map.empty [] [] nextVid b++ BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ -- Retry makes sense only within a OrElse context. If it is a branch other than+ -- OrElse left side, then bubble up the `retry` to the frame above.+ -- Skip the continuation and propagate the retry into the outer frame+ -- using the written set for the outer frame+ go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry++ OrElse a b k ->+ {-# SCC "execAtomically.go.OrElse" #-} do+ -- Execute the left side in a new frame with an empty written set+ let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl+ go ctl' read Map.empty [] [] nextVid a++ NewTVar !mbLabel x k ->+ {-# SCC "execAtomically.go.NewTVar" #-} do+ !v <- execNewTVar nextVid mbLabel x+ go ctl read written writtenSeq (SomeTVar v : createdSeq) (succ nextVid) (k v)++ LabelTVar !label tvar k ->+ {-# SCC "execAtomically.go.LabelTVar" #-} do+ !_ <- writeSTRef (tvarLabel tvar) $! (Just label)+ go ctl read written writtenSeq createdSeq nextVid k++ TraceTVar tvar f k ->+ {-# SCC "execAtomically.go.TraceTVar" #-} do+ !_ <- writeSTRef (tvarTrace tvar) (Just f)+ go ctl read written writtenSeq createdSeq nextVid k++ ReadTVar v k+ | tvarId v `Map.member` read ->+ {-# SCC "execAtomically.go.ReadTVar" #-} do+ x <- execReadTVar v+ go ctl read written writtenSeq createdSeq nextVid (k x)+ | otherwise ->+ {-# SCC "execAtomically.go.ReadTVar" #-} do+ x <- execReadTVar v+ let read' = Map.insert (tvarId v) (SomeTVar v) read+ go ctl read' written writtenSeq createdSeq nextVid (k x)++ WriteTVar v x k+ | tvarId v `Map.member` written ->+ {-# SCC "execAtomically.go.WriteTVar" #-} do+ !_ <- execWriteTVar v x+ go ctl read written writtenSeq createdSeq nextVid k+ | otherwise ->+ {-# SCC "execAtomically.go.WriteTVar" #-} do+ !_ <- saveTVar v+ !_ <- execWriteTVar v x+ let written' = Map.insert (tvarId v) (SomeTVar v) written+ go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k++ SayStm msg k ->+ {-# SCC "execAtomically.go.SayStm" #-} do+ trace <- go ctl read written writtenSeq createdSeq nextVid k+ return $ SimTrace time tid tlbl (EventSay msg) trace++ OutputStm x k ->+ {-# SCC "execAtomically.go.OutputStm" #-} do+ trace <- go ctl read written writtenSeq createdSeq nextVid k+ return $ SimTrace time tid tlbl (EventLog x) trace++ LiftSTStm st k ->+ {-# SCC "schedule.LiftSTStm" #-} do+ x <- strictToLazyST st+ go ctl read written writtenSeq createdSeq nextVid (k x)++ FixStm f k ->+ {-# SCC "execAtomically.go.FixStm" #-} do+ r <- newSTRef (throw NonTermination)+ x <- unsafeInterleaveST $ readSTRef r+ let k' = unSTM (f x) $ \x' ->+ LiftSTStm (lazyToStrictST (writeSTRef r x')) (\() -> k x')+ go ctl read written writtenSeq createdSeq nextVid k'++ where+ localInvariant =+ Map.keysSet written+ == Set.fromList [ tvarId tvar | SomeTVar tvar <- writtenSeq ]+++-- | Special case of 'execAtomically' supporting only var reads and writes+--+execAtomically' :: StmA s () -> ST s [SomeTVar s]+execAtomically' = go Map.empty+ where+ go :: Map TVarId (SomeTVar s) -- set of vars written+ -> StmA s ()+ -> ST s [SomeTVar s]+ go !written action = case action of+ ReturnStm () -> do+ !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar) written+ return (Map.elems written)+ ReadTVar v k -> do+ x <- execReadTVar v+ go written (k x)+ WriteTVar v x k+ | tvarId v `Map.member` written -> do+ !_ <- execWriteTVar v x+ go written k+ | otherwise -> do+ !_ <- saveTVar v+ !_ <- execWriteTVar v x+ let written' = Map.insert (tvarId v) (SomeTVar v) written+ go written' k+ _ -> error "execAtomically': only for special case of reads and writes"+++execNewTVar :: TVarId -> Maybe String -> a -> ST s (TVar s a)+execNewTVar nextVid !mbLabel x = do+ !tvarLabel <- newSTRef mbLabel+ !tvarCurrent <- newSTRef x+ !tvarUndo <- newSTRef $! []+ !tvarBlocked <- newSTRef ([], Set.empty)+ !tvarVClock <- newSTRef $! VectorClock Map.empty+ !tvarTrace <- newSTRef $! Nothing+ return TVar {tvarId = nextVid, tvarLabel,+ tvarCurrent, tvarUndo, tvarBlocked, tvarVClock,+ tvarTrace}+++-- 'execReadTVar' is defined in `Control.Monad.IOSim.Type` and shared with /IOSimPOR/++execWriteTVar :: TVar s a -> a -> ST s ()+execWriteTVar TVar{tvarCurrent} = writeSTRef tvarCurrent+{-# INLINE execWriteTVar #-}++execTryPutTMVar :: TMVar (IOSim s) a -> a -> ST s Bool+execTryPutTMVar (TMVar var) a = do+ v <- execReadTVar var+ case v of+ Nothing -> execWriteTVar var (Just a)+ >> return True+ Just _ -> return False+{-# INLINE execTryPutTMVar #-}++saveTVar :: TVar s a -> ST s ()+saveTVar TVar{tvarCurrent, tvarUndo} = do+ -- push the current value onto the undo stack+ v <- readSTRef tvarCurrent+ vs <- readSTRef tvarUndo+ !_ <- writeSTRef tvarUndo (v:vs)+ return ()++revertTVar :: TVar s a -> ST s ()+revertTVar TVar{tvarCurrent, tvarUndo} = do+ -- pop the undo stack, and revert the current value+ vs <- readSTRef tvarUndo+ !_ <- writeSTRef tvarCurrent (head vs)+ !_ <- writeSTRef tvarUndo (tail vs)+ return ()+{-# INLINE revertTVar #-}++commitTVar :: TVar s a -> ST s ()+commitTVar TVar{tvarUndo} = do+ vs <- readSTRef tvarUndo+ -- pop the undo stack, leaving the current value unchanged+ !_ <- writeSTRef tvarUndo (tail vs)+ return ()+{-# INLINE commitTVar #-}++readTVarUndos :: TVar s a -> ST s [a]+readTVarUndos TVar{tvarUndo} = readSTRef tvarUndo++-- | Trace a 'TVar'. It must be called only on 'TVar's that were new or+-- 'written.+traceTVarST :: TVar s a+ -> Bool -- true if it's a new 'TVar'+ -> ST s TraceValue+traceTVarST TVar{tvarCurrent, tvarUndo, tvarTrace} new = do+ mf <- readSTRef tvarTrace+ case mf of+ Nothing -> return TraceValue { traceDynamic = (Nothing :: Maybe ())+ , traceString = Nothing }+ Just f -> do+ vs <- readSTRef tvarUndo+ v <- readSTRef tvarCurrent+ case (new, vs) of+ (True, _) -> f Nothing v+ (_, _:_) -> f (Just $ last vs) v+ _ -> error "traceTVarST: unexpected tvar state"++++--+-- Blocking and unblocking on TVars+--++readTVarBlockedThreads :: TVar s a -> ST s [ThreadId]+readTVarBlockedThreads TVar{tvarBlocked} = fst <$> readSTRef tvarBlocked++blockThreadOnTVar :: ThreadId -> TVar s a -> ST s ()+blockThreadOnTVar tid TVar{tvarBlocked} = do+ (tids, tidsSet) <- readSTRef tvarBlocked+ when (tid `Set.notMember` tidsSet) $ do+ let !tids' = tid : tids+ !tidsSet' = Set.insert tid tidsSet+ !_ <- writeSTRef tvarBlocked (tids', tidsSet')+ return ()++unblockAllThreadsFromTVar :: TVar s a -> ST s ()+unblockAllThreadsFromTVar TVar{tvarBlocked} = do+ !_ <- writeSTRef tvarBlocked ([], Set.empty)+ return ()++-- | For each TVar written to in a transaction (in order) collect the threads+-- that blocked on each one (in order).+--+-- Also, for logging purposes, return an association between the threads and+-- the var writes that woke them.+--+threadsUnblockedByWrites :: [SomeTVar s]+ -> ST s ([ThreadId], Map ThreadId (Set (Labelled TVarId)))+threadsUnblockedByWrites written = do+ !tidss <- sequence+ [ (,) <$> labelledTVarId tvar <*> readTVarBlockedThreads tvar+ | SomeTVar tvar <- written ]+ -- Threads to wake up, in wake up order, annotated with the vars written that+ -- caused the unblocking.+ -- We reverse the individual lists because the tvarBlocked is used as a stack+ -- so it is in order of last written, LIFO, and we want FIFO behaviour.+ let !wakeup = ordNub [ tid | (_vid, tids) <- tidss, tid <- reverse tids ]+ wokeby = Map.fromListWith Set.union+ [ (tid, Set.singleton vid)+ | (vid, tids) <- tidss+ , tid <- tids ]+ return (wakeup, wokeby)++ordNub :: Ord a => [a] -> [a]+ordNub = go Set.empty+ where+ go !_ [] = []+ go !s (x:xs)+ | x `Set.member` s = go s xs+ | otherwise = x : go (Set.insert x s) xs+{-# INLINE ordNub #-}
+ src/Control/Monad/IOSim/InternalTypes.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Internal types shared between `IOSim` and `IOSimPOR`.+--+module Control.Monad.IOSim.InternalTypes+ ( ThreadControl (..)+ , ControlStack (..)+ , IsLocked (..)+ , unsafeUnregisterTimeout+ ) where++import Control.Exception (Exception)+import Control.Concurrent.Class.MonadSTM+import Control.Monad.Class.MonadThrow (MaskingState (..))++import Control.Monad.IOSim.Types (IOSim (..), SimA (..), ThreadId, TimeoutId)++import GHC.Exts (oneShot)++-- We hide the type @b@ here, so it's useful to bundle these two parts together,+-- rather than having Thread have an existential type, which makes record+-- updates awkward.+data ThreadControl s a where+ ThreadControl :: SimA s b+ -> !(ControlStack s b a)+ -> ThreadControl s a++instance Show (ThreadControl s a) where+ show _ = "..."++data ControlStack s b a where+ MainFrame :: ControlStack s a a+ ForkFrame :: ControlStack s () a+ MaskFrame :: (b -> SimA s c) -- subsequent continuation+ -> MaskingState -- thread local state to restore+ -> !(ControlStack s c a)+ -> ControlStack s b a+ CatchFrame :: Exception e+ => (e -> SimA s b) -- exception continuation+ -> (b -> SimA s c) -- subsequent continuation+ -> !(ControlStack s c a)+ -> ControlStack s b a+ TimeoutFrame :: TimeoutId+ -> TMVar (IOSim s) ThreadId+ -> (Maybe b -> SimA s c)+ -> !(ControlStack s c a)+ -> ControlStack s b a+ DelayFrame :: TimeoutId+ -> SimA s c+ -> ControlStack s c a+ -> ControlStack s b a++instance Show (ControlStack s b a) where+ show = show . dash+ where+ dash :: ControlStack s b' a -> ControlStackDash+ dash MainFrame = MainFrame'+ dash ForkFrame = ForkFrame'+ dash (MaskFrame _ m cs) = MaskFrame' m (dash cs)+ dash (CatchFrame _ _ cs) = CatchFrame' (dash cs)+ dash (TimeoutFrame tmid _ _ cs) = TimeoutFrame' tmid (dash cs)+ dash (DelayFrame tmid _ cs) = DelayFrame' tmid (dash cs)++data ControlStackDash =+ MainFrame'+ | ForkFrame'+ | MaskFrame' MaskingState ControlStackDash+ | CatchFrame' ControlStackDash+ -- TODO: Figure out a better way to include IsLocked here+ | TimeoutFrame' TimeoutId ControlStackDash+ | ThreadDelayFrame' TimeoutId ControlStackDash+ | DelayFrame' TimeoutId ControlStackDash+ deriving Show++data IsLocked = NotLocked | Locked !ThreadId+ deriving (Eq, Show)++-- | Unsafe method which removes a timeout.+--+-- It's not part of public API, and it might cause deadlocks when used in+-- a wrong context.+--+-- It is defined here rather so that it's not exposed to the user, even tough+-- one could define it oneself.+--+-- TODO: `SimA` constructors should be defined here.+--+unsafeUnregisterTimeout :: TimeoutId -> IOSim s ()+unsafeUnregisterTimeout tmid = IOSim $ oneShot $ \k -> UnregisterTimeout tmid (k ())
+ src/Control/Monad/IOSim/STM.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | 'io-sim' implementation of 'TQueue', 'TBQueue' and 'MVar'.+--+-- Unlike the default implementation available in 'io-classes' the 'TQueue' and+-- 'TBQueue' are using a single 'TVar', which simplifies the implementation of+-- 'traceTQueue' and 'traceTBQueue' methods.+--+module Control.Monad.IOSim.STM where++import Control.Exception (SomeAsyncException (..))++import Control.Concurrent.Class.MonadSTM.TVar+import Control.Monad.Class.MonadSTM (MonadInspectSTM (..),+ MonadLabelledSTM, MonadSTM (..), MonadTraceSTM,+ TraceValue (..))+import Control.Monad.Class.MonadThrow++import Numeric.Natural (Natural)++import Deque.Strict (Deque)+import qualified Deque.Strict as Deque++--+-- Default TQueue implementation in terms of a 'TVar' (used by sim)+--++newtype TQueueDefault m a = TQueue (TVar m ([a], [a]))++labelTQueueDefault+ :: MonadLabelledSTM m+ => TQueueDefault m a -> String -> STM m ()+labelTQueueDefault (TQueue queue) label = labelTVar queue label++traceTQueueDefault+ :: MonadTraceSTM m+ => proxy m+ -> TQueueDefault m a+ -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)+ -> STM m ()+traceTQueueDefault p (TQueue queue) f =+ traceTVar p queue+ (\mas as -> f (g <$> mas) (g as))+ where+ g (xs, ys) = xs ++ reverse ys++newTQueueDefault :: MonadSTM m => STM m (TQueueDefault m a)+newTQueueDefault = TQueue <$> newTVar ([], [])++writeTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()+writeTQueueDefault (TQueue queue) a = do+ (xs, ys) <- readTVar queue+ writeTVar queue $! (xs, a : ys)++readTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m a+readTQueueDefault queue = maybe retry return =<< tryReadTQueueDefault queue++tryReadTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m (Maybe a)+tryReadTQueueDefault (TQueue queue) = do+ (xs, ys) <- readTVar queue+ case xs of+ (x:xs') -> do+ writeTVar queue $! (xs', ys)+ return (Just x)+ [] ->+ case reverse ys of+ [] -> return Nothing+ (z:zs) -> do+ writeTVar queue $! (zs, [])+ return (Just z)++isEmptyTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m Bool+isEmptyTQueueDefault (TQueue queue) = do+ (xs, ys) <- readTVar queue+ return $ case xs of+ _:_ -> False+ [] -> case ys of+ [] -> True+ _ -> False++peekTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m a+peekTQueueDefault (TQueue queue) = do+ (xs, _) <- readTVar queue+ case xs of+ x :_ -> return x+ [] -> retry++tryPeekTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m (Maybe a)+tryPeekTQueueDefault (TQueue queue) = do+ (xs, _) <- readTVar queue+ return $ case xs of+ x :_ -> Just x+ [] -> Nothing++flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a]+flushTQueueDefault (TQueue queue) = uncurry (++) <$> readTVar queue++unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()+unGetTQueueDefault (TQueue queue) a = do+ (xs, ys) <- readTVar queue+ writeTVar queue (a : xs, ys)++--+-- Default TBQueue implementation in terms of 'Seq' (used by sim)+--++data TBQueueDefault m a = TBQueue+ !(TVar m ([a], Natural, [a], Natural))+ !Natural++labelTBQueueDefault+ :: MonadLabelledSTM m+ => TBQueueDefault m a -> String -> STM m ()+labelTBQueueDefault (TBQueue queue _size) label = labelTVar queue label++traceTBQueueDefault+ :: MonadTraceSTM m+ => proxy m+ -> TBQueueDefault m a+ -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)+ -> STM m ()+traceTBQueueDefault p (TBQueue queue _size) f =+ traceTVar p queue (\mas as -> f (g <$> mas) (g as))+ where+ g (xs, _, ys, _) = xs ++ reverse ys+++newTBQueueDefault :: MonadSTM m => Natural -> STM m (TBQueueDefault m a)+newTBQueueDefault size | size >= fromIntegral (maxBound :: Int)+ = error "newTBQueueDefault: size larger than Int"+newTBQueueDefault size =+ flip TBQueue size <$> (newTVar $! ([], 0, [], size))++readTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m a+readTBQueueDefault queue = maybe retry return =<< tryReadTBQueueDefault queue++tryReadTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m (Maybe a)+tryReadTBQueueDefault (TBQueue queue _size) = do+ (xs, r, ys, w) <- readTVar queue+ let !r' = r + 1+ case xs of+ (x:xs') -> do+ writeTVar queue $! (xs', r', ys, w)+ return (Just x)+ [] ->+ case reverse ys of+ [] -> do+ writeTVar queue $! (xs, r', ys, w)+ return Nothing++ -- NB. lazy: we want the transaction to be+ -- short, otherwise it will conflict+ (z:zs) -> do+ writeTVar queue $! (zs, r', [], w)+ return (Just z)++peekTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m a+peekTBQueueDefault queue = maybe retry return =<< tryPeekTBQueueDefault queue++tryPeekTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m (Maybe a)+tryPeekTBQueueDefault (TBQueue queue _size) = do+ (xs, _, _, _) <- readTVar queue+ return $ case xs of+ (x:_) -> Just x+ _ -> Nothing++writeTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> a -> STM m ()+writeTBQueueDefault (TBQueue queue _size) a = do+ (xs, r, ys, w) <- readTVar queue+ if (w > 0)+ then do let !w' = w - 1+ writeTVar queue $! (xs, r, a:ys, w')+ else do+ if (r > 0)+ then let !w' = r - 1 in+ writeTVar queue (xs, 0, a:ys, w')+ else retry++isEmptyTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool+isEmptyTBQueueDefault (TBQueue queue _size) = do+ (xs, _, ys, _) <- readTVar queue+ case xs of+ _:_ -> return False+ [] -> case ys of+ [] -> return True+ _ -> return False++isFullTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool+isFullTBQueueDefault (TBQueue queue _size) = do+ (_, r, _, w) <- readTVar queue+ return $+ if (w > 0)+ then False+ else if (r > 0)+ then False+ else True++lengthTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Natural+lengthTBQueueDefault (TBQueue queue size) = do+ (_, r, _, w) <- readTVar queue+ return $! size - r - w++flushTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m [a]+flushTBQueueDefault (TBQueue queue size) = do+ (xs, _, ys, _) <- readTVar queue+ if null xs && null ys+ then return []+ else do+ writeTVar queue $! ([], 0, [], size)+ return (xs ++ reverse ys)++unGetTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> a -> STM m ()+unGetTBQueueDefault (TBQueue queue _size) a = do+ (xs, r, ys, w) <- readTVar queue+ if (r > 0)+ then do writeTVar queue (a : xs, r - 1, ys, w)+ else do+ if (w > 0)+ then writeTVar queue (a : xs, r, ys, w - 1)+ else retry+++--+-- Default MVar implementation in terms of STM (used by sim)+--++-- | A default 'MonadMVar' implementation is based on `TVar`'s. An @MVar@+-- guarantees fairness.+--+-- /Implementation details:/+--+-- 'STM' does not guarantee fairness, instead it provide compositionally.+-- Fairness of 'putMVarDefault' and 'takeMVarDefault' is provided by tracking+-- queue of blocked operation in the 'MVarState', e.g. when a 'putMVarDefault'+-- is scheduled on a full 'MVar', the request is put on to the back of the queue+-- together with a wakeup var. When 'takeMVarDefault' executes, it returns the+-- value and is using the first element of the queue to set the new value of+-- the 'MVar' and signals next `putMVarDefault` operation to unblock. This has+-- an effect as if all the racing `putMVarDefault` calls where executed in+-- turns.+--+-- Note that 'readMVar' has interesting semantics: it is guaranteed to read+-- the next value put using 'putMVar', and all readers will wake up, not just+-- the first. To support this, the implementation uses two queues in the empty+-- MVar case: one for threads blocked on 'takeMVar', and one for threads+-- blocked on 'readMVar'. The 'putMVar' has to wake up all readers and the+-- first \"taker\" (if any).+--+newtype MVarDefault m a = MVar (TVar m (MVarState m a))++data MVarState m a = MVarEmpty !(Deque (TVar m (Maybe a))) -- blocked on take+ !(Deque (TVar m (Maybe a))) -- blocked on read+ | MVarFull a !(Deque (a, TVar m Bool)) -- blocked on put+++newEmptyMVarDefault :: MonadSTM m => m (MVarDefault m a)+newEmptyMVarDefault = MVar <$> newTVarIO (MVarEmpty mempty mempty)+++newMVarDefault :: MonadSTM m => a -> m (MVarDefault m a)+newMVarDefault a = MVar <$> newTVarIO (MVarFull a mempty)+++putMVarDefault :: ( MonadMask m+ , MonadSTM m+ , forall x tvar. tvar ~ TVar m x => Eq tvar+ )+ => MVarDefault m a -> a -> m ()+putMVarDefault (MVar tv) x = mask_ $ do+ res <- atomically $ do+ s <- readTVar tv+ case s of+ -- It's full, add ourselves to the end of the 'put' blocked queue.+ MVarFull x' putq -> do+ putvar <- newTVar False+ writeTVar tv (MVarFull x' (Deque.snoc (x, putvar) putq))+ return (Just putvar)++ -- The MVar is empty. Wake up any threads blocked in readMVar.+ -- If there's at least one thread blocked in takeMVar, we wake up the+ -- first, leaving the MVar empty. Otherwise the MVar becomes full.+ MVarEmpty takeq readq -> do+ mapM_ (\readvar -> writeTVar readvar (Just x)) readq++ case Deque.uncons takeq of+ Nothing ->+ writeTVar tv (MVarFull x mempty)++ Just (takevar, takeq') -> do+ writeTVar takevar (Just x)+ writeTVar tv (MVarEmpty takeq' mempty)++ return Nothing++ case res of+ -- we have to block on our own putvar until we can complete the put+ Just putvar ->+ atomically (readTVar putvar >>= check)+ `catch` \e@SomeAsyncException {} -> do+ atomically $ do+ s <- readTVar tv+ case s of+ MVarFull x' putq -> do+ -- async exception was thrown while we were blocked on putvar;+ -- we need to remove it from the queue, otherwise we will have+ -- a space leak.+ let putq' = Deque.filter ((/= putvar) . snd) putq+ writeTVar tv (MVarFull x' putq')++ -- This case is unlikely but possible if another thread ran+ -- first and modified the mvar. This situation is fine as far as+ -- space leaks are concerned because it means our wait var is no+ -- longer in the wait queue.+ MVarEmpty {} -> return ()+ throwIO e++ -- we managed to do the put synchronously+ Nothing -> return ()+++tryPutMVarDefault :: MonadSTM m+ => MVarDefault m a -> a -> m Bool+tryPutMVarDefault (MVar tv) x =+ atomically $ do+ s <- readTVar tv+ case s of+ MVarFull {} -> return False++ -- The MVar is empty. Wake up any threads blocked in readMVar.+ -- If there's at least one thread blocked in takeMVar, we wake up the+ -- first, leaving the MVar empty. Otherwise the MVar becomes full.+ MVarEmpty takeq readq -> do++ mapM_ (\readvar -> writeTVar readvar (Just x)) readq++ case Deque.uncons takeq of+ Nothing ->+ writeTVar tv (MVarFull x mempty)++ Just (takevar, takeq') -> do+ writeTVar takevar (Just x)+ writeTVar tv (MVarEmpty takeq' mempty)++ return True+++takeMVarDefault :: ( MonadMask m+ , MonadSTM m+ , forall x tvar. tvar ~ TVar m x => Eq tvar+ )+ => MVarDefault m a+ -> m a+takeMVarDefault (MVar tv) = mask_ $ do+ res <- atomically $ do+ s <- readTVar tv+ case s of+ -- It's empty, add ourselves to the end of the 'take' blocked queue.+ MVarEmpty takeq readq -> do+ takevar <- newTVar Nothing+ writeTVar tv (MVarEmpty (Deque.snoc takevar takeq) readq)+ return (Left takevar)++ -- It's full. If there's at least one thread blocked in putMVar, wake+ -- up the first one leaving the MVar full with the new put value.+ -- Otherwise the MVar becomes empty.+ MVarFull x putq ->+ case Deque.uncons putq of+ Nothing -> do+ writeTVar tv (MVarEmpty mempty mempty)+ return (Right x)++ Just ((x', putvar), putq') -> do+ writeTVar putvar True+ writeTVar tv (MVarFull x' putq')+ return (Right x)++ case res of+ -- we have to block on our own takevar until we can complete the read+ Left takevar ->+ atomically (readTVar takevar >>= maybe retry return)+ `catch` \e@SomeAsyncException {} -> do+ atomically $ do+ s <- readTVar tv+ case s of+ MVarEmpty takeq readq -> do+ -- async exception was thrown while were were blocked on+ -- takevar; we need to remove it from 'takeq', otherwise we+ -- will have a space leak.+ let takeq' = Deque.filter (/= takevar) takeq+ writeTVar tv (MVarEmpty takeq' readq)++ -- This case is unlikely but possible if another thread ran+ -- first and modified the mvar. This situation is fine as far as+ -- space leaks are concerned because it means our wait var is no+ -- longer in the wait queue.+ MVarFull {} -> return ()+ throwIO e++ -- we managed to do the take synchronously+ Right x -> return x+++tryTakeMVarDefault :: MonadSTM m+ => MVarDefault m a+ -> m (Maybe a)+tryTakeMVarDefault (MVar tv) = do+ atomically $ do+ s <- readTVar tv+ case s of+ MVarEmpty _ _ -> return Nothing++ -- It's full. If there's at least one thread blocked in putMVar, wake+ -- up the first one leaving the MVar full with the new put value.+ -- Otherwise the MVar becomes empty.+ MVarFull x putq ->+ case Deque.uncons putq of+ Nothing -> do+ writeTVar tv (MVarEmpty mempty mempty)+ return (Just x)++ Just ((x', putvar), putq') -> do+ writeTVar putvar True+ writeTVar tv (MVarFull x' putq')+ return (Just x)+++-- | 'readMVarDefault' when the 'MVar' is empty, guarantees to receive next+-- 'putMVar' value. It will also not block if the 'MVar' is full, even if there+-- are other threads attempting to 'putMVar'.+--+readMVarDefault :: ( MonadSTM m+ , MonadMask m+ , forall x tvar. tvar ~ TVar m x => Eq tvar+ )+ => MVarDefault m a+ -> m a+readMVarDefault (MVar tv) = do+ res <- atomically $ do+ s <- readTVar tv+ case s of+ -- It's empty, add ourselves to the 'read' blocked queue.+ MVarEmpty takeq readq -> do+ readvar <- newTVar Nothing+ writeTVar tv (MVarEmpty takeq (Deque.snoc readvar readq))+ return (Left readvar)++ -- if it's full return the value+ MVarFull x _ -> return (Right x)++ case res of+ -- we have to block on our own readvar until we can complete the read+ Left readvar ->+ atomically (readTVar readvar >>= maybe retry return)+ `catch` \e@SomeAsyncException {} -> do+ atomically $ do+ s <- readTVar tv+ case s of+ MVarEmpty takeq readq -> do+ -- async exception was thrown while were were blocked on+ -- readvar; we need to remove it from 'readq', otherwise we+ -- will have a space leak.+ let readq' = Deque.filter (/= readvar) readq+ writeTVar tv (MVarEmpty takeq readq')++ -- This case is unlikely but possible if another thread ran+ -- first and modified the mvar. This situation is fine as far as+ -- space leaks are concerned because it means our wait var is no+ -- longer in the wait queue.+ MVarFull {} -> return ()+ throwIO e++ -- we managed to do the take synchronously+ Right x -> return x+++tryReadMVarDefault :: MonadSTM m+ => MVarDefault m a -> m (Maybe a)+tryReadMVarDefault (MVar tv) =+ atomically $ do+ s <- readTVar tv+ case s of+ MVarFull x _ -> return (Just x)+ MVarEmpty {} -> return Nothing+++isEmptyMVarDefault :: MonadSTM m+ => MVarDefault m a -> m Bool+isEmptyMVarDefault (MVar tv) =+ atomically $ do+ s <- readTVar tv+ case s of+ MVarFull {} -> return False+ MVarEmpty {} -> return True
+ src/Control/Monad/IOSim/Types.hs view
@@ -0,0 +1,1211 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- Needed for `SimEvent` type.+{-# OPTIONS_GHC -Wno-partial-fields #-}++module Control.Monad.IOSim.Types+ ( IOSim (..)+ , runIOSim+ , traceM+ , traceSTM+ , liftST+ , SimA (..)+ , StepId+ , STMSim+ , STM (..)+ , runSTM+ , StmA (..)+ , StmTxResult (..)+ , BranchStmA (..)+ , StmStack (..)+ , TimeoutException (..)+ , setCurrentTime+ , unshareClock+ , ScheduleControl (..)+ , ScheduleMod (..)+ , ExplorationOptions (..)+ , ExplorationSpec+ , withScheduleBound+ , withBranching+ , withStepTimelimit+ , withReplay+ , stdExplorationOptions+ , EventlogEvent (..)+ , EventlogMarker (..)+ , SimEventType (..)+ , SimEvent (..)+ , SimResult (..)+ , SimTrace+ , Trace.Trace (SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceRacesFound, TraceLoop)+ , ppTrace+ , ppTrace_+ , ppSimEvent+ , ppDebug+ , Labelled (..)+ , module Control.Monad.IOSim.CommonTypes+ , Thrower (..)+ , Time (..)+ , addTime+ , diffTime+ -- * Internal API+ , Timeout (..)+ , newTimeout+ , readTimeout+ , cancelTimeout+ , awaitTimeout+ -- * Low-level API+ , execReadTVar+ ) where++import Control.Applicative+import Control.Exception (ErrorCall (..), asyncExceptionFromException,+ asyncExceptionToException)+import Control.Monad+import Control.Monad.Fix (MonadFix (..))++import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)+import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar+import Control.Monad.Class.MonadAsync hiding (Async)+import qualified Control.Monad.Class.MonadAsync as MonadAsync+import Control.Monad.Class.MonadEventlog+import Control.Monad.Class.MonadFork hiding (ThreadId)+import qualified Control.Monad.Class.MonadFork as MonadFork+import Control.Monad.Class.MonadMVar+import Control.Monad.Class.MonadST+import Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..),+ MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..),+ TArrayDefault, TChanDefault, TMVarDefault, TSemDefault,+ TraceValue, atomically, retry)+import qualified Control.Monad.Class.MonadSTM.Internal as MonadSTM+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadTest+import Control.Monad.Class.MonadThrow as MonadThrow hiding+ (getMaskingState)+import qualified Control.Monad.Class.MonadThrow as MonadThrow+import Control.Monad.Class.MonadTime+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer+import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))+import qualified Control.Monad.Class.MonadTimer.SI as SI+import Control.Monad.ST.Lazy+import qualified Control.Monad.ST.Strict as StrictST+import Control.Monad.ST.Unsafe (unsafeSTToIO)++import qualified Control.Monad.Catch as Exceptions+import qualified Control.Monad.Fail as Fail++import Data.Bifoldable+import Data.Bifunctor (bimap)+import Data.Dynamic (Dynamic, toDyn)+import qualified Data.List.Trace as Trace+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe)+import Data.Monoid (Endo (..))+import Data.STRef.Lazy+import Data.Semigroup (Max (..))+import Data.Time.Clock (diffTimeToPicoseconds)+import Data.Typeable+import Data.Word (Word64)+import qualified Debug.Trace as Debug+import NoThunks.Class (NoThunks (..))+import Text.Printf++import GHC.Exts (oneShot)+import GHC.Generics (Generic)+import Quiet (Quiet (..))++import Control.Monad.IOSim.CommonTypes+import Control.Monad.IOSim.STM+import Control.Monad.IOSimPOR.Types+++import qualified System.IO.Error as IO.Error (userError)++{-# ANN module "HLint: ignore Use readTVarIO" #-}+newtype IOSim s a = IOSim { unIOSim :: forall r. (a -> SimA s r) -> SimA s r }++runIOSim :: IOSim s a -> SimA s a+runIOSim (IOSim k) = k Return++-- | 'IOSim' has the ability to story any 'Typeable' value in its trace which+-- can then be recovered with `selectTraceEventsDynamic` or+-- `selectTraceEventsDynamic'`.+--+traceM :: Typeable a => a -> IOSim s ()+traceM x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ())++-- | Trace a value, in the same was as `traceM` does, but from the `STM` monad.+-- This is primarily useful for debugging.+--+traceSTM :: Typeable a => a -> STMSim s ()+traceSTM x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ())++data Thrower = ThrowSelf | ThrowOther deriving (Ord, Eq, Show)++data SimA s a where+ Return :: a -> SimA s a++ Say :: String -> SimA s b -> SimA s b+ Output :: Dynamic -> SimA s b -> SimA s b++ LiftST :: StrictST.ST s a -> (a -> SimA s b) -> SimA s b++ GetMonoTime :: (Time -> SimA s b) -> SimA s b+ GetWallTime :: (UTCTime -> SimA s b) -> SimA s b+ SetWallTime :: UTCTime -> SimA s b -> SimA s b+ UnshareClock :: SimA s b -> SimA s b++ StartTimeout :: DiffTime -> SimA s a -> (Maybe a -> SimA s b) -> SimA s b+ UnregisterTimeout :: TimeoutId -> SimA s a -> SimA s a+ RegisterDelay :: DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b+ ThreadDelay :: DiffTime -> SimA s b -> SimA s b++ NewTimeout :: DiffTime -> (Timeout s -> SimA s b) -> SimA s b+ CancelTimeout :: Timeout s -> SimA s b -> SimA s b++ Throw :: SomeException -> SimA s a+ Catch :: Exception e =>+ SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b+ Evaluate :: a -> (a -> SimA s b) -> SimA s b++ Fork :: IOSim s () -> (ThreadId -> SimA s b) -> SimA s b+ GetThreadId :: (ThreadId -> SimA s b) -> SimA s b+ LabelThread :: ThreadId -> String -> SimA s b -> SimA s b++ Atomically :: STM s a -> (a -> SimA s b) -> SimA s b++ ThrowTo :: SomeException -> ThreadId -> SimA s a -> SimA s a+ SetMaskState :: MaskingState -> IOSim s a -> (a -> SimA s b) -> SimA s b+ GetMaskState :: (MaskingState -> SimA s b) -> SimA s b++ YieldSim :: SimA s a -> SimA s a++ ExploreRaces :: SimA s b -> SimA s b++ Fix :: (x -> IOSim s x) -> (x -> SimA s r) -> SimA s r+++newtype STM s a = STM { unSTM :: forall r. (a -> StmA s r) -> StmA s r }++instance Semigroup a => Semigroup (STM s a) where+ a <> b = (<>) <$> a <*> b++instance Monoid a => Monoid (STM s a) where+ mempty = pure mempty++runSTM :: STM s a -> StmA s a+runSTM (STM k) = k ReturnStm++data StmA s a where+ ReturnStm :: a -> StmA s a+ ThrowStm :: SomeException -> StmA s a+ CatchStm :: StmA s a -> (SomeException -> StmA s a) -> (a -> StmA s b) -> StmA s b++ NewTVar :: Maybe String -> x -> (TVar s x -> StmA s b) -> StmA s b+ LabelTVar :: String -> TVar s a -> StmA s b -> StmA s b+ ReadTVar :: TVar s a -> (a -> StmA s b) -> StmA s b+ WriteTVar :: TVar s a -> a -> StmA s b -> StmA s b+ Retry :: StmA s b+ OrElse :: StmA s a -> StmA s a -> (a -> StmA s b) -> StmA s b++ SayStm :: String -> StmA s b -> StmA s b+ OutputStm :: Dynamic -> StmA s b -> StmA s b+ TraceTVar :: forall s a b.+ TVar s a+ -> (Maybe a -> a -> ST s TraceValue)+ -> StmA s b -> StmA s b++ LiftSTStm :: StrictST.ST s a -> (a -> StmA s b) -> StmA s b+ FixStm :: (x -> STM s x) -> (x -> StmA s r) -> StmA s r++-- Exported type+type STMSim = STM++--+-- Monad class instances+--++instance Functor (IOSim s) where+ {-# INLINE fmap #-}+ fmap f = \d -> IOSim $ oneShot $ \k -> unIOSim d (k . f)++instance Applicative (IOSim s) where+ {-# INLINE pure #-}+ pure = \x -> IOSim $ oneShot $ \k -> k x++ {-# INLINE (<*>) #-}+ (<*>) = \df dx -> IOSim $ oneShot $ \k ->+ unIOSim df (\f -> unIOSim dx (\x -> k (f x)))++ {-# INLINE (*>) #-}+ (*>) = \dm dn -> IOSim $ oneShot $ \k -> unIOSim dm (\_ -> unIOSim dn k)++instance Monad (IOSim s) where+ return = pure++ {-# INLINE (>>=) #-}+ (>>=) = \dm f -> IOSim $ oneShot $ \k -> unIOSim dm (\m -> unIOSim (f m) k)++ {-# INLINE (>>) #-}+ (>>) = (*>)++#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif++instance Semigroup a => Semigroup (IOSim s a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (IOSim s a) where+ mempty = pure mempty++#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif++instance Fail.MonadFail (IOSim s) where+ fail msg = IOSim $ oneShot $ \_ -> Throw (toException (IO.Error.userError msg))++instance MonadFix (IOSim s) where+ mfix f = IOSim $ oneShot $ \k -> Fix f k+++instance Functor (STM s) where+ {-# INLINE fmap #-}+ fmap f = \d -> STM $ oneShot $ \k -> unSTM d (k . f)++instance Applicative (STM s) where+ {-# INLINE pure #-}+ pure = \x -> STM $ oneShot $ \k -> k x++ {-# INLINE (<*>) #-}+ (<*>) = \df dx -> STM $ oneShot $ \k ->+ unSTM df (\f -> unSTM dx (\x -> k (f x)))++ {-# INLINE (*>) #-}+ (*>) = \dm dn -> STM $ oneShot $ \k -> unSTM dm (\_ -> unSTM dn k)++instance Monad (STM s) where+ return = pure++ {-# INLINE (>>=) #-}+ (>>=) = \dm f -> STM $ oneShot $ \k -> unSTM dm (\m -> unSTM (f m) k)++ {-# INLINE (>>) #-}+ (>>) = (*>)++#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif++instance Fail.MonadFail (STM s) where+ fail msg = STM $ oneShot $ \_ -> ThrowStm (toException (ErrorCall msg))++instance Alternative (STM s) where+ empty = MonadSTM.retry+ (<|>) = MonadSTM.orElse++instance MonadPlus (STM s) where++instance MonadFix (STM s) where+ mfix f = STM $ oneShot $ \k -> FixStm f k++instance MonadSay (IOSim s) where+ say msg = IOSim $ oneShot $ \k -> Say msg (k ())++instance MonadThrow (IOSim s) where+ throwIO e = IOSim $ oneShot $ \_ -> Throw (toException e)++instance MonadEvaluate (IOSim s) where+ evaluate a = IOSim $ oneShot $ \k -> Evaluate a k++-- | Just like the IO instance, we don't actually check anything here+instance NoThunks (IOSim s a) where+ showTypeOf _ = "IOSim"+ wNoThunks _ctxt _act = return Nothing++instance Exceptions.MonadThrow (IOSim s) where+ throwM = MonadThrow.throwIO++instance MonadThrow (STM s) where+ throwIO e = STM $ oneShot $ \_ -> ThrowStm (toException e)++ -- Since these involve re-throwing the exception and we don't provide+ -- CatchSTM at all, then we can get away with trivial versions:+ bracket before after thing = do+ a <- before+ r <- thing a+ _ <- after a+ return r++ finally thing after = do+ r <- thing+ _ <- after+ return r++instance Exceptions.MonadThrow (STM s) where+ throwM = MonadThrow.throwIO+++instance MonadCatch (STM s) where++ catch action handler = STM $ oneShot $ \k -> CatchStm (runSTM action) (runSTM . fromHandler handler) k+ where+ -- Get a total handler from the given handler+ fromHandler :: Exception e => (e -> STM s a) -> SomeException -> STM s a+ fromHandler h e = case fromException e of+ Nothing -> throwIO e -- Rethrow the exception if handler does not handle it.+ Just e' -> h e'++ -- Masking is not required as STM actions are always run inside+ -- `execAtomically` and behave as if masked. Also note that the default+ -- implementation of `generalBracket` needs mask, and is part of `MonadThrow`.+ generalBracket acquire release use = do+ resource <- acquire+ b <- use resource `catch` \e -> do+ _ <- release resource (ExitCaseException e)+ throwIO e+ c <- release resource (ExitCaseSuccess b)+ return (b, c)++instance Exceptions.MonadCatch (STM s) where+ catch = MonadThrow.catch++instance MonadCatch (IOSim s) where+ catch action handler =+ IOSim $ oneShot $ \k -> Catch (runIOSim action) (runIOSim . handler) k++instance Exceptions.MonadCatch (IOSim s) where+ catch = MonadThrow.catch++instance MonadMask (IOSim s) where+ mask action = do+ b <- getMaskingStateImpl+ case b of+ Unmasked -> block $ action unblock+ MaskedInterruptible -> action block+ MaskedUninterruptible -> action blockUninterruptible++ uninterruptibleMask action = do+ b <- getMaskingStateImpl+ case b of+ Unmasked -> blockUninterruptible $ action unblock+ MaskedInterruptible -> blockUninterruptible $ action block+ MaskedUninterruptible -> action blockUninterruptible++instance MonadMaskingState (IOSim s) where+ getMaskingState = getMaskingStateImpl+ interruptible action = do+ b <- getMaskingStateImpl+ case b of+ Unmasked -> action+ MaskedInterruptible -> unblock action+ MaskedUninterruptible -> action++instance Exceptions.MonadMask (IOSim s) where+ mask = MonadThrow.mask+ uninterruptibleMask = MonadThrow.uninterruptibleMask++ generalBracket acquire release use =+ mask $ \unmasked -> do+ resource <- acquire+ b <- unmasked (use resource) `catch` \e -> do+ _ <- release resource (Exceptions.ExitCaseException e)+ throwIO e+ c <- release resource (Exceptions.ExitCaseSuccess b)+ return (b, c)++instance NoThunks a => NoThunks (StrictTVar (IOSim s) a) where+ showTypeOf _ = "StrictTVar IOSim"+ wNoThunks ctxt tvar = do+ a <- unsafeSTToIO . lazyToStrictST . execReadTVar . StrictTVar.toLazyTVar+ $ tvar+ noThunks ctxt a++execReadTVar :: TVar s a -> ST s a+execReadTVar TVar{tvarCurrent} = readSTRef tvarCurrent+{-# INLINE execReadTVar #-}++getMaskingStateImpl :: IOSim s MaskingState+unblock, block, blockUninterruptible :: IOSim s a -> IOSim s a++getMaskingStateImpl = IOSim GetMaskState+unblock a = IOSim (SetMaskState Unmasked a)+block a = IOSim (SetMaskState MaskedInterruptible a)+blockUninterruptible a = IOSim (SetMaskState MaskedUninterruptible a)++instance MonadThread (IOSim s) where+ type ThreadId (IOSim s) = ThreadId+ myThreadId = IOSim $ oneShot $ \k -> GetThreadId k+ labelThread t l = IOSim $ oneShot $ \k -> LabelThread t l (k ())++instance MonadFork (IOSim s) where+ forkIO task = IOSim $ oneShot $ \k -> Fork task k+ forkOn _ task = IOSim $ oneShot $ \k -> Fork task k+ forkIOWithUnmask f = forkIO (f unblock)+ throwTo tid e = IOSim $ oneShot $ \k -> ThrowTo (toException e) tid (k ())+ yield = IOSim $ oneShot $ \k -> YieldSim (k ())++instance MonadTest (IOSim s) where+ exploreRaces = IOSim $ oneShot $ \k -> ExploreRaces (k ())++instance MonadSay (STMSim s) where+ say msg = STM $ oneShot $ \k -> SayStm msg (k ())+++instance MonadLabelledSTM (IOSim s) where+ labelTVar tvar label = STM $ \k -> LabelTVar label tvar (k ())+ labelTQueue = labelTQueueDefault+ labelTBQueue = labelTBQueueDefault++instance MonadSTM (IOSim s) where+ type STM (IOSim s) = STM s+ type TVar (IOSim s) = TVar s+ type TMVar (IOSim s) = TMVarDefault (IOSim s)+ type TQueue (IOSim s) = TQueueDefault (IOSim s)+ type TBQueue (IOSim s) = TBQueueDefault (IOSim s)+ type TArray (IOSim s) = TArrayDefault (IOSim s)+ type TSem (IOSim s) = TSemDefault (IOSim s)+ type TChan (IOSim s) = TChanDefault (IOSim s)++ atomically action = IOSim $ oneShot $ \k -> Atomically action k++ newTVar x = STM $ oneShot $ \k -> NewTVar Nothing x k+ readTVar tvar = STM $ oneShot $ \k -> ReadTVar tvar k+ writeTVar tvar x = STM $ oneShot $ \k -> WriteTVar tvar x (k ())+ retry = STM $ oneShot $ \_ -> Retry+ orElse a b = STM $ oneShot $ \k -> OrElse (runSTM a) (runSTM b) k++ newTMVar = MonadSTM.newTMVarDefault+ newEmptyTMVar = MonadSTM.newEmptyTMVarDefault+ takeTMVar = MonadSTM.takeTMVarDefault+ tryTakeTMVar = MonadSTM.tryTakeTMVarDefault+ putTMVar = MonadSTM.putTMVarDefault+ tryPutTMVar = MonadSTM.tryPutTMVarDefault+ readTMVar = MonadSTM.readTMVarDefault+ tryReadTMVar = MonadSTM.tryReadTMVarDefault+ swapTMVar = MonadSTM.swapTMVarDefault+ isEmptyTMVar = MonadSTM.isEmptyTMVarDefault++ newTQueue = newTQueueDefault+ readTQueue = readTQueueDefault+ tryReadTQueue = tryReadTQueueDefault+ peekTQueue = peekTQueueDefault+ tryPeekTQueue = tryPeekTQueueDefault+ flushTQueue = flushTQueueDefault+ writeTQueue = writeTQueueDefault+ isEmptyTQueue = isEmptyTQueueDefault+ unGetTQueue = unGetTQueueDefault++ newTBQueue = newTBQueueDefault+ readTBQueue = readTBQueueDefault+ tryReadTBQueue = tryReadTBQueueDefault+ peekTBQueue = peekTBQueueDefault+ tryPeekTBQueue = tryPeekTBQueueDefault+ flushTBQueue = flushTBQueueDefault+ writeTBQueue = writeTBQueueDefault+ lengthTBQueue = lengthTBQueueDefault+ isEmptyTBQueue = isEmptyTBQueueDefault+ isFullTBQueue = isFullTBQueueDefault+ unGetTBQueue = unGetTBQueueDefault++ newTSem = MonadSTM.newTSemDefault+ waitTSem = MonadSTM.waitTSemDefault+ signalTSem = MonadSTM.signalTSemDefault+ signalTSemN = MonadSTM.signalTSemNDefault++ newTChan = MonadSTM.newTChanDefault+ newBroadcastTChan = MonadSTM.newBroadcastTChanDefault+ writeTChan = MonadSTM.writeTChanDefault+ readTChan = MonadSTM.readTChanDefault+ tryReadTChan = MonadSTM.tryReadTChanDefault+ peekTChan = MonadSTM.peekTChanDefault+ tryPeekTChan = MonadSTM.tryPeekTChanDefault+ dupTChan = MonadSTM.dupTChanDefault+ unGetTChan = MonadSTM.unGetTChanDefault+ isEmptyTChan = MonadSTM.isEmptyTChanDefault+ cloneTChan = MonadSTM.cloneTChanDefault++instance MonadInspectSTM (IOSim s) where+ type InspectMonad (IOSim s) = ST s+ inspectTVar _ TVar { tvarCurrent } = readSTRef tvarCurrent+ inspectTMVar _ (MonadSTM.TMVar TVar { tvarCurrent }) = readSTRef tvarCurrent++-- | This instance adds a trace when a variable was written, just after the+-- stm transaction was committed.+--+-- Traces the first value using dynamic tracing, like 'traceM' does, i.e. with+-- 'EventDynamic'; the string is traced using 'EventSay'.+--+instance MonadTraceSTM (IOSim s) where+ traceTVar _ tvar f = STM $ \k -> TraceTVar tvar f (k ())+ traceTQueue = traceTQueueDefault+ traceTBQueue = traceTBQueueDefault+++instance MonadMVar (IOSim s) where+ type MVar (IOSim s) = MVarDefault (IOSim s)+ newEmptyMVar = newEmptyMVarDefault+ newMVar = newMVarDefault+ takeMVar = takeMVarDefault+ putMVar = putMVarDefault+ tryTakeMVar = tryTakeMVarDefault+ tryPutMVar = tryPutMVarDefault+ readMVar = readMVarDefault+ tryReadMVar = tryReadMVarDefault+ isEmptyMVar = isEmptyMVarDefault++data Async s a = Async !ThreadId (STM s (Either SomeException a))++instance Eq (Async s a) where+ Async tid _ == Async tid' _ = tid == tid'++instance Ord (Async s a) where+ compare (Async tid _) (Async tid' _) = compare tid tid'++instance Functor (Async s) where+ fmap f (Async tid a) = Async tid (fmap f <$> a)++instance MonadAsync (IOSim s) where+ type Async (IOSim s) = Async s++ async action = do+ var <- MonadSTM.newEmptyTMVarIO+ tid <- mask $ \restore ->+ forkIO $ try (restore action)+ >>= MonadSTM.atomically . MonadSTM.putTMVar var+ MonadSTM.labelTMVarIO var ("async-" ++ show tid)+ return (Async tid (MonadSTM.readTMVar var))++ asyncOn _ = async+ asyncBound = async++ asyncThreadId (Async tid _) = tid++ waitCatchSTM (Async _ w) = w+ pollSTM (Async _ w) = (Just <$> w) `MonadSTM.orElse` return Nothing++ cancel a@(Async tid _) = throwTo tid AsyncCancelled <* waitCatch a+ cancelWith a@(Async tid _) e = throwTo tid e <* waitCatch a++ asyncWithUnmask k = async (k unblock)+ asyncOnWithUnmask _ k = async (k unblock)++instance MonadST (IOSim s) where+ withLiftST f = f liftST++-- | Lift an 'StrictST.ST' computation to 'IOSim'.+--+-- Note: you can use 'MonadST' to lift 'StrictST.ST' computations, this is just+-- a more convenient function just for 'IOSim'.+liftST :: StrictST.ST s a -> IOSim s a+liftST action = IOSim $ oneShot $ \k -> LiftST action k++instance MonadMonotonicTimeNSec (IOSim s) where+ getMonotonicTimeNSec = IOSim $ oneShot $ \k -> GetMonoTime (k . conv)+ where+ -- convert time in picoseconds to nanoseconds+ conv :: Time -> Word64+ conv (Time d) = fromIntegral (diffTimeToPicoseconds d `div` 1_000)++instance MonadMonotonicTime (IOSim s) where+ getMonotonicTime = IOSim $ oneShot $ \k -> GetMonoTime k++instance MonadTime (IOSim s) where+ getCurrentTime = IOSim $ oneShot $ \k -> GetWallTime k++-- | Set the current wall clock time for the thread's clock domain.+--+setCurrentTime :: UTCTime -> IOSim s ()+setCurrentTime t = IOSim $ oneShot $ \k -> SetWallTime t (k ())++-- | Put the thread into a new wall clock domain, not shared with the parent+-- thread. Changing the wall clock time in the new clock domain will not affect+-- the other clock of other threads. All threads forked by this thread from+-- this point onwards will share the new clock domain.+--+unshareClock :: IOSim s ()+unshareClock = IOSim $ oneShot $ \k -> UnshareClock (k ())++instance MonadDelay (IOSim s) where+ -- Use optimized IOSim primitive+ threadDelay d =+ IOSim $ oneShot $ \k -> ThreadDelay (SI.microsecondsAsIntToDiffTime d)+ (k ())++instance SI.MonadDelay (IOSim s) where+ threadDelay d =+ IOSim $ oneShot $ \k -> ThreadDelay d (k ())++data Timeout s = Timeout !(TVar s TimeoutState) !TimeoutId+ -- ^ a timeout+ | NegativeTimeout !TimeoutId+ -- ^ a negative timeout++newTimeout :: DiffTime -> IOSim s (Timeout s)+newTimeout d = IOSim $ oneShot $ \k -> NewTimeout d k++readTimeout :: Timeout s -> STM s TimeoutState+readTimeout (Timeout var _key) = MonadSTM.readTVar var+readTimeout (NegativeTimeout _key) = pure TimeoutCancelled++cancelTimeout :: Timeout s -> IOSim s ()+cancelTimeout t = IOSim $ oneShot $ \k -> CancelTimeout t (k ())++awaitTimeout :: Timeout s -> STM s Bool+awaitTimeout t = do s <- readTimeout t+ case s of+ TimeoutPending -> retry+ TimeoutFired -> return True+ TimeoutCancelled -> return False++instance MonadTimer (IOSim s) where+ timeout d action+ | d < 0 = Just <$> action+ | d == 0 = return Nothing+ | otherwise = IOSim $ oneShot $ \k -> StartTimeout d' (runIOSim action) k+ where+ d' = SI.microsecondsAsIntToDiffTime d++ registerDelay d = IOSim $ oneShot $ \k -> RegisterDelay d' k+ where+ d' = SI.microsecondsAsIntToDiffTime d++instance SI.MonadTimer (IOSim s) where+ timeout d action+ | d < 0 = Just <$> action+ | d == 0 = return Nothing+ | otherwise = IOSim $ oneShot $ \k -> StartTimeout d (runIOSim action) k++ registerDelay d = IOSim $ oneShot $ \k -> RegisterDelay d k+ registerDelayCancellable d = do+ t <- newTimeout d+ return (readTimeout t, cancelTimeout t)++newtype TimeoutException = TimeoutException TimeoutId deriving Eq++instance Show TimeoutException where+ show (TimeoutException tmid) = "<<timeout " ++ show tmid ++ " >>"++instance Exception TimeoutException where+ toException = asyncExceptionToException+ fromException = asyncExceptionFromException++-- | Wrapper for Eventlog events so they can be retrieved from the trace with+-- 'selectTraceEventsDynamic'.+newtype EventlogEvent = EventlogEvent String++-- | Wrapper for Eventlog markers so they can be retrieved from the trace with+-- 'selectTraceEventsDynamic'.+newtype EventlogMarker = EventlogMarker String++instance MonadEventlog (IOSim s) where+ traceEventIO = traceM . EventlogEvent+ traceMarkerIO = traceM . EventlogMarker++-- | 'Trace' is a recursive data type, it is the trace of a 'IOSim'+-- computation. The trace will contain information about thread scheduling,+-- blocking on 'TVar's, and other internal state changes of 'IOSim'. More+-- importantly it also supports traces generated by the computation with 'say'+-- (which corresponds to using 'putStrLn' in 'IO'), 'traceEventM', or+-- dynamically typed traces with 'traceM' (which generalise the @base@ library+-- 'Debug.Trace.traceM')+--+-- It also contains information on discovered races.+--+-- See also: 'Control.Monad.IOSim.traceEvents',+-- 'Control.Monad.IOSim.traceResult', 'Control.Monad.IOSim.selectTraceEvents',+-- 'Control.Monad.IOSim.selectTraceEventsDynamic' and+-- 'Control.Monad.IOSim.printTraceEventsSay'.+--+data SimEvent+ -- | Used when using `IOSim`.+ = SimEvent {+ seTime :: !Time,+ seThreadId :: !ThreadId,+ seThreadLabel :: !(Maybe ThreadLabel),+ seType :: !SimEventType+ }+ -- | Only used for /IOSimPOR/+ | SimPOREvent {+ seTime :: !Time,+ seThreadId :: !ThreadId,+ seStep :: !Int,+ seThreadLabel :: !(Maybe ThreadLabel),+ seType :: !SimEventType+ }+ -- | Only used for /IOSimPOR/+ | SimRacesFound [ScheduleControl]+ deriving Generic+ deriving Show via Quiet SimEvent+++-- | Pretty print a 'SimEvent'.+--+ppSimEvent :: Int -- ^ width of the time+ -> Int -- ^ width of thread id+ -> Int -- ^ width of thread label+ -> SimEvent+ -> String+ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime, seThreadId, seThreadLabel, seType} =+ printf "%-*s - %-*s %-*s - %s"+ timeWidth+ (show seTime)+ tidWidth+ (show seThreadId)+ tLabelWidth+ threadLabel+ (show seType)+ where+ threadLabel = fromMaybe "" seThreadLabel+ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime, seThreadId, seStep, seThreadLabel, seType} =+ printf "%-*s - %-*s %-*s - %s"+ timeWidth+ (show seTime)+ tidWidth+ (show (seThreadId, seStep))+ tLableWidth+ threadLabel+ (show seType)+ where+ threadLabel = fromMaybe "" seThreadLabel+ppSimEvent _ _ _ (SimRacesFound controls) =+ "RacesFound "++show controls++-- | A result type of a simulation.+data SimResult a+ = MainReturn !Time a ![Labelled ThreadId]+ -- ^ Return value of the main thread.+ | MainException !Time SomeException ![Labelled ThreadId]+ -- ^ Exception thrown by the main thread.+ | Deadlock !Time ![Labelled ThreadId]+ -- ^ Deadlock discovered in the simulation. Deadlocks are discovered if+ -- simply the simulation cannot do any progress in a given time slot and+ -- there's no event which would advance the time.+ | Loop+ -- ^ Only returned by /IOSimPOR/ when a step execution took longer than+ -- 'explorationStepTimelimit` was exceeded.+ deriving (Show, Functor)++-- | A type alias for 'IOSim' simulation trace. It comes with useful pattern+-- synonyms.+--+type SimTrace a = Trace.Trace (SimResult a) SimEvent++-- | Pretty print simulation trace.+--+ppTrace :: Show a => SimTrace a -> String+ppTrace tr = Trace.ppTrace+ show+ (ppSimEvent timeWidth tidWith labelWidth)+ tr+ where+ (Max timeWidth, Max tidWith, Max labelWidth) =+ bimaximum+ . bimap (const (Max 0, Max 0, Max 0))+ (\a -> case a of+ SimEvent {seTime, seThreadId, seThreadLabel} ->+ ( Max (length (show seTime))+ , Max (length (show (seThreadId)))+ , Max (length seThreadLabel)+ )+ SimPOREvent {seTime, seThreadId, seThreadLabel} ->+ ( Max (length (show seTime))+ , Max (length (show (seThreadId)))+ , Max (length seThreadLabel)+ )+ SimRacesFound {} ->+ (Max 0, Max 0, Max 0)+ )+ $ tr+++-- | Like 'ppTrace' but does not show the result value.+--+ppTrace_ :: SimTrace a -> String+ppTrace_ tr = Trace.ppTrace+ (const "")+ (ppSimEvent timeWidth tidWith labelWidth)+ tr+ where+ (Max timeWidth, Max tidWith, Max labelWidth) =+ bimaximum+ . bimap (const (Max 0, Max 0, Max 0))+ (\a -> case a of+ SimEvent {seTime, seThreadId, seThreadLabel} ->+ ( Max (length (show seTime))+ , Max (length (show (seThreadId)))+ , Max (length seThreadLabel)+ )+ SimPOREvent {seTime, seThreadId, seThreadLabel} ->+ ( Max (length (show seTime))+ , Max (length (show (seThreadId)))+ , Max (length seThreadLabel)+ )+ SimRacesFound {} ->+ (Max 0, Max 0, Max 0)+ )+ $ tr++-- | Trace each event using 'Debug.trace'; this is useful when a trace ends with+-- a pure error, e.g. an assertion.+--+ppDebug :: SimTrace a -> x -> x+ppDebug = appEndo+ . foldMap (Endo . Debug.trace . show)+ . Trace.toList+++pattern SimTrace :: Time -> ThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a+ -> SimTrace a+pattern SimTrace time threadId threadLabel traceEvent trace =+ Trace.Cons (SimEvent time threadId threadLabel traceEvent)+ trace++pattern SimPORTrace :: Time -> ThreadId -> Int -> Maybe ThreadLabel -> SimEventType -> SimTrace a+ -> SimTrace a+pattern SimPORTrace time threadId step threadLabel traceEvent trace =+ Trace.Cons (SimPOREvent time threadId step threadLabel traceEvent)+ trace++pattern TraceRacesFound :: [ScheduleControl] -> SimTrace a+ -> SimTrace a+pattern TraceRacesFound controls trace =+ Trace.Cons (SimRacesFound controls)+ trace++pattern TraceMainReturn :: Time -> a -> [Labelled ThreadId]+ -> SimTrace a+pattern TraceMainReturn time a threads = Trace.Nil (MainReturn time a threads)++pattern TraceMainException :: Time -> SomeException -> [Labelled ThreadId]+ -> SimTrace a+pattern TraceMainException time err threads = Trace.Nil (MainException time err threads)++pattern TraceDeadlock :: Time -> [Labelled ThreadId]+ -> SimTrace a+pattern TraceDeadlock time threads = Trace.Nil (Deadlock time threads)++pattern TraceLoop :: SimTrace a+pattern TraceLoop = Trace.Nil Loop++{-# COMPLETE SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop #-}+++-- | Events recorded by the simulation.+--+data SimEventType+ = EventSay String+ -- ^ hold value of `say`+ | EventLog Dynamic+ -- ^ hold a dynamic value of `Control.Monad.IOSim.traceM`+ | EventMask MaskingState+ -- ^ masking state changed++ | EventThrow SomeException+ -- ^ throw exception+ | EventThrowTo SomeException ThreadId+ -- ^ throw asynchronous exception (`throwTo`)+ | EventThrowToBlocked+ -- ^ the thread which executed `throwTo` is blocked+ | EventThrowToWakeup+ -- ^ the thread which executed `throwTo` is woken up+ | EventThrowToUnmasked (Labelled ThreadId)+ -- ^ a target thread of `throwTo` unmasked its exceptions, this is paired+ -- with `EventThrowToWakeup` for threads which were blocked on `throwTo`++ | EventThreadForked ThreadId+ -- ^ forked a thread+ | EventThreadFinished+ -- ^ thread terminated normally+ | EventThreadUnhandled SomeException+ -- ^ thread terminated by an unhandled exception++ --+ -- STM events+ --++ -- | committed STM transaction+ | EventTxCommitted [Labelled TVarId] -- ^ stm tx wrote to these+ [Labelled TVarId] -- ^ and created these+ (Maybe Effect) -- ^ effect performed (only for `IOSimPOR`)+ -- | aborted an STM transaction (by an exception)+ -- + -- For /IOSimPOR/ it also holds performed effect.+ | EventTxAborted (Maybe Effect)+ -- | STM transaction blocked (due to `retry`)+ | EventTxBlocked [Labelled TVarId] -- stm tx blocked reading these+ (Maybe Effect) -- ^ effect performed (only for `IOSimPOR`)+ | EventTxWakeup [Labelled TVarId] -- ^ changed vars causing retry++ | EventUnblocked [ThreadId]+ -- ^ unblocked threads by a committed STM transaction++ --+ -- Timeouts, Timers & Delays+ --++ | EventThreadDelay TimeoutId Time+ -- ^ thread delayed+ | EventThreadDelayFired TimeoutId+ -- ^ thread woken up after a delay++ | EventTimeoutCreated TimeoutId ThreadId Time+ -- ^ new timeout created (via `timeout`)+ | EventTimeoutFired TimeoutId+ -- ^ timeout fired++ | EventRegisterDelayCreated TimeoutId TVarId Time+ -- ^ registered delay (via `registerDelay`)+ | EventRegisterDelayFired TimeoutId+ -- ^ registered delay fired++ | EventTimerCreated TimeoutId TVarId Time+ -- ^ a new 'Timeout' created (via `newTimeout`)+ | EventTimerUpdated TimeoutId Time+ -- ^ a 'Timeout' was updated (via `updateTimeout`)+ | EventTimerCancelled TimeoutId+ -- ^ a 'Timeout' was cancelled (via `cancelTimeout`)+ | EventTimerFired TimeoutId+ -- ^ a 'Timeout` fired++ --+ -- threadStatus+ --+ + -- | event traced when `threadStatus` is executed+ | EventThreadStatus ThreadId -- ^ current thread+ ThreadId -- ^ queried thread++ --+ -- /IOSimPOR/ events+ --++ | EventSimStart ScheduleControl+ -- ^ /IOSimPOR/ event: new execution started exploring the given schedule.+ | EventThreadSleep+ -- ^ /IOSimPOR/ event: the labelling thread was runnable, but its execution+ -- was delayed, until 'EventThreadWake'.+ --+ -- Event inserted to mark a difference between a failed trace and a similar+ -- passing trace.+ | EventThreadWake+ -- ^ /IOSimPOR/ event: marks when the thread was rescheduled by /IOSimPOR/+ | EventDeschedule Deschedule+ -- ^ /IOSim/ and /IOSimPOR/ event: a thread was descheduled+ | EventFollowControl ScheduleControl+ -- ^ /IOSimPOR/ event: following given schedule+ | EventAwaitControl StepId ScheduleControl+ -- ^ /IOSimPOR/ event: thread delayed to follow the given schedule+ | EventPerformAction StepId+ -- ^ /IOSimPOR/ event: perform action of the given step+ | EventReschedule ScheduleControl+ deriving Show+++-- | A labelled value.+--+-- For example 'labelThread' or `labelTVar' will insert a label to `ThreadId`+-- (or `TVarId`).+data Labelled a = Labelled {+ l_labelled :: !a,+ l_label :: !(Maybe String)+ }+ deriving (Eq, Ord, Generic)+ deriving Show via Quiet (Labelled a)++--+-- Executing STM Transactions+--++-- | Result of an STM computation.+--+data StmTxResult s a =+ -- | A committed transaction reports the vars that were written (in order+ -- of first write) so that the scheduler can unblock other threads that+ -- were blocked in STM transactions that read any of these vars.+ --+ -- It reports the vars that were read, so we can update vector clocks+ -- appropriately.+ --+ -- The third list of vars is ones that were created during this+ -- transaction. This is useful for an implementation of 'traceTVar'.+ --+ -- It also includes the updated TVarId name supply.+ --+ StmTxCommitted a [SomeTVar s] -- ^ written tvars+ [SomeTVar s] -- ^ read tvars+ [SomeTVar s] -- ^ created tvars+ [Dynamic]+ [String]+ TVarId -- updated TVarId name supply++ -- | A blocked transaction reports the vars that were read so that the+ -- scheduler can block the thread on those vars.+ --+ | StmTxBlocked [SomeTVar s]++ -- | An aborted transaction reports the vars that were read so that the+ -- vector clock can be updated.+ --+ | StmTxAborted [SomeTVar s] SomeException+++-- | A branch indicates that an alternative statement is available in the current+-- context. For example, `OrElse` has two alternative statements, say "left"+-- and "right". While executing the left statement, `OrElseStmA` branch indicates+-- that the right branch is still available, in case the left statement fails.+data BranchStmA s a =+ -- | `OrElse` statement with its 'right' alternative.+ OrElseStmA (StmA s a)+ -- | `CatchStm` statement with the 'catch' handler.+ | CatchStmA (SomeException -> StmA s a)+ -- | Unlike the other two branches, the no-op branch is not an explicit+ -- part of the STM syntax. It simply indicates that there are no+ -- alternative statements left to be executed. For example, when running+ -- right alternative of the `OrElse` statement or when running the catch+ -- handler of a `CatchStm` statement, there are no alternative statements+ -- available. This case is represented by the no-op branch.+ | NoOpStmA++data StmStack s b a where+ -- | Executing in the context of a top level 'atomically'.+ AtomicallyFrame :: StmStack s a a++ -- | Executing in the context of the /left/ hand side of a branch.+ -- A right branch is represented by a frame containing empty statement.+ BranchFrame :: !(BranchStmA s a) -- right alternative, can be empty+ -> (a -> StmA s b) -- subsequent continuation+ -> Map TVarId (SomeTVar s) -- saved written vars set+ -> [SomeTVar s] -- saved written vars list+ -> [SomeTVar s] -- created vars list+ -> StmStack s b c+ -> StmStack s a c+++---+--- Schedules+---++-- | Modified execution schedule.+--+data ScheduleControl = ControlDefault+ -- ^ default scheduling mode+ | ControlAwait [ScheduleMod]+ -- ^ if the current control is 'ControlAwait', the normal+ -- scheduling will proceed, until the thread found in the+ -- first 'ScheduleMod' reaches the given step. At this+ -- point the thread is put to sleep, until after all the+ -- steps are followed.+ | ControlFollow [StepId] [ScheduleMod]+ -- ^ follow the steps then continue with schedule+ -- modifications. This control is set by 'followControl'+ -- when 'controlTargets' returns true.+ deriving (Eq, Ord, Show)++-- | A schedule modification inserted at given execution step.+--+data ScheduleMod = ScheduleMod{+ -- | Step at which the 'ScheduleMod' is activated.+ scheduleModTarget :: StepId,+ -- | 'ScheduleControl' at the activation step. It is needed by+ -- 'extendScheduleControl' when combining the discovered schedule with the+ -- initial one.+ scheduleModControl :: ScheduleControl,+ -- | Series of steps which are executed at the target step. This *includes*+ -- the target step, not necessarily as the last step.+ scheduleModInsertion :: [StepId]+ }+ deriving (Eq, Ord)++-- | Execution step is identified by the thread id and a monotonically+-- increasing number (thread specific).+--+type StepId = (ThreadId, Int)++instance Show ScheduleMod where+ showsPrec d (ScheduleMod tgt ctrl insertion) =+ showParen (d>10) $+ showString "ScheduleMod " .+ showsPrec 11 tgt .+ showString " " .+ showsPrec 11 ctrl .+ showString " " .+ showsPrec 11 insertion++---+--- Exploration options+---++-- | Race exploration options.+--+data ExplorationOptions = ExplorationOptions{+ explorationScheduleBound :: Int,+ -- ^ This is an upper bound on the number of schedules with race reversals+ -- that will be explored; a bound of zero means that the default schedule+ -- will be explored, but no others. Setting the bound to zero makes+ -- IOSimPOR behave rather like IOSim, in that only one schedule is+ -- explored, but (a) IOSimPOR is considerably slower, because it still+ -- collects information on potential races, and (b) the IOSimPOR schedule+ -- is different (based on priorities, in contrast to IOSim's round-robin),+ -- and plays better with shrinking.+ --+ -- The default value is `100`.+ explorationBranching :: Int,+ -- ^ The branching factor. This is the number of alternative schedules that+ -- IOSimPOR tries to run, per race reversal. With the default parameters,+ -- IOSimPOR will try to reverse the first 33 (100 div 3) races discovered+ -- using the default schedule, then (if 33 or more races are discovered),+ -- for each such reversed race, will run the reversal and try to reverse+ -- two more races in the resulting schedule. A high branching factor will+ -- explore more combinations of reversing fewer races, within the overall+ -- schedule bound. A branching factor of one will explore only schedules+ -- resulting from a single race reversal (unless there are fewer races+ -- available to be reversed than the schedule bound).+ --+ -- The default value is `3`.+ explorationStepTimelimit :: Maybe Int,+ -- ^ Limit on the computation time allowed per scheduling step, for+ -- catching infinite loops etc.+ --+ -- The default value is `Nothing`.+ explorationReplay :: Maybe ScheduleControl+ -- ^ A schedule to replay.+ --+ -- The default value is `Nothing`.+ }+ deriving Show++stdExplorationOptions :: ExplorationOptions+stdExplorationOptions = ExplorationOptions{+ explorationScheduleBound = 100,+ explorationBranching = 3,+ explorationStepTimelimit = Nothing,+ explorationReplay = Nothing+ }++type ExplorationSpec = ExplorationOptions -> ExplorationOptions++withScheduleBound :: Int -> ExplorationSpec+withScheduleBound n e = e{explorationScheduleBound = n}++withBranching :: Int -> ExplorationSpec+withBranching n e = e{explorationBranching = n}++withStepTimelimit :: Int -> ExplorationSpec+withStepTimelimit n e = e{explorationStepTimelimit = Just n}++withReplay :: ScheduleControl -> ExplorationSpec+withReplay r e = e{explorationReplay = Just r}
+ src/Control/Monad/IOSimPOR/Internal.hs view
@@ -0,0 +1,1958 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted')+-- and 'reschedule'.+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-matches #-}++module Control.Monad.IOSimPOR.Internal+ ( IOSim (..)+ , runIOSim+ , runSimTraceST+ , traceM+ , traceSTM+ , STM+ , STMSim+ , setCurrentTime+ , unshareClock+ , TimeoutException (..)+ , EventlogEvent (..)+ , EventlogMarker (..)+ , ThreadId+ , ThreadLabel+ , Labelled (..)+ , SimTrace+ , Trace.Trace (SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock)+ , SimEvent (..)+ , SimResult (..)+ , SimEventType (..)+ , liftST+ , execReadTVar+ , controlSimTraceST+ , ScheduleControl (..)+ , ScheduleMod (..)+ ) where++import Prelude hiding (read)++import Data.Dynamic+import Data.Foldable (foldlM, traverse_)+import qualified Data.List as List+import qualified Data.List.Trace as Trace+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.Ord+import Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Time (UTCTime (..), fromGregorian)++import Control.Exception (NonTermination (..),+ assert, throw)+import Control.Monad (join, when)+import Control.Monad.ST.Lazy+import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)+import Data.STRef.Lazy++import Control.Concurrent.Class.MonadSTM.TMVar+import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)+import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)+import Control.Monad.Class.MonadSTM hiding (STM)+import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))+import Control.Monad.Class.MonadThrow as MonadThrow+import Control.Monad.Class.MonadTime+import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))++import Control.Monad.IOSim.InternalTypes+import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent),+ Trace (SimTrace))+import Control.Monad.IOSim.Types (SimEvent)+import Control.Monad.IOSimPOR.Timeout (unsafeTimeout)+import Control.Monad.IOSimPOR.Types++--+-- Simulation interpreter+--++data Thread s a = Thread {+ threadId :: !ThreadId,+ threadControl :: !(ThreadControl s a),+ threadStatus :: !ThreadStatus,+ threadMasking :: !MaskingState,+ -- other threads blocked in a ThrowTo to us because we are or were masked+ threadThrowTo :: ![(SomeException, Labelled ThreadId, VectorClock)],+ threadClockId :: !ClockId,+ threadLabel :: Maybe ThreadLabel,+ threadNextTId :: !Int,+ threadStep :: !Int,+ threadVClock :: VectorClock,+ threadEffect :: Effect, -- in the current step+ threadRacy :: !Bool+ }+ deriving Show++isThreadBlocked :: Thread s a -> Bool+isThreadBlocked t = case threadStatus t of+ ThreadBlocked {} -> True+ _ -> False++isThreadDone :: Thread s a -> Bool+isThreadDone t = case threadStatus t of+ ThreadDone -> True+ _ -> False++threadStepId :: Thread s a -> (ThreadId, Int)+threadStepId Thread{ threadId, threadStep } = (threadId, threadStep)++isRacyThreadId :: ThreadId -> Bool+isRacyThreadId (RacyThreadId _) = True+isRacyThreadId _ = True++isNotRacyThreadId :: ThreadId -> Bool+isNotRacyThreadId (ThreadId _) = True+isNotRacyThreadId _ = False++bottomVClock :: VectorClock+bottomVClock = VectorClock Map.empty++insertVClock :: ThreadId -> Int -> VectorClock -> VectorClock+insertVClock tid !step (VectorClock m) = VectorClock (Map.insert tid step m)++leastUpperBoundVClock :: VectorClock -> VectorClock -> VectorClock+leastUpperBoundVClock (VectorClock m) (VectorClock m') =+ VectorClock (Map.unionWith max m m')++-- hbfVClock :: VectorClock -> VectorClock -> Bool+-- hbfVClock (VectorClock m) (VectorClock m') = Map.isSubmapOfBy (<=) m m'++happensBeforeStep :: Step -- ^ an earlier step+ -> Step -- ^ a later step+ -> Bool+happensBeforeStep step step' =+ Just (stepStep step)+ <= Map.lookup (stepThreadId step)+ (getVectorClock $ stepVClock step')++labelledTVarId :: TVar s a -> ST s (Labelled TVarId)+labelledTVarId TVar { tvarId, tvarLabel } = Labelled tvarId <$> readSTRef tvarLabel++labelledThreads :: Map ThreadId (Thread s a) -> [Labelled ThreadId]+labelledThreads threadMap =+ -- @Map.foldr'@ (and alikes) are not strict enough, to not retain the+ -- original thread map we need to evaluate the spine of the list.+ -- TODO: https://github.com/haskell/containers/issues/749+ Map.foldr'+ (\Thread { threadId, threadLabel } !acc -> Labelled threadId threadLabel : acc)+ [] threadMap+++-- | Timers mutable variables. First one supports 'newTimeout' api, the second+-- one 'Control.Monad.Class.MonadTimer.SI.registerDelay', the third one+-- 'Control.Monad.Class.MonadTimer.SI.threadDelay'.+--+data TimerCompletionInfo s =+ Timer !(TVar s TimeoutState)+ -- ^ `newTimeout` timer.+ | TimerRegisterDelay !(TVar s Bool)+ -- ^ `registerDelay` timer.+ | TimerThreadDelay !ThreadId !TimeoutId+ -- ^ `threadDelay` timer run by `ThreadId` which was assigned the given+ -- `TimeoutId` (only used to report in a trace).+ | TimerTimeout !ThreadId !TimeoutId !(TMVar (IOSim s) ThreadId)+ -- ^ `timeout` timer run by `ThreadId` which was assigned the given+ -- `TimeoutId` (only used to report in a trace).++type RunQueue = OrdPSQ (Down ThreadId) (Down ThreadId) ()+type Timeouts s = OrdPSQ TimeoutId Time (TimerCompletionInfo s)++-- | Internal state.+--+data SimState s a = SimState {+ runqueue :: !RunQueue,+ -- | All threads other than the currently running thread: both running+ -- and blocked threads.+ threads :: !(Map ThreadId (Thread s a)),+ -- | current time+ curTime :: !Time,+ -- | ordered list of timers and timeouts+ timers :: !(Timeouts s),+ -- | timeout locks in order to synchronize the timeout handler and the+ -- main thread+ clocks :: !(Map ClockId UTCTime),+ nextVid :: !TVarId, -- ^ next unused 'TVarId'+ nextTmid :: !TimeoutId, -- ^ next unused 'TimeoutId'+ -- | previous steps (which we may race with).+ -- Note this is *lazy*, so that we don't compute races we will not reverse.+ races :: Races,+ -- | control the schedule followed, and initial value+ control :: !ScheduleControl,+ control0 :: !ScheduleControl,+ -- | limit on the computation time allowed per scheduling step, for+ -- catching infinite loops etc+ perStepTimeLimit :: Maybe Int++ }++initialState :: SimState s a+initialState =+ SimState {+ runqueue = PSQ.empty,+ threads = Map.empty,+ curTime = Time 0,+ timers = PSQ.empty,+ clocks = Map.singleton (ClockId []) epoch1970,+ nextVid = TVarId 0,+ nextTmid = TimeoutId 0,+ races = noRaces,+ control = ControlDefault,+ control0 = ControlDefault,+ perStepTimeLimit = Nothing+ }+ where+ epoch1970 = UTCTime (fromGregorian 1970 1 1) 0++invariant :: Maybe (Thread s a) -> SimState s a -> x -> x++invariant (Just running) simstate@SimState{runqueue,threads,clocks} =+ assert (not (isThreadBlocked running))+ . assert (threadId running `Map.notMember` threads)+ . assert (not (Down (threadId running) `PSQ.member` runqueue))+ . assert (threadClockId running `Map.member` clocks)+ . invariant Nothing simstate++invariant Nothing SimState{runqueue,threads,clocks} =+ assert (PSQ.fold' (\(Down tid) _ _ a -> tid `Map.member` threads && a) True runqueue)+ . assert (and [ (isThreadBlocked t || isThreadDone t) == not (Down (threadId t) `PSQ.member` runqueue)+ | t <- Map.elems threads ])+ . assert (and (zipWith (\(Down tid, _, _) (Down tid', _, _) -> tid > tid')+ (PSQ.toList runqueue)+ (drop 1 (PSQ.toList runqueue))))+ . assert (and [ threadClockId t `Map.member` clocks+ | t <- Map.elems threads ])++-- | Interpret the simulation monotonic time as a 'NominalDiffTime' since+-- the start.+timeSinceEpoch :: Time -> NominalDiffTime+timeSinceEpoch (Time t) = fromRational (toRational t)+++-- | Insert thread into `runqueue`.+--+insertThread :: Thread s a -> RunQueue -> RunQueue+insertThread Thread { threadId } = PSQ.insert (Down threadId) (Down threadId) ()+++-- | Schedule / run a thread.+--+schedule :: forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)+schedule thread@Thread{+ threadId = tid,+ threadControl = ThreadControl action ctl,+ threadMasking = maskst,+ threadLabel = tlbl,+ threadStep = tstep,+ threadVClock = vClock,+ threadEffect = effect+ }+ simstate@SimState {+ runqueue,+ threads,+ timers,+ clocks,+ nextVid, nextTmid,+ curTime = time,+ control,+ perStepTimeLimit+ }++ | controlTargets (tid,tstep) control =+ -- The next step is to be delayed according to the+ -- specified schedule. Switch to following the schedule.+ SimPORTrace time tid tstep tlbl (EventFollowControl control) <$>+ schedule thread simstate{ control = followControl control }++ | not $ controlFollows (tid,tstep) control =+ -- the control says this is not the next step to+ -- follow. We should be at the beginning of a step;+ -- we put the present thread to sleep and reschedule+ -- the correct thread.+ -- The assertion says that the only effect that may have+ -- happened in the start of a thread is us waking up.+ ( SimPORTrace time tid tstep tlbl (EventAwaitControl (tid,tstep) control)+ . SimPORTrace time tid tstep tlbl (EventDeschedule Sleep)+ ) <$> deschedule Sleep thread simstate++ | otherwise =+ invariant (Just thread) simstate $+ case control of+ ControlFollow (s:_) _+ -> fmap (SimPORTrace time tid tstep tlbl (EventPerformAction (tid,tstep)))+ _ -> id+ $+ -- The next line forces the evaluation of action, which should be unevaluated up to+ -- this point. This is where we actually *run* user code.+ case maybe Just unsafeTimeout perStepTimeLimit action of+ Nothing -> return TraceLoop+ Just _ -> case action of++ Return x -> case ctl of+ MainFrame ->+ -- the main thread is done, so we're done+ -- even if other threads are still running+ return $ SimPORTrace time tid tstep tlbl EventThreadFinished+ $ traceFinalRacesFound simstate+ $ TraceMainReturn time x ( labelledThreads+ . Map.filter (not . isThreadDone)+ $ threads+ )++ ForkFrame -> do+ -- this thread is done+ let thread' = thread+ !trace <- deschedule Terminated thread' simstate+ return $ SimPORTrace time tid tstep tlbl EventThreadFinished+ $ SimPORTrace time tid tstep tlbl (EventDeschedule Terminated)+ $ trace++ MaskFrame k maskst' ctl' -> do+ -- pop the control stack, restore thread-local state+ let thread' = thread { threadControl = ThreadControl (k x) ctl'+ , threadMasking = maskst'+ }+ -- but if we're now unmasked, check for any pending async exceptions+ !trace <- deschedule Interruptable thread' simstate+ return $ SimPORTrace time tid tstep tlbl (EventMask maskst')+ $ SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable)+ $ trace++ CatchFrame _handler k ctl' -> do+ -- pop the control stack and continue+ let thread' = thread { threadControl = ThreadControl (k x) ctl' }+ schedule thread' simstate++ TimeoutFrame tmid lock k ctl' -> do+ -- It could happen that the timeout action finished at the same time+ -- as the timeout expired, this will be a race condition. That's why+ -- we have the locks to solve this.++ -- We cannot do `tryPutMVar` in the `treadAction`, because we need to+ -- know if the `lock` is empty right now when we still have the frame.+ v <- execTryPutTMVar lock undefined+ let -- Kill the assassin throwing thread then unmask exceptions and+ -- carry on the continuation+ threadAction :: IOSim s ()+ threadAction =+ if v then unsafeUnregisterTimeout tmid+ else atomically (takeTMVar lock) >>= killThread++ thread' =+ thread { threadControl =+ ThreadControl (case threadAction of+ IOSim k' -> k' (\() -> k (Just x)))+ ctl'+ }+ schedule thread' simstate++ DelayFrame tmid k ctl' -> do+ let thread' = thread { threadControl = ThreadControl k ctl' }+ timers' = PSQ.delete tmid timers+ schedule thread' simstate { timers = timers' }++ Throw e -> case unwindControlStack e thread timers of+ -- Found a CatchFrame+ (Right thread0@Thread { threadMasking = maskst' }, timers'') -> do+ -- We found a suitable exception handler, continue with that+ -- We record a step, in case there is no exception handler on replay.+ let thread' = stepThread thread0+ control' = advanceControl (threadStepId thread0) control+ races' = updateRacesInSimState thread0 simstate+ trace <- schedule thread' simstate{ races = races',+ control = control',+ timers = timers'' }+ return (SimPORTrace time tid tstep tlbl (EventThrow e) $+ SimPORTrace time tid tstep tlbl (EventMask maskst') trace)++ (Left isMain, timers'')+ -- We unwound and did not find any suitable exception handler, so we+ -- have an unhandled exception at the top level of the thread.+ | isMain -> do+ let thread' = thread { threadStatus = ThreadDone }+ -- An unhandled exception in the main thread terminates the program+ return (SimPORTrace time tid tstep tlbl (EventThrow e) $+ SimPORTrace time tid tstep tlbl (EventThreadUnhandled e) $+ traceFinalRacesFound simstate { threads = Map.insert tid thread' threads } $+ TraceMainException time e (labelledThreads threads))++ | otherwise -> do+ -- An unhandled exception in any other thread terminates the thread+ let terminated = Terminated+ !trace <- deschedule terminated thread simstate { timers = timers'' }+ return $ SimPORTrace time tid tstep tlbl (EventThrow e)+ $ SimPORTrace time tid tstep tlbl (EventThreadUnhandled e)+ $ SimPORTrace time tid tstep tlbl (EventDeschedule terminated)+ $ trace++ Catch action' handler k -> do+ -- push the failure and success continuations onto the control stack+ let thread' = thread { threadControl = ThreadControl action'+ (CatchFrame handler k ctl)+ }+ schedule thread' simstate++ Evaluate expr k -> do+ mbWHNF <- unsafeIOToST $ try $ evaluate expr+ case mbWHNF of+ Left e -> do+ -- schedule this thread to immediately raise the exception+ let thread' = thread { threadControl = ThreadControl (Throw e) ctl }+ schedule thread' simstate+ Right whnf -> do+ -- continue with the resulting WHNF+ let thread' = thread { threadControl = ThreadControl (k whnf) ctl }+ schedule thread' simstate++ Say msg k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ trace <- schedule thread' simstate+ return (SimPORTrace time tid tstep tlbl (EventSay msg) trace)++ Output x k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ trace <- schedule thread' simstate+ return (SimPORTrace time tid tstep tlbl (EventLog x) trace)++ LiftST st k -> do+ x <- strictToLazyST st+ let thread' = thread { threadControl = ThreadControl (k x) ctl }+ schedule thread' simstate++ GetMonoTime k -> do+ let thread' = thread { threadControl = ThreadControl (k time) ctl }+ schedule thread' simstate++ GetWallTime k -> do+ let clockid = threadClockId thread+ clockoff = clocks Map.! clockid+ walltime = timeSinceEpoch time `addUTCTime` clockoff+ thread' = thread { threadControl = ThreadControl (k walltime) ctl }+ schedule thread' simstate++ SetWallTime walltime' k -> do+ let clockid = threadClockId thread+ clockoff = clocks Map.! clockid+ walltime = timeSinceEpoch time `addUTCTime` clockoff+ clockoff' = addUTCTime (diffUTCTime walltime' walltime) clockoff+ thread' = thread { threadControl = ThreadControl k ctl }+ simstate' = simstate { clocks = Map.insert clockid clockoff' clocks }+ schedule thread' simstate'++ UnshareClock k -> do+ let clockid = threadClockId thread+ clockoff = clocks Map.! clockid+ clockid' = let ThreadId i = tid in ClockId i -- reuse the thread id+ thread' = thread { threadControl = ThreadControl k ctl+ , threadClockId = clockid' }+ simstate' = simstate { clocks = Map.insert clockid' clockoff clocks }+ schedule thread' simstate'++ -- This case is guarded by checks in 'timeout' itself.+ StartTimeout d _ _ | d <= 0 ->+ error "schedule: StartTimeout: Impossible happened"++ StartTimeout d action' k -> do+ lock <- TMVar <$> execNewTVar nextVid (Just $ "lock-" ++ show nextTmid) Nothing+ let expiry = d `addTime` time+ timers' = PSQ.insert nextTmid expiry (TimerTimeout tid nextTmid lock) timers+ thread' = thread { threadControl =+ ThreadControl action'+ (TimeoutFrame nextTmid lock k ctl)+ }+ trace <- deschedule Yield thread' simstate { timers = timers'+ , nextTmid = succ nextTmid }+ return (SimPORTrace time tid tstep tlbl (EventTimeoutCreated nextTmid tid expiry) trace)++ UnregisterTimeout tmid k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ schedule thread' simstate { timers = PSQ.delete tmid timers }++ RegisterDelay d k | d < 0 -> do+ tvar <- execNewTVar nextVid+ (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ True+ modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+ let !expiry = d `addTime` time+ !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+ trace <- schedule thread' simstate { nextVid = succ nextVid }+ return (SimPORTrace time tid tstep tlbl (EventRegisterDelayCreated nextTmid nextVid expiry) $+ SimPORTrace time tid tstep tlbl (EventRegisterDelayFired nextTmid) $+ trace)++ RegisterDelay d k -> do+ tvar <- execNewTVar nextVid+ (Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")+ False+ modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+ let !expiry = d `addTime` time+ !timers' = PSQ.insert nextTmid expiry (TimerRegisterDelay tvar) timers+ !thread' = thread { threadControl = ThreadControl (k tvar) ctl }+ trace <- schedule thread' simstate { timers = timers'+ , nextVid = succ nextVid+ , nextTmid = succ nextTmid }+ return (SimPORTrace time tid tstep tlbl+ (EventRegisterDelayCreated nextTmid nextVid expiry) trace)++ ThreadDelay d k | d < 0 -> do+ let expiry = d `addTime` time+ thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) }+ simstate' = simstate { nextTmid = succ nextTmid }+ trace <- schedule thread' simstate'+ return (SimPORTrace time tid tstep tlbl (EventThreadDelay nextTmid expiry) $+ SimPORTrace time tid tstep tlbl (EventThreadDelayFired nextTmid) $+ trace)++ ThreadDelay d k -> do+ let expiry = d `addTime` time+ timers' = PSQ.insert nextTmid expiry (TimerThreadDelay tid nextTmid) timers+ thread' = thread { threadControl = ThreadControl (Return ()) (DelayFrame nextTmid k ctl) }+ trace <- deschedule (Blocked BlockedOnOther) thread'+ simstate { timers = timers',+ nextTmid = succ nextTmid }+ return (SimPORTrace time tid tstep tlbl (EventThreadDelay nextTmid expiry) trace)++ -- we treat negative timers as cancelled ones; for the record we put+ -- `EventTimerCreated` and `EventTimerCancelled` in the trace; This differs+ -- from `GHC.Event` behaviour.+ NewTimeout d k | d < 0 -> do+ let t = NegativeTimeout nextTmid+ expiry = d `addTime` time+ thread' = thread { threadControl = ThreadControl (k t) ctl }+ trace <- schedule thread' simstate { nextTmid = succ nextTmid }+ return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid nextVid expiry) $+ SimPORTrace time tid tstep tlbl (EventTimerCancelled nextTmid) $+ trace)++ NewTimeout d k -> do+ tvar <- execNewTVar nextVid+ (Just $ "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")+ TimeoutPending+ modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+ let expiry = d `addTime` time+ t = Timeout tvar nextTmid+ timers' = PSQ.insert nextTmid expiry (Timer tvar) timers+ thread' = thread { threadControl = ThreadControl (k t) ctl }+ trace <- schedule thread' simstate { timers = timers'+ , nextVid = succ (succ nextVid)+ , nextTmid = succ nextTmid }+ return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid nextVid expiry) trace)++ CancelTimeout (Timeout tvar tmid) k -> do+ let timers' = PSQ.delete tmid timers+ written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)+ (wakeup, wokeby) <- threadsUnblockedByWrites written+ mapM_ (\(SomeTVar var) -> unblockAllThreadsFromTVar var) written+ let effect' = effect+ <> writeEffects written+ <> wakeupEffects wakeup+ thread' = thread { threadControl = ThreadControl k ctl+ , threadEffect = effect'+ }+ (unblocked,+ simstate') = unblockThreads False vClock wakeup simstate+ modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)+ !trace <- deschedule Yield thread' simstate' { timers = timers' }+ return $ SimPORTrace time tid tstep tlbl (EventTimerCancelled tmid)+ $ traceMany+ -- TODO: step+ [ (time, tid', (-1), tlbl', EventTxWakeup vids)+ | tid' <- unblocked+ , let tlbl' = lookupThreadLabel tid' threads+ , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]+ $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)+ $ trace++ -- cancelling a negative timer is a no-op+ CancelTimeout (NegativeTimeout _tmid) k -> do+ -- negative timers are promptly removed from the state+ let thread' = thread { threadControl = ThreadControl k ctl }+ schedule thread' simstate++ Fork a k -> do+ let nextTId = threadNextTId thread+ tid' | threadRacy thread = setRacyThread $ childThreadId tid nextTId+ | otherwise = childThreadId tid nextTId+ thread' = thread { threadControl = ThreadControl (k tid') ctl,+ threadNextTId = nextTId + 1,+ threadEffect = effect+ <> forkEffect tid'+ }+ thread'' = Thread { threadId = tid'+ , threadControl = ThreadControl (runIOSim a)+ ForkFrame+ , threadStatus = ThreadRunning + , threadMasking = threadMasking thread+ , threadThrowTo = []+ , threadClockId = threadClockId thread+ , threadLabel = Nothing+ , threadNextTId = 1+ , threadStep = 0+ , threadVClock = insertVClock tid' 0+ $ vClock+ , threadEffect = mempty+ , threadRacy = threadRacy thread+ }+ threads' = Map.insert tid' thread'' threads+ -- A newly forked thread may have a higher priority, so we deschedule this one.+ !trace <- deschedule Yield thread'+ simstate { runqueue = insertThread thread'' runqueue+ , threads = threads' }+ return $ SimPORTrace time tid tstep tlbl (EventThreadForked tid')+ $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)+ $ trace++ Atomically a k -> execAtomically time tid tlbl nextVid (runSTM a) $ \res ->+ case res of+ StmTxCommitted x written read created+ tvarDynamicTraces tvarStringTraces nextVid' -> do+ (wakeup, wokeby) <- threadsUnblockedByWrites written+ mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written+ vClockRead <- leastUpperBoundTVarVClocks read+ let vClock' = vClock `leastUpperBoundVClock` vClockRead+ effect' = effect+ <> readEffects read+ <> writeEffects written+ <> wakeupEffects unblocked+ thread' = thread { threadControl = ThreadControl (k x) ctl,+ threadVClock = vClock',+ threadEffect = effect' }+ (unblocked,+ simstate') = unblockThreads True vClock' wakeup simstate+ sequence_ [ modifySTRef (tvarVClock r) (leastUpperBoundVClock vClock')+ | SomeTVar r <- created ++ written ]+ written' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written+ created' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) created+ -- We deschedule a thread after a transaction... another may have woken up.+ !trace <- deschedule Yield thread' simstate' { nextVid = nextVid' }+ return $+ SimPORTrace time tid tstep tlbl (EventTxCommitted written' created' (Just effect')) $+ traceMany+ [ (time, tid', tstep, tlbl', EventTxWakeup vids')+ | tid' <- unblocked+ , let tlbl' = lookupThreadLabel tid' threads+ , let Just vids' = Set.toList <$> Map.lookup tid' wokeby ] $+ traceMany+ [ (time, tid, tstep, tlbl, EventLog tr)+ | tr <- tvarDynamicTraces+ ] $+ traceMany+ [ (time, tid, tstep, tlbl, EventSay str)+ | str <- tvarStringTraces+ ] $+ SimPORTrace time tid tstep tlbl (EventUnblocked unblocked) $+ SimPORTrace time tid tstep tlbl (EventDeschedule Yield) $+ trace++ StmTxAborted read e -> do+ -- schedule this thread to immediately raise the exception+ vClockRead <- leastUpperBoundTVarVClocks read+ let effect' = effect <> readEffects read+ thread' = thread { threadControl = ThreadControl (Throw e) ctl,+ threadVClock = vClock `leastUpperBoundVClock` vClockRead,+ threadEffect = effect' }+ trace <- schedule thread' simstate+ return $ SimPORTrace time tid tstep tlbl (EventTxAborted (Just effect'))+ $ trace++ StmTxBlocked read -> do+ mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read+ vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read+ vClockRead <- leastUpperBoundTVarVClocks read+ let effect' = effect <> readEffects read+ thread' = thread { threadVClock = vClock `leastUpperBoundVClock` vClockRead,+ threadEffect = effect' }+ !trace <- deschedule (Blocked BlockedOnSTM) thread' simstate+ return $ SimPORTrace time tid tstep tlbl (EventTxBlocked vids (Just effect'))+ $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnSTM))+ $ trace++ GetThreadId k -> do+ let thread' = thread { threadControl = ThreadControl (k tid) ctl }+ schedule thread' simstate++ LabelThread tid' l k | tid' == tid -> do+ let thread' = thread { threadControl = ThreadControl k ctl+ , threadLabel = Just l }+ schedule thread' simstate++ LabelThread tid' l k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads+ schedule thread' simstate { threads = threads' }++ ExploreRaces k -> do+ let thread' = thread { threadControl = ThreadControl k ctl+ , threadRacy = True }+ schedule thread' simstate++ Fix f k -> do+ r <- newSTRef (throw NonTermination)+ x <- unsafeInterleaveST $ readSTRef r+ let k' = unIOSim (f x) $ \x' ->+ LiftST (lazyToStrictST (writeSTRef r x')) (\() -> k x')+ thread' = thread { threadControl = ThreadControl k' ctl }+ schedule thread' simstate++ GetMaskState k -> do+ let thread' = thread { threadControl = ThreadControl (k maskst) ctl }+ schedule thread' simstate++ SetMaskState maskst' action' k -> do+ let thread' = thread { threadControl = ThreadControl+ (runIOSim action')+ (MaskFrame k maskst ctl)+ , threadMasking = maskst' }+ trace <-+ case maskst' of+ -- If we're now unmasked then check for any pending async exceptions+ Unmasked -> SimPORTrace time tid tstep tlbl (EventDeschedule Interruptable)+ <$> deschedule Interruptable thread' simstate+ _ -> schedule thread' simstate+ return $ SimPORTrace time tid tstep tlbl (EventMask maskst')+ $ trace++ ThrowTo e tid' _ | tid' == tid -> do+ -- Throw to ourself is equivalent to a synchronous throw,+ -- and works irrespective of masking state since it does not block.+ let thread' = thread { threadControl = ThreadControl (Throw e) ctl+ , threadEffect = effect+ }+ trace <- schedule thread' simstate+ return (SimPORTrace time tid tstep tlbl (EventThrowTo e tid) trace)++ ThrowTo e tid' k -> do+ let thread' = thread { threadControl = ThreadControl k ctl,+ threadEffect = effect <> throwToEffect tid'+ <> wakeUpEffect,+ threadVClock = vClock `leastUpperBoundVClock` vClockTgt+ }+ (vClockTgt,+ wakeUpEffect,+ willBlock) = (threadVClock t,+ if isThreadBlocked t then wakeupEffects [tid'] else mempty,+ not (threadInterruptible t || isThreadDone t))+ where Just t = Map.lookup tid' threads++ if willBlock+ then do+ -- The target thread has async exceptions masked so we add the+ -- exception and the source thread id to the pending async exceptions.+ let adjustTarget t =+ t { threadThrowTo = (e, Labelled tid tlbl, vClock) : threadThrowTo t }+ threads' = Map.adjust adjustTarget tid' threads+ trace <- deschedule (Blocked BlockedOnOther) thread' simstate { threads = threads' }+ return $ SimPORTrace time tid tstep tlbl (EventThrowTo e tid')+ $ SimPORTrace time tid tstep tlbl EventThrowToBlocked+ $ SimPORTrace time tid tstep tlbl (EventDeschedule (Blocked BlockedOnOther))+ $ trace+ else do+ -- The target thread has async exceptions unmasked, or is masked but+ -- is blocked (and all blocking operations are interruptible) then we+ -- raise the exception in that thread immediately. This will either+ -- cause it to terminate or enter an exception handler.+ -- In the meantime the thread masks new async exceptions. This will+ -- be resolved if the thread terminates or if it leaves the exception+ -- handler (when restoring the masking state would trigger the any+ -- new pending async exception).+ let adjustTarget t@Thread{ threadControl = ThreadControl _ ctl',+ threadVClock = vClock' } =+ t { threadControl = ThreadControl (Throw e) ctl'+ , threadStatus = if isThreadDone t+ then threadStatus t+ else ThreadRunning+ , threadVClock = vClock' `leastUpperBoundVClock` vClock }+ (_unblocked, simstate'@SimState { threads = threads' }) = unblockThreads False vClock [tid'] simstate+ threads'' = Map.adjust adjustTarget tid' threads'+ simstate'' = simstate' { threads = threads'' }++ -- We yield at this point because the target thread may be higher+ -- priority, so this should be a step for race detection.+ trace <- deschedule Yield thread' simstate''+ return $ SimPORTrace time tid tstep tlbl (EventThrowTo e tid')+ $ trace++ -- intentionally a no-op (at least for now)+ YieldSim k -> do+ let thread' = thread { threadControl = ThreadControl k ctl }+ schedule thread' simstate+++threadInterruptible :: Thread s a -> Bool+threadInterruptible thread =+ case threadMasking thread of+ Unmasked -> True+ MaskedInterruptible+ | isThreadBlocked thread -> True -- blocking operations are interruptible+ | otherwise -> False+ MaskedUninterruptible -> False++deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)++deschedule Yield thread@Thread { threadId = tid }+ simstate@SimState{runqueue, threads, control} =++ -- We don't interrupt runnable threads anywhere else.+ -- We do it here by inserting the current thread into the runqueue in priority order.++ let thread' = stepThread thread+ runqueue' = insertThread thread' runqueue+ threads' = Map.insert tid thread' threads+ control' = advanceControl (threadStepId thread) control in+ reschedule simstate { runqueue = runqueue',+ threads = threads',+ races = updateRacesInSimState thread simstate,+ control = control' }++deschedule Interruptable thread@Thread {+ threadId = tid,+ threadStep = tstep,+ threadControl = ThreadControl _ ctl,+ threadMasking = Unmasked,+ threadThrowTo = (e, tid', vClock') : etids,+ threadLabel = tlbl,+ threadVClock = vClock,+ threadEffect = effect+ }+ simstate@SimState{ curTime = time, threads } = do++ -- We're unmasking, but there are pending blocked async exceptions.+ -- So immediately raise the exception and unblock the blocked thread+ -- if possible.+ let thread' = thread { threadControl = ThreadControl (Throw e) ctl+ , threadMasking = MaskedInterruptible+ , threadThrowTo = etids+ , threadVClock = vClock `leastUpperBoundVClock` vClock'+ }+ (unblocked,+ simstate') = unblockThreads False vClock [l_labelled tid'] simstate+ -- the thread is stepped when we Yield+ !trace <- deschedule Yield thread' simstate'+ return $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield)+ $ SimPORTrace time tid tstep tlbl (EventThrowToUnmasked tid')+ -- TODO: step+ $ traceMany [ (time, tid'', (-1), tlbl'', EventThrowToWakeup)+ | tid'' <- unblocked+ , let tlbl'' = lookupThreadLabel tid'' threads ]+ trace++deschedule Interruptable thread@Thread{threadId = tid } simstate@SimState{ control } =+ -- Either masked or unmasked but no pending async exceptions.+ -- Either way, just carry on.+ -- Record a step, though, in case on replay there is an async exception.+ let thread' = stepThread thread in+ schedule thread'+ simstate{ races = updateRacesInSimState thread simstate,+ control = advanceControl (threadStepId thread) control }++deschedule (Blocked _blockedReason) thread@Thread { threadId = tid+ , threadThrowTo = _ : _+ , threadMasking = maskst+ , threadEffect = effect } simstate+ | maskst /= MaskedUninterruptible =+ -- We're doing a blocking operation, which is an interrupt point even if+ -- we have async exceptions masked, and there are pending blocked async+ -- exceptions. So immediately raise the exception and unblock the blocked+ -- thread if possible.+ deschedule Interruptable thread { threadMasking = Unmasked } simstate++deschedule (Blocked blockedReason) thread@Thread{ threadId = tid, threadEffect = effect } simstate@SimState{threads, control} =+ let thread1 = thread { threadStatus = ThreadBlocked blockedReason }+ thread' = stepThread thread1+ threads' = Map.insert (threadId thread') thread' threads in+ reschedule simstate { threads = threads',+ races = updateRacesInSimState thread1 simstate,+ control = advanceControl (threadStepId thread1) control }++deschedule Terminated thread@Thread { threadId = tid, threadVClock = vClock, threadEffect = effect }+ simstate@SimState{ curTime = time, control } = do+ -- This thread is done. If there are other threads blocked in a+ -- ThrowTo targeted at this thread then we can wake them up now.+ let thread1 = thread+ thread' = stepThread $ thread { threadStatus = ThreadDone }+ wakeup = map (\(_,tid',_) -> l_labelled tid') (reverse (threadThrowTo thread))+ (unblocked,+ simstate'@SimState{threads}) =+ unblockThreads False vClock wakeup simstate+ threads' = Map.insert tid thread' threads+ -- We must keep terminated threads in the state to preserve their vector clocks,+ -- which matters when other threads throwTo them.+ !trace <- reschedule simstate' { races = threadTerminatesRaces tid $+ updateRacesInSimState thread1 simstate,+ control = advanceControl (threadStepId thread) control,+ threads = threads' }+ return $ traceMany+ -- TODO: step+ [ (time, tid', (-1), tlbl', EventThrowToWakeup)+ | tid' <- unblocked+ , let tlbl' = lookupThreadLabel tid' threads ]+ trace++deschedule Sleep thread@Thread { threadId = tid , threadEffect = effect }+ simstate@SimState{runqueue, threads} =++ -- Schedule control says we should run a different thread. Put+ -- this one to sleep without recording a step.++ let runqueue' = insertThread thread runqueue+ threads' = Map.insert tid thread threads in+ reschedule simstate { runqueue = runqueue', threads = threads' }+++-- Choose the next thread to run.+reschedule :: SimState s a -> ST s (SimTrace a)++-- If we are following a controlled schedule, just do that.+reschedule simstate@SimState{ runqueue, threads,+ control=control@(ControlFollow ((tid,tstep):_) _),+ curTime=time+ } =+ fmap (SimPORTrace time tid tstep Nothing (EventReschedule control)) $+ assert (Down tid `PSQ.member` runqueue) $+ assert (tid `Map.member` threads) $+ invariant Nothing simstate $+ let thread = threads Map.! tid in+ assert (threadId thread == tid) $+ --assert (threadStep thread == tstep) $+ if threadStep thread /= tstep then+ error $ "Thread step out of sync\n"+ ++ " runqueue: "++show runqueue++"\n"+ ++ " follows: "++show tid++", step "++show tstep++"\n"+ ++ " actual step: "++show (threadStep thread)++"\n"+ ++ "Thread:\n" ++ show thread ++ "\n"+ else+ schedule thread simstate { runqueue = PSQ.delete (Down tid) runqueue+ , threads = Map.delete tid threads }++-- When there is no current running thread but the runqueue is non-empty then+-- schedule the next one to run.+reschedule simstate@SimState{ runqueue, threads }+ | Just (Down !tid, _, _, runqueue') <- PSQ.minView runqueue =+ invariant Nothing simstate $++ let thread = threads Map.! tid in+ schedule thread simstate { runqueue = runqueue'+ , threads = Map.delete tid threads }++-- But when there are no runnable threads, we advance the time to the next+-- timer event, or stop.+reschedule simstate@SimState{ threads, timers, curTime = time, races } =+ invariant Nothing simstate $++ -- time is moving on+ --Debug.trace ("Rescheduling at "++show time++", "+++ --show (length (concatMap stepInfoRaces (activeRaces races++completeRaces races)))++" races") $++ -- important to get all events that expire at this time+ case removeMinimums timers of+ Nothing -> return (traceFinalRacesFound simstate $+ TraceDeadlock time (labelledThreads threads))++ Just (tmids, time', fired, timers') -> assert (time' >= time) $ do++ -- Reuse the STM functionality here to write all the timer TVars.+ -- Simplify to a special case that only reads and writes TVars.+ written <- execAtomically' (runSTM $ mapM_ timeoutAction fired)+ (wakeupSTM, wokeby) <- threadsUnblockedByWrites written+ mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written++ let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ]+ wakeup = fst `fmap` wakeupThreadDelay ++ wakeupSTM+ -- TODO: the vector clock below cannot be right, can it?+ (_, !simstate') = unblockThreads False bottomVClock wakeup simstate++ -- For each 'timeout' action where the timeout has fired, start a+ -- new thread to execute throwTo to interrupt the action.+ !timeoutExpired = [ (tid, tmid, lock)+ | TimerTimeout tid tmid lock <- fired ]++ -- all open races will be completed and reported at this time+ !simstate'' <- forkTimeoutInterruptThreads timeoutExpired+ simstate' { races = noRaces }+ !trace <- reschedule simstate'' { curTime = time'+ , timers = timers' }+ let traceEntries =+ [ ( time', ThreadId [-1], -1, Just "timer"+ , EventTimerFired tmid)+ | (tmid, Timer _) <- zip tmids fired ]+ ++ [ ( time', ThreadId [-1], -1, Just "register delay timer"+ , EventRegisterDelayFired tmid)+ | (tmid, TimerRegisterDelay _) <- zip tmids fired ]+ ++ [ (time', tid', -1, tlbl', EventTxWakeup vids)+ | tid' <- wakeupSTM+ , let tlbl' = lookupThreadLabel tid' threads+ , let Just vids = Set.toList <$> Map.lookup tid' wokeby ]+ ++ [ ( time', tid, -1, Just "thread delay timer"+ , EventThreadDelayFired tmid)+ | (tid, tmid) <- wakeupThreadDelay ]+ ++ [ ( time', tid, -1, Just "timeout timer"+ , EventTimeoutFired tmid)+ | (tid, tmid, _) <- timeoutExpired ]+ ++ [ ( time', tid, -1, Just "forked thread"+ , EventThreadForked tid)+ | (tid, _, _) <- timeoutExpired ]++ return $+ traceFinalRacesFound simstate $+ traceMany traceEntries trace+ where+ timeoutAction (Timer var) = do+ x <- readTVar var+ case x of+ TimeoutPending -> writeTVar var TimeoutFired+ TimeoutFired -> error "MonadTimer(Sim): invariant violation"+ TimeoutCancelled -> return ()+ timeoutAction (TimerRegisterDelay var) = writeTVar var True+ timeoutAction (TimerThreadDelay _ _) = return ()+ timeoutAction (TimerTimeout _ _ _) = return ()++unblockThreads :: forall s a.+ Bool -- ^ `True` if we are blocked on STM+ -> VectorClock+ -> [ThreadId]+ -> SimState s a+ -> ([ThreadId], SimState s a)+unblockThreads !onlySTM vClock wakeup simstate@SimState {runqueue, threads} =+ -- To preserve our invariants (that threadBlocked is correct)+ -- we update the runqueue and threads together here+ ( unblockedIds+ , simstate { runqueue = foldr insertThread runqueue unblocked,+ threads = threads'+ })+ where+ -- can only unblock if the thread exists and is blocked (not running)+ unblocked :: [Thread s a]+ !unblocked = [ thread+ | tid <- wakeup+ , thread <-+ case Map.lookup tid threads of+ Just Thread { threadStatus = ThreadRunning }+ -> [ ]+ Just t@Thread { threadStatus = ThreadBlocked BlockedOnOther }+ | onlySTM+ -> [ ]+ | otherwise+ -> [t]+ Just t@Thread { threadStatus = ThreadBlocked BlockedOnSTM }+ -> [t]+ _ -> [ ]+ ]++ unblockedIds :: [ThreadId]+ !unblockedIds = map threadId unblocked++ -- and in which case we mark them as now running+ !threads' = List.foldl'+ (flip (Map.adjust+ (\t -> t { threadStatus = ThreadRunning,+ threadVClock = vClock `leastUpperBoundVClock` threadVClock t })))+ threads unblockedIds++-- | This function receives a list of TimerTimeout values that represent threads+-- for which the timeout expired and kills the running thread if needed.+--+-- This function is responsible for the second part of the race condition issue+-- and relates to the 'schedule's 'TimeoutFrame' locking explanation (here is+-- where the assassin threads are launched. So, as explained previously, at this+-- point in code, the timeout expired so we need to interrupt the running+-- thread. If the running thread finished at the same time the timeout expired+-- we have a race condition. To deal with this race condition what we do is+-- look at the lock value. If it is 'Locked' this means that the running thread+-- already finished (or won the race) so we can safely do nothing. Otherwise, if+-- the lock value is 'NotLocked' we need to acquire the lock and launch an+-- assassin thread that is going to interrupt the running one. Note that we+-- should run this interrupting thread in an unmasked state since it might+-- receive a 'ThreadKilled' exception.+--+forkTimeoutInterruptThreads :: forall s a.+ [(ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)]+ -> SimState s a+ -> ST s (SimState s a)+forkTimeoutInterruptThreads timeoutExpired simState =+ foldlM (\st@SimState{ runqueue, threads }+ (t, TMVar lock)+ -> do+ v <- execReadTVar lock+ return $ case v of+ Nothing -> st { runqueue = insertThread t runqueue,+ threads = Map.insert (threadId t) t threads+ }+ Just _ -> st+ )+ simState'+ throwToThread++ where+ -- we launch a thread responsible for throwing an AsyncCancelled exception+ -- to the thread which timeout expired+ throwToThread :: [(Thread s a, TMVar (IOSim s) ThreadId)] ++ (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired+ where+ fn :: SimState s a+ -> (ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)+ -> (SimState s a, (Thread s a, TMVar (IOSim s) ThreadId))+ fn state@SimState { threads } (tid, tmid, lock) =+ let t = case tid `Map.lookup` threads of+ Just t' -> t'+ Nothing -> error ("IOSimPOR: internal error: unknown thread " ++ show tid)+ nextId = threadNextTId t+ tid' = childThreadId tid nextId+ in ( state { threads = Map.insert tid t { threadNextTId = succ nextId } threads }+ , ( Thread { threadId = tid',+ threadControl =+ ThreadControl+ (runIOSim $ do+ mtid <- myThreadId+ v2 <- atomically $ tryPutTMVar lock mtid+ when v2 $+ throwTo tid (toException (TimeoutException tmid)))+ ForkFrame,+ threadStatus = ThreadRunning,+ threadMasking = Unmasked,+ threadThrowTo = [],+ threadClockId = threadClockId t,+ threadLabel = Just "timeout-forked-thread",+ threadNextTId = 1,+ threadStep = 0,+ threadVClock = insertVClock tid' 0+ $ threadVClock t,+ threadEffect = mempty,+ threadRacy = threadRacy t+ }+ , lock+ )+ )+ ++-- | Iterate through the control stack to find an enclosing exception handler+-- of the right type, or unwind all the way to the top level for the thread.+--+-- Also return if it's the main thread or a forked thread since we handle the+-- cases differently.+--+unwindControlStack :: forall s a.+ SomeException+ -> Thread s a+ -> Timeouts s+ -> ( Either Bool (Thread s a)+ , Timeouts s+ )+unwindControlStack e thread = \timeouts ->+ case threadControl thread of+ ThreadControl _ ctl -> unwind (threadMasking thread) ctl timeouts+ where+ unwind :: forall s' c. MaskingState+ -> ControlStack s' c a+ -> Timeouts s+ -> (Either Bool (Thread s' a), Timeouts s)+ unwind _ MainFrame timers = (Left True, timers)+ unwind _ ForkFrame timers = (Left False, timers)+ unwind _ (MaskFrame _k maskst' ctl) timers = unwind maskst' ctl timers++ unwind maskst (CatchFrame handler k ctl) timers =+ case fromException e of+ -- not the right type, unwind to the next containing handler+ Nothing -> unwind maskst ctl timers++ -- Ok! We will be able to continue the thread with the handler+ -- followed by the continuation after the catch+ Just e' -> ( Right thread {+ -- As per async exception rules, the handler is run+ -- masked+ threadControl = ThreadControl (handler e')+ (MaskFrame k maskst ctl),+ threadMasking = atLeastInterruptibleMask maskst+ }+ , timers+ )++ -- Either Timeout fired or the action threw an exception.+ -- - If Timeout fired, then it was possibly during this thread's execution+ -- so we need to run the continuation with a Nothing value.+ -- - If the timeout action threw an exception we need to keep unwinding the+ -- control stack looking for a handler to this exception.+ unwind maskst (TimeoutFrame tmid isLockedRef k ctl) timers =+ case fromException e of+ -- Exception came from timeout expiring+ Just (TimeoutException tmid') | tmid == tmid' ->+ (Right thread { threadControl = ThreadControl (k Nothing) ctl }, timers')+ -- Exception came from a different exception+ _ -> unwind maskst ctl timers'+ where+ -- Remove the timeout associated with the 'TimeoutFrame'.+ timers' = PSQ.delete tmid timers++ unwind maskst (DelayFrame tmid _k ctl) timers =+ unwind maskst ctl timers'+ where+ -- Remove the timeout associated with the 'DelayFrame'.+ timers' = PSQ.delete tmid timers++ atLeastInterruptibleMask :: MaskingState -> MaskingState+ atLeastInterruptibleMask Unmasked = MaskedInterruptible+ atLeastInterruptibleMask ms = ms+++removeMinimums :: (Ord k, Ord p)+ => OrdPSQ k p a+ -> Maybe ([k], p, [a], OrdPSQ k p a)+removeMinimums = \psq ->+ case PSQ.minView psq of+ Nothing -> Nothing+ Just (k, p, x, psq') -> Just (collectAll [k] p [x] psq')+ where+ collectAll ks p xs psq =+ case PSQ.minView psq of+ Just (k, p', x, psq')+ | p == p' -> collectAll (k:ks) p (x:xs) psq'+ _ -> (reverse ks, p, reverse xs, psq)++traceMany :: [(Time, ThreadId, Int, Maybe ThreadLabel, SimEventType)]+ -> SimTrace a -> SimTrace a+traceMany [] trace = trace+traceMany ((time, tid, tstep, tlbl, event):ts) trace =+ SimPORTrace time tid tstep tlbl event (traceMany ts trace)++lookupThreadLabel :: ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel+lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads)+++-- | The most general method of running 'IOSim' is in 'ST' monad. One can+-- recover failures or the result from 'SimTrace' with 'traceResult', or access+-- 'TraceEvent's generated by the computation with 'traceEvents'. A slightly+-- more convenient way is exposed by 'runSimTrace'.+--+runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a)+runSimTraceST mainAction = controlSimTraceST Nothing ControlDefault mainAction++controlSimTraceST :: Maybe Int -> ScheduleControl -> IOSim s a -> ST s (SimTrace a)+controlSimTraceST limit control mainAction =+ SimPORTrace (curTime initialState)+ (threadId mainThread)+ 0+ (threadLabel mainThread)+ (EventSimStart control)+ <$> schedule mainThread initialState { control = control,+ control0 = control,+ perStepTimeLimit = limit+ }+ where+ mainThread =+ Thread {+ threadId = ThreadId [],+ threadControl = ThreadControl (runIOSim mainAction) MainFrame,+ threadStatus = ThreadRunning,+ threadMasking = Unmasked,+ threadThrowTo = [],+ threadClockId = ClockId [],+ threadLabel = Just "main",+ threadNextTId = 1,+ threadStep = 0,+ threadVClock = insertVClock (ThreadId []) 0 bottomVClock,+ threadEffect = mempty,+ threadRacy = False+ }+++--+-- Executing STM Transactions+--++execAtomically :: forall s a c.+ Time+ -> ThreadId+ -> Maybe ThreadLabel+ -> TVarId+ -> StmA s a+ -> (StmTxResult s a -> ST s (SimTrace c))+ -> ST s (SimTrace c)+execAtomically time tid tlbl nextVid0 action0 k0 =+ go AtomicallyFrame Map.empty Map.empty [] [] nextVid0 action0+ where+ go :: forall b.+ StmStack s b a+ -> Map TVarId (SomeTVar s) -- set of vars read+ -> Map TVarId (SomeTVar s) -- set of vars written+ -> [SomeTVar s] -- vars written in order (no dups)+ -> [SomeTVar s] -- vars created in order+ -> TVarId -- var fresh name supply+ -> StmA s b+ -> ST s (SimTrace c)+ go !ctl !read !written !writtenSeq !createdSeq !nextVid action = assert localInvariant $+ case action of+ ReturnStm x ->+ {-# SCC "execAtomically.go.ReturnStm" #-}+ case ctl of+ AtomicallyFrame -> do+ -- Trace each created TVar+ !ds <- traverse (\(SomeTVar tvar) -> traceTVarST tvar True) createdSeq+ -- Trace & commit each TVar+ !ds' <- Map.elems <$> traverse+ (\(SomeTVar tvar) -> do+ tr <- traceTVarST tvar False+ !_ <- commitTVar tvar+ -- Also assert the data invariant that outside a tx+ -- the undo stack is empty:+ undos <- readTVarUndos tvar+ assert (null undos) $ return tr+ ) written++ -- Return the vars written, so readers can be unblocked+ k0 $ StmTxCommitted x (reverse writtenSeq)+ (Map.elems read)+ (reverse createdSeq)+ (mapMaybe (\TraceValue { traceDynamic }+ -> toDyn <$> traceDynamic)+ $ ds ++ ds')+ (mapMaybe traceString $ ds ++ ds')+ nextVid++ BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do+ -- The branch has successfully completed the transaction. Hence,+ -- the alternative branch can be ignored.+ -- Commit the TVars written in this sub-transaction that are also+ -- in the written set of the outer transaction+ !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)+ (Map.intersection written writtenOuter)+ -- Merge the written set of the inner with the outer+ let written' = Map.union written writtenOuter+ writtenSeq' = filter (\(SomeTVar tvar) ->+ tvarId tvar `Map.notMember` writtenOuter)+ writtenSeq+ ++ writtenOuterSeq+ createdSeq' = createdSeq ++ createdOuterSeq+ -- Skip the orElse right hand and continue with the k continuation+ go ctl' read written' writtenSeq' createdSeq' nextVid (k x)++ ThrowStm e ->+ {-# SCC "execAtomically.go.ThrowStm" #-} do+ -- Revert all the TVar writes+ !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written+ case ctl of+ AtomicallyFrame -> do+ k0 $ StmTxAborted (Map.elems read) (toException e)++ BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ -- Execute the left side in a new frame with an empty written set.+ -- but preserve ones that were set prior to it, as specified in the+ -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.+ let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'+ go ctl'' read Map.empty [] [] nextVid (h e)++ BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)++ BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)++ CatchStm a h k ->+ {-# SCC "execAtomically.go.ThrowStm" #-} do+ -- Execute the left side in a new frame with an empty written set+ let ctl' = BranchFrame (CatchStmA h) k written writtenSeq createdSeq ctl+ go ctl' read Map.empty [] [] nextVid a++ Retry ->+ {-# SCC "execAtomically.go.Retry" #-} do+ -- Always revert all the TVar writes for the retry+ !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written+ case ctl of+ AtomicallyFrame -> do+ -- Return vars read, so the thread can block on them+ k0 $! StmTxBlocked $! Map.elems read++ BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame.OrElseStmA" #-} do+ -- Execute the orElse right hand with an empty written set+ let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'+ go ctl'' read Map.empty [] [] nextVid b++ BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->+ {-# SCC "execAtomically.go.BranchFrame" #-} do+ -- Retry makes sense only within a OrElse context. If it is a branch other than+ -- OrElse left side, then bubble up the `retry` to the frame above.+ -- Skip the continuation and propagate the retry into the outer frame+ -- using the written set for the outer frame+ go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry++ OrElse a b k ->+ {-# SCC "execAtomically.go.OrElse" #-} do+ -- Execute the left side in a new frame with an empty written set+ let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl+ go ctl' read Map.empty [] [] nextVid a++ NewTVar !mbLabel x k ->+ {-# SCC "execAtomically.go.NewTVar" #-} do+ !v <- execNewTVar nextVid mbLabel x+ -- record a write to the TVar so we know to update its VClock+ let written' = Map.insert (tvarId v) (SomeTVar v) written+ -- save the value: it will be committed or reverted+ !_ <- saveTVar v+ go ctl read written' writtenSeq (SomeTVar v : createdSeq) (succ nextVid) (k v)++ LabelTVar !label tvar k ->+ {-# SCC "execAtomically.go.LabelTVar" #-} do+ !_ <- writeSTRef (tvarLabel tvar) $! (Just label)+ go ctl read written writtenSeq createdSeq nextVid k++ TraceTVar tvar f k ->+ {-# SCC "execAtomically.go.TraceTVar" #-} do+ !_ <- writeSTRef (tvarTrace tvar) (Just f)+ go ctl read written writtenSeq createdSeq nextVid k++ ReadTVar v k+ | tvarId v `Map.member` read ->+ {-# SCC "execAtomically.go.ReadTVar" #-} do+ x <- execReadTVar v+ go ctl read written writtenSeq createdSeq nextVid (k x)+ | otherwise ->+ {-# SCC "execAtomically.go.ReadTVar" #-} do+ x <- execReadTVar v+ let read' = Map.insert (tvarId v) (SomeTVar v) read+ go ctl read' written writtenSeq createdSeq nextVid (k x)++ WriteTVar v x k+ | tvarId v `Map.member` written ->+ {-# SCC "execAtomically.go.WriteTVar" #-} do+ !_ <- execWriteTVar v x+ go ctl read written writtenSeq createdSeq nextVid k+ | otherwise ->+ {-# SCC "execAtomically.go.WriteTVar" #-} do+ !_ <- saveTVar v+ !_ <- execWriteTVar v x+ let written' = Map.insert (tvarId v) (SomeTVar v) written+ go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k++ SayStm msg k ->+ {-# SCC "execAtomically.go.SayStm" #-} do+ trace <- go ctl read written writtenSeq createdSeq nextVid k+ -- TODO: step+ return $ SimPORTrace time tid (-1) tlbl (EventSay msg) trace++ OutputStm x k ->+ {-# SCC "execAtomically.go.OutputStm" #-} do+ trace <- go ctl read written writtenSeq createdSeq nextVid k+ -- TODO: step+ return $ SimPORTrace time tid (-1) tlbl (EventLog x) trace++ LiftSTStm st k ->+ {-# SCC "schedule.LiftSTStm" #-} do+ x <- strictToLazyST st+ go ctl read written writtenSeq createdSeq nextVid (k x)++ FixStm f k ->+ {-# SCC "execAtomically.go.FixStm" #-} do+ r <- newSTRef (throw NonTermination)+ x <- unsafeInterleaveST $ readSTRef r+ let k' = unSTM (f x) $ \x' ->+ LiftSTStm (lazyToStrictST (writeSTRef r x')) (\() -> k x')+ go ctl read written writtenSeq createdSeq nextVid k'++ where+ localInvariant =+ Map.keysSet written+ == Set.fromList ([ tvarId tvar | SomeTVar tvar <- writtenSeq ]+ ++ [ tvarId tvar | SomeTVar tvar <- createdSeq ])+++-- | Special case of 'execAtomically' supporting only var reads and writes+--+execAtomically' :: StmA s () -> ST s [SomeTVar s]+execAtomically' = go Map.empty+ where+ go :: Map TVarId (SomeTVar s) -- set of vars written+ -> StmA s ()+ -> ST s [SomeTVar s]+ go !written action = case action of+ ReturnStm () -> do+ !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar) written+ return (Map.elems written)+ ReadTVar v k -> do+ x <- execReadTVar v+ go written (k x)+ WriteTVar v x k+ | tvarId v `Map.member` written -> do+ !_ <- execWriteTVar v x+ go written k+ | otherwise -> do+ !_ <- saveTVar v+ !_ <- execWriteTVar v x+ let written' = Map.insert (tvarId v) (SomeTVar v) written+ go written' k+ _ -> error "execAtomically': only for special case of reads and writes"+++execNewTVar :: TVarId -> Maybe String -> a -> ST s (TVar s a)+execNewTVar nextVid !mbLabel x = do+ tvarLabel <- newSTRef mbLabel+ tvarCurrent <- newSTRef x+ tvarUndo <- newSTRef []+ tvarBlocked <- newSTRef ([], Set.empty)+ tvarVClock <- newSTRef bottomVClock+ tvarTrace <- newSTRef Nothing+ return TVar {tvarId = nextVid, tvarLabel,+ tvarCurrent, tvarUndo, tvarBlocked, tvarVClock,+ tvarTrace}++-- 'execReadTVar' is defined in `Control.Monad.IOSim.Type` and shared with /IOSim/++execWriteTVar :: TVar s a -> a -> ST s ()+execWriteTVar TVar{tvarCurrent} = writeSTRef tvarCurrent+{-# INLINE execWriteTVar #-}++execTryPutTMVar :: TMVar (IOSim s) a -> a -> ST s Bool+execTryPutTMVar (TMVar var) a = do+ v <- execReadTVar var+ case v of+ Nothing -> execWriteTVar var (Just a)+ >> return True+ Just _ -> return False+{-# INLINE execTryPutTMVar #-}++saveTVar :: TVar s a -> ST s ()+saveTVar TVar{tvarCurrent, tvarUndo} = do+ -- push the current value onto the undo stack+ v <- readSTRef tvarCurrent+ vs <- readSTRef tvarUndo+ writeSTRef tvarUndo (v:vs)++revertTVar :: TVar s a -> ST s ()+revertTVar TVar{tvarCurrent, tvarUndo} = do+ -- pop the undo stack, and revert the current value+ vs <- readSTRef tvarUndo+ writeSTRef tvarCurrent (head vs)+ writeSTRef tvarUndo (tail vs)+{-# INLINE revertTVar #-}++commitTVar :: TVar s a -> ST s ()+commitTVar TVar{tvarUndo} = do+ vs <- readSTRef tvarUndo+ -- pop the undo stack, leaving the current value unchanged+ writeSTRef tvarUndo (tail vs)+{-# INLINE commitTVar #-}++readTVarUndos :: TVar s a -> ST s [a]+readTVarUndos TVar{tvarUndo} = readSTRef tvarUndo++-- | Trace a 'TVar'. It must be called only on 'TVar's that were new or+-- 'written.+traceTVarST :: TVar s a+ -> Bool -- true if it's a new 'TVar'+ -> ST s TraceValue+traceTVarST TVar{tvarCurrent, tvarUndo, tvarTrace} new = do+ mf <- readSTRef tvarTrace+ case mf of+ Nothing -> return TraceValue { traceDynamic = (Nothing :: Maybe ()), traceString = Nothing }+ Just f -> do+ vs <- readSTRef tvarUndo+ v <- readSTRef tvarCurrent+ case (new, vs) of+ (True, _) -> f Nothing v+ (_, _:_) -> f (Just $ last vs) v+ _ -> error "traceTVarST: unexpected tvar state"++++leastUpperBoundTVarVClocks :: [SomeTVar s] -> ST s VectorClock+leastUpperBoundTVarVClocks tvars =+ foldr leastUpperBoundVClock bottomVClock <$>+ sequence [readSTRef (tvarVClock r) | SomeTVar r <- tvars]++--+-- Blocking and unblocking on TVars+--++readTVarBlockedThreads :: TVar s a -> ST s [ThreadId]+readTVarBlockedThreads TVar{tvarBlocked} = fst <$> readSTRef tvarBlocked++blockThreadOnTVar :: ThreadId -> TVar s a -> ST s ()+blockThreadOnTVar tid TVar{tvarBlocked} = do+ (tids, tidsSet) <- readSTRef tvarBlocked+ when (tid `Set.notMember` tidsSet) $ do+ let !tids' = tid : tids+ !tidsSet' = Set.insert tid tidsSet+ writeSTRef tvarBlocked (tids', tidsSet')++unblockAllThreadsFromTVar :: TVar s a -> ST s ()+unblockAllThreadsFromTVar TVar{tvarBlocked} = do+ writeSTRef tvarBlocked ([], Set.empty)++-- | For each TVar written to in a transaction (in order) collect the threads+-- that blocked on each one (in order).+--+-- Also, for logging purposes, return an association between the threads and+-- the var writes that woke them.+--+threadsUnblockedByWrites :: [SomeTVar s]+ -> ST s ([ThreadId], Map ThreadId (Set (Labelled TVarId)))+threadsUnblockedByWrites written = do+ tidss <- sequence+ [ (,) <$> labelledTVarId tvar <*> readTVarBlockedThreads tvar+ | SomeTVar tvar <- written ]+ -- Threads to wake up, in wake up order, annotated with the vars written that+ -- caused the unblocking.+ -- We reverse the individual lists because the tvarBlocked is used as a stack+ -- so it is in order of last written, LIFO, and we want FIFO behaviour.+ let wakeup = ordNub [ tid | (_vid, tids) <- tidss, tid <- reverse tids ]+ wokeby = Map.fromListWith Set.union+ [ (tid, Set.singleton vid)+ | (vid, tids) <- tidss+ , tid <- tids ]+ return (wakeup, wokeby)++ordNub :: Ord a => [a] -> [a]+ordNub = go Set.empty+ where+ go !_ [] = []+ go !s (x:xs)+ | x `Set.member` s = go s xs+ | otherwise = x : go (Set.insert x s) xs++--+-- Steps+--++data Step = Step {+ stepThreadId :: !ThreadId,+ stepStep :: !Int,+ stepEffect :: !Effect,+ stepVClock :: !VectorClock+ }+ deriving Show++-- steps race if they can be reordered with a possibly different outcome+racingSteps :: Step -- ^ an earlier step+ -> Step -- ^ a later step+ -> Bool+racingSteps s s' =+ stepThreadId s /= stepThreadId s'+ && not (stepThreadId s' `elem` effectWakeup (stepEffect s))+ && (stepEffect s `racingEffects` stepEffect s'+ || throwsTo s s'+ || throwsTo s' s)+ where throwsTo s1 s2 =+ stepThreadId s2 `elem` effectThrows (stepEffect s1)+ && stepEffect s2 /= mempty++currentStep :: Thread s a -> Step+currentStep Thread { threadId = tid,+ threadStep = tstep,+ threadEffect = teffect,+ threadVClock = vClock+ } =+ Step { stepThreadId = tid,+ stepStep = tstep,+ stepEffect = teffect,+ stepVClock = vClock+ }++stepThread :: Thread s a -> Thread s a+stepThread thread@Thread { threadId = tid,+ threadStep = tstep,+ threadVClock = vClock } =+ thread { threadStep = tstep+1,+ threadEffect = mempty,+ threadVClock = insertVClock tid (tstep+1) vClock+ }++-- As we run a simulation, we collect info about each previous step+data StepInfo = StepInfo {+ stepInfoStep :: Step,+ -- Control information when we reached this step+ stepInfoControl :: ScheduleControl,+ -- threads that are still concurrent with this step+ stepInfoConcurrent :: Set ThreadId,+ -- steps following this one that did not happen after it+ -- (in reverse order)+ stepInfoNonDep :: [Step],+ -- later steps that race with this one+ stepInfoRaces :: [Step]+ }+ deriving Show++--+-- Races+--++data Races = Races { -- These steps may still race with future steps+ activeRaces :: ![StepInfo],+ -- These steps cannot be concurrent with future steps+ completeRaces :: ![StepInfo]+ }+ deriving Show++noRaces :: Races+noRaces = Races [] []++updateRacesInSimState :: Thread s a -> SimState s a -> Races+updateRacesInSimState thread SimState{ control, threads, races } =+ traceRaces $+ updateRaces step+ (isThreadBlocked thread)+ control+ (Map.keysSet (Map.filter (\t -> not (isThreadDone t)+ && threadId t `Set.notMember`+ effectForks (stepEffect step)+ ) threads))+ races+ where+ step = currentStep thread++-- | 'updateRaces' turns a current 'Step' into 'StepInfo', and updates all+-- 'activeRaces'.+--+-- We take care that steps can only race against threads in their+-- concurrent set. When this becomes empty, a step can be retired into+-- the "complete" category, but only if there are some steps racing+-- with it.+updateRaces :: Step -> Bool -> ScheduleControl -> Set ThreadId -> Races -> Races+updateRaces newStep@Step{ stepThreadId = tid, stepEffect = newEffect }+ blocking+ control+ newConcurrent0+ races@Races{ activeRaces } =++ let justBlocking :: Bool+ justBlocking = blocking && onlyReadEffect newEffect++ -- a new step cannot race with any threads that it just woke up+ new :: [StepInfo]+ !new | isNotRacyThreadId tid = [] -- non-racy threads do not race+ | Set.null newConcurrent = [] -- cannot race with anything+ | justBlocking = [] -- no need to defer a blocking transaction+ | otherwise =+ [StepInfo { stepInfoStep = newStep,+ stepInfoControl = control,+ stepInfoConcurrent = newConcurrent,+ stepInfoNonDep = [],+ stepInfoRaces = []+ }]+ where+ newConcurrent :: Set ThreadId+ newConcurrent = foldr Set.delete newConcurrent0 (effectWakeup newEffect)++ activeRaces' :: [StepInfo]+ !activeRaces' =+ [ -- if this step depends on the previous step, or is not concurrent,+ -- then any threads that it wakes up become non-concurrent also.+ let !lessConcurrent = foldr Set.delete concurrent (effectWakeup newEffect) in+ if tid `elem` concurrent then+ let theseStepsRace = isRacyThreadId tid && racingSteps step newStep+ happensBefore = step `happensBeforeStep` newStep+ !nondep' | happensBefore = nondep+ | otherwise = newStep : nondep+ -- We will only record the first race with each thread---reversing+ -- the first race makes the next race detectable. Thus we remove a+ -- thread from the concurrent set after the first race.+ concurrent' | happensBefore = Set.delete tid lessConcurrent+ | theseStepsRace = Set.delete tid concurrent+ | otherwise = concurrent+ -- Here we record discovered races.+ -- We only record a new race if we are following the default schedule,+ -- to avoid finding the same race in different parts of the search space.+ !stepRaces' | (control == ControlDefault ||+ control == ControlFollow [] []) &&+ theseStepsRace = newStep : stepRaces+ | otherwise = stepRaces++ in stepInfo { stepInfoConcurrent = effectForks newEffect+ `Set.union` concurrent',+ stepInfoNonDep = nondep',+ stepInfoRaces = stepRaces'+ }++ else stepInfo { stepInfoConcurrent = lessConcurrent }++ | !stepInfo@StepInfo { stepInfoStep = step,+ stepInfoConcurrent = concurrent,+ stepInfoNonDep = nondep,+ stepInfoRaces = stepRaces+ }+ <- activeRaces ]+ in normalizeRaces $ races { activeRaces = new ++ activeRaces' }++-- When a thread terminates, we remove it from the concurrent thread+-- sets of active races.++threadTerminatesRaces :: ThreadId -> Races -> Races+threadTerminatesRaces tid races@Races{ activeRaces } =+ let activeRaces' = [ s{stepInfoConcurrent = Set.delete tid stepInfoConcurrent}+ | s@StepInfo{ stepInfoConcurrent } <- activeRaces ]+ in normalizeRaces $ races{ activeRaces = activeRaces' }++normalizeRaces :: Races -> Races+normalizeRaces Races{ activeRaces, completeRaces } =+ let !activeRaces' = filter (not . null. stepInfoConcurrent) activeRaces+ !completeRaces' = filter (not . null. stepInfoRaces)+ (filter (null . stepInfoConcurrent) activeRaces)+ ++ completeRaces+ in Races{ activeRaces = activeRaces', completeRaces = completeRaces' }++-- We assume that steps do not race with later steps after a quiescent+-- period. Quiescent periods end when simulated time advances, thus we+-- are assuming here that all work is completed before a timer+-- triggers.++quiescentRaces :: Races -> Races+quiescentRaces Races{ activeRaces, completeRaces } =+ Races{ activeRaces = [],+ completeRaces = [ s{stepInfoConcurrent = Set.empty}+ | s <- activeRaces+ , not (null (stepInfoRaces s))+ ] ++ completeRaces }++traceRaces :: Races -> Races+traceRaces r = r+-- traceRaces r@Races{activeRaces,completeRaces} =+-- Debug.trace ("Tracking "++show (length (concatMap stepInfoRaces activeRaces)) ++" races") r+++--+-- Schedule control+--++controlTargets :: StepId -> ScheduleControl -> Bool+controlTargets stepId+ (ControlAwait (ScheduleMod{ scheduleModTarget }:_)) =+ stepId == scheduleModTarget+controlTargets _stepId _ = False++followControl :: ScheduleControl -> ScheduleControl+followControl (ControlAwait (ScheduleMod { scheduleModInsertion } : mods)) =+ ControlFollow scheduleModInsertion mods+followControl (ControlAwait []) = error "Impossible: followControl (ControlAwait [])"+followControl ControlDefault{} = error "Impossible: followControl ControlDefault{}"+followControl ControlFollow{} = error "Impossible: followControl ControlFollow{}"++controlFollows :: StepId -> ScheduleControl -> Bool+controlFollows _stepId ControlDefault = True+controlFollows _stepId (ControlFollow [] _) = True+controlFollows stepId (ControlFollow (stepId':_) _) = stepId == stepId'+controlFollows stepId (ControlAwait (smod:_)) = stepId /= scheduleModTarget smod+controlFollows _ (ControlAwait []) = error "Impossible: controlFollows _ (ControlAwait [])"++advanceControl :: StepId -> ScheduleControl -> ScheduleControl+advanceControl (tid,step) control@(ControlFollow ((tid',step'):sids') tgts)+ | tid /= tid' =+ -- we are switching threads to follow the schedule+ --Debug.trace ("Switching threads from "++show (tid,step)++" to "++show (tid',step')++"\n") $+ control+ | step == step' =+ ControlFollow sids' tgts+ | otherwise =+ error $ concat+ [ "advanceControl ", show (tid,step)+ , " cannot follow step ", show step'+ , "\n"+ ]+advanceControl stepId (ControlFollow [] []) =+ ControlDefault+advanceControl stepId (ControlFollow [] tgts) =+ ControlAwait tgts+advanceControl stepId control =+ assert (not $ controlTargets stepId control) $+ control++--+-- Schedule modifications+--++stepStepId :: Step -> (ThreadId, Int)+stepStepId Step{ stepThreadId = tid, stepStep = n } = (tid,n)++stepInfoToScheduleMods :: StepInfo -> [ScheduleMod]+stepInfoToScheduleMods+ StepInfo{ stepInfoStep = step,+ stepInfoControl = control,+ stepInfoNonDep = nondep,+ stepInfoRaces = races+ } =+ -- It is actually possible for a later step that races with an earlier one+ -- not to *depend* on it in a happens-before sense. But we don't want to try+ -- to follow any steps *after* the later one.+ [ ScheduleMod+ { scheduleModTarget = stepStepId step+ , scheduleModControl = control+ , scheduleModInsertion = takeWhile (/=stepStepId step')+ (map stepStepId (reverse nondep))+ ++ [stepStepId step']+ -- It should be unnecessary to include the delayed+ -- step in the insertion, since the default+ -- scheduling should run it anyway. Removing it may+ -- help avoid redundant schedules.+ -- ++ [stepStepId step]+ }+ | step' <- races ]++traceFinalRacesFound :: SimState s a -> SimTrace a -> SimTrace a+traceFinalRacesFound SimState{ control0 = control, races } =+ TraceRacesFound [extendScheduleControl control m | m <- scheduleMods]+ where+ scheduleMods :: [ScheduleMod]+ scheduleMods =+ concatMap stepInfoToScheduleMods+ . completeRaces+ . quiescentRaces+ $ races++-- Extend an existing schedule control with a newly discovered schedule mod+extendScheduleControl' :: ScheduleControl -> ScheduleMod -> ScheduleControl+extendScheduleControl' ControlDefault m = ControlAwait [m]+extendScheduleControl' (ControlAwait mods) m =+ case scheduleModControl m of+ ControlDefault -> ControlAwait (mods++[m])+ ControlAwait mods' ->+ let common = length mods - length mods' in+ assert (common >= 0 && drop common mods==mods') $+ ControlAwait (take common mods++[m{ scheduleModControl = ControlDefault }])+ ControlFollow stepIds mods' ->+ let common = length mods - length mods' - 1+ m' = mods !! common+ isUndo = scheduleModTarget m' `elem` scheduleModInsertion m+ m'' = m'{ scheduleModInsertion =+ takeWhile (/=scheduleModTarget m)+ (scheduleModInsertion m')+ +++ scheduleModInsertion m }+ in+ assert (common >= 0) $+ assert (drop (common+1) mods == mods') $+ if isUndo+ then ControlAwait mods -- reject this mod... it's undoing a previous one+ else ControlAwait (take common mods++[m''])+extendScheduleControl' ControlFollow{} ScheduleMod{} =+ -- note: this case is impossible, since `extendScheduleControl'` first+ -- argument is either the initial `ControlDefault` or a result of calling+ -- `extendScheduleControl'` itself.+ error "Impossible: extendScheduleControl' ControlFollow{} ScheduleMod{}"++extendScheduleControl :: ScheduleControl -> ScheduleMod -> ScheduleControl+extendScheduleControl control m =+ let control' = extendScheduleControl' control m in+ {- Debug.trace (unlines ["",+ "Extending "++show control,+ " with "++show m,+ " yields "++show control']) -}+ control'
+ src/Control/Monad/IOSimPOR/QuickCheckUtils.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Control.Monad.IOSimPOR.QuickCheckUtils where++import Control.Parallel+import Test.QuickCheck.Gen+import Test.QuickCheck.Property++-- Take the conjunction of several properties, in parallel This is a+-- modification of code from Test.QuickCheck.Property, to run non-IO+-- properties in parallel. It also takes care NOT to label its result+-- as an IO property (using IORose), unless one of its arguments is+-- itself an IO property. This is needed to permit parallel testing.+conjoinPar :: TestableNoCatch prop => [prop] -> Property+conjoinPar = conjoinSpeculate speculate+ where+ -- speculation tries to evaluate each Rose tree in parallel, to WHNF+ -- This will not perform any IO, but should evaluate non-IO properties+ -- completely.+ speculate [] = []+ speculate (rose:roses) = roses' `par` rose' `pseq` (rose':roses')+ where rose' = case rose of+ MkRose result _ -> let ans = maybe True id $ ok result in ans `pseq` rose+ IORose _ -> rose+ roses' = speculate roses++-- We also need a version of conjoin that is sequential, but does not+-- label its result as an IO property unless one of its arguments+-- is. Consequently it does not catch exceptions in its arguments.+conjoinNoCatch :: TestableNoCatch prop => [prop] -> Property+conjoinNoCatch = conjoinSpeculate id++conjoinSpeculate :: TestableNoCatch prop => ([Rose Result] -> [Rose Result]) -> [prop] -> Property+conjoinSpeculate spec ps =+ againNoCatch $+ MkProperty $+ do roses <- mapM (fmap unProp . unProperty . propertyNoCatch) ps+ return (MkProp $ conj id (spec roses))+ where++ conj k [] =+ MkRose (k succeeded) []++ conj k (p : ps) = do+ result <- p+ case ok result of+ _ | not (expect result) ->+ return failed { reason = "expectFailure may not occur inside a conjunction" }+ Just True -> conj (addLabels result . addCallbacksAndCoverage result . k) ps+ Just False -> p+ Nothing -> do+ let rest = conj (addCallbacksAndCoverage result . k) ps+ result2 <- rest+ -- Nasty work to make sure we use the right callbacks+ case ok result2 of+ Just True -> MkRose (result2 { ok = Nothing }) []+ Just False -> rest+ Nothing -> rest++ addCallbacksAndCoverage result r =+ r { callbacks = callbacks result ++ callbacks r,+ requiredCoverage = requiredCoverage result ++ requiredCoverage r }+ addLabels result r =+ r { labels = labels result ++ labels r,+ classes = classes result ++ classes r,+ tables = tables result ++ tables r }++-- |&&| is a replacement for .&&. that evaluates its arguments in+-- parallel. |&&| does NOT label its result as an IO property, unless+-- one of its arguments is--which .&&. does. This means that using+-- .&&. inside an argument to conjoinPar limits parallelism, while+-- |&&| does not.++infixr 1 |&&|++(|&&|) :: TestableNoCatch prop => prop -> prop -> Property+p |&&| q = conjoinPar [p, q]++-- .&&| is a sequential, but parallelism-friendly version of .&&., that+-- tests its arguments in sequence, but does not label its result as+-- an IO property unless one of its arguments is.++infixr 1 .&&|+(.&&|) :: TestableNoCatch prop => prop -> prop -> Property+p .&&| q = conjoinNoCatch [p, q]+++-- property catches exceptions in its argument, turning everything+-- Testable into an IORose property, which cannot be paralellized. We+-- need an alternative that permits parallelism by allowing exceptions+-- to propagate. This is a modified clone of code from+-- Test.QuickCheck.Property.++class TestableNoCatch prop where+ propertyNoCatch :: prop -> Property++instance TestableNoCatch Discard where+ propertyNoCatch _ = propertyNoCatch rejected++instance TestableNoCatch Bool where+ propertyNoCatch = propertyNoCatch . liftBool++instance TestableNoCatch Result where+ propertyNoCatch = MkProperty . return . MkProp . return++instance TestableNoCatch Prop where+ propertyNoCatch p = MkProperty . return $ p++instance TestableNoCatch prop => TestableNoCatch (Gen prop) where+ propertyNoCatch mp = MkProperty $ do p <- mp; unProperty (againNoCatch $ propertyNoCatch p)++instance TestableNoCatch Property where+ propertyNoCatch p = p++againNoCatch :: Property -> Property+againNoCatch (MkProperty gen) = MkProperty $ do+ MkProp rose <- gen+ return . MkProp $ fmap (\res -> res{ abort = False }) rose
+ src/Control/Monad/IOSimPOR/Timeout.hs view
@@ -0,0 +1,67 @@+module Control.Monad.IOSimPOR.Timeout+ ( Timeout+ , timeout+ , unsafeTimeout+ ) where++-- This module provides a timeout function like System.Timeout, BUT+-- garbage collection time is not included (provided GHC stats are+-- enabled, +RTS -T -RTS). Thus this can be used more reliably to+-- limit computation time.++import Control.Concurrent+import Control.Exception (Exception (..), asyncExceptionFromException,+ asyncExceptionToException, bracket, handleJust,+ uninterruptibleMask_)+import Control.Monad+import Data.Unique (Unique, newUnique)+import GHC.Stats+import System.IO.Unsafe+++-- An internal type that is thrown as a dynamic exception to+-- interrupt the running IO computation when the timeout has+-- expired.++-- | An exception thrown to a thread by 'timeout' to interrupt a timed-out+-- computation.++newtype Timeout = Timeout Unique deriving Eq++-- | @since 4.0+instance Show Timeout where+ show _ = "<<timeout>>"++instance Exception Timeout where+ toException = asyncExceptionToException+ fromException = asyncExceptionFromException++timeout :: Int -> IO a -> IO (Maybe a)+timeout n f+ | n < 0 = fmap Just f+ | n == 0 = return Nothing+ | otherwise = do+ pid <- myThreadId+ ex <- fmap Timeout newUnique+ handleJust (\e -> if e == ex then Just () else Nothing)+ (\_ -> return Nothing)+ (bracket (forkIOWithUnmask $ \unmask ->+ unmask $ waitFor n >> throwTo pid ex)+ (uninterruptibleMask_ . killThread)+ (\_ -> fmap Just f))++waitFor :: Int -> IO ()+waitFor n = do+ t0 <- getGCTime+ threadDelay n+ t1 <- getGCTime+ when (t1 > t0) $+ -- allow some extra time because of GC+ waitFor (t1-t0)++getGCTime :: IO Int+getGCTime = fromIntegral . (`div` 1000) . gc_elapsed_ns <$> getRTSStats++-- | unsafeTimeout n a forces the evaluation of a, with a time limit of n microseconds.+unsafeTimeout :: Int -> a -> Maybe a+unsafeTimeout n a = unsafePerformIO $ timeout n $ return $! a
+ src/Control/Monad/IOSimPOR/Types.hs view
@@ -0,0 +1,70 @@+module Control.Monad.IOSimPOR.Types where++import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set++import Control.Monad.IOSim.CommonTypes++--+-- Effects+--++-- | An `Effect` aggregates effects performed by a thread. Only used by+-- *IOSimPOR*.+--+data Effect = Effect {+ effectReads :: !(Set TVarId),+ effectWrites :: !(Set TVarId),+ effectForks :: !(Set ThreadId),+ effectThrows :: ![ThreadId],+ effectWakeup :: ![ThreadId]+ }+ deriving (Eq, Show)++instance Semigroup Effect where+ Effect r w s ts wu <> Effect r' w' s' ts' wu' =+ Effect (r <> r') (w <> w') (s <> s') (ts ++ ts') (wu++wu')++instance Monoid Effect where+ mempty = Effect Set.empty Set.empty Set.empty [] []++-- readEffect :: SomeTVar s -> Effect+-- readEffect r = mempty{effectReads = Set.singleton $ someTvarId r }++readEffects :: [SomeTVar s] -> Effect+readEffects rs = mempty{effectReads = Set.fromList (map someTvarId rs)}++-- writeEffect :: SomeTVar s -> Effect+-- writeEffect r = mempty{effectWrites = Set.singleton $ someTvarId r }++writeEffects :: [SomeTVar s] -> Effect+writeEffects rs = mempty{effectWrites = Set.fromList (map someTvarId rs)}++forkEffect :: ThreadId -> Effect+forkEffect tid = mempty{effectForks = Set.singleton $ tid}++throwToEffect :: ThreadId -> Effect+throwToEffect tid = mempty{ effectThrows = [tid] }++wakeupEffects :: [ThreadId] -> Effect+wakeupEffects tids = mempty{effectWakeup = tids}++someTvarId :: SomeTVar s -> TVarId+someTvarId (SomeTVar r) = tvarId r++onlyReadEffect :: Effect -> Bool+onlyReadEffect e = e { effectReads = effectReads mempty } == mempty++racingEffects :: Effect -> Effect -> Bool+racingEffects e e' =+ effectThrows e `intersectsL` effectThrows e'+ || effectReads e `intersects` effectWrites e'+ || effectWrites e `intersects` effectReads e'+ || effectWrites e `intersects` effectWrites e'+ where+ intersects :: Ord a => Set a -> Set a -> Bool+ intersects a b = not $ a `Set.disjoint` b++ intersectsL :: Eq a => [a] -> [a] -> Bool+ intersectsL a b = not $ null $ a `List.intersect` b
+ src/Data/List/Trace.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++module Data.List.Trace+ ( Trace (..)+ , ppTrace+ , toList+ , fromList+ , head+ , tail+ , filter+ , length+ ) where++import Prelude hiding (filter, head, length, tail)++import Control.Applicative (Alternative (..))+import Control.Monad (MonadPlus (..))+import Control.Monad.Fix (MonadFix (..), fix)+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Functor.Classes++-- | A 'cons' list with polymorphic 'nil'.+--+-- * @'Trace' Void a@ is an infinite stream+-- * @'Trace' () a@ is isomorphic to @[a]@+--+-- Usually used with @a@ being a non empty sum type.+--+data Trace a b+ = Cons b (Trace a b)+ | Nil a+ deriving (Show, Eq, Ord, Functor)++head :: Trace a b -> b+head (Cons b _) = b+head _ = error "Trace.head: empty"++tail :: Trace a b -> Trace a b+tail (Cons _ o) = o+tail Nil {} = error "Trace.tail: empty"++filter :: (b -> Bool) -> Trace a b -> Trace a b+filter _fn o@Nil {} = o+filter fn (Cons b o) =+ case fn b of+ True -> Cons b (filter fn o)+ False -> filter fn o++length :: Trace a b -> Int+length (Cons _ o) = (+) 1 $! length o+length Nil {} = 0++toList :: Trace a b -> [b]+toList = bifoldr (\_ bs -> bs) (:) []++fromList :: a -> [b] -> Trace a b+fromList a = foldr Cons (Nil a)++-- | Pretty print a 'Trace'.+--+ppTrace :: (a -> String) -> (b -> String) -> Trace a b -> String+ppTrace sa sb (Cons b bs) = sb b ++ "\n" ++ ppTrace sa sb bs+ppTrace sa _sb (Nil a) = sa a++instance Bifunctor Trace where+ bimap f g (Cons b bs) = Cons (g b) (bimap f g bs)+ bimap f _ (Nil a) = Nil (f a)++instance Bifoldable Trace where+ bifoldMap f g (Cons b bs) = g b <> bifoldMap f g bs+ bifoldMap f _ (Nil a) = f a++ bifoldr f g c = go+ where+ go (Cons b bs) = b `g` go bs+ go (Nil a) = a `f` c+ {-# INLINE[0] bifoldr #-}++ bifoldl f g = go+ where+ go c (Cons b bs) = go (c `g` b) bs+ go c (Nil a) = c `f` a+ {-# INLINE[0] bifoldl #-}++instance Bitraversable Trace where+ bitraverse f g (Cons b bs) = Cons <$> g b <*> bitraverse f g bs+ bitraverse f _ (Nil a) = Nil <$> f a++instance Semigroup a => Semigroup (Trace a b) where+ Cons b o <> o' = Cons b (o <> o')+ o@Nil {} <> (Cons b o') = Cons b (o <> o')+ Nil a <> Nil a' = Nil (a <> a')++instance Monoid a => Monoid (Trace a b) where+ mempty = Nil mempty++instance Monoid a => Applicative (Trace a) where+ pure b = Cons b (Nil mempty)+ Cons f fs <*> o = fmap f o <> (fs <*> o)+ Nil a <*> _ = Nil a++instance Monoid a => Monad (Trace a) where+ return = pure+ -- @bifoldMap Nil id@ is the @join@ of @Trace a@+ o >>= f = bifoldMap Nil id $ fmap f o++#if MIN_VERSION_base(4,13,0)+instance Monoid a => MonadFail (Trace a) where+ fail _ = mzero+#endif++instance Monoid a => Alternative (Trace a) where+ empty = mempty+ (<|>) = (<>)++instance Monoid a => MonadPlus (Trace a) where+ mzero = mempty+ mplus = (<>)++instance Monoid a => MonadFix (Trace a) where+ mfix f = case fix (f . head) of+ o@Nil {} -> o+ Cons b _ -> Cons b (mfix (tail . f))++instance Eq a => Eq1 (Trace a) where+ liftEq f (Cons b o) (Cons b' o') = f b b' && liftEq f o o'+ liftEq _ Nil {} Cons {} = False+ liftEq _ Cons {} Nil {} = False+ liftEq _ (Nil a) (Nil a') = a == a'++instance Ord a => Ord1 (Trace a) where+ liftCompare f (Cons b o) (Cons b' o') = f b b' `compare` liftCompare f o o'+ liftCompare _ Nil {} Cons {} = LT+ liftCompare _ Cons {} Nil {} = GT+ liftCompare _ (Nil a) (Nil a') = a `compare` a'++instance Show a => Show1 (Trace a) where+ liftShowsPrec showsPrec_ showsList_ prec (Cons b o)+ = showString "Cons "+ . showsPrec_ prec b+ . showChar ' '+ . showParen True (liftShowsPrec showsPrec_ showsList_ prec o)+ liftShowsPrec _showsPrec _showsList _prec (Nil a)+ = showString "Nil "+ . shows a
+ test/Main.hs view
@@ -0,0 +1,18 @@+module Main (main) where++import Test.Tasty++import qualified Test.Control.Monad.Class.MonadMVar (tests)+import qualified Test.Control.Monad.IOSim (tests)+import qualified Test.Control.Monad.IOSimPOR (tests)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+ testGroup "IO Sim"+ [ Test.Control.Monad.Class.MonadMVar.tests+ , Test.Control.Monad.IOSim.tests+ , Test.Control.Monad.IOSimPOR.tests+ ]
+ test/Test/Control/Monad/Class/MonadMVar.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Test.Control.Monad.Class.MonadMVar where++import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadMVar+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer.SI+import Data.Bifoldable (bifoldMap)+import Data.Foldable (traverse_)+import Data.Functor (void, ($>))+import Data.Maybe (isNothing)+import Data.Monoid (All (..))++import Control.Monad.IOSim++import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (testProperty)++tests :: TestTree+tests =+ testGroup "Control.Monad.Class.MonadMVar"+ [ testGroup "putMVar"+ [ testProperty "fairness (IOSim)" prop_putMVar_fairness_sim+ , testCase "blocks on a full MVar (IOSim)"+ unit_putMVar_blocks_on_full_sim+ , testCase "blocks on a full MVar (IO)"+ unit_putMVar_blocks_on_full_io+ ]+ , testGroup "takeMVar"+ [ testProperty "fairness (IOSim)" prop_takeMVar_fairness_sim+ , testCase "blocks on an empty MVar (IOSim)"+ unit_takeMVar_blocks_on_empty_sim+ , testCase "blocks on an empty MVar (IO)"+ unit_takeMVar_blocks_on_empty_io+ ]+ , testGroup "tryTakeMVar"+ [ testCase "does not block on an empty MVar (IOSim)"+ unit_tryTakeMVar_empty+ , testCase "does not block on a full MVar (IOSim)"+ unit_tryTakeMVar_full+ , testCase "return value on an empty MVar (IOSim)"+ unit_tryTakeMVar_return_empty_sim+ , testCase "return value on an full MVar (IOSim)"+ unit_tryTakeMVar_return_full_sim+ ]+ , testGroup "tryPutMVar"+ [ testCase "does not block on an empty MVar (IOSim)"+ unit_tryPutMVar_empty+ , testCase "does not block on a full MVar (IOSim)"+ unit_tryPutMVar_full+ , testCase "return value on an empty MVar (IOSim)"+ unit_tryPutMVar_return_empty_sim+ , testCase "return value on an full MVar (IOSim)"+ unit_tryPutMVar_return_full_sim+ ]+ , testGroup "isEmptyMVar"+ [ testCase "empty MVar is empty" unit_isEmptyMVar_empty_sim+ , testCase "full MVar is not empty" unit_isEmptyMVar_full_sim+ ]+ ]+++--+-- putMVar+--++-- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'+-- as it relies on its thread scheduling and determinism.+--+putMVar_fairness_property+ :: forall m.+ ( MonadAsync m+ , MonadDelay m+ , MonadMVar m+ )+ => Int -- ^ number of threads+ -> m Bool+putMVar_fairness_property n = do+ v <- newEmptyMVar+ traverse_ (\a -> async $ do threadDelay 0.01+ putMVar v a)+ [1..n]+ threadDelay 0.02+ results <- sequence (replicate n (takeMVar v))+ return $ results == [1..n]++prop_putMVar_fairness_sim :: Positive (Small Int)+ -> Property+prop_putMVar_fairness_sim (Positive (Small n)) =+ let trace = runSimTrace (putMVar_fairness_property n)+ in counterexample (ppTrace trace)+ $ case traceResult False trace of+ Left err -> counterexample (show err) False+ Right a -> property a+++unit_putMVar_blocks_on_full+ :: ( MonadFork m+ , MonadDelay m+ , MonadMVar m+ )+ => m Bool+unit_putMVar_blocks_on_full = do+ start <- getMonotonicTime+ let delta = 0.01+ v <- newMVar ()+ _ <- forkIO $ threadDelay delta+ >> takeMVar v+ $> ()+ putMVar v ()+ end <- getMonotonicTime+ return (end `diffTime` start >= delta)++unit_putMVar_blocks_on_full_sim :: Assertion+unit_putMVar_blocks_on_full_sim = assertBool "did not block on an full MVar" $+ runSimOrThrow unit_putMVar_blocks_on_full++unit_putMVar_blocks_on_full_io :: Assertion+unit_putMVar_blocks_on_full_io =+ unit_putMVar_blocks_on_full >>= assertBool "did not block on an full MVar"+++--+-- takeMVar+--++-- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'+-- as it relies on its thread scheduling and determinism.+--+takeMVar_fairness_property+ :: forall m.+ ( MonadAsync m+ , MonadDelay m+ , MonadMVar m+ , Eq (Async m Int)+ )+ => Int -- ^ number of threads+ -> m Property+takeMVar_fairness_property n = do+ v <- newEmptyMVar+ ts <- sequence $ replicate n (async $ takeMVar v)+ threadDelay 0.01+ traverse_ (putMVar v) [1..n]+ results <- waitAll ts+ return $ results === [1..n]++prop_takeMVar_fairness_sim :: Positive (Small Int)+ -> Property+prop_takeMVar_fairness_sim (Positive (Small n)) =+ runSimOrThrow (takeMVar_fairness_property n)+++unit_takeMVar_blocks_on_empty+ :: ( MonadFork m+ , MonadDelay m+ , MonadMVar m+ )+ => m Bool+unit_takeMVar_blocks_on_empty = do+ start <- getMonotonicTime+ let delta = 0.01+ v <- newEmptyMVar+ _ <- forkIO $ threadDelay delta+ >> putMVar v ()+ takeMVar v+ end <- getMonotonicTime+ return (end `diffTime` start >= delta)++unit_takeMVar_blocks_on_empty_sim :: Assertion+unit_takeMVar_blocks_on_empty_sim = assertBool "did not block on an empty MVar" $ runSimOrThrow unit_takeMVar_blocks_on_empty++unit_takeMVar_blocks_on_empty_io :: Assertion+unit_takeMVar_blocks_on_empty_io =+ unit_takeMVar_blocks_on_empty >>= assertBool "did not block on an empty MVar"++--+-- tryTakeMVar+--+++-- | Check that `IOSim`'s `tryTakeMVar` is non blocking.+--+tryTakeMVar_non_blocking_property+ :: Bool -> Bool+tryTakeMVar_non_blocking_property isEmpty =+ validateTrace $ runSimTrace $ do+ v <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ void $ tryTakeMVar v+ where+ validateTrace :: SimTrace a -> Bool+ validateTrace = getAll . bifoldMap (const (All True))+ (\ev -> case seType ev of+ EventTxBlocked {} -> All False+ _ -> All True)++unit_tryTakeMVar_empty :: Assertion+unit_tryTakeMVar_empty = assertBool "blocked on an empty MVar" $+ tryTakeMVar_non_blocking_property False++unit_tryTakeMVar_full :: Assertion+unit_tryTakeMVar_full = assertBool "blocked on an empty MVar" $+ tryTakeMVar_non_blocking_property True+++tryTakeMVar_return_value+ :: MonadMVar m+ => Bool+ -> m Bool+tryTakeMVar_return_value isEmpty =+ do v <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ a <- tryTakeMVar v+ return $ isNothing a == isEmpty++unit_tryTakeMVar_return_empty_sim :: Assertion+unit_tryTakeMVar_return_empty_sim =+ assertBool "tryTakeMVar on an empty should return result" $+ runSimOrThrow (tryTakeMVar_return_value True)++unit_tryTakeMVar_return_full_sim :: Assertion+unit_tryTakeMVar_return_full_sim =+ assertBool "tryTakeMVar on an full should return result" $+ runSimOrThrow (tryTakeMVar_return_value False)++--+-- tryPutMVar+--++-- | Check that `IOSim`'s `tryPutMVar` is non blocking.+--+tryPutMVar_non_blocking_property+ :: Bool -> Bool+tryPutMVar_non_blocking_property isEmpty =+ validateTrace $ runSimTrace $ do+ v <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ void $ tryPutMVar v ()+ where+ validateTrace :: SimTrace a -> Bool+ validateTrace = getAll . bifoldMap (const (All True))+ (\ev -> case seType ev of+ EventTxBlocked {} -> All False+ _ -> All True)++unit_tryPutMVar_empty :: Assertion+unit_tryPutMVar_empty = assertBool "blocked on an empty MVar" $+ tryPutMVar_non_blocking_property False++unit_tryPutMVar_full :: Assertion+unit_tryPutMVar_full = assertBool "blocked on an empty MVar" $+ tryPutMVar_non_blocking_property True+++tryPutMVar_return_value+ :: forall m.+ MonadMVar m+ => Bool+ -> m Bool+tryPutMVar_return_value isEmpty = do+ v :: MVar m ()+ <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ a <- tryPutMVar v ()+ return $ a == isEmpty++unit_tryPutMVar_return_empty_sim :: Assertion+unit_tryPutMVar_return_empty_sim =+ assertBool "tryPutMVar on an empty should return result" $+ runSimOrThrow (tryPutMVar_return_value True)++unit_tryPutMVar_return_full_sim :: Assertion+unit_tryPutMVar_return_full_sim =+ assertBool "tryPutMVar on an full should return result" $+ runSimOrThrow (tryPutMVar_return_value False)++--+-- isEmptyMVar+--++prop_isEmptyMVar+ :: forall m. MonadMVar m+ => Bool+ -> m Bool+prop_isEmptyMVar isEmpty = do+ v :: MVar m ()+ <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ (isEmpty ==) <$> isEmptyMVar v++unit_isEmptyMVar_empty_sim :: Assertion+unit_isEmptyMVar_empty_sim =+ assertBool "empty mvar must be empty" $+ runSimOrThrow (prop_isEmptyMVar True)++unit_isEmptyMVar_full_sim :: Assertion+unit_isEmptyMVar_full_sim =+ assertBool "full mvar must not be empty" $+ runSimOrThrow (prop_isEmptyMVar False)++--+-- Utils+--++waitAll :: forall m.+ ( MonadAsync m+ , Eq (Async m Int)+ )+ => [Async m Int] -> m [Int]+waitAll = go []+ where+ go :: [Int] -> [Async m Int] -> m [Int]+ go as ts = do+ (t, a) <- waitAny ts+ let ts' = filter (/= t) ts+ case ts' of+ [] -> return (reverse (a : as))+ _ -> go (a : as) ts'
+ test/Test/Control/Monad/IOSim.hs view
@@ -0,0 +1,1344 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Control.Monad.IOSim+ ( tests+ , TestThreadGraph (..)+ -- * Timeout tests+ , WithSanityCheck (..)+ , withSanityCheck+ , ignoreSanityCheck+ , isSanityCheckIgnored+ , TimeoutConstraints+ , TimeoutDuration+ , ActionDuration+ , singleTimeoutExperiment+ ) where++import Data.Either (isLeft)+import Data.Fixed (Micro)+import Data.Foldable (foldl')+import Data.Functor (($>))+import Data.Time.Clock (picosecondsToDiffTime)++import Control.Exception (ArithException (..), AsyncException)+import Control.Monad+import Control.Monad.Fix+import System.IO.Error (ioeGetErrorString, isUserError)++import Control.Concurrent.Class.MonadSTM.Strict+import qualified Control.Concurrent.Class.MonadSTM.TVar as LazySTM+import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadThrow+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer.SI+import Control.Monad.IOSim++import Test.Control.Monad.Utils+import Test.Control.Monad.STM++import Test.QuickCheck+import Test.Tasty hiding (after)+import Test.Tasty.QuickCheck++tests :: TestTree+tests =+ testGroup "IO simulator"+ [ testProperty "read/write graph (IO)" prop_stm_graph_io+ , testProperty "read/write graph (IOSim)" (withMaxSuccess 1000 prop_stm_graph_sim)+ , testGroup "timeouts"+ [ testProperty "IOSim" (withMaxSuccess 1000 prop_timers_ST)+ -- fails since we just use `threadDelay` to schedule timers in `IO`.+ , testProperty "IO" (expectFailure prop_timers_IO)+ , testProperty "IOSim: no deadlock" prop_timeout_no_deadlock_Sim+ , testProperty "IO: no deadlock" prop_timeout_no_deadlock_IO+ , testProperty "timeout" prop_timeout+ , testProperty "timeouts" prop_timeouts+ , testProperty "stacked timeouts" prop_stacked_timeouts+ , testProperty "async exceptions 1" unit_timeouts_and_async_exceptions_1+ , testProperty "async exceptions 2" unit_timeouts_and_async_exceptions_2+ , testProperty "async exceptions 3" unit_timeouts_and_async_exceptions_3+ , testProperty "threadDelay and STM" unit_threadDelay_and_stm+ , testProperty "throwTo and STM" unit_throwTo_and_stm+ ]+ , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim)+ , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST)+ , testProperty "order (IO)" (expectFailure prop_fork_order_IO)+ , testProperty "STM wakeup order" prop_wakeup_order_ST+ , testGroup "throw/catch unit tests"+ [ testProperty "0" unit_catch_0+ , testProperty "1" unit_catch_1+ , testProperty "2" unit_catch_2+ , testProperty "3" unit_catch_3+ , testProperty "4" unit_catch_4+ , testProperty "5" unit_catch_5+ , testProperty "6" unit_catch_6+ ]+ , testGroup "masking state"+ [ testProperty "set (IO)"+ $ forall_masking_states unit_set_masking_state_IO+ , testProperty "set (IOSim)"+ $ forall_masking_states unit_set_masking_state_ST++ , testProperty "unmask (IO)"+ $ forall_masking_states $ \ms ->+ forall_masking_states $ \ms' -> unit_unmask_IO ms ms'+ , testProperty "unmask (IOSim)"+ $ forall_masking_states $ \ms ->+ forall_masking_states $ \ms' -> unit_unmask_ST ms ms'++ , testProperty "fork (IO)"+ $ forall_masking_states unit_fork_masking_state_IO+ , testProperty "fork (IOSim)"+ $ forall_masking_states unit_fork_masking_state_ST++ , testProperty "fork unmask (IO)"+ $ forall_masking_states $ \ms ->+ forall_masking_states $ \ms' -> unit_fork_unmask_IO ms ms'+ , testProperty "fork unmask (IOSim)"+ $ forall_masking_states $ \ms ->+ forall_masking_states $ \ms' -> unit_fork_unmask_ST ms ms'++ , testProperty "catch (IO)"+ $ forall_masking_states unit_catch_throwIO_masking_state_IO+ , testProperty "catch (IOSim)"+ $ forall_masking_states unit_catch_throwIO_masking_state_ST++ , testProperty "catch: throwTo (IO)"+ $ forall_masking_states unit_catch_throwTo_masking_state_IO+ , testProperty "catch: throwTo (IOSim)"+ $ forall_masking_states unit_catch_throwTo_masking_state_ST++ , testProperty "catch: throwTo async (IO)"+ $ forall_masking_states unit_catch_throwTo_masking_state_async_IO+ , testProperty "catch: throwTo async (IOSim)"+ $ forall_masking_states unit_catch_throwTo_masking_state_async_ST++ , testProperty "catch: throwTo async blocking (IO)"+ $ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_IO+ , testProperty "catch: throwTo async blocking (IOSim)"+ $ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_ST+ ]+ , testProperty "evaluate unit test" unit_evaluate_0+ , testGroup "forkIO unit tests"+ [ testProperty "1" unit_fork_1+ , testProperty "2" unit_fork_2+ ]+ , testGroup "async exception unit tests"+ [ testProperty "1" unit_async_1+ , testProperty "2" unit_async_2+ , testProperty "3" unit_async_3+ , testProperty "4" unit_async_4+ , testProperty "5" unit_async_5+ , testProperty "6" unit_async_6+ , testProperty "7" unit_async_7+ , testProperty "8" unit_async_8+ , testProperty "9" unit_async_9+ , testProperty "10" unit_async_10+ , testProperty "11" unit_async_11+ , testProperty "12" unit_async_12+ , testProperty "13" unit_async_13+ , testProperty "14" unit_async_14+ , testProperty "15" unit_async_15+ , testProperty "16" unit_async_16+ ]+ , testGroup "STM reference semantics"+ [ testProperty "Reference vs IO" prop_stm_referenceIO+ , testProperty "Reference vs Sim" prop_stm_referenceSim+ ]+ , testGroup "MonadFix instances"+ [ testGroup "IOSim"+ [ testProperty "purity" prop_mfix_purity_IOSim+ , testProperty "purity2" prop_mfix_purity_2+ , testProperty "tightening" prop_mfix_left_shrinking_IOSim+ , testProperty "lazy" prop_mfix_lazy+ , testProperty "recdata" prop_mfix_recdata+ ]+ , testGroup "STM"+ [ testProperty "purity" prop_mfix_purity_STM+ , testProperty "tightening" prop_mfix_left_shrinking_STM+ ]+ ]+ -- NOTE: Most of the tests below only work because the io-sim+ -- scheduler works the way it does.+ , testGroup "MonadTimerCancellable"+ [ testProperty "registerDelayCancellable (IOSim impl)"+ (prop_registerDelayCancellable registerDelayCancellable)+ , testProperty "registerDelayCancellable (IO impl)"+ (prop_registerDelayCancellable $+ defaultRegisterDelayCancellable+ (newTimeout . microsecondsAsIntToDiffTime)+ readTimeout+ cancelTimeout+ awaitTimeout+ )+ ]+ ]++--+-- Read/Write graph+--++prop_stm_graph_io :: TestThreadGraph -> Property+prop_stm_graph_io g =+ ioProperty $+ prop_stm_graph g++prop_stm_graph_sim :: TestThreadGraph -> Bool+prop_stm_graph_sim g =+ case runSim (prop_stm_graph g) of+ Right () -> True+ _ -> False+ -- TODO: Note that we do not use runSimStrictShutdown here to check+ -- that all other threads finished, but perhaps we should and structure+ -- the graph tests so that's the case.++prop_timers_ST :: TestMicro -> Property+prop_timers_ST (TestMicro xs) =+ let ds = map (realToFrac :: Micro -> DiffTime) xs+ in runSimOrThrow $ test_timers ds++prop_timers_IO :: [Positive Int] -> Property+prop_timers_IO = ioProperty . test_timers+ . map (microsecondsToDiffTime . (*100) . getPositive)+ where+ microsecondsToDiffTime :: Int -> DiffTime+ microsecondsToDiffTime = picosecondsToDiffTime . (* 1000000) . toInteger++--+-- Forking+--++prop_fork_order_ST :: Positive Int -> Property+prop_fork_order_ST n = runSimOrThrow $ test_fork_order n++prop_fork_order_IO :: Positive Int -> Property+prop_fork_order_IO = ioProperty . test_fork_order++prop_threadId_order_order_Sim :: Positive Int -> Property+prop_threadId_order_order_Sim n = runSimOrThrow $ test_threadId_order n++prop_wakeup_order_ST :: Property+prop_wakeup_order_ST = runSimOrThrow $ test_wakeup_order++--+-- MonadFix properties+--++-- | Purity demands that @mfix (return . f) = return (fix f)@.+--+prop_mfix_purity_m :: forall m. MonadFix m => Positive Int -> m Bool+prop_mfix_purity_m (Positive n) =+ (== fix factorial n) . ($ n) <$> mfix (return . factorial)+ where+ factorial :: (Int -> Int) -> Int -> Int+ factorial = \rec_ k -> if k <= 1 then 1 else k * rec_ (k - 1)++prop_mfix_purity_IOSim :: Positive Int -> Bool+prop_mfix_purity_IOSim a = runSimOrThrow $ prop_mfix_purity_m a++prop_mfix_purity_STM:: Positive Int -> Bool+prop_mfix_purity_STM a = runSimOrThrow $ atomically $ prop_mfix_purity_m a++prop_mfix_purity_2 :: [Positive Int] -> Bool+prop_mfix_purity_2 as =+ -- note: both 'IOSim' expressions are equivalent using 'Monad' and+ -- 'Applicative' laws only.+ runSimOrThrow (join $ mfix (return . recDelay)+ <*> return as')+ == expected+ &&+ runSimOrThrow (mfix (return . recDelay) >>= ($ as'))+ == expected+ where+ as' :: [Int]+ as' = getPositive `map` as++ -- recursive sum using 'threadDelay'+ recDelay :: MonadDelay m+ => ([Int] -> m Time)+ -> [Int] -> m Time+ recDelay = \rec_ bs ->+ case bs of+ [] -> getMonotonicTime+ (b : bs') -> threadDelay (realToFrac b)+ >> rec_ bs'++ expected :: Time+ expected = foldl' (flip addTime)+ (Time 0)+ (realToFrac `map` as')+++prop_mfix_left_shrinking_IOSim+ :: Int+ -> NonNegative Int+ -> Positive Int+ -> Bool+prop_mfix_left_shrinking_IOSim n (NonNegative d) (Positive i) =+ let mn :: IOSim s Int+ mn = do say ""+ threadDelay (realToFrac d)+ return n+ in+ take i+ (runSimOrThrow $+ mfix (\rec_ -> mn >>= \a -> do+ threadDelay (realToFrac d) $> a : rec_))+ ==+ take i+ (runSimOrThrow $+ mn >>= \a ->+ (mfix (\rec_ -> do+ threadDelay (realToFrac d) $> a : rec_)))+++prop_mfix_left_shrinking_STM+ :: Int+ -> Positive Int+ -> Bool+prop_mfix_left_shrinking_STM n (Positive i) =+ let mn :: STMSim s Int+ mn = do say ""+ return n+ in+ take i+ (runSimOrThrow $ atomically $+ mfix (\rec_ -> mn >>= \a -> return $ a : rec_))+ ==+ take i+ (runSimOrThrow $ atomically $+ mn >>= \a ->+ (mfix (\rec_ -> return $ a : rec_)))++++-- | 'Example 8.2.1' in 'Value Recursion in Monadic Computations'+-- <https://leventerkok.github.io/papers/erkok-thesis.pdf>+--+prop_mfix_lazy :: NonEmptyList Char+ -> Bool+prop_mfix_lazy (NonEmpty env) =+ take samples+ (runSimOrThrow (withEnv (mfix . replicateHeadM)))+ == replicate samples (head env)+ where+ samples :: Int+ samples = 10++ replicateHeadM ::+ (+#if MIN_VERSION_base(4,13,0)+ MonadFail m+#else+ Monad m+#endif+ )+ => m Char+ -> [Char] -> m [Char]+ replicateHeadM getChar_ as = do+ -- Note: 'getChar' will be executed only once! This follows from 'fixIO`+ -- semantics.+ a <- getChar_+ return (a : as)++ -- construct 'getChar' using the simulated environment+ withEnv :: (+#if MIN_VERSION_base(4,13,0)+ MonadFail m,+#endif+ MonadSTM m+ )+ => (m Char -> m a) -> m a+ withEnv k = do+ v <- newTVarIO env+ let getChar_ =+ atomically $ do+ as <- readTVar v+ case as of+ [] -> error "withEnv: runtime error"+ (a : as') -> writeTVar v as'+ $> a+ k getChar_+++-- | 'Example 8.2.3' in 'Value Recursion in Monadic Computations'+-- <https://leventerkok.github.io/papers/erkok-thesis.pdf>+--+prop_mfix_recdata :: Property+prop_mfix_recdata = ioProperty $ do+ expected <- experiment+ let res = runSimOrThrow experiment+ return $+ take samples res+ ==+ take samples expected+ where+ samples :: Int+ samples = 10++ experiment :: ( MonadSTM m+ , MonadFix m+ )+ => m [Int]+ experiment = do+ (_, y) <-+ mfix (\ ~(x, _) -> do+ y <- LazySTM.newTVarIO x+ return (1:x, y)+ )+ atomically (LazySTM.readTVar y)++--+-- Synchronous exceptions+--++unit_catch_0, unit_catch_1, unit_catch_2, unit_catch_3, unit_catch_4,+ unit_catch_5, unit_catch_6,+ unit_fork_1, unit_fork_2+ :: Property++-- unhandled top level exception+unit_catch_0 =+ runSimTraceSay example === ["before"]+ .&&. case traceResult True (runSimTrace example) of+ Left (FailureException e) -> property (maybe False (==DivideByZero) $ fromException e)+ _ -> property False++ where+ example :: IOSim s ()+ example = do+ say "before"+ _ <- throwIO DivideByZero+ say "after"++-- normal execution of a catch frame+unit_catch_1 =+ runSimTraceSay+ (do catch (say "inner") (\(_e :: IOError) -> say "handler")+ say "after"+ )+ ===+ ["inner", "after"]+++-- catching an exception thrown in a catch frame+unit_catch_2 =+ runSimTraceSay+ (do catch (do say "inner1"+ _ <- throwIO DivideByZero+ say "inner2")+ (\(_e :: ArithException) -> say "handler")+ say "after"+ )+ ===+ ["inner1", "handler", "after"]+++-- not catching an exception of the wrong type+unit_catch_3 =+ runSimTraceSay+ (do catch (do say "inner"+ throwIO DivideByZero)+ (\(_e :: IOError) -> say "handler")+ say "after"+ )+ ===+ ["inner"]+++-- catching an exception in an outer handler+unit_catch_4 =+ runSimTraceSay+ (do catch (catch (do say "inner"+ throwIO DivideByZero)+ (\(_e :: IOError) -> say "handler1"))+ (\(_e :: ArithException) -> say "handler2")+ say "after"+ )+ ===+ ["inner", "handler2", "after"]+++-- catching an exception in the inner handler+unit_catch_5 =+ runSimTraceSay+ (do catch (catch (do say "inner"+ throwIO DivideByZero)+ (\(_e :: ArithException) -> say "handler1"))+ (\(_e :: ArithException) -> say "handler2")+ say "after"+ )+ ===+ ["inner", "handler1", "after"]+++-- catching an exception in the inner handler, rethrowing and catching in outer+unit_catch_6 =+ runSimTraceSay+ (do catch (catch (do say "inner"+ throwIO DivideByZero)+ (\(e :: ArithException) -> do+ say "handler1"+ throwIO e))+ (\(_e :: ArithException) -> say "handler2")+ say "after"+ )+ ===+ ["inner", "handler1", "handler2", "after"]+++-- evaluate should catch pure errors+unit_evaluate_0 :: Property+unit_evaluate_0 =+ -- This property also fails if the @error@ is not caught by the sim monad+ -- and instead reaches the QuickCheck driver.+ property $ isLeft $ runSim $ evaluate (error "boom" :: ())+++-- The sim terminates when the main thread terminates+unit_fork_1 =+ runSimTraceSay example === ["parent"]+ .&&. case traceResult True (runSimTrace example) of+ Left FailureSloppyShutdown{} -> property True+ _ -> property False+ where+ example :: IOSim s ()+ example = do+ void $ forkIO $ say "child"+ say "parent"++-- Try works and we can pass exceptions back from threads.+-- And terminating with an exception is reported properly.+unit_fork_2 =+ runSimTraceSay example === ["parent", "user error (oh noes!)"]+ .&&. case traceResult True (runSimTrace example) of+ Left (FailureException e)+ | Just ioe <- fromException e+ , isUserError ioe+ , ioeGetErrorString ioe == "oh noes!" -> property True+ _ -> property False+ where+ example :: IOSim s ()+ example = do+ resVar <- newEmptyTMVarIO+ void $ forkIO $ do+ res <- try (fail "oh noes!")+ atomically (putTMVar resVar (res :: Either SomeException ()))+ say "parent"+ Left e <- atomically (takeTMVar resVar)+ say (show e)+ throwIO e+++--+-- Asyncronous exceptions+--++unit_async_1, unit_async_2, unit_async_3, unit_async_4, unit_async_5,+ unit_async_6, unit_async_7, unit_async_8, unit_async_9, unit_async_10,+ unit_async_11, unit_async_12, unit_async_13, unit_async_14, unit_async_15,+ unit_async_16+ :: Property+++unit_async_1 =+ runSimTraceSay+ (do mtid <- myThreadId+ say ("main " ++ show mtid)+ ctid <- forkIO $ do tid <- myThreadId+ say ("child " ++ show tid)+ say ("parent " ++ show ctid)+ threadDelay 1+ )+ ===+ ["main ThreadId []", "parent ThreadId [1]", "child ThreadId [1]"]+++unit_async_2 =+ runSimTraceSay+ (do tid <- myThreadId+ say "before"+ throwTo tid DivideByZero+ say "after"+ )+ ===+ ["before"]+++unit_async_3 =+ runSimTraceSay+ (do tid <- myThreadId+ catch (do say "before"+ throwTo tid DivideByZero+ say "never")+ (\(_e :: ArithException) -> say "handler"))+ ===+ ["before", "handler"]+++unit_async_4 =+ runSimTraceSay+ (do tid <- forkIO $ say "child"+ threadDelay 1+ -- child has already terminated when we throw the async exception+ throwTo tid DivideByZero+ say "parent done")+ ===+ ["child", "parent done"]+++unit_async_5 =+ runSimTraceSay+ (do tid <- forkIO $ do+ say "child"+ catch (atomically retry)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "handler", "child done", "parent done"]+++unit_async_6 =+ runSimTraceSay+ (do tid <- forkIO $ mask_ $+ do+ say "child"+ threadDelay 1+ say "child masked"+ -- while masked, do a blocking (interruptible) operation+ catch (atomically retry)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "child masked", "handler", "child done", "parent done"]+++unit_async_7 =+ runSimTraceSay+ (do tid <- forkIO $+ mask $ \restore -> do+ say "child"+ threadDelay 1+ say "child masked"+ -- restore mask state, allowing interrupt+ catch (restore (say "never"))+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "child masked", "handler", "child done", "parent done"]+++unit_async_8 =+ runSimTraceSay+ (do tid <- forkIO $ do+ catch (do mask_ $ do+ say "child"+ threadDelay 1+ say "child masked"+ -- exception raised when we leave mask frame+ say "child unmasked")+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "child masked", "handler", "child done", "parent done"]+++unit_async_9 =+ runSimTraceSay+ (do tid <- forkIO $+ mask_ $ do+ say "child"+ threadDelay 1+ fail "oh noes!"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ -- throwTo blocks but then unblocks because the child dies+ say "parent done")+ ===+ ["child", "parent done"]+++unit_async_10 =+ runSimTraceSay+ (do tid1 <- forkIO $ do+ mask_ $ do+ threadDelay 1+ say "child 1"+ yield+ say "child 1 running"+ say "never 1"+ tid2 <- forkIO $ do+ threadDelay 1+ say "child 2"+ -- this one blocks, since child 1 is running with+ -- async exceptions masked+ throwTo tid1 DivideByZero+ say "never 2"+ threadDelay 1+ yield+ -- this one does not block, child 2 does not have exceptions+ -- masked (and it is blocked in an interruptible throwTo)+ throwTo tid2 DivideByZero+ threadDelay 1+ say "parent done"+ )+ ===+ ["child 1", "child 2", "child 1 running", "parent done"]+++unit_async_11 =+ runSimTraceSay+ (do tid1 <- forkIO $ do+ mask_ $ do+ threadDelay 1+ say "child 1"+ yield+ say "child 1 running"+ say "never 1"+ tid2 <- forkIO $+ -- Same as unit_async_10 but we run masked here+ -- this is subtle: when the main thread throws the+ -- exception it raises the exception here even though+ -- it is masked because this thread is blocked in the+ -- throwTo and so is interruptible.+ mask_ $ do+ threadDelay 1+ say "child 2"+ throwTo tid1 DivideByZero+ say "never 2"+ threadDelay 1+ yield+ -- this one does not block, even though child 2 has exceptions+ -- masked, since it is blocked in an interruptible throwTo+ throwTo tid2 DivideByZero+ threadDelay 1+ say "parent done"+ )+ ===+ ["child 1", "child 2", "child 1 running", "parent done"]+++unit_async_12 =+ runSimTraceSay+ (do tid <- forkIO $ do+ uninterruptibleMask_ $ do+ say "child"+ threadDelay 1+ say "child masked"+ -- while masked, do a blocking (interruptible) operation+ catch (threadDelay 1)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ say "never"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "child masked", "child done", "parent done"]+++unit_async_13 =+ case runSim+ (uninterruptibleMask_ $ do+ tid <- forkIO $ atomically retry+ throwTo tid DivideByZero)+ of Left FailureDeadlock {} -> property True+ _ -> property False+++unit_async_14 =+ runSimTraceSay+ (do tid <- forkIO $ do+ uninterruptibleMask_ $ do+ say "child"+ threadDelay 1+ say "child masked"+ -- while masked do a blocking operation, but this is+ -- an uninterruptible mask so nothing happens+ catch (threadDelay 1)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ say "never"+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "child masked", "child done", "parent done"]+++unit_async_15 =+ runSimTraceSay+ (do tid <- forkIO $+ uninterruptibleMask $ \restore -> do+ say "child"+ threadDelay 1+ say "child masked"+ -- restore mask state, allowing interrupt+ catch (restore (say "never"))+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "child masked", "handler", "child done", "parent done"]+++unit_async_16 =+ runSimTraceSay+ (do tid <- forkIO $ do+ catch (do uninterruptibleMask_ $ do+ say "child"+ threadDelay 1+ say "child masked"+ -- exception raised when we leave mask frame+ say "child unmasked")+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done")+ ===+ ["child", "child masked", "handler", "child done", "parent done"]+++--+-- Tests vs STM operational semantics+--++-- | Compare the behaviour of the STM reference operational semantics with+-- the behaviour of the real IO STM implementation.+--+prop_stm_referenceIO :: SomeTerm -> Property+prop_stm_referenceIO t =+ ioProperty (prop_stm_referenceM t)++-- | Compare the behaviour of the STM reference operational semantics with+-- the behaviour of the IO simulator's STM implementation.+--+prop_stm_referenceSim :: SomeTerm -> Property+prop_stm_referenceSim t =+ runSimOrThrow (prop_stm_referenceM t)++--+-- MonadTimer+--++prop_timeout_no_deadlock_Sim :: Bool+prop_timeout_no_deadlock_Sim = runSimOrThrow prop_timeout_no_deadlockM++prop_timeout_no_deadlock_IO :: Property+prop_timeout_no_deadlock_IO = ioProperty prop_timeout_no_deadlockM++type TimeoutDuration = DiffTime+type ActionDuration = DiffTime+type TimeoutConstraints m =+ ( MonadAsync m+ , MonadDelay m+ , MonadFork m+ , MonadTime m+ , MonadTimer m+ , MonadMask m+ , MonadThrow (STM m)+ , MonadSay m+ , MonadMaskingState m+ )++instance Arbitrary DiffTime where+ arbitrary = millisecondsToDiffTime <$>+ frequency+ [ (4, choose (0, 5))+ , (1, choose (5, 10))+ ]+ where+ millisecondsToDiffTime = picosecondsToDiffTime . (* 1_000_000_000)++ shrink = map (fromRational . getNonNegative)+ . shrink+ . NonNegative+ . toRational++singleTimeoutExperiment+ :: TimeoutConstraints m+ => TimeoutDuration+ -> ActionDuration+ -> m (WithSanityCheck Property)+singleTimeoutExperiment intendedTimeoutDuration+ intendedActionDuration = do++ before <- getMonotonicTime++ -- Allow the action to run for intendedTimeoutDuration+ result <- timeout intendedTimeoutDuration $ do++ getMaskingState >>= say . show+ -- Simulate an action that should take intendedActionDuration+ threadDelay intendedActionDuration++ -- but we also measure the actual duration+ getMonotonicTime++ after <- getMonotonicTime++ return $ experimentResult intendedTimeoutDuration+ intendedActionDuration+ before after result++data WithSanityCheck prop+ = WithSanityCheck prop++ -- | The first one represents the property without sanity check, the other one+ -- sanity check (which failed). It is kept to keep its `counterexample`s.+ | WithSanityCheckFailure prop prop+ deriving (Functor)++ignoreSanityCheck :: WithSanityCheck prop -> prop+ignoreSanityCheck (WithSanityCheck prop) = prop+ignoreSanityCheck (WithSanityCheckFailure prop _) = prop++withSanityCheck :: WithSanityCheck Property -> Property+withSanityCheck (WithSanityCheck prop) = prop+withSanityCheck (WithSanityCheckFailure prop sanityCheck) = prop .&&. sanityCheck++isSanityCheckIgnored :: WithSanityCheck prop -> Bool+isSanityCheckIgnored WithSanityCheck{} = False+isSanityCheckIgnored WithSanityCheckFailure {} = True+++experimentResult :: TimeoutDuration+ -> ActionDuration+ -> Time+ -> Time+ -> Maybe Time+ -> WithSanityCheck Property+experimentResult intendedTimeoutDuration+ intendedActionDuration+ before after result =+ counterexamples+ [ "intendedTimeoutDuration: " ++ show intendedTimeoutDuration+ , "intendedActionDuration: " ++ show intendedActionDuration+ , "actualOverallDuration: " ++ show actualOverallDuration+ ] <$>+ if ignoredSanityCheck+ then WithSanityCheckFailure timeoutCheck sanityCheck+ else WithSanityCheck $ sanityCheck .&&. timeoutCheck+ where+ actualOverallDuration = diffTime after before+ intendedOverallDuration = min intendedTimeoutDuration intendedActionDuration++ ignoredSanityCheck =+ actualOverallDuration < intendedOverallDuration+ || actualOverallDuration > intendedOverallDuration++ sanityCheck = counterexample "sanityCheckLow" sanityCheckLow+ .&&. counterexample "sanityCheckHigh" sanityCheckHigh++ sanityCheckLow =+ actualOverallDuration >= intendedOverallDuration++ sanityCheckHigh =+ actualOverallDuration <= intendedOverallDuration++ timeoutCheck =+ case result of+ Nothing ->+ counterexamples+ [ "timeout fired (but should not have)"+ , "violation of timeout property:\n" +++ " actualOverallDuration >= intendedTimeoutDuration"+ ] $+ actualOverallDuration >= intendedTimeoutDuration++ Just afterAction ->+ let actualActionDuration = diffTime afterAction before in+ counterexamples+ [ "actualActionDuration: " ++ show actualActionDuration+ , "timeout did not fire (but should not have)"+ , "violation of timeout property:\n" +++ " actualActionDuration <= intendedTimeoutDuration"+ ] $+ actualActionDuration <= intendedActionDuration+++prop_timeout+ :: TimeoutDuration+ -> ActionDuration+ -> Property+prop_timeout intendedTimeoutDuration intendedActionDuration = + runSimOrThrow (withSanityCheck <$>+ singleTimeoutExperiment+ intendedTimeoutDuration+ intendedActionDuration)+++prop_timeouts+ :: [(TimeoutDuration, ActionDuration)]+ -> Property+prop_timeouts times =+ counterexample (ppTrace_ trace) $+ either (\e -> counterexample (show e) False) id $+ traceResult False trace+ where+ trace =+ runSimTrace $+ conjoin' <$>+ sequence+ [ fmap (counterexample ("failure on timeout test #" ++ show n))+ <$> singleTimeoutExperiment intendedTimeoutDuration+ intendedActionDuration+ | ((intendedTimeoutDuration,+ intendedActionDuration), n) <- zip times [1 :: Int ..] ]++ maxFailures = 0++ conjoin' :: [WithSanityCheck Property] -> Property+ conjoin' props =+ conjoin (ignoreSanityCheck `map` props)+ .&&. let numFailures = length (filter isSanityCheckIgnored props)+ in counterexample+ ("too many failures: " ++ show numFailures ++ " ≰ " ++ show maxFailures)+ (numFailures <= maxFailures)+++prop_stacked_timeouts :: TimeoutDuration+ -> TimeoutDuration+ -> ActionDuration+ -> Property+prop_stacked_timeouts timeout0 timeout1 actionDuration =+ let trace = runSimTrace experiment in+ counterexample (ppTrace_ trace) $+ either (\e -> counterexample (show e) False) (=== predicted) (traceResult False trace)+ where+ experiment :: IOSim s (Maybe (Maybe ()))+ experiment = timeout timeout0 (timeout timeout1 (threadDelay actionDuration))++ predicted | timeout0 == 0+ = Nothing++ | timeout1 == 0+ = Just Nothing++ | actionDuration <= min timeout0 timeout1+ = Just (Just ())++ | timeout0 < timeout1+ = Nothing++ | otherwise -- i.e. timeout0 >= timeout1+ = Just Nothing+++unit_timeouts_and_async_exceptions_1 :: Property+unit_timeouts_and_async_exceptions_1 =+ let trace = runSimTrace experiment in+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ delay = 1++ experiment :: IOSim s Property+ experiment = do+ tid <- forkIO $ void $+ timeout delay (atomically retry)++ threadDelay (delay / 2)+ killThread tid+ threadDelay 1+ return $ property True +++unit_timeouts_and_async_exceptions_2 :: Property+unit_timeouts_and_async_exceptions_2 =+ let trace = runSimTrace experiment in+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ delay = 1++ experiment :: IOSim s Property+ experiment = do+ tid <- forkIO $ void $+ timeout delay (atomically retry) `catch` (\(_ :: AsyncException) -> return Nothing)++ threadDelay (delay / 2)+ killThread tid+ threadDelay 1+ return $ property True +++unit_timeouts_and_async_exceptions_3 :: Property+unit_timeouts_and_async_exceptions_3 =+ let trace = runSimTrace experiment in+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ delay = 1++ experiment :: IOSim s Property+ experiment = do+ tid <- forkIO $ void $+ timeout delay (atomically retry `catch` (\(_ :: AsyncException) -> return ()))++ threadDelay (delay / 2)+ killThread tid+ threadDelay 1+ return $ property True +++-- | Verify that a thread blocked on `threadDelay` is not unblocked by an STM+-- transaction.+--+unit_threadDelay_and_stm :: Property+unit_threadDelay_and_stm =+ let trace = runSimTrace experiment in+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ experiment :: IOSim s Property+ experiment = do+ v0 <- newTVarIO False+ v1 <- newTVarIO False++ _ <- forkIO $ do+ threadDelay 1+ atomically $ writeTVar v0 True+ atomically $ (readTVar v1 >>= check) `orElse` (readTVar v0 >>= check)++ let delay = 2+ t0 <- getMonotonicTime+ _ <- forkIO $ do+ threadDelay 1+ atomically $ writeTVar v1 True+ threadDelay delay+ t1 <- getMonotonicTime++ return (t1 `diffTime` t0 === delay)+++-- | Verify that a thread blocked on `throwTo` is not unblocked by an STM+-- transaction.+--+unit_throwTo_and_stm :: Property+unit_throwTo_and_stm =+ let trace = runSimTrace experiment in+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ experiment :: IOSim s Property+ experiment = do+ v0 <- newTVarIO False+ v1 <- newTVarIO False++ _ <- forkIO $ do+ threadDelay 1+ atomically $ writeTVar v0 True+ atomically $ (readTVar v1 >>= check) `orElse` (readTVar v0 >>= check)++ let delay = 2+ t0 <- getMonotonicTime+ _ <- forkIO $ do+ threadDelay 1+ atomically $ writeTVar v1 True+ tid <- forkIO $ uninterruptibleMask_ (threadDelay 2)+ threadDelay 0.1 -- make sure the other thread masks exceptions+ killThread tid+ t1 <- getMonotonicTime++ return (t1 `diffTime` t0 === delay)++--+-- MonadMask properties+--++unit_set_masking_state_IO :: MaskingState -> Property+unit_set_masking_state_IO =+ ioProperty . prop_set_masking_state++unit_set_masking_state_ST :: MaskingState -> Property+unit_set_masking_state_ST ms =+ runSimOrThrow (prop_set_masking_state ms)++unit_unmask_IO :: MaskingState -> MaskingState -> Property+unit_unmask_IO ms ms' = ioProperty $ prop_unmask ms ms'++unit_unmask_ST :: MaskingState -> MaskingState -> Property+unit_unmask_ST ms ms' = runSimOrThrow $ prop_unmask ms ms'++unit_fork_masking_state_IO :: MaskingState -> Property+unit_fork_masking_state_IO =+ ioProperty . prop_fork_masking_state++unit_fork_masking_state_ST :: MaskingState -> Property+unit_fork_masking_state_ST ms =+ runSimOrThrow (prop_fork_masking_state ms)++unit_fork_unmask_IO :: MaskingState -> MaskingState -> Property+unit_fork_unmask_IO ms ms' = ioProperty $ prop_fork_unmask ms ms'++unit_fork_unmask_ST :: MaskingState -> MaskingState -> Property+unit_fork_unmask_ST ms ms' = runSimOrThrow $ prop_fork_unmask ms ms'++unit_catch_throwIO_masking_state_IO :: MaskingState -> Property+unit_catch_throwIO_masking_state_IO ms =+ ioProperty $ prop_catch_throwIO_masking_state ms++unit_catch_throwIO_masking_state_ST :: MaskingState -> Property+unit_catch_throwIO_masking_state_ST ms =+ runSimOrThrow (prop_catch_throwIO_masking_state ms)++unit_catch_throwTo_masking_state_IO :: MaskingState -> Property+unit_catch_throwTo_masking_state_IO =+ ioProperty . prop_catch_throwTo_masking_state++unit_catch_throwTo_masking_state_ST :: MaskingState -> Property+unit_catch_throwTo_masking_state_ST ms =+ runSimOrThrow $ prop_catch_throwTo_masking_state ms++unit_catch_throwTo_masking_state_async_IO :: MaskingState -> Property+unit_catch_throwTo_masking_state_async_IO =+ ioProperty . prop_catch_throwTo_masking_state_async++unit_catch_throwTo_masking_state_async_ST :: MaskingState -> Property+unit_catch_throwTo_masking_state_async_ST ms =+ runSimOrThrow (prop_catch_throwTo_masking_state_async ms)++unit_catch_throwTo_masking_state_async_mayblock_IO :: MaskingState -> Property+unit_catch_throwTo_masking_state_async_mayblock_IO =+ ioProperty . prop_catch_throwTo_masking_state_async_mayblock++unit_catch_throwTo_masking_state_async_mayblock_ST :: MaskingState -> Property+unit_catch_throwTo_masking_state_async_mayblock_ST ms =+ runSimOrThrow (prop_catch_throwTo_masking_state_async_mayblock ms)++--+-- MonadTimerCancellable+--++data DelayWithCancel = DelayWithCancel DiffTime (Maybe DiffTime)+ deriving Show++instance Arbitrary DelayWithCancel where+ arbitrary =+ oneof+ [ -- small delay+ (\delay -> DelayWithCancel+ (microsecondsAsIntToDiffTime delay)+ Nothing)+ <$> arbitrary+ -- cancelled delay after small delay+ , (\delay -> DelayWithCancel+ (microsecondsAsIntToDiffTime delay + maxDelay)+ Nothing)+ <$> arbitrary++ , -- large delay+ do delay <- arbitrary+ cancel_ <- arbitrary `suchThat` (<= delay)+ return (DelayWithCancel (microsecondsAsIntToDiffTime delay)+ (Just (microsecondsAsIntToDiffTime cancel_)))+ , -- cancelled delay after large delay+ do delay <- arbitrary+ cancel_ <- arbitrary `suchThat` (<= delay)+ return (DelayWithCancel (microsecondsAsIntToDiffTime delay + maxDelay)+ (Just (microsecondsAsIntToDiffTime cancel_ + maxDelay)))+ ]+ where+ maxDelay :: DiffTime+ maxDelay = microsecondsAsIntToDiffTime maxBound++prop_registerDelayCancellable+ :: (forall s. DiffTime -> IOSim s (STM (IOSim s) TimeoutState, IOSim s ()))+ -- ^ implementation + -> DelayWithCancel+ -> Property+prop_registerDelayCancellable registerDelayCancellableImpl+ (DelayWithCancel delay mbCancel) =+ -- 'within' covers the case where `registerDelayCancellable` would not+ -- make progress awaiting for the timeout (a live lock).+ within 1000 $+ let trace = runSimTrace sim+ in case traceResult True trace of+ Left err -> counterexample (ppTrace trace)+ . counterexample (show err)+ $ False+ Right (_, r) -> counterexample (ppTrace trace) r+ where+ sim :: IOSim s (Maybe TimeoutState, Bool)+ sim = do+ (readTimeout_, cancelTimeout_) <- registerDelayCancellableImpl delay+ case mbCancel of++ Nothing -> do+ atomically $ do+ tv <- readTimeout_+ case tv of+ TimeoutFired -> return ()+ TimeoutPending -> retry+ TimeoutCancelled -> return ()+ t <- getMonotonicTime+ return (Nothing, t == Time (delay `max` 0))++ Just cancelDelay -> do+ threadDelay cancelDelay+ cancelTimeout_+ tv <- atomically readTimeout_+ return $ case () of+ _ | delay < cancelDelay -> (Just tv, tv == TimeoutFired)+ | delay == cancelDelay -> (Just tv, tv == TimeoutFired+ || tv == TimeoutCancelled)+ | otherwise -> (Just tv, tv == TimeoutCancelled)++--+-- Utils+--++counterexamples :: Testable t => [String] -> t -> Property+counterexamples [] p = property p+counterexamples (c:cs) p = counterexample c (counterexamples cs p)
+ test/Test/Control/Monad/IOSimPOR.hs view
@@ -0,0 +1,1031 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-unused-top-binds #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Test.Control.Monad.IOSimPOR (tests) where++import Data.Fixed (Micro)+import Data.Foldable (foldl')+import Data.Functor (($>))+import Data.IORef+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map++import System.Exit+import System.IO.Error (ioeGetErrorString, isUserError)+import System.IO.Unsafe++import Control.Exception (ArithException (..), AsyncException)+import Control.Monad+import Control.Monad.Fix+import Control.Parallel++import Control.Monad.Class.MonadFork+import Control.Concurrent.Class.MonadSTM+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadTest+import Control.Monad.Class.MonadThrow+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer.SI+import Control.Monad.IOSim++import GHC.Generics++import Test.Control.Monad.IOSim (TimeoutDuration, ActionDuration,+ WithSanityCheck (..), ignoreSanityCheck,+ isSanityCheckIgnored, singleTimeoutExperiment,+ withSanityCheck)+import Test.Control.Monad.Utils+import Test.Control.Monad.STM++import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck++tests :: TestTree+tests =+ testGroup "IO simulator POR"+ [ testProperty "propSimulates" propSimulates+ , testProperty "propExploration" propExploration+ -- , testProperty "propPermutations" propPermutations+ , testGroup "IO simulator properties"+ [ testProperty "read/write graph (IOSim)" (withMaxSuccess 1000 prop_stm_graph_sim)+ , testGroup "timeouts"+ [ testProperty "IOSim" (withMaxSuccess 1000 prop_timers_ST)+ , testProperty "IOSim: no deadlock" prop_timeout_no_deadlock_Sim+ , testProperty "timeout" prop_timeout+ , testProperty "timeouts" prop_timeouts+ , testProperty "stacked timeouts" prop_stacked_timeouts+ ]+ , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim)+ , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST)+ , testGroup "throw/catch unit tests"+ [ testProperty "0" unit_catch_0+ , testProperty "1" unit_catch_1+ , testProperty "2" unit_catch_2+ , testProperty "3" unit_catch_3+ , testProperty "4" unit_catch_4+ , testProperty "5" unit_catch_5+ , testProperty "6" unit_catch_6+ ]+ , testGroup "masking state"+ [ testProperty "set (IOSim)"+ $ forall_masking_states unit_set_masking_state_ST++ , testProperty "unmask (IOSim)"+ $ forall_masking_states $ \ms ->+ forall_masking_states $ \ms' -> unit_unmask_ST ms ms'++ , testProperty "fork (IOSim)"+ $ forall_masking_states unit_fork_masking_state_ST++ , testProperty "fork unmask (IOSim)"+ $ forall_masking_states $ \ms ->+ forall_masking_states $ \ms' -> unit_fork_unmask_ST ms ms'++ , testProperty "catch (IOSim)"+ $ forall_masking_states unit_catch_throwIO_masking_state_ST++ , testProperty "catch: throwTo (IOSim)"+ $ forall_masking_states unit_catch_throwTo_masking_state_ST++ , testProperty "catch: throwTo async (IOSim)"+ $ forall_masking_states unit_catch_throwTo_masking_state_async_ST++ , testProperty "catch: throwTo async blocking (IOSim)"+ $ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_ST+ ]+ , testProperty "evaluate unit test" unit_evaluate_0+ , testGroup "forkIO unit tests"+ [ testProperty "1" unit_fork_1+ ]+ , testGroup "async exception unit tests"+ [ testProperty "1" unit_async_1+ , testProperty "3" unit_async_3+ , testProperty "4" unit_async_4+ , testProperty "5" unit_async_5+ , testProperty "6" unit_async_6+ , testProperty "7" unit_async_7+ , testProperty "8" unit_async_8+ , testProperty "9" unit_async_9+ ]+ , testGroup "STM reference semantics"+ [ testProperty "Reference vs Sim" prop_stm_referenceSim+ ]+ , testGroup "MonadFix instance"+ [ testProperty "purity" prop_mfix_purity+ , testProperty "purity2" prop_mfix_purity_2+ , testProperty "tightening" prop_mfix_left_shrinking+ , testProperty "lazy" prop_mfix_lazy+ ]+ ]+ ]++data Step =+ WhenSet Int Int+ | ThrowTo Int+ | Delay Int+ | Timeout TimeoutStep+ deriving (Eq, Ord, Show)++data TimeoutStep =+ NewTimeout Int+ | CancelTimeout+ | AwaitTimeout+ deriving (Eq, Ord, Show, Generic)++instance Arbitrary Step where+ arbitrary = frequency [(5,do m <- choose (1,20)+ n <- choose (0,m)+ return $ WhenSet m n),+ (1,do NonNegative i <- arbitrary+ return $ ThrowTo i),+ (1,do Positive i <- arbitrary+ return $ Delay i),+ (1,Timeout <$> arbitrary)]++ shrink (WhenSet m n) = map (WhenSet m) (shrink n) +++ map (`WhenSet` n) (filter (>=n) (shrink m))+ shrink (ThrowTo i) = map ThrowTo (shrink i)+ shrink (Delay i) = map Delay (shrink i)+ shrink (Timeout t) = map Timeout (shrink t)++instance Arbitrary TimeoutStep where+ arbitrary = do Positive i <- arbitrary+ frequency $ map (fmap return) $+ [(3,NewTimeout i),+ (1,CancelTimeout),+ (3,AwaitTimeout)]++ shrink = genericShrink+++newtype Task = Task [Step]+ deriving (Eq, Ord, Show)++instance Arbitrary Task where+ arbitrary = do+ steps <- arbitrary+ return . Task $ normalize steps+ shrink (Task steps) =+ (Task <$> compressSteps steps) +++ (Task . normalize <$> shrink steps)++normalize :: [Step] -> [Step]+normalize steps = plug steps wsSteps 1000000+ where wsSteps = reverse $ List.sort [s | s@(WhenSet _ _) <- steps]+ plug [] [] _ = []+ plug (WhenSet _ _:s) (WhenSet a b:ws) m = WhenSet (min a m) (min b m):plug s ws (min b m)+ plug (step:s) ws m = step:plug s ws m+ plug _ _ _ = error "plug: impossible"++compressSteps :: [Step] -> [[Step]]+compressSteps (WhenSet a b:WhenSet c d:steps) =+ [WhenSet a d:steps] ++ ((WhenSet a b:) <$> compressSteps (WhenSet c d:steps))+compressSteps (s:steps) = (s:) <$> compressSteps steps+compressSteps [] = []++newtype Tasks = Tasks [Task]+ deriving Show++instance Arbitrary Tasks where+ arbitrary = Tasks . fixSymbolicThreadIds <$> scale (min 20) arbitrary+ shrink (Tasks ts) = Tasks . fixSymbolicThreadIds <$>+ removeTask ts +++ shrink ts +++ shrinkDelays ts +++ advanceThrowTo ts +++ sortTasks ts++fixSymbolicThreadIds :: [Task] -> [Task]+fixSymbolicThreadIds tasks = mapSymThreadIds (`mod` length tasks) tasks++shrinkDelays :: [Task] -> [[Task]]+shrinkDelays tasks+ | null times = []+ | otherwise = [map (Task . removeTime d) [steps | Task steps <- tasks]+ | d <- times]+ where times = foldr List.union [] [scanl1 (+) [d | Delay d <- t] | Task t <- tasks]+ removeTime 0 steps = steps+ removeTime _ [] = []+ removeTime d (Delay d':steps)+ | d==d' = steps+ | d< d' = Delay (d'-d):steps+ | d> d' = removeTime (d-d') steps+ removeTime d (s:steps) =+ s:removeTime d steps++removeTask :: [Task] -> [[Task]]+removeTask tasks =+ [ mapThrowTos (fixup i) . map (dontThrowTo i) $ take i tasks++drop (i+1) tasks+ | i <- [0..length tasks-1]]+ where fixup i j | j>i = j-1+ | otherwise = j+ dontThrowTo i (Task steps) = Task (filter (/=ThrowTo i) steps)++advanceThrowTo :: [Task] -> [[Task]]+advanceThrowTo [] = []+advanceThrowTo (Task steps:ts) =+ ((:ts) . Task <$> advance steps) +++ ((Task steps:) <$> advanceThrowTo ts)+ where advance (WhenSet a b:ThrowTo i:steppes) =+ [ThrowTo i:WhenSet a b:steppes] ++ (([WhenSet a b,ThrowTo i]++) <$> advance steppes)+ advance (s:steppes) = (s:) <$> advance steppes+ advance [] = []++mapSymThreadIds :: (Int -> Int) -> [Task] -> [Task]+mapSymThreadIds f tasks = map mapTask tasks+ where mapTask (Task steps) = Task (map mapStep steps)+ mapStep (ThrowTo i) = ThrowTo (f i)+ mapStep s = s++mapThrowTos :: (Int -> Int) -> [Task] -> [Task]+mapThrowTos f tasks = map mapTask tasks+ where mapTask (Task steps) = Task (map mapStep steps)+ mapStep (ThrowTo i) = ThrowTo (f i)+ mapStep s = s++sortTasks :: Ord a => [a] -> [[a]]+sortTasks (x:y:xs) | x>y = [y:x:xs] ++ ((x:) <$> sortTasks (y:xs))+sortTasks (x:xs) = (x:) <$> sortTasks xs+sortTasks [] = []++interpret :: forall s. TVar (IOSim s) Int -> TVar (IOSim s) [ThreadId (IOSim s)] -> Task -> IOSim s (ThreadId (IOSim s))+interpret r t (Task steps) = forkIO $ do+ context <- atomically $ do+ ts <- readTVar t+ when (null ts) retry+ timer <- newTVar Nothing+ return (ts,timer)+ mapM_ (interpretStep context) steps+ where interpretStep _ (WhenSet m n) = atomically $ do+ a <- readTVar r+ when (a/=m) retry+ writeTVar r n+ interpretStep (ts,_) (ThrowTo i) = throwTo (ts !! i) (ExitFailure 0)+ interpretStep _ (Delay i) = threadDelay (fromIntegral i)+ interpretStep (_,timer) (Timeout tstep) = do+ timerVal <- atomically $ readTVar timer+ case (timerVal,tstep) of+ (_,NewTimeout n) -> do tout <- newTimeout (fromIntegral n)+ atomically $ writeTVar timer (Just tout)+ (Just tout,CancelTimeout) -> cancelTimeout tout+ (Just tout,AwaitTimeout) -> atomically $ awaitTimeout tout >> return ()+ (Nothing,_) -> return ()++runTasks :: [Task] -> IOSim s (Int,Int)+runTasks tasks = do+ let m = maximum [maxTaskValue t | Task t <- tasks]+ r <- atomically $ newTVar m+ t <- atomically $ newTVar []+ exploreRaces+ ts <- mapM (interpret r t) tasks+ atomically $ writeTVar t ts+ threadDelay 1000000000 -- allow the SUT threads to run+ a <- atomically $ readTVar r+ return (m,a)++maxTaskValue :: [Step] -> Int+maxTaskValue (WhenSet m _:_) = m+maxTaskValue (_:t) = maxTaskValue t+maxTaskValue [] = 0++propSimulates :: Tasks -> Property+propSimulates (Tasks tasks) =+ any (not . null . (\(Task steps)->steps)) tasks ==>+ let Right (m,a) = runSim (runTasks tasks) in+ m>=a++propExploration :: Tasks -> Property+propExploration (Tasks tasks) =+ -- Debug.trace ("\nTasks:\n"++ show tasks) $+ any (not . null . (\(Task steps)->steps)) tasks ==>+ traceNoDuplicates $ \addTrace ->+ --traceCounter $ \addTrace ->+ exploreSimTrace id (runTasks tasks) $ \_ trace ->+ --Debug.trace (("\nTrace:\n"++) . splitTrace . noExceptions $ show trace) $+ addTrace trace $+ counterexample (splitTrace . noExceptions $ show trace) $+ case traceResult False trace of+ Right (m,a) -> property $ m>=a+ Left e -> counterexample (show e) False++-- Testing propPermutations n should collect every permutation of [1..n] once only.+-- Test manually, and supply a small value of n.+propPermutations :: Int -> Property+propPermutations n =+ traceNoDuplicates $ \addTrace ->+ exploreSimTrace (withScheduleBound 10000) (doit n) $ \_ trace ->+ addTrace trace $+ let Right result = traceResult False trace in+ tabulate "Result" [noExceptions $ show $ result] $+ True++doit :: Int -> IOSim s [Int]+doit n = do+ r <- atomically $ newTVar []+ exploreRaces+ mapM_ (\i -> forkIO $ atomically $ modifyTVar r (++[i])) [1..n]+ threadDelay 1+ atomically $ readTVar r++ordered :: Ord a => [a] -> Bool+ordered xs = and (zipWith (<) xs (drop 1 xs))++noExceptions :: [Char] -> [Char]+noExceptions xs = unsafePerformIO $ try (evaluate xs) >>= \case+ Right [] -> return []+ Right (x:ys) -> return (x:noExceptions ys)+ Left e -> return ("\n"++show (e :: SomeException))++splitTrace :: [Char] -> [Char]+splitTrace [] = []+splitTrace (x:xs) | begins "(Trace" = "\n(" ++ splitTrace xs+ | otherwise = x:splitTrace xs+ where begins s = take (length s) (x:xs) == s++traceCounter :: (Testable prop1, Show a1) => ((a1 -> a2 -> a2) -> prop1) -> Property+traceCounter k = r `pseq` (k addTrace .&&.+ tabulate "Trace repetitions" (map show $ traceCounts ()) True)+ where+ r = unsafePerformIO $ newIORef (Map.empty :: Map String Int)+ addTrace t x = unsafePerformIO $ do+ atomicModifyIORef r (\m->(Map.insertWith (+) (show t) 1 m,()))+ return x+ traceCounts () = unsafePerformIO $ Map.elems <$> readIORef r++traceNoDuplicates :: (Testable prop1, Show a1) => ((a1 -> a2 -> a2) -> prop1) -> Property+traceNoDuplicates k = r `pseq` (k addTrace .&&. maximum (traceCounts ()) == 1)+ where+ r = unsafePerformIO $ newIORef (Map.empty :: Map String Int)+ addTrace t x = unsafePerformIO $ do+ atomicModifyIORef r (\m->(Map.insertWith (+) (show t) 1 m,()))+ return x+ traceCounts () = unsafePerformIO $ Map.elems <$> readIORef r++--+-- IOSim reused properties+--+++--+-- Read/Write graph+--++prop_stm_graph_sim :: TestThreadGraph -> Property+prop_stm_graph_sim g =+ traceNoDuplicates $ \addTrace ->+ exploreSimTrace id (prop_stm_graph g) $ \_ trace ->+ addTrace trace $+ counterexample (splitTrace . noExceptions $ show trace) $+ case traceResult False trace of+ Right () -> property True+ Left e -> counterexample (show e) False+ -- TODO: Note that we do not use runSimStrictShutdown here to check+ -- that all other threads finished, but perhaps we should and structure+ -- the graph tests so that's the case.++prop_timers_ST :: TestMicro -> Property+prop_timers_ST (TestMicro xs) =+ let ds = map (realToFrac :: Micro -> DiffTime) xs+ in exploreSimTrace id (test_timers ds) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++--+-- Forking+--++prop_fork_order_ST :: Positive Int -> Property+prop_fork_order_ST n =+ exploreSimTrace id (test_fork_order n) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++prop_threadId_order_order_Sim :: Positive Int -> Property+prop_threadId_order_order_Sim n =+ exploreSimTrace id (test_threadId_order n) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++--+-- MonadFix properties+--++-- | Purity demands that @mfix (return . f) = return (fix f)@.+--+prop_mfix_purity :: Positive Int -> Property+prop_mfix_purity (Positive n) =+ exploreSimTrace id (mfix (return . factorial)) $ \_ trace ->+ case traceResult False trace of+ Right f -> f n === fix factorial n+ Left e -> counterexample (show e) False+ where+ factorial :: (Int -> Int) -> Int -> Int+ factorial = \rec_ k -> if k <= 1 then 1 else k * rec_ (k - 1)++prop_mfix_purity_2 :: [Positive Int] -> Property+prop_mfix_purity_2 as =+ -- note: both 'IOSim' expressions are equivalent using 'Monad' and+ -- 'Applicative' laws only.+ exploreSimTrace id (join $ mfix (return . recDelay)+ <*> return as') (\_ trace ->+ case traceResult False trace of+ Right a -> a === expected+ Left e -> counterexample (show e) False)+ .&&.+ exploreSimTrace id (mfix (return . recDelay) >>= ($ as')) (\_ trace ->+ case traceResult False trace of+ Right a -> a === expected+ Left e -> counterexample (show e) False)+ where+ as' :: [Int]+ as' = getPositive `map` as++ -- recursive sum using 'threadDelay'+ recDelay :: MonadDelay m+ => ([Int] -> m Time)+ -> [Int] -> m Time+ recDelay = \rec_ bs ->+ case bs of+ [] -> getMonotonicTime+ (b : bs') -> threadDelay (realToFrac b)+ >> rec_ bs'++ expected :: Time+ expected = foldl' (flip addTime)+ (Time 0)+ (realToFrac `map` as')++prop_mfix_left_shrinking+ :: Int+ -> NonNegative Int+ -> Positive Int+ -> Property+prop_mfix_left_shrinking n (NonNegative d) (Positive i) =+ let mn :: IOSim s Int+ mn = do say ""+ threadDelay (realToFrac d)+ return n+ in exploreSimTrace id (mfix (\rec_ -> mn >>= \a ->+ threadDelay (realToFrac d) $> a : rec_))+ (\_ trace1 ->+ exploreSimTrace id (mn >>= \a ->+ mfix (\rec_ ->+ threadDelay (realToFrac d) $> a : rec_))+ (\_ trace2 ->+ case (traceResult False trace1, traceResult False trace2) of+ (Right a , Right b) -> take i a === take i b+ (Left e , Right _) -> counterexample (show e) False+ (Right _ , Left e) -> counterexample (show e) False+ (Left e , Left e') -> counterexample (show e ++ " " ++ show e') False))+++-- | 'Example 8.2.1' in 'Value Recursion in Monadic Computations'+-- <https://leventerkok.github.io/papers/erkok-thesis.pdf>+--+prop_mfix_lazy :: NonEmptyList Char+ -> Property+prop_mfix_lazy (NonEmpty env) =+ exploreSimTrace id (withEnv (mfix . replicateHeadM)) (\_ trace ->+ case traceResult False trace of+ Right a -> take samples a === replicate samples (head env)+ Left e -> counterexample (show e) False)+ where+ samples :: Int+ samples = 10++ replicateHeadM :: MonadFail m+ => m Char+ -> String -> m String+ replicateHeadM getChar_ as = do+ -- Note: 'getChar' will be executed only once! This follows from 'fixIO`+ -- semantics.+ a <- getChar_+ return (a : as)++ -- construct 'getChar' using the simulated environment+ withEnv :: (++ MonadFail m,++ MonadSTM m+ )+ => (m Char -> m a) -> m a+ withEnv k = do+ v <- newTVarIO env+ let getChar_ =+ atomically $ do+ as <- readTVar v+ case as of+ [] -> error "withEnv: runtime error"+ (a : as') -> writeTVar v as'+ $> a+ k getChar_++--+-- Syncronous exceptions+--++unit_catch_0, unit_catch_1, unit_catch_2, unit_catch_3, unit_catch_4,+ unit_catch_5, unit_catch_6, unit_fork_1+ :: Property+++-- exploreSimTrace id (withEnv (mfix . replicateHeadM)) (\_ trace ->+-- case traceResult False trace of+-- Right a -> take samples a === replicate samples (head env)+-- Left e -> counterexample (show e) False)++-- unhandled top level exception+unit_catch_0 =+ exploreSimTrace id example $ \_ trace ->+ counterexample (List.intercalate "\n" $ map show $ traceEvents trace) $+ counterexample (show $ selectTraceSay trace) $+ selectTraceSay trace === ["before"]+ .&&.+ case traceResult True trace of+ Left (FailureException e) -> property ((Just DivideByZero ==) $ fromException e)+ _ -> property False+ where+ example :: IOSim s ()+ example = do+ say "before"+ _ <- throwIO DivideByZero+ say "after"++-- normal execution of a catch frame+unit_catch_1 =+ exploreSimTrace id (do catch (say "inner")+ (\(_e :: IOError) -> say "handler")+ say "after")+ $ \_ trace ->+ selectTraceSay trace === ["inner", "after"]++-- catching an exception thrown in a catch frame+unit_catch_2 =+ exploreSimTrace id+ (do catch (do say "inner1"+ _ <- throwIO DivideByZero+ say "inner2")+ (\(_e :: ArithException) -> say "handler")+ say "after"+ ) $ \_ trace ->+ selectTraceSay trace === ["inner1", "handler", "after"]++-- not catching an exception of the wrong type+unit_catch_3 =+ exploreSimTrace id+ (do catch (do say "inner"+ throwIO DivideByZero)+ (\(_e :: IOError) -> say "handler")+ say "after"+ ) $ \_ trace ->+ selectTraceSay trace === ["inner"]+++-- catching an exception in an outer handler+unit_catch_4 =+ exploreSimTrace id+ (do catch (catch (do say "inner"+ throwIO DivideByZero)+ (\(_e :: IOError) -> say "handler1"))+ (\(_e :: ArithException) -> say "handler2")+ say "after"+ ) $ \_ trace ->+ selectTraceSay trace === ["inner", "handler2", "after"]+++-- catching an exception in the inner handler+unit_catch_5 =+ exploreSimTrace id+ (do catch (catch (do say "inner"+ throwIO DivideByZero)+ (\(_e :: ArithException) -> say "handler1"))+ (\(_e :: ArithException) -> say "handler2")+ say "after"+ ) $ \_ trace ->+ selectTraceSay trace === ["inner", "handler1", "after"]++-- catching an exception in the inner handler, rethrowing and catching in outer+unit_catch_6 =+ exploreSimTrace id+ (do catch (catch (do say "inner"+ throwIO DivideByZero)+ (\(e :: ArithException) -> do+ say "handler1"+ throwIO e))+ (\(_e :: ArithException) -> say "handler2")+ say "after"+ ) $ \_ trace ->+ selectTraceSay trace === ["inner", "handler1", "handler2", "after"]++-- evaluate should catch pure errors+unit_evaluate_0 :: Property+unit_evaluate_0 =+ -- This property also fails if the @error@ is not caught by the sim monad+ -- and instead reaches the QuickCheck driver.+ -- property $ isLeft $ runSim $ evaluate (error "boom" :: ())+ exploreSimTrace id (evaluate (error "boom" :: ())) $ \_ trace ->+ case traceResult False trace of+ Right _ -> counterexample "didn't fail" False+ Left _ -> property True+++-- Try works and we can pass exceptions back from threads.+-- And terminating with an exception is reported properly.+unit_fork_1 =+ exploreSimTrace id example $ \_ trace ->+ selectTraceSay trace === ["parent", "user error (oh noes!)"]+ .&&. case traceResult True trace of+ Left (FailureException e)+ | Just ioe <- fromException e+ , isUserError ioe+ , ioeGetErrorString ioe == "oh noes!" -> property True+ _ -> property False+ where+ example :: IOSim s ()+ example = do+ resVar <- newEmptyTMVarIO+ void $ forkIO $ do+ res <- try (fail "oh noes!")+ atomically (putTMVar resVar (res :: Either SomeException ()))+ say "parent"+ Left e <- atomically (takeTMVar resVar)+ say (show e)+ throwIO e+++--+-- Asyncronous exceptions+--++unit_async_1, unit_async_2, unit_async_3, unit_async_4,+ unit_async_5, unit_async_6, unit_async_7, unit_async_8,+ unit_async_9+ :: Property+++unit_async_1 =+ exploreSimTrace id+ (do tid <- myThreadId+ say "before"+ throwTo tid DivideByZero+ say "after"+ ) $ \_ trace ->+ selectTraceSay trace === ["before"]+++unit_async_2 =+ runSimTraceSay+ (do tid <- myThreadId+ catch (do say "before"+ throwTo tid DivideByZero+ say "never")+ (\(_e :: ArithException) -> say "handler"))+ ===+ ["before", "handler"]+++unit_async_3 =+ exploreSimTrace id+ (do tid <- forkIO $ say "child"+ threadDelay 1+ -- child has already terminated when we throw the async exception+ throwTo tid DivideByZero+ say "parent done"+ ) $ \_ trace ->+ selectTraceSay trace === ["child", "parent done"]+++unit_async_4 =+ exploreSimTrace id+ (do tid <- forkIO $ do+ say "child"+ catch (atomically retry)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done"+ ) $ \_ trace ->+ selectTraceSay trace === ["child", "handler", "child done", "parent done"]+++unit_async_5 =+ exploreSimTrace id+ (do tid <- forkIO $ mask_ $+ do+ say "child"+ threadDelay 1+ say "child masked"+ -- while masked, do a blocking (interruptible) operation+ catch (atomically retry)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done"+ ) $ \_ trace ->+ selectTraceSay trace === ["child", "child masked", "handler", "child done", "parent done"]+++unit_async_6 =+ exploreSimTrace id+ (do tid <- forkIO $+ mask_ $ do+ say "child"+ threadDelay 1+ fail "oh noes!"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ -- throwTo blocks but then unblocks because the child dies+ say "parent done") $ \_ trace ->+ selectTraceSay trace === ["child", "parent done"]+++unit_async_7 =+ exploreSimTrace id+ (do tid <- forkIO $ do+ uninterruptibleMask_ $ do+ say "child"+ threadDelay 1+ say "child masked"+ -- while masked, do a blocking (interruptible) operation+ catch (threadDelay 1)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ say "never"+ -- parent and child wake up on the runqueue at the same time+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done") $ \_ trace ->+ selectTraceSay trace === ["child", "child masked", "child done", "parent done"]+++unit_async_8 =+ exploreSimTrace id+ (uninterruptibleMask_ $ do+ tid <- forkIO $ atomically retry+ throwTo tid DivideByZero) $ \_ trace ->+ case traceResult False trace of+ Left FailureDeadlock {} -> property True+ _ -> property False+++unit_async_9 =+ exploreSimTrace id+ (do tid <- forkIO $ do+ uninterruptibleMask_ $ do+ say "child"+ threadDelay 1+ say "child masked"+ -- while masked do a blocking operation, but this is+ -- an uninterruptible mask so nothing happens+ catch (threadDelay 1)+ (\(_e :: ArithException) -> say "handler")+ say "child done"+ say "never"+ threadDelay 1+ throwTo tid DivideByZero+ threadDelay 1+ say "parent done") $ \_ trace ->+ selectTraceSay trace === ["child", "child masked", "child done", "parent done"]+++--+-- Tests vs STM operational semantics+--++-- | Compare the behaviour of the STM reference operational semantics with+-- the behaviour of the IO simulator's STM implementation.+--+prop_stm_referenceSim :: SomeTerm -> Property+prop_stm_referenceSim t =+ exploreSimTrace id (prop_stm_referenceM t) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++prop_timeout_no_deadlock_Sim :: Property+prop_timeout_no_deadlock_Sim = -- runSimOrThrow prop_timeout_no_deadlockM+ exploreSimTrace id prop_timeout_no_deadlockM $ \_ trace ->+ case traceResult False trace of+ Right a -> property a+ Left e -> counterexample (show e) False++prop_timeout+ :: TimeoutDuration+ -> ActionDuration+ -> Property+prop_timeout intendedTimeoutDuration intendedActionDuration = + exploreSimTrace id experiment $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False+ where+ experiment :: IOSim s Property+ experiment = do+ exploreRaces+ withSanityCheck <$> singleTimeoutExperiment intendedTimeoutDuration intendedActionDuration++prop_timeouts+ :: [(TimeoutDuration, ActionDuration)]+ -> Property+prop_timeouts times = exploreSimTrace id experiment $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False+ where+ experiment :: IOSim s Property+ experiment = do+ exploreRaces+ conjoin' <$>+ sequence+ [ fmap (counterexample ("failure on timeout test #" ++ show n))+ <$> singleTimeoutExperiment intendedTimeoutDuration+ intendedActionDuration+ | ((intendedTimeoutDuration,+ intendedActionDuration), n) <- zip times [1 :: Int ..] ]++ maxFailures = 0++ conjoin' :: [WithSanityCheck Property] -> Property+ conjoin' props =+ conjoin (ignoreSanityCheck `map` props)+ .&&. let numFailures = length (filter isSanityCheckIgnored props)+ in counterexample+ ("too many failures: " ++ show numFailures ++ " ≰ " ++ show maxFailures)+ (numFailures <= maxFailures)+++prop_stacked_timeouts :: DiffTime+ -> DiffTime+ -> DiffTime+ -> Property+prop_stacked_timeouts timeout0 timeout1 actionDuration =+ exploreSimTrace id experiment $ \_ trace ->+ case traceResult False trace of+ Right result -> result === predicted+ Left e -> counterexample (show e) False+ where+ experiment :: IOSim s (Maybe (Maybe ()))+ experiment = exploreRaces+ >> timeout timeout0 (timeout timeout1 (threadDelay actionDuration))++ predicted | timeout0 == 0+ = Nothing++ | timeout1 == 0+ = Just Nothing++ -- This differs from `IOSim` case; `IOSimPOR` is using+ -- different scheduler.+ | actionDuration < min timeout0 timeout1+ = Just (Just ())++ | timeout0 < timeout1+ = Nothing++ | otherwise -- i.e. timeout0 >= timeout1+ = Just Nothing++unit_timeouts_and_async_exceptions_1 :: Property+unit_timeouts_and_async_exceptions_1 =+ exploreSimTrace id experiment $ \_ trace ->+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ delay = 1++ experiment :: IOSim s Property+ experiment = do+ exploreRaces+ tid <- forkIO $ void $+ timeout delay (atomically retry)++ threadDelay (delay / 2)+ killThread tid+ threadDelay 1+ return $ property True +++unit_timeouts_and_async_exceptions_2 :: Property+unit_timeouts_and_async_exceptions_2 =+ exploreSimTrace id experiment $ \_ trace ->+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ delay = 1++ experiment :: IOSim s Property+ experiment = do+ exploreRaces+ tid <- forkIO $ void $+ timeout delay (atomically retry) `catch` (\(_ :: AsyncException) -> return Nothing)++ threadDelay (delay / 2)+ killThread tid+ threadDelay 1+ return $ property True +++unit_timeouts_and_async_exceptions_3 :: Property+unit_timeouts_and_async_exceptions_3 =+ exploreSimTrace id experiment $ \_ trace ->+ counterexample (ppTrace_ trace)+ . either (\e -> counterexample (show e) False) id+ . traceResult False+ $ trace+ where+ delay = 1++ experiment :: IOSim s Property+ experiment = do+ exploreRaces+ tid <- forkIO $ void $+ timeout delay (atomically retry `catch` (\(_ :: AsyncException) -> return ()))++ threadDelay (delay / 2)+ killThread tid+ threadDelay 1+ return $ property True ++--+-- MonadMask properties+--++unit_set_masking_state_ST :: MaskingState -> Property+unit_set_masking_state_ST ms =+ exploreSimTrace id (prop_set_masking_state ms) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++unit_unmask_ST :: MaskingState -> MaskingState -> Property+unit_unmask_ST ms ms' =+ exploreSimTrace id (prop_unmask ms ms') $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++unit_fork_masking_state_ST :: MaskingState -> Property+unit_fork_masking_state_ST ms =+ exploreSimTrace id (prop_fork_masking_state ms) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++unit_fork_unmask_ST :: MaskingState -> MaskingState -> Property+unit_fork_unmask_ST ms ms' =+ exploreSimTrace id (prop_fork_unmask ms ms') $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++unit_catch_throwIO_masking_state_ST :: MaskingState -> Property+unit_catch_throwIO_masking_state_ST ms =+ exploreSimTrace id (prop_catch_throwIO_masking_state ms) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++unit_catch_throwTo_masking_state_ST :: MaskingState -> Property+unit_catch_throwTo_masking_state_ST ms =+ exploreSimTrace id (prop_catch_throwTo_masking_state ms) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++unit_catch_throwTo_masking_state_async_ST :: MaskingState -> Property+unit_catch_throwTo_masking_state_async_ST ms =+ exploreSimTrace id (prop_catch_throwTo_masking_state_async ms) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False++unit_catch_throwTo_masking_state_async_mayblock_ST :: MaskingState -> Property+unit_catch_throwTo_masking_state_async_mayblock_ST ms =+ exploreSimTrace id (prop_catch_throwTo_masking_state_async_mayblock ms) $ \_ trace ->+ case traceResult False trace of+ Right a -> a+ Left e -> counterexample (show e) False
+ test/Test/Control/Monad/STM.hs view
@@ -0,0 +1,867 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}++-- | A reference implementation of the STM operational semantics.+--+-- It is based on the paper /Composable Memory Transactions/, which gives the+-- operational semantics of STM Haskell in Figures 2--4.+--+-- <https://research.microsoft.com/en-us/um/people/simonpj/papers/stm/stm.pdf>+--+module Test.Control.Monad.STM where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, maybeToList)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Type.Equality+import Prelude hiding (exp)++import Control.Concurrent.Class.MonadSTM.TVar as STM+import Control.Monad.Class.MonadSTM as STM+import Control.Monad.Class.MonadThrow++import Test.QuickCheck+++-- | The type level structure of types in our STM 'Term's. This is kept simple,+-- just unit and ints as base types, and the type of STM variables.+--+data Type where+ TyUnit :: Type+ TyInt :: Type+ TyVar :: Type -> Type+++-- | A value level representation of the types of STM 'Term's.+--+data TyRep (t :: Type) where+ TyRepUnit :: TyRep TyUnit+ TyRepInt :: TyRep TyInt+ TyRepVar :: TyRep t -> TyRep (TyVar t)++deriving instance Show (TyRep t)+++-- | Figure 2 in the paper gives the syntax of STM terms. It does not+-- distinguish between STM action terms and other terms. We make such a+-- distinction here because it makes the encoding and generation of terms+-- easier, and the restriction is not fundamental for the STM semantics.+--+-- Note that we choose not to implement @catch@ as we do not need it. But it+-- should be straightforward to add if it becomes necessary.+--+data Term (t :: Type) where++ Return :: Expr t -> Term t+ Throw :: Expr a -> Term t+ Catch :: Term t -> Term t -> Term t+ Retry :: Term t++ ReadTVar :: Name (TyVar t) -> Term t+ WriteTVar :: Name (TyVar t) -> Expr t -> Term TyUnit+ NewTVar :: Expr t -> Term (TyVar t)++ -- | This is the ordinary monad bind for STM terms.+ Bind :: Term a -> Name a -> Term t -> Term t+ OrElse :: Term t -> Term t -> Term t++deriving instance Show (Term t)+++-- | Expressions that can appear within 'Term's.+--+data Expr (t :: Type) where++ ExprUnit :: Expr TyUnit+ ExprInt :: Int -> Expr TyInt+ ExprName :: Name t -> Expr t++deriving instance Show (Expr t)+++-- | Normal form values that occur during evaluation.+--+data Value (t :: Type) where++ ValUnit :: Value TyUnit+ ValInt :: Int -> Value TyInt+ ValVar :: Var t -> Value (TyVar t)++deriving instance Show (Value t)+++-- | We have both names and STM variables, and it is important to keep the two+-- concepts distinct. We need names because we have bind, and in particular the+-- same name may end up referring to different variables during execution,+-- depending on runtime conditions.+--+-- The bound variable scheme here is just a simple fresh name supply. The+-- variable bindings are held in the 'Env'.+--+-- The names are typed and carry a representation of their type.+--+data Name (t :: Type) = Name !NameId (TyRep t)+deriving instance Show (Name t)++newtype NameId = NameId Int+ deriving (Eq, Ord, Enum, Show)++-- | An STM variable. The value is held in the 'Heap'. A simple fresh name+-- supply scheme is used.+--+-- The variables are typed and carry a representation of their type.+--+data Var (t :: Type) = Var !VarId (TyRep t)+deriving instance Show (Var t)++newtype VarId = VarId Int+ deriving (Eq, Ord, Enum, Show)++++--+-- Type rep utils+--++eqTyRep :: TyRep a -> TyRep b -> Maybe (a :~: b)+eqTyRep TyRepUnit TyRepUnit = Just Refl+eqTyRep TyRepInt TyRepInt = Just Refl+eqTyRep (TyRepVar a) (TyRepVar b) = case eqTyRep a b of+ Nothing -> Nothing+ Just Refl -> Just Refl+eqTyRep _ _ = Nothing++nameTyRep :: Name t -> TyRep t+nameTyRep (Name _ tyrep) = tyrep++varTyRep :: Var t -> TyRep t+varTyRep (Var _ tyrep) = tyrep++tyRepExpr :: Expr t -> TyRep t+tyRepExpr (ExprName n) = nameTyRep n+tyRepExpr ExprUnit = TyRepUnit+tyRepExpr (ExprInt _) = TyRepInt++tyRepValue :: Value t -> TyRep t+tyRepValue ValUnit = TyRepUnit+tyRepValue (ValInt _) = TyRepInt+tyRepValue (ValVar v) = TyRepVar (varTyRep v)+++--+-- Evaluation environments+--++data SomeName where+ SomeName :: Name t -> SomeName++data SomeValue where+ SomeValue :: Value t -> SomeValue++deriving instance Show SomeName+deriving instance Show SomeValue+++-- | The environment is a mapping of 'Name's to their values.+--+newtype Env = Env (Map NameId SomeValue)+ deriving Show++-- | Lookup a name in the environment. This dynamically checks the types.+--+lookupEnv :: Env -> Name t -> Value t+lookupEnv (Env env) (Name name tyrep) =+ fromMaybe (error "lookupEnv: no such var") $ do+ SomeValue v <- Map.lookup name env+ Refl <- tyrep `eqTyRep` tyRepValue v+ return v++extendEnv :: Name t -> Value t -> Env -> Env+extendEnv (Name name _tyrep) v (Env env) =+ Env (Map.insert name (SomeValue v) env)+++--+-- Heaps for mutable variable+--++data SomeVar where+ SomeVar :: Var t -> SomeVar++-- | The heap is a mapping of 'Var's to their current values.+--+newtype Heap = Heap (Map VarId SomeValue)+ deriving (Show, Semigroup, Monoid)++-- | The STM semantics uses two heaps, the other one is called the allocations.+type Allocs = Heap+++readVar :: Heap -> Var t -> Value t+readVar (Heap heap) (Var n tyrep) =+ fromMaybe (error "readVar: no such var") $ do+ SomeValue v <- Map.lookup n heap+ Refl <- tyrep `eqTyRep` tyRepValue v+ return v++writeVar :: Heap -> Var t -> Value t -> Heap+writeVar (Heap heap) (Var n tyrep) v' =+ fromMaybe (error "writeVar: no such var") $ do+ SomeValue v <- Map.lookup n heap+ Refl <- tyrep `eqTyRep` tyRepValue v+ let heap' = Heap (Map.insert n (SomeValue v') heap)+ return heap'++-- | Extend the heap and allocs with a fresh variable.+extendHeap :: (Heap, Allocs) -> Value t -> (Var t, Heap, Allocs)+extendHeap (Heap heap, Heap allocs) v =+ (var, Heap heap', Heap allocs')+ where+ var = Var n' (tyRepValue v)+ heap' = Map.insert n' (SomeValue v) heap+ allocs' = Map.insert n' (SomeValue v) allocs+ n' :: VarId+ n' = case Map.maxViewWithKey heap of+ Nothing -> VarId 0+ Just ((n, _), _) -> succ n+++--+-- Top level results+--++-- | The overall result of an STM transaction.+--+-- This is used for both the reference evaluator 'evalAtomically' and the+-- conversion into the implementation STM via 'execAtomically'.+--+data TxResult =+ TxComitted ImmValue+ | TxBlocked+ | TxAborted ImmValue+ deriving (Eq, Show)++-- | An immutable snapshot of a 'Value' where the current values of the mutable+-- variables are captured and included.+--+-- 'ImmValVar' is an evidence that it was the value within in a mutable+-- variable; the identity of the variable is forgotten.+--+data ImmValue where++ ImmValUnit :: ImmValue+ ImmValInt :: Int -> ImmValue+ ImmValVar :: ImmValue -> ImmValue+ deriving (Eq, Show)++-- | In the execution in real STM transactions are aborted by throwing an+-- exception.+--+instance Exception ImmValue++++--+-- Evaluation+--++evalExpr :: Env -> Expr t -> Value t+evalExpr env (ExprName n) = lookupEnv env n+evalExpr _env ExprUnit = ValUnit+evalExpr _env (ExprInt n) = ValInt n++-- | The normal form for a 'Term' after execution.+--+data NfTerm (t :: Type) where++ NfReturn :: Value t -> NfTerm t+ NfThrow :: Value a -> NfTerm t+ NfRetry :: NfTerm t++deriving instance Show (NfTerm t)+++-- | The STM transition rules. They reduce a 'Term' to a normal-form 'NfTerm'.+--+-- Compare the implementation of this against the operational semantics in+-- Figure 4 in the paper including the `Catch` semantics from the Appendix A.+--+evalTerm :: Env -> Heap -> Allocs -> Term t -> (NfTerm t, Heap, Allocs)+evalTerm !env !heap !allocs term = case term of++ Return e -> (NfReturn e', heap, allocs)+ where+ e' = evalExpr env e++ Throw e -> (NfThrow e', heap, allocs)+ where+ e' = evalExpr env e++ -- Exception semantics are detailed in "Appendix A Exception semantics" p 12-13 of+ -- <https://research.microsoft.com/en-us/um/people/simonpj/papers/stm/stm.pdf>+ Catch t1 t2 ->+ let (nf1, heap', allocs') = evalTerm env heap mempty t1 in case nf1 of++ -- Rule XSTM1+ -- M; heap, {} => return P; heap', allocs'+ -- --------------------------------------------------------+ -- S[catch M N]; heap, allocs => S[return P]; heap', allocs U allocs'+ NfReturn v -> (NfReturn v, heap', allocs <> allocs')++ -- Rule XSTM2+ -- M; heap, {} => throw P; heap', allocs'+ -- --------------------------------------------------------+ -- S[catch M N]; heap, allocs => S[N P]; heap U allocs', allocs U allocs'+ NfThrow _ -> evalTerm env (heap <> allocs') (allocs <> allocs') t2++ -- Rule XSTM3+ -- M; heap, {} => retry; heap', allocs'+ -- --------------------------------------------------------+ -- S[catch M N]; heap, allocs => S[retry]; heap, allocs+ NfRetry -> (NfRetry, heap, allocs)+++ Retry -> (NfRetry, heap, allocs)++ -- Rule READ+ ReadTVar nvar -> (NfReturn (readVar heap var), heap, allocs)+ where+ ValVar var = lookupEnv env nvar++ -- Rule WRITE+ WriteTVar nvar exp -> (NfReturn ValUnit, heap', allocs)+ where+ heap' = writeVar heap var val+ (ValVar var) = lookupEnv env nvar+ val = evalExpr env exp++ -- Rule NEW+ NewTVar exp ->+ let val = evalExpr env exp+ (var, heap', allocs') = extendHeap (heap, allocs) val+ in (NfReturn (ValVar var), heap', allocs')++ Bind t1 name t2 ->+ let (nf1, heap', allocs') = evalTerm env heap allocs t1 in+ case nf1 of++ -- Rule BIND+ NfReturn v -> evalTerm env' heap' allocs' t2+ where+ env' = extendEnv name v env++ -- Rule THROW+ NfThrow v -> (NfThrow v, heap', allocs')++ -- Rule RETRY+ NfRetry -> (NfRetry, heap', allocs')++ OrElse t1 t2 ->+ let (nft1, heap', allocs') = evalTerm env heap allocs t1 in+ case nft1 of++ -- Rule OR1+ NfReturn v -> (NfReturn v, heap', allocs')++ -- Rule OR2+ NfThrow v -> (NfThrow v, heap', allocs')++ -- Rule OR3+ NfRetry -> evalTerm env heap allocs t2++-- | The top level rule for STM transitions (on closed terms).+--+evalAtomically :: Term t -> (TxResult, Heap)+evalAtomically t =+ let env = Env mempty+ heap = mempty+ allocs = mempty+ (t', heap', allocs') = evalTerm env heap allocs t in+ case t' of++ -- Rule ARET+ NfReturn v -> (TxComitted v', heap')+ where v' = snapshotValue heap' v++ -- Rule ATHROW+ NfThrow v -> (TxAborted v', heap <> allocs')+ where v' = snapshotValue heap' v++ -- There is no rule in the paper for atomic retry because the lack of+ -- that case means the system has to progress by picking a different+ -- thread which is exactly what one wants for retry.+ --+ -- But we have to have a total result. So we have a blocked result+ -- with the heap unchanged.+ NfRetry -> (TxBlocked, heap)++-- | Capture an immutable snapshot of a value, given the current value of the+-- mutable variable heap.+--+snapshotValue :: Heap -> Value t -> ImmValue+snapshotValue _ ValUnit = ImmValUnit+snapshotValue _ (ValInt x) = ImmValInt x+snapshotValue h (ValVar n) = ImmValVar (snapshotValue h (readVar h n))+++--+-- Execution in an STM monad (real or sim)+--++data ExecValue m (t :: Type) where++ ExecValUnit :: ExecValue m TyUnit+ ExecValInt :: Int -> ExecValue m TyInt+ ExecValVar :: TVar m (ExecValue m t)+ -> TyRep t -> ExecValue m (TyVar t)++instance Show (ExecValue m t) where+ show ExecValUnit = "ExecValUnit"+ show (ExecValInt x) = "ExecValInt " ++ show x+ show (ExecValVar _ tyrep) = "ExecValVar (<tvar> :: " ++ show tyrep ++ ")"+++data SomeExecValue m where+ SomeExecValue :: ExecValue m t -> SomeExecValue m++deriving instance Show (SomeExecValue m)+++newtype ExecEnv m = ExecEnv (Map NameId (SomeExecValue m))+ deriving (Semigroup, Monoid)++tyRepExecValue :: ExecValue m t -> TyRep t+tyRepExecValue ExecValUnit = TyRepUnit+tyRepExecValue (ExecValInt _) = TyRepInt+tyRepExecValue (ExecValVar _ tyrep) = TyRepVar tyrep++lookupExecEnv :: ExecEnv m -> Name t -> ExecValue m t+lookupExecEnv (ExecEnv env) (Name name tyrep) =+ fromMaybe (error "lookupExecEnv: no such var") $ do+ SomeExecValue v <- Map.lookup name env+ Refl <- tyrep `eqTyRep` tyRepExecValue v+ return v++extendExecEnv :: Name t -> ExecValue m t -> ExecEnv m -> ExecEnv m+extendExecEnv (Name name _tyrep) v (ExecEnv env) =+ ExecEnv (Map.insert name (SomeExecValue v) env)+++-- | Execute an STM 'Term' in the 'STM' monad.+--+execTerm :: (MonadSTM m, MonadCatch (STM m))+ => ExecEnv m+ -> Term t+ -> STM m (ExecValue m t)+execTerm env t =+ case t of+ Return e -> do+ let e' = execExpr env e+ return e'++ Throw e -> do+ let e' = execExpr env e+ throwSTM =<< snapshotExecValue e'++ Catch t1 t2 -> execTerm env t1 `catch` \(_ :: ImmValue) -> execTerm env t2++ Retry -> retry++ ReadTVar n -> do+ let tv = case lookupExecEnv env n of+ ExecValVar v _ -> v+ readTVar tv++ WriteTVar n e -> do+ let tv = case lookupExecEnv env n of+ ExecValVar v _ -> v+ e' = execExpr env e+ writeTVar tv e'+ return ExecValUnit++ NewTVar e -> do+ let e' = execExpr env e+ tyrep = tyRepExecValue e'+ tv <- newTVar e'+ return (ExecValVar tv tyrep)+++ Bind t1 n1 t2 -> do+ v1 <- execTerm env t1+ let env' = extendExecEnv n1 v1 env+ execTerm env' t2++ OrElse t1 t2 -> execTerm env t1+ `orElse` execTerm env t2++execExpr :: forall m t. ExecEnv m -> Expr t -> ExecValue m t+execExpr _ ExprUnit = ExecValUnit+execExpr _ (ExprInt x) = ExecValInt x+execExpr env (ExprName n) = lookupExecEnv env n++snapshotExecValue :: MonadSTM m => ExecValue m t -> STM m ImmValue+snapshotExecValue ExecValUnit = return ImmValUnit+snapshotExecValue (ExecValInt x) = return (ImmValInt x)+snapshotExecValue (ExecValVar v _) = fmap ImmValVar+ (snapshotExecValue =<< readTVar v)++execAtomically :: forall m t. (MonadSTM m, MonadCatch (STM m), MonadCatch m)+ => Term t -> m TxResult+execAtomically t =+ toTxResult <$> try (atomically action')+ where+ action = snapshotExecValue =<< execTerm (mempty :: ExecEnv m) t++ action' = fmap Just action `orElse` return Nothing+ -- We want to observe if the transaction would block. If we trust the STM+ -- implementation then we can just use 'orElse' to observe the blocking.++ toTxResult (Right (Just x)) = TxComitted x+ toTxResult (Left e) = TxAborted e+ toTxResult (Right Nothing) = TxBlocked+++--+-- QuickCheck generators+--++instance Arbitrary SomeTerm where+ arbitrary = genSomeTerm emptyGenEnv++ shrink (SomeTerm tyrep t) = [ SomeTerm tyrep t' | t' <- shrinkTerm t ]+++data SomeTerm where+ SomeTerm :: TyRep t -> Term t -> SomeTerm++data SomeExpr where+ SomeExpr :: Expr t -> SomeExpr++deriving instance Show SomeTerm+deriving instance Show SomeExpr+++-- | The generator environment, used to keep track of what names are in scope+-- in the terms and expressions we generate.+--+data GenEnv = GenEnv {+ -- | The sets of names, grouped by type+ envNames :: TyTrie NameId,++ -- | For managing the fresh name supply+ envNextName :: NameId+ }++data TyTrie a =+ TyTrieEmpty+ | TyTrieNode {+ trieUnit :: [a],+ trieInt :: [a],+ trieVar :: TyTrie a+ }+ deriving Show++lookupTyTrie :: TyTrie a -> TyRep t -> [a]+lookupTyTrie TyTrieNode{trieUnit} TyRepUnit = trieUnit+lookupTyTrie TyTrieNode{trieInt} TyRepInt = trieInt+lookupTyTrie TyTrieNode{trieVar} (TyRepVar tyrep) = lookupTyTrie trieVar tyrep+lookupTyTrie _ _ = []++insertTyTrie :: TyTrie a -> TyRep t -> a -> TyTrie a+insertTyTrie TyTrieEmpty tyrep x =+ case tyrep of+ TyRepUnit -> TyTrieNode [x] [] TyTrieEmpty+ TyRepInt -> TyTrieNode [] [x] TyTrieEmpty+ TyRepVar tyrep' -> TyTrieNode [] [] (insertTyTrie TyTrieEmpty tyrep' x)++insertTyTrie node@TyTrieNode{trieUnit = us, trieInt = ns, trieVar} tyrep x =+ case tyrep of+ TyRepUnit -> node { trieUnit = x : us }+ TyRepInt -> node { trieInt = x : ns }+ TyRepVar tyrep' -> node { trieVar = insertTyTrie trieVar tyrep' x }++emptyGenEnv :: GenEnv+emptyGenEnv = GenEnv TyTrieEmpty (NameId 0)++lookupNames :: GenEnv -> TyRep t -> Maybe [Name t]+lookupNames GenEnv{envNames} tyrep =+ case lookupTyTrie envNames tyrep of+ [] -> Nothing+ ns -> Just [ Name n tyrep | n <- ns ]++freshName :: GenEnv -> TyRep t -> (Name t, GenEnv)+freshName GenEnv {envNames, envNextName} tyrep =+ (name, env')+ where+ name = Name envNextName tyrep+ env' = GenEnv {+ envNames = insertTyTrie envNames tyrep envNextName,+ envNextName = succ envNextName+ }++pickName :: GenEnv -> TyRep t -> Maybe (Gen (Name t))+pickName env tyrep =+ elements <$> lookupNames env tyrep++data SomeVarName where+ SomeVarName :: Name (TyVar t) -> SomeVarName+deriving instance Show SomeVarName++lookupVarNames :: GenEnv -> [SomeVarName]+lookupVarNames GenEnv{envNames = TyTrieEmpty} = []+lookupVarNames GenEnv{envNames = TyTrieNode{trieVar = trieVar0}} =+ go 0 trieVar0+ where+ go :: Int -> TyTrie NameId -> [SomeVarName]+ go _ TyTrieEmpty = []+ go d TyTrieNode{trieUnit = us, trieInt = ns, trieVar} =+ [ deep n TyRepUnit d | n <- us ]+ ++ [ deep n TyRepInt d | n <- ns ]+ ++ go (succ d) trieVar++deep :: NameId -> TyRep t -> Int -> SomeVarName+deep nid tyrep 0 = SomeVarName (Name nid (TyRepVar tyrep))+deep nid tyrep d = deep nid (TyRepVar tyrep) (pred d)+++-- | Generate a 'Term' of some type.+--+genSomeTerm :: GenEnv -> Gen SomeTerm+genSomeTerm env =+ oneof+ [ SomeTerm TyRepUnit+ <$> genTerm env TyRepUnit+ , SomeTerm TyRepInt+ <$> genTerm env TyRepInt+ , SomeTerm (TyRepVar TyRepInt)+ <$> genTerm env (TyRepVar TyRepInt)+ , SomeTerm (TyRepVar (TyRepVar TyRepInt))+ <$> genTerm env (TyRepVar (TyRepVar TyRepInt))+ -- vars of vars is probably deep enough.+ ]++-- | Generate a 'Term' of a given type.+--+genTerm :: GenEnv -> TyRep t -> Gen (Term t)+genTerm env tyrep =+ sized $ \sz ->+ if sz <= 1+ then leafTerm+ else frequency [ (1, leafTerm), (2, binTerm) ]+ where+ leafTerm =+ frequency' $+ [ (2, fmap Return <$> genExpr env tyrep)+ , (1, Just ((\(SomeExpr e) -> Throw e) <$> genSomeExpr env))+ , (1, Just (pure Retry))+ , (3, do genvarname <- pickName env (TyRepVar tyrep)+ return (ReadTVar <$> genvarname))+ , (3, case tyrep of+ TyRepUnit ->+ case [ WriteTVar varname <$> genexpr+ | SomeVarName varname <- lookupVarNames env+ , let TyRepVar valtyrep = nameTyRep varname+ , genexpr <- maybeToList $ genExpr env valtyrep+ ]+ of [] -> Nothing+ ws -> Just (oneof ws)+ TyRepVar vartyrep ->+ fmap NewTVar <$> genExpr env vartyrep+ TyRepInt ->+ Nothing)+ ]++ binTerm = frequency [ (2, bindTerm), (1, orElseTerm), (1, catchTerm)]++ bindTerm =+ sized $ \sz -> do+ let sz1 = sz `div` 3 -- 1/3+ sz2 = sz * 2 `div` 3 -- 2/3+ -- To right bias it a bit++ SomeTerm t1ty t1 <- resize sz1 (genSomeTerm env)+ let (name, env') = freshName env t1ty+ t2 <- resize sz2 (genTerm env' tyrep)+ return (Bind t1 name t2)++ orElseTerm =+ scale (`div` 2) $+ OrElse <$> genTerm env tyrep+ <*> genTerm env tyrep++ catchTerm =+ scale (`div` 2) $+ Catch <$> genTerm env tyrep+ <*> genTerm env tyrep++genSomeExpr :: GenEnv -> Gen SomeExpr+genSomeExpr env =+ oneof'+ [ fmap SomeExpr <$> genExpr env TyRepUnit+ , fmap SomeExpr <$> genExpr env TyRepInt+ , fmap SomeExpr <$> genExpr env (TyRepVar TyRepInt)+ , fmap SomeExpr <$> genExpr env (TyRepVar (TyRepVar TyRepInt))+ ]++genExpr :: GenEnv -> TyRep t -> Maybe (Gen (Expr t))+genExpr env tyrep@TyRepUnit =+ Just $ oneof'+ [ Just (pure ExprUnit)+ , fmap ExprName <$> pickName env tyrep+ ]+genExpr env tyrep@TyRepInt =+ Just $ oneof'+ [ Just (ExprInt <$> arbitrary)+ , fmap ExprName <$> pickName env tyrep+ ]+genExpr env tyrep@TyRepVar{} =+ fmap ExprName <$> pickName env tyrep+++elements' :: [Maybe a] -> Gen a+elements' xs = elements [ g | Just g <- xs ]++oneof' :: [Maybe (Gen a)] -> Gen a+oneof' xs = oneof [ g | Just g <- xs ]++frequency' :: [(Int, Maybe (Gen a))] -> Gen a+frequency' xs = frequency [ (n, g) | (n, Just g) <- xs ]++shrinkTerm :: Term t -> [Term t]+shrinkTerm t =+ case t of+ Return e -> [Return e' | e' <- shrinkExpr e]+ Throw e -> [Throw e' | e' <- shrinkExpr e]+ Catch t1 t2 -> [t1, t2]+ ++ [Catch t1' t2' | (t1', t2') <- liftShrink2 shrinkTerm shrinkTerm (t1, t2)]+ Retry -> []+ ReadTVar _ -> []++ WriteTVar _ _ -> [Return ExprUnit] --TODO: there are other less drastic shrinks possible here++ NewTVar e -> [NewTVar e' | e' <- shrinkExpr e]++ Bind t1 n t2 -> [ t2 | nameId n `Set.notMember` freeNamesTerm t2 ]+ ++ [ Bind t1' n t2' | (t1', t2') <- liftShrink2 shrinkTerm shrinkTerm (t1, t2) ]++ OrElse t1 t2 -> [t1, t2]+ ++ [ OrElse t1' t2' | (t1', t2') <- liftShrink2 shrinkTerm shrinkTerm (t1, t2) ]++shrinkExpr :: Expr t -> [Expr t]+shrinkExpr ExprUnit = []+shrinkExpr (ExprInt n) = [ExprInt n' | n' <- shrink n]+shrinkExpr (ExprName (Name _ TyRepUnit)) = [ExprUnit]+shrinkExpr (ExprName (Name _ TyRepInt)) = [ExprInt 0]+shrinkExpr (ExprName (Name _ (TyRepVar _))) = []++freeNamesTerm :: Term t -> Set NameId+freeNamesTerm (Return e) = freeNamesExpr e+freeNamesTerm (Throw e) = freeNamesExpr e+-- The current generator of catch term ignores the argument passed to the+-- handler.+-- TODO: Correctly handle free names when the handler also binds a variable.+freeNamesTerm (Catch t1 t2) = freeNamesTerm t1 <> freeNamesTerm t2+freeNamesTerm Retry = Set.empty+freeNamesTerm (ReadTVar n) = Set.singleton (nameId n)+freeNamesTerm (WriteTVar n e) = Set.singleton (nameId n) <> freeNamesExpr e+freeNamesTerm (NewTVar e) = freeNamesExpr e+freeNamesTerm (Bind t1 n t2) = freeNamesTerm t1 <> Set.delete (nameId n)+ (freeNamesTerm t2)+freeNamesTerm (OrElse t1 t2) = freeNamesTerm t1 <> freeNamesTerm t2++freeNamesExpr :: Expr t -> Set NameId+freeNamesExpr ExprUnit = Set.empty+freeNamesExpr (ExprInt _) = Set.empty+freeNamesExpr (ExprName n) = Set.singleton (nameId n)++nameId :: Name t -> NameId+nameId (Name nid _) = nid++prop_genSomeTerm :: SomeTerm -> Property+prop_genSomeTerm (SomeTerm tyrep term) =+ tabulate "1. Term type" [show tyrep] $+ tabulate "2. Term size" [show (sizeBucket (termSize term))] $+ tabulate "3. Term depth" [show (termDepth term)] $+ case evalAtomically term of+ (!_val, !_heap') -> True+ where+ sizeBucket s = ((s-1) `div` 10 + 1) * 10+++termSize :: Term a -> Int+termSize Return{} = 1+termSize Throw{} = 1+termSize (Catch a b) = 1 + termSize a + termSize b+termSize Retry{} = 1+termSize ReadTVar{} = 1+termSize WriteTVar{} = 1+termSize NewTVar{} = 1+termSize (Bind a _ b) = 1 + termSize a + termSize b+termSize (OrElse a b) = 1 + termSize a + termSize b++termDepth :: Term a -> Int+termDepth Return{} = 1+termDepth Throw{} = 1+termDepth (Catch a b) = 1 + max (termDepth a) (termDepth b)+termDepth Retry{} = 1+termDepth ReadTVar{} = 1+termDepth WriteTVar{} = 1+termDepth NewTVar{} = 1+termDepth (Bind a _ b) = 1 + max (termDepth a) (termDepth b)+termDepth (OrElse a b) = 1 + max (termDepth a) (termDepth b)++showTerm :: Int -> Term t -> ShowS+showTerm p (Return e) = showParen (p > 10) $+ showString "return " . showExpr 11 e+showTerm p (Throw e) = showParen (p > 10) $+ showString "throwSTM " . showExpr 11 e+showTerm p (Catch t1 t2) = showParen (p > 9) $+ showTerm 10 t1 . showString " `catch` "+ . showTerm 10 t2+showTerm _ Retry = showString "retry"+showTerm p (ReadTVar n) = showParen (p > 10) $+ showString "readTVar " . showName n+showTerm p (WriteTVar n e) = showParen (p > 10) $+ showString "writeTVar " . showName n+ . showChar ' ' . showExpr 11 e+showTerm p (NewTVar e) = showParen (p > 10) $+ showString "newTVar " . showExpr 11 e+showTerm p (Bind t1 n t2) = showParen (p > 1) $+ showTerm 2 t1 . showString " >>= \\"+ . showNameTyped n . showString " -> "+ . showTerm 1 t2+showTerm p (OrElse t1 t2) = showParen (p > 9) $+ showTerm 10 t1 . showString " `orElse` "+ . showTerm 10 t2++showExpr :: Int -> Expr t -> ShowS+showExpr _ ExprUnit = showString "()"+showExpr p (ExprInt n) = showsPrec p n+showExpr _ (ExprName n) = showName n++showName :: Name t -> ShowS+showName (Name (NameId nid) _) = showChar 'v' . shows nid++showNameTyped :: Name t -> ShowS+showNameTyped (Name (NameId nid) tyrep) =+ showChar 'v' . shows nid+ . showString " :: " . showTyRep 0 tyrep++showTyRep :: Int -> TyRep t -> ShowS+showTyRep _ TyRepUnit = showString "()"+showTyRep _ TyRepInt = showString "Int"+showTyRep p (TyRepVar t) = showParen (p > 10) $+ showString "TVar " . showTyRep 11 t
+ test/Test/Control/Monad/Utils.hs view
@@ -0,0 +1,514 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Control.Monad.Utils where++import Data.Array+import Data.Fixed (Fixed (..), Micro)+import Data.Function (on)+import Data.Graph+import Data.List (sortBy)++import Control.Monad++import Control.Monad.Class.MonadFork+import Control.Concurrent.Class.MonadSTM.Strict+import Control.Monad.Class.MonadThrow+import Control.Monad.Class.MonadTimer.SI+import Control.Monad.IOSim++import Test.Control.Monad.STM++import Test.QuickCheck++--+-- Read/Write graph+--++prop_stm_graph :: (MonadFork m, MonadSTM m) => TestThreadGraph -> m ()+prop_stm_graph (TestThreadGraph g) = do+ vars <- listArray (bounds g) <$>+ sequence [ newTVarIO False | _ <- vertices g ]+ forM_ (vertices g) $ \v ->+ void $ forkIO $ do+ -- read all the inputs and wait for them to become true+ -- then write to all the outputs+ let incomming = g' ! v+ outgoing = g ! v+ atomically $ do+ sequence_ [ readTVar (vars ! var) >>= check | var <- incomming ]+ sequence_ [ writeTVar (vars ! var) True | var <- outgoing ]++ let -- the vertices with outgoing but no incoming edges+ inputs = [ v+ | v <- vertices g+ , not (null (g ! v))+ , null (g' ! v) ]+ -- the vertices with incoming but no outgoing edges+ outputs = [ v+ | v <- vertices g+ , not (null (g' ! v))+ , null (g ! v) ]++ -- write to the inputs and wait for the outputs+ void $ forkIO $ atomically $ sequence_ [ writeTVar (vars ! var) True | var <- inputs ]+ atomically $ sequence_ [ readTVar (vars ! var) >>= check | var <- outputs ]+ where+ g' = transposeG g -- for incoming edges++newtype TestThreadGraph = TestThreadGraph Graph+ deriving Show++instance Arbitrary TestThreadGraph where+ arbitrary =+ sized $ \sz ->+ TestThreadGraph <$> arbitraryAcyclicGraph+ (choose (2, 8 `min` (sz `div` 3)))+ (choose (1, 8 `min` (sz `div` 3)))+ 0.3++arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph+arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do+ nranks <- genNRanks+ rankSizes <- replicateM nranks genNPerRank+ let rankStarts = scanl (+) 0 rankSizes+ rankRanges = drop 1 (zip rankStarts (tail rankStarts))+ totalRange = sum rankSizes+ rankEdges <- mapM (uncurry genRank) rankRanges+ return $ buildG (0, totalRange-1) (concat rankEdges)+ where+ genRank :: Vertex -> Vertex -> Gen [Edge]+ genRank rankStart rankEnd =+ filterM (const (pick edgeChance))+ [ (i,j)+ | i <- [0..rankStart-1]+ , j <- [rankStart..rankEnd-1]+ ]++ pick :: Float -> Gen Bool+ pick chance = (< chance) <$> choose (0,1)+++--+-- Timers+--++newtype TestMicro = TestMicro [Micro]+ deriving Show++-- |+-- Arbitrary non negative micro numbers with a high probability of+-- repetitions.+instance Arbitrary TestMicro where+ arbitrary = sized $ \n -> TestMicro <$> genN n []+ where+ genN :: Int -> [Micro] -> Gen [Micro]+ genN 0 rs = return rs+ genN n [] = do+ r <- genMicro+ genN (n - 1) [r]+ genN n rs = do+ r <- frequency+ [ (2, elements rs)+ , (1, genMicro)+ ]+ genN (n - 1) (r : rs)++ genMicro :: Gen Micro+ genMicro = MkFixed <$> arbitrary++ shrink (TestMicro rs) = [ TestMicro rs' | rs' <- shrinkList (const []) rs ]++test_timers :: forall m.+ ( MonadDelay m+ , MonadFork m+ , MonadTimer m+ )+ => [DiffTime]+ -> m Property+test_timers xs =+ label (lbl xs) . isValid <$> withProbe experiment+ where+ countUnique :: Eq a => [a] -> Int+ countUnique [] = 0+ countUnique (a:as) =+ let as' = filter (== a) as+ in 1 + countUnique as'++ lbl :: Eq a => [a] -> String+ lbl as =+ let p = (if null as then 0 else (100 * countUnique as) `div` length as) `mod` 10 * 10+ in show p ++ "% unique"++ experiment :: Probe m (DiffTime, Int) -> m ()+ experiment p = do+ tvars <- forM (zip xs [0..]) $ \(t, idx) -> do+ v <- newTVarIO False+ void $ forkIO $ threadDelay t >> do+ probeOutput p (t, idx)+ atomically $ writeTVar v True+ return v++ -- wait for all tvars+ forM_ tvars $ \v -> atomically (readTVar v >>= check)++ isValid :: [(DiffTime, Int)] -> Property+ isValid tr =+ -- all timers should fire+ (length tr === length xs)+ -- timers should fire in the right order+ .&&. (sortBy (on sortFn fst) tr === tr)++ -- timers with negative timeout never fired, so we treat them as they would+ -- all fired at once at @-∞@. This is to say that the following function is+ -- a well defined partial order.+ sortFn :: DiffTime -> DiffTime -> Ordering+ sortFn a b | a >= 0 && b >= 0 = a `compare` b+ | a < 0 && b < 0 = EQ+ | otherwise = a `compare` b++--+-- Forking+--++test_fork_order :: forall m.+ ( MonadFork m+ , MonadTimer m+ )+ => Positive Int+ -> m Property+test_fork_order = \(Positive n) -> isValid n <$> withProbe (experiment n)+ where+ experiment :: Int -> Probe m Int -> m ()+ experiment 0 _ = return ()+ experiment n p = do+ v <- newTVarIO False++ void $ forkIO $ do+ probeOutput p n+ atomically $ writeTVar v True+ experiment (n - 1) p++ -- wait for the spawned thread to finish+ atomically $ readTVar v >>= check++ isValid :: Int -> [Int] -> Property+ isValid n tr = tr === [n,n-1..1]++test_threadId_order :: forall m.+ ( MonadFork m+ , MonadTimer m+ )+ => Positive Int+ -> m Property+test_threadId_order = \(Positive n) -> do+ isValid n <$> (forM [1..n] (const experiment))+ where+ experiment :: m (ThreadId m)+ experiment = do+ v <- newTVarIO False++ tid <- forkIO $ atomically $ writeTVar v True++ -- wait for the spawned thread to finish+ atomically $ readTVar v >>= check+ return tid++ isValid :: Int -> [ThreadId m] -> Property+ isValid n tr = map show tr === map (("ThreadId " ++ ) . show . (:[])) [1..n]++-- This property is not actually deterministic in IO. Uncomment the following+-- and try it! Arguably therefore, this property does not need to be true for+-- the Sim either. Perhaps we should introduce random scheduling and abandon+-- this property. In the meantime it's a helpful sanity check.++--prop_wakeup_order_IO = ioProperty test_wakeup_order++test_wakeup_order :: ( MonadDelay m+ , MonadFork m+ , MonadTimer m+ )+ => m Property+test_wakeup_order = do+ v <- newTVarIO False+ wakupOrder <-+ withProbe $ \p -> do+ sequence_+ [ do _ <- forkIO $ do+ atomically $ do+ x <- readTVar v+ check x+ probeOutput p (n :: Int)+ threadDelay 0.1+ | n <- [0..9] ]+ atomically $ writeTVar v True+ threadDelay 0.1+ return (wakupOrder === [0..9]) --FIFO order++--+-- Probe mini-abstraction+--++-- | Where returning results directly is not convenient, we can build up+-- a trace of events we want to observe, and can do probe output from+-- multiple threads.+--+type Probe m x = StrictTVar m [x]++withProbe :: MonadSTM m => (Probe m x -> m ()) -> m [x]+withProbe action = do+ probe <- newTVarIO []+ action probe+ reverse <$> atomically (readTVar probe)++probeOutput :: MonadSTM m => Probe m x -> x -> m ()+probeOutput probe x = atomically (modifyTVar probe (x:))++--+-- Tests vs STM operational semantics+--++--TODO: would be nice to also have stronger tests here:+-- * compare all the tvar values in the heap+-- * compare the read and write sets++-- | Compare the behaviour of the STM reference operational semantics with+-- the behaviour of any 'MonadSTM' STM implementation.+--+prop_stm_referenceM :: ( MonadSTM m+ , MonadCatch (STM m)+ , MonadCatch m+ )+ => SomeTerm -> m Property+prop_stm_referenceM (SomeTerm _tyrep t) = do+ let (r1, _heap) = evalAtomically t+ r2 <- execAtomically t+ return (r1 === r2)++-- | Check that 'timeout' does not deadlock when executed with asynchronous+-- exceptions uninterruptibly masked.+--+prop_timeout_no_deadlockM :: forall m.+ ( MonadDelay m+ , MonadFork m+ , MonadTimer m+ , MonadMask m+ )+ => m Bool+prop_timeout_no_deadlockM = do+ v <- registerDelay' 0.01+ r <- uninterruptibleMask_ $ timeout 0.02 $ do+ atomically $ do+ readTVar v >>= check+ return True+ case r of+ Nothing -> return False+ Just b -> return b+ where+ -- Like 'registerDelay', but does not require threaded RTS in the @m ~ IO@+ -- case.+ registerDelay' :: DiffTime -> m (StrictTVar m Bool)+ registerDelay' delta = do+ v <- newTVarIO False+ _ <- forkIO $ do+ threadDelay delta+ atomically (writeTVar v True)+ return v++--+-- MonadMask properties+--++setMaskingState_ :: MonadMask m => MaskingState -> m a -> m a+setMaskingState_ Unmasked = id+setMaskingState_ MaskedInterruptible = mask_+setMaskingState_ MaskedUninterruptible = uninterruptibleMask_++setMaskingState :: MonadMask m => MaskingState+ -> ((forall x. m x -> m x) -> m a) -> m a+setMaskingState Unmasked = \f -> f id+setMaskingState MaskedInterruptible = mask+setMaskingState MaskedUninterruptible = uninterruptibleMask++maxMS :: MaskingState -> MaskingState -> MaskingState+maxMS MaskedUninterruptible _ = MaskedUninterruptible+maxMS _ MaskedUninterruptible = MaskedUninterruptible+maxMS MaskedInterruptible _ = MaskedInterruptible+maxMS _ MaskedInterruptible = MaskedInterruptible+maxMS Unmasked Unmasked = Unmasked++-- | Check that setting masking state is effective.+--+prop_set_masking_state :: MonadMaskingState m+ => MaskingState+ -> m Property+prop_set_masking_state ms =+ setMaskingState_ ms $ do+ ms' <- getMaskingState+ return (ms === ms')++-- | Check that 'unmask' restores the masking state.+--+prop_unmask :: MonadMaskingState m+ => MaskingState+ -> MaskingState+ -> m Property+prop_unmask ms ms' =+ setMaskingState_ ms $+ setMaskingState ms' $ \unmask -> do+ ms'' <- unmask getMaskingState+ return (ms'' === ms)++-- | Check that masking state is inherited by a forked thread.+--+prop_fork_masking_state :: ( MonadMaskingState m+ , MonadFork m+ , MonadSTM m+ )+ => MaskingState -> m Property+prop_fork_masking_state ms = setMaskingState_ ms $ do+ var <- newEmptyTMVarIO+ _ <- forkIO $ getMaskingState >>= atomically . putTMVar var+ ms' <- atomically $ takeTMVar var+ return $ ms === ms'++-- | Check that 'unmask' restores the masking state in a forked thread.+--+-- Note: unlike 'prop_unmask', 'forkIOWithUnmask's 'unmask' function will+-- restore 'Unmasked' state, not the encosing masking state.+--+prop_fork_unmask :: ( MonadMaskingState m+ , MonadFork m+ , MonadSTM m+ )+ => MaskingState+ -> MaskingState+ -> m Property+prop_fork_unmask ms ms' =+ setMaskingState_ ms $+ setMaskingState_ ms' $ do+ var <- newEmptyTMVarIO+ _ <- forkIOWithUnmask $ \unmask -> unmask getMaskingState+ >>= atomically . putTMVar var+ ms'' <- atomically $ takeTMVar var+ return $ Unmasked === ms''++-- | A unit test which checks the masking state in the context of a catch+-- handler.+--+prop_catch_throwIO_masking_state :: forall m. MonadMaskingState m+ => MaskingState -> m Property+prop_catch_throwIO_masking_state ms =+ setMaskingState_ ms $ do+ throwIO (userError "error")+ `catch` \(_ :: IOError) -> do+ ms' <- getMaskingState+ return $ ms' === MaskedInterruptible `maxMS` ms++-- | Like 'prop_catch_masking_state' but using 'throwTo'.+--+prop_catch_throwTo_masking_state :: forall m.+ ( MonadMaskingState m+ , MonadFork m+ )+ => MaskingState -> m Property+prop_catch_throwTo_masking_state ms =+ setMaskingState_ ms $ do+ tid <- myThreadId+ (throwTo tid (userError "error") >> error "impossible")+ `catch` \(_ :: IOError) -> do+ ms' <- getMaskingState+ return $ ms' === MaskedInterruptible `maxMS` ms++-- | Like 'prop_catch_throwTo_masking_state' but using 'throwTo' to a different+-- thread which is in a non-blocking mode.+--+prop_catch_throwTo_masking_state_async :: forall m.+ ( MonadMaskingState m+ , MonadFork m+ , MonadSTM m+ , MonadDelay m+ )+ => MaskingState -> m Property+prop_catch_throwTo_masking_state_async ms = do+ sgnl <- newEmptyTMVarIO+ var <- newEmptyTMVarIO+ tid <- forkIO $+ setMaskingState ms $ \unmask ->+ (do atomically $ putTMVar sgnl ()+ unmask (threadDelay 1)+ )+ `catch` \(_ :: IOError) -> do+ ms' <- getMaskingState+ atomically $ putTMVar var (ms' === ms `maxMS` MaskedInterruptible)+ -- wait until the catch handler is installed+ atomically $ takeTMVar sgnl+ -- the forked thread is interruptibly blocked on `threadDelay`,+ -- `throwTo` will not block+ throwTo tid (userError "error")+ atomically $ takeTMVar var++-- | Like 'prop_catch_throwTo_masking_state_async' but 'throwTo' will block if+-- masking state is set to 'MaskedUninterruptible'. This makes sure that the+-- 'willBlock' branch of 'ThrowTo' in 'schedule' is covered.+--+prop_catch_throwTo_masking_state_async_mayblock :: forall m.+ ( MonadMaskingState m+ , MonadFork m+ , MonadSTM m+ , MonadDelay m+ )+ => MaskingState -> m Property+prop_catch_throwTo_masking_state_async_mayblock ms = do+ sgnl <- newEmptyTMVarIO+ var <- newEmptyTMVarIO+ tid <- forkIO $+ setMaskingState ms $ \unmask ->+ (do atomically $ putTMVar sgnl ()+ -- if 'ms' is 'MaskedUninterruptible' then the following+ -- 'threadDelay' will block.+ threadDelay 0.1+ -- make sure that even in 'MaskedUninterruptible' the thread+ -- unblocks so async exceptions can be delivered.+ unmask (threadDelay 1)+ )+ `catch` \(_ :: IOError) -> do+ ms' <- getMaskingState+ atomically $ putTMVar var (ms' === ms `maxMS` MaskedInterruptible)+ -- wait until the catch handler is installed+ atomically $ takeTMVar sgnl+ threadDelay 0.05+ -- we know the forked thread is interruptibly blocked on `threadDelay`,+ -- `throwTo` will not be blocked.+ throwTo tid (userError "error")+ atomically $ takeTMVar var++--+-- MonadMask properties+--++forall_masking_states :: (MaskingState -> Property)+ -> Property+forall_masking_states prop =+ -- make sure that the property is executed once!+ withMaxSuccess 1 $+ foldr (\ms p -> counterexample (show ms) (prop ms) .&&. p)+ (property True)+ [Unmasked, MaskedInterruptible, MaskedUninterruptible]++--+-- Utils+--++runSimTraceSay :: (forall s. IOSim s a) -> [String]+runSimTraceSay action = selectTraceSay (runSimTrace action)++selectTraceSay :: SimTrace a -> [String]+selectTraceSay (SimTrace _ _ _ (EventSay msg) trace) = msg : selectTraceSay trace+selectTraceSay (SimTrace _ _ _ _ trace) = selectTraceSay trace+selectTraceSay (SimPORTrace _ _ _ _ (EventSay msg) trace) = msg : selectTraceSay trace+selectTraceSay (SimPORTrace _ _ _ _ _ trace) = selectTraceSay trace+selectTraceSay _ = []+