Drop support for invariant checking
authorBen Gamari <ben@smart-cactus.org>
Thu, 31 May 2018 17:54:40 +0000 (13:54 -0400)
committerBen Gamari <ben@smart-cactus.org>
Sat, 2 Jun 2018 23:03:18 +0000 (19:03 -0400)
16 files changed:
Control/Monad/STM.hs
changelog.md
stm.cabal
tests/T14171.hs [deleted file]
tests/T14171.stderr [deleted file]
tests/T3049.hs [deleted file]
tests/T3049.stdout [deleted file]
tests/T4057.hs [deleted file]
tests/T4057.stdout [deleted file]
tests/all.T
tests/stm060.hs [deleted file]
tests/stm060.stdout [deleted file]
tests/stm062.hs [deleted file]
tests/stm062.stdout [deleted file]
tests/stm063.hs [deleted file]
tests/stm063.stdout [deleted file]

index fb21f53..f185d37 100644 (file)
 --
 -- This module only defines the 'STM' monad; you probably want to
 -- import "Control.Concurrent.STM" (which exports "Control.Monad.STM").
+--
+-- Note that invariant checking (namely the @always@ and @alwaysSucceeds@
+-- functions) has been removed. See ticket [#14324](https://ghc.haskell.org/trac/ghc/ticket/14324) and
+-- the [removal proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0011-deprecate-stm-invariants.rst).
+-- Existing users are encouraged to encapsulate their STM operations in safe
+-- abstractions which can perform the invariant checking without help from the
+-- runtime system.
+
 -----------------------------------------------------------------------------
 
 module Control.Monad.STM (
         STM,
         atomically,
 #ifdef __GLASGOW_HASKELL__
-        always,
-        alwaysSucceeds,
         retry,
         orElse,
         check,
index ec2a6a5..8d3e576 100644 (file)
@@ -1,5 +1,9 @@
 # Changelog for [`stm` package](http://hackage.haskell.org/package/stm)
 
+## 2.5.0.0 *TBA*
+
+  * Removed `alwaysSucceeds` and `always`, GHC's invariant checking primitives. (GHC #14324)
+
 ## 2.4.5.0 *Feb 2018*
 
   * Fix space leak in `TBQueue` (gh-2, GHC#14494)
index 94b2022..1ec9a25 100644 (file)
--- a/stm.cabal
+++ b/stm.cabal
@@ -1,5 +1,5 @@
 name:           stm
-version:        2.4.5.0
+version:        2.5.0.0
 -- don't forget to update changelog.md file!
 license:        BSD3
 license-file:   LICENSE
diff --git a/tests/T14171.hs b/tests/T14171.hs
deleted file mode 100644 (file)
index e954d72..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-module Main where
-
-import Control.Concurrent.STM
-import Control.Concurrent.STM.TVar
-import Control.Applicative
-import Prelude -- for AMP compat
-
-data A = A String deriving (Eq, Show)
-
-data E = E {
-  a :: TVar [Int],
-  b :: TVar A,
-  c :: TVar [Int]
-  }
-
-consistency_1 :: E -> STM Bool
-consistency_1 = \e -> do
-  _ <- readTVar $ c e
-  return True
-
-installSanityChecks :: E -> IO ()
-installSanityChecks e = do
-  x e
-  fail "You should see this failure"
-
-x :: E -> IO ()
-x e = do
-  -- This unexpected succeeds
-  atomically $ installCheck consistency_1
-  -- error "derp2"
-  where
-    installCheck check = always $ check e
-
-main :: IO ()
-main = do
-  state <- initialize
-  installSanityChecks state
-
-initialize :: IO E
-initialize = E <$> newTVarIO [] <*> newTVarIO (A "USD") <*> newTVarIO []
diff --git a/tests/T14171.stderr b/tests/T14171.stderr
deleted file mode 100644 (file)
index 84de5c7..0000000
+++ /dev/null
@@ -1 +0,0 @@
-T14171: user error (You should see this failure)
diff --git a/tests/T3049.hs b/tests/T3049.hs
deleted file mode 100644 (file)
index 1894562..0000000
+++ /dev/null
@@ -1,8 +0,0 @@
-import Control.Concurrent.STM
-
-main = do
-  x <- atomically $ do
-    v <- newTVar 0
-    always $ return True -- remove this line and all is fine
-    return v
-  atomically (readTVar x) >>= print
diff --git a/tests/T3049.stdout b/tests/T3049.stdout
deleted file mode 100644 (file)
index 573541a..0000000
+++ /dev/null
@@ -1 +0,0 @@
-0
diff --git a/tests/T4057.hs b/tests/T4057.hs
deleted file mode 100644 (file)
index cda40f0..0000000
+++ /dev/null
@@ -1,20 +0,0 @@
-import Control.Monad
-import GHC.Conc
-import System.IO
-
-modifyTVar :: TVar Integer -> (Integer -> Integer) -> STM ()
-modifyTVar t f = readTVar t >>= writeTVar t . f
-
-main :: IO ()
-main = do
-  hSetBuffering stdout LineBuffering
-  t <- newTVarIO 0
-  let f = atomically $ do always (liftM2 (<=) (readTVar t) (return 5))
-                          modifyTVar t succ
-  putStrLn "f1"
-  f
-  putStrLn "f2"
-  f
-  putStrLn "v"
-  v <- atomically $ readTVar t
-  print v
diff --git a/tests/T4057.stdout b/tests/T4057.stdout
deleted file mode 100644 (file)
index 7276a06..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
-f1
-f2
-v
-2
index c2ea89e..be105ff 100644 (file)
@@ -19,14 +19,8 @@ test('stm055', exit_code(1), compile_and_run, ['-package stm'])
 test('stm056', only_ways(['threaded1','threaded2']),
                 compile_and_run, ['-package stm'])
 
-test('stm060', normal, compile_and_run, ['-package stm'])
 test('stm061', normal, compile_and_run, ['-package stm'])
-test('stm062', normal, compile_and_run, ['-package stm'])
-test('stm063', when(fast(),skip), compile_and_run, ['-package stm'])
 test('T2411', ignore_stdout, compile_and_run, ['-package stm'])
-test('T3049', normal, compile_and_run, ['-package stm'])
-test('T4057', normal, compile_and_run, ['-package stm'])
 test('stm064', normal, compile_and_run, ['-package stm'])
 test('stm065', normal, compile_and_run, ['-package stm'])
 test('cloneTChan001', normal, compile_and_run, ['-package stm'])
-test('T14171', exit_code(1), compile_and_run, ['-package stm'])
diff --git a/tests/stm060.hs b/tests/stm060.hs
deleted file mode 100644 (file)
index 5ebdaf0..0000000
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-module Main where
-
-import GHC.Conc
-import Control.Exception
-
--- Create trivial invariants using a single TVar
-main = do
-  putStr "\nStarting\n"
-  x <- atomically ( newTVar 42 )
-
-  putStr "\nAdding trivially true invariant (no TVar access)\n"
-  atomically ( alwaysSucceeds ( return 1 ) )
-
-  putStr "\nAdding trivially true invariant (no TVar access)\n"
-  atomically ( always ( return True ) )
-
-  putStr "\nAdding a trivially true invariant (TVar access)\n"
-  atomically ( alwaysSucceeds ( readTVar x ) )
-
-  putStr "\nAdding an invariant that's false when attempted to be added\n"
-  Control.Exception.catch (atomically ( do writeTVar x 100
-                                           alwaysSucceeds ( do v <- readTVar x
-                                                               if (v == 100) then throw (ErrorCall "URK") else return () )
-                                           writeTVar x 0 ) )
-      (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putStr "\nWriting to a TVar watched by a trivially true invariant\n"
-  atomically ( writeTVar x 17 )
-
-  putStr "\nAdding a second trivially true invariant (same TVar access)\n"
-  atomically ( alwaysSucceeds ( readTVar x ) )
-
-  putStr "\nWriting to a TVar watched by both trivially true invariants\n"
-  atomically ( writeTVar x 18 )
-
-  putStr "\nAdding a trivially false invariant (no TVar access)\n"
-  Control.Exception.catch (atomically ( alwaysSucceeds ( throw (ErrorCall "Exn raised in invariant") ) ) )
-      (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putStr "\nAdding a trivially false invariant (no TVar access)\n"
-  Control.Exception.catch (atomically ( always ( throw (ErrorCall "Exn raised in invariant") ) ) )
-      (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putStr "\nAdding a trivially false invariant (no TVar access)\n"
-  Control.Exception.catch (atomically ( always ( return False ) ) )
-      (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putStr "\nAdding a trivially false invariant (with TVar access)\n"
-  Control.Exception.catch (atomically (
-                alwaysSucceeds ( do t <- readTVar x
-                                    throw (ErrorCall "Exn raised in invariant") ) ) )
-      (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putStr "\nAdding a third invariant true if TVar != 42\n"
-  atomically ( alwaysSucceeds ( do t <- readTVar x
-                                   if (t == 42) then throw (ErrorCall "Exn raised in invariant") else return () ) )
-
-  putStr "\nViolating third invariant by setting TVar to 42\n"
-  Control.Exception.catch (atomically ( writeTVar x 42 ) )
-      (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putStr "\nChecking final TVar contents\n"
-  t <- atomically ( readTVar x )
-  putStr ("Final value = " ++ (show t) ++ "\n")
-
-  putStr "\nDone\n"
-
diff --git a/tests/stm060.stdout b/tests/stm060.stdout
deleted file mode 100644 (file)
index b476708..0000000
+++ /dev/null
@@ -1,39 +0,0 @@
-
-Starting
-
-Adding trivially true invariant (no TVar access)
-
-Adding trivially true invariant (no TVar access)
-
-Adding a trivially true invariant (TVar access)
-
-Adding an invariant that's false when attempted to be added
-Caught: URK
-
-Writing to a TVar watched by a trivially true invariant
-
-Adding a second trivially true invariant (same TVar access)
-
-Writing to a TVar watched by both trivially true invariants
-
-Adding a trivially false invariant (no TVar access)
-Caught: Exn raised in invariant
-
-Adding a trivially false invariant (no TVar access)
-Caught: Exn raised in invariant
-
-Adding a trivially false invariant (no TVar access)
-Caught: Transactional invariant violation
-
-Adding a trivially false invariant (with TVar access)
-Caught: Exn raised in invariant
-
-Adding a third invariant true if TVar != 42
-
-Violating third invariant by setting TVar to 42
-Caught: Exn raised in invariant
-
-Checking final TVar contents
-Final value = 18
-
-Done
diff --git a/tests/stm062.hs b/tests/stm062.hs
deleted file mode 100644 (file)
index 31d364c..0000000
+++ /dev/null
@@ -1,39 +0,0 @@
-module Main where
-
-import GHC.Conc
-import Control.Exception
-
--- Test invariants using multiple TVars
-main = do
-  putStr "\nStarting\n"
-  (x1, x2, x3) <- atomically ( do x1 <- newTVar 0
-                                  x2 <- newTVar 0 
-                                  x3 <- newTVar 0 
-                                  return (x1, x2, x3))
-
-  putStr "\nAttaching invariant\n";
-  atomically ( alwaysSucceeds ( do v1 <- readTVar x1
-                                   v23 <- readTVar (if (v1 >= 0) then x2 else x3)
-                                   if (v23 > v1) then throw (ErrorCall "Exn") else return () ) )
-
-  putStr "\nTouching invariant (should keep on same TVars)\n"
-  atomically ( do writeTVar x1 1
-                  writeTVar x2 1 )
-
-  putStr "\nTouching invariant (should move it to other TVars)\n"
-  atomically ( do writeTVar x1 (-1)
-                  writeTVar x3 (-1) )
-
-  putStr "\nTouching invariant (should keep on same TVars)\n"
-  atomically ( do writeTVar x1 (-2)
-                  writeTVar x3 (-3) )
-
-  putStr "\nChecking TVar contents\n"
-  (t1, t2, t3) <- atomically ( do t1 <- readTVar x1
-                                  t2 <- readTVar x2
-                                  t3 <- readTVar x3
-                                  return (t1, t2, t3))
-  putStr ("Contents = (" ++ (show t1) ++ "," ++ (show t2) ++ "," ++ (show t3) ++ ")\n")
-
-  putStr "\nDone\n"
-         
diff --git a/tests/stm062.stdout b/tests/stm062.stdout
deleted file mode 100644 (file)
index 6cff439..0000000
+++ /dev/null
@@ -1,15 +0,0 @@
-\r
-Starting\r
-\r
-Attaching invariant\r
-\r
-Touching invariant (should keep on same TVars)\r
-\r
-Touching invariant (should move it to other TVars)\r
-\r
-Touching invariant (should keep on same TVars)\r
-\r
-Checking TVar contents\r
-Contents = (-2,1,-3)\r
-\r
-Done\r
diff --git a/tests/stm063.hs b/tests/stm063.hs
deleted file mode 100644 (file)
index 13c4a3c..0000000
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-module Main where
-
-import GHC.Conc
-import Control.Exception
-import Foreign.StablePtr
-import System.IO
-import Control.Concurrent.MVar
-
--- Test invariants using updates & blocking in invariants
-main = do
-  m <- newEmptyMVar
-  forkIO (do_test m)
-  -- We do the test in a separate thread, because this test relies on
-  -- being able to catch BlockedIndefinitely, and the main thread
-  -- won't receive that exception under GHCi because it is held alive
-  -- by the interrupt (^C) handler thread.
-  newStablePtr m
-  -- the MVar m must be kept alive, otherwise when the subthread is
-  -- BlockedIndefinitely, the MVar will be unreachable and the main
-  -- thread will also be considered to be BlockedIndefinitely.
-  takeMVar m
-
-do_test m = do
-  newStablePtr stdout
-
-  putStr "\nStarting\n"
-  (x1, x2, x3) <- atomically ( do x1 <- newTVar 0
-                                  x2 <- newTVar 0 
-                                  x3 <- newTVar 0 
-                                  return (x1, x2, x3))
-
-  putStr "\nAttaching successful invariant that makes an update\n";
-  atomically ( alwaysSucceeds ( writeTVar x1 42 ) ) 
-
-  putStr "\nAttaching successful invariant that uses retry&orelse internally\n";
-  atomically ( alwaysSucceeds ( retry `orElse` return () ) ) 
-
-  putStr "\nAttaching a failed invariant that makes an update\n";
-  Control.Exception.catch (atomically ( do writeTVar x1 17
-                                           alwaysSucceeds ( throw (ErrorCall "Exn raised in invariant") ) ) )
-      (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putStr "\nAttaching an invariant that blocks\n";
-  forkIO ( do threadDelay 1000000
-              atomically ( writeTVar x1 10 ) 
-              return ()) 
-  atomically ( do alwaysSucceeds ( do v1 <- readTVar x1
-                                      if (v1 == 0) then retry else return () )
-              )
-  
-  putStr "\nAnother update to the TVar with the blocking invariant\n"
-  atomically ( writeTVar x1 20 ) 
-
-  putStr "\nUpdate the TVar to cause the invariant to block again (expect thread blocked indef)\n"
-  Control.Exception.catch (atomically ( writeTVar x1 0 ))
-                 (\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
-
-  putMVar m ()         
diff --git a/tests/stm063.stdout b/tests/stm063.stdout
deleted file mode 100644 (file)
index 3021e1a..0000000
+++ /dev/null
@@ -1,16 +0,0 @@
-
-Starting
-
-Attaching successful invariant that makes an update
-
-Attaching successful invariant that uses retry&orelse internally
-
-Attaching a failed invariant that makes an update
-Caught: Exn raised in invariant
-
-Attaching an invariant that blocks
-
-Another update to the TVar with the blocking invariant
-
-Update the TVar to cause the invariant to block again (expect thread blocked indef)
-Caught: thread blocked indefinitely in an STM transaction