diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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)) + ] + ] + ] diff --git a/io-sim.cabal b/io-sim.cabal new file mode 100644 --- /dev/null +++ b/io-sim.cabal @@ -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 diff --git a/src/Control/Monad/IOSim.hs b/src/Control/Monad/IOSim.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSim.hs @@ -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 [ "<>" + ] + displayException (FailureSloppyShutdown threads) = + concat [ "<>" + ] + 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 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 diff --git a/src/Control/Monad/IOSim/CommonTypes.hs b/src/Control/Monad/IOSim/CommonTypes.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSim/CommonTypes.hs @@ -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) diff --git a/src/Control/Monad/IOSim/Internal.hs b/src/Control/Monad/IOSim/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSim/Internal.hs @@ -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 $ "<>") + 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 $ "<>") + 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 $ "<>") + 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 #-} diff --git a/src/Control/Monad/IOSim/InternalTypes.hs b/src/Control/Monad/IOSim/InternalTypes.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSim/InternalTypes.hs @@ -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 ()) diff --git a/src/Control/Monad/IOSim/STM.hs b/src/Control/Monad/IOSim/STM.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSim/STM.hs @@ -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 diff --git a/src/Control/Monad/IOSim/Types.hs b/src/Control/Monad/IOSim/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSim/Types.hs @@ -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) = "<>" + +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} diff --git a/src/Control/Monad/IOSimPOR/Internal.hs b/src/Control/Monad/IOSimPOR/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSimPOR/Internal.hs @@ -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 $ "<>") + 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 $ "<>") + 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 $ "<>") + 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' diff --git a/src/Control/Monad/IOSimPOR/QuickCheckUtils.hs b/src/Control/Monad/IOSimPOR/QuickCheckUtils.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSimPOR/QuickCheckUtils.hs @@ -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 diff --git a/src/Control/Monad/IOSimPOR/Timeout.hs b/src/Control/Monad/IOSimPOR/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSimPOR/Timeout.hs @@ -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 _ = "<>" + +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 diff --git a/src/Control/Monad/IOSimPOR/Types.hs b/src/Control/Monad/IOSimPOR/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IOSimPOR/Types.hs @@ -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 diff --git a/src/Data/List/Trace.hs b/src/Data/List/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Trace.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/Control/Monad/Class/MonadMVar.hs b/test/Test/Control/Monad/Class/MonadMVar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Monad/Class/MonadMVar.hs @@ -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' diff --git a/test/Test/Control/Monad/IOSim.hs b/test/Test/Control/Monad/IOSim.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Monad/IOSim.hs @@ -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' +-- +-- +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' +-- +-- +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) diff --git a/test/Test/Control/Monad/IOSimPOR.hs b/test/Test/Control/Monad/IOSimPOR.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Monad/IOSimPOR.hs @@ -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' +-- +-- +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 diff --git a/test/Test/Control/Monad/STM.hs b/test/Test/Control/Monad/STM.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Monad/STM.hs @@ -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. +-- +-- +-- +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 + -- + 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 ( :: " ++ 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 diff --git a/test/Test/Control/Monad/Utils.hs b/test/Test/Control/Monad/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Monad/Utils.hs @@ -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 _ = [] +