mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-25 06:21:46 +03:00
127 lines
4.0 KiB
Haskell
Executable File
127 lines
4.0 KiB
Haskell
Executable File
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-
|
|
The auto-update package:
|
|
https://hackage.haskell.org/package/auto-update
|
|
|
|
Users found a possible deadlock and livelock:
|
|
https://www.reddit.com/r/haskell/comments/2i5d7m/updating_autoupdate/
|
|
|
|
This is the code from Control.AutoUpdate modified to use the
|
|
@MonadConc@ abstraction, with tests added to verify that the issues
|
|
identified are caught.. The original code is available under the MIT
|
|
license, which is reproduced below.
|
|
|
|
- - - - -
|
|
|
|
Copyright (c) 2014 Michael Snoyman
|
|
|
|
Permission is hereby granted, free of charge, to any person obtaining
|
|
a copy of this software and associated documentation files (the
|
|
"Software"), to deal in the Software without restriction, including
|
|
without limitation the rights to use, copy, modify, merge, publish,
|
|
distribute, sublicense, and/or sell copies of the Software, and to
|
|
permit persons to whom the Software is furnished to do so, subject to
|
|
the following conditions:
|
|
|
|
The above copyright notice and this permission notice shall be included
|
|
in all copies or substantial portions of the Software.
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
|
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
|
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
|
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
|
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
|
-}
|
|
|
|
module Examples.AutoUpdate where
|
|
|
|
import Control.Exception (SomeException)
|
|
import Control.Monad
|
|
import Control.Monad.Conc.Class
|
|
|
|
-- test imports
|
|
import Test.DejaFu (Bounds(..), Failure(..), MemType(..), defaultBounds, gives)
|
|
import Test.Framework (Test)
|
|
import Test.Framework.Providers.HUnit (hUnitTestToTests)
|
|
import Test.HUnit (test)
|
|
import Test.HUnit.DejaFu
|
|
|
|
tests :: [Test]
|
|
tests = hUnitTestToTests $ test
|
|
[ testDejafu' SequentialConsistency
|
|
defaultBounds
|
|
deadlocks
|
|
"deadlocks"
|
|
(gives [Left Deadlock, Right ()])
|
|
|
|
, testDejafu' SequentialConsistency
|
|
defaultBounds { boundPreemp = Just 3 }
|
|
nondeterministic
|
|
"nondeterministic"
|
|
(gives [Left Deadlock, Right 0, Right 1])
|
|
]
|
|
|
|
-- This exhibits a deadlock with no preemptions.
|
|
deadlocks :: MonadConc m => m ()
|
|
deadlocks = join (mkAutoUpdate defaultUpdateSettings)
|
|
|
|
-- This exhibits nondeterminism with three preemptions.
|
|
nondeterministic :: forall m. MonadConc m => m Int
|
|
nondeterministic = do
|
|
var <- newCRef 0
|
|
let settings = (defaultUpdateSettings :: UpdateSettings m ())
|
|
{ updateAction = atomicModifyCRef var (\x -> (x+1, x)) }
|
|
auto <- mkAutoUpdate settings
|
|
auto
|
|
auto
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
data UpdateSettings m a = UpdateSettings
|
|
{ updateFreq :: Int
|
|
, updateSpawnThreshold :: Int
|
|
, updateAction :: m a
|
|
}
|
|
|
|
defaultUpdateSettings :: MonadConc m => UpdateSettings m ()
|
|
defaultUpdateSettings = UpdateSettings
|
|
{ updateFreq = 1000000
|
|
, updateSpawnThreshold = 3
|
|
, updateAction = return ()
|
|
}
|
|
|
|
mkAutoUpdate :: MonadConc m => UpdateSettings m a -> m (m a)
|
|
mkAutoUpdate us = do
|
|
currRef <- newCRef Nothing
|
|
needsRunning <- newEmptyMVar
|
|
lastValue <- newEmptyMVar
|
|
|
|
void $ fork $ forever $ do
|
|
takeMVar needsRunning
|
|
|
|
a <- catchSome $ updateAction us
|
|
|
|
writeCRef currRef $ Just a
|
|
void $ tryTakeMVar lastValue
|
|
putMVar lastValue a
|
|
|
|
threadDelay $ updateFreq us
|
|
|
|
writeCRef currRef Nothing
|
|
void $ takeMVar lastValue
|
|
|
|
return $ do
|
|
mval <- readCRef currRef
|
|
case mval of
|
|
Just val -> return val
|
|
Nothing -> do
|
|
void $ tryPutMVar needsRunning ()
|
|
readMVar lastValue
|
|
|
|
catchSome :: MonadConc m => m a -> m a
|
|
catchSome act = catch act $
|
|
\e -> throw (e :: SomeException)
|