skew?

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad

main = do
  dog <- newTVarIO False
  cat <- newTVarIO False
  let unset = do
        d <- readTVar dog
        c <- readTVar cat
        if (d || c) then retry else return ()
      setDog = unset >> writeTVar dog True
      setCat = unset >> writeTVar cat True
      oops = do
        d <- readTVar dog
        c <- readTVar cat
        guard (d && c)
      reset = do
        writeTVar dog False
        writeTVar cat False
      reset' = do
        d <- readTVar dog
        c <- readTVar cat
        guard (d || c)
        reset
  -- return (setDog,setCat,reset,oops,sample (dog,cat))
  forkIO (atomically oops >> putStrLn "Oh Noes!")
  forever (do
    forkIO (atomically setDog)
    forkIO (atomically setCat)
    atomically reset'
    atomically reset')

sample (va,vb) = atomically (do a <- readTVar va; b <- readTVar vb; return (a,b))
11:9: Error: Use when
Found:
if (d || c) then retry else return ()
Why not:
when (d || c) retry
11:9: Warning: Redundant bracket
Found:
if (d || c) then retry else return ()
Why not:
if d || c then retry else return ()

skew? (annotation)

1
2
3
4
5
6
7
$ ghc -threaded --make Skew
[1 of 1] Compiling Main             ( Skew.hs, Skew.o )
Linking Skew ...
$ ./Skew +RTS -N2
Tick
Oh Noes!
Skew: thread blocked indefinitely in an STM transaction

skew? (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Concurrent
import Control.Monad

main = do
  dog <- newTVarIO False
  cat <- newTVarIO False
  let unset = do
        d <- readTVar dog
        c <- readTVar cat
        if (d || c) then retry else return ()
      setDog = unset >> writeTVar dog True
      setCat = unset >> writeTVar cat True
      oops = do
        d <- readTVar dog
        c <- readTVar cat
        guard (d && c)
      reset = do
        writeTVar dog False
        writeTVar cat False
  -- return (setDog,setCat,reset,oops,sample (dog,cat))
  forkIO (atomically oops >> putStrLn "Oh Noes!")
  waitSem <- atomically (newTSem 0)
  forever ((lots 10000 $ do
    forkIO (atomically setDog >> atomically (signalTSem waitSem))
    forkIO (atomically setCat >> atomically (signalTSem waitSem))
    atomically (waitTSem waitSem)
    atomically reset
    atomically (waitTSem waitSem)
    atomically reset) >> putStrLn "Tick")

lots 0 a = return ()
lots n a = a >> lots (n-1) a

sample (va,vb) = atomically (do a <- readTVar va; b <- readTVar vb; return (a,b))
12:9: Error: Use when
Found:
if (d || c) then retry else return ()
Why not:
when (d || c) retry
12:9: Warning: Redundant bracket
Found:
if (d || c) then retry else return ()
Why not:
if d || c then retry else return ()
25:12: Warning: Redundant $
Found:
(lots 10000 $
do forkIO (atomically setDog >> atomically (signalTSem waitSem))
forkIO (atomically setCat >> atomically (signalTSem waitSem))
atomically (waitTSem waitSem)
atomically reset
atomically (waitTSem waitSem)
atomically reset)
>> putStrLn "Tick"
Why not:
lots 10000
(do forkIO (atomically setDog >> atomically (signalTSem waitSem))
forkIO (atomically setCat >> atomically (signalTSem waitSem))
atomically (waitTSem waitSem)
atomically reset
atomically (waitTSem waitSem)
atomically reset)
>> putStrLn "Tick"

skew? (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Concurrent
import Control.Monad

main = do
  dog <- newTVarIO False
  cat <- newTVarIO False
  let unset = do
        d <- readTVar dog
        c <- readTVar cat
        if (d || c) then retry else return ()
      setDog = unset >> writeTVar dog True
      setCat = unset >> writeTVar cat True
      oops = do
        d <- readTVar dog
        c <- readTVar cat
        guard (d && c)
      reset = do
        writeTVar dog False
        writeTVar cat False
  forkIO (forever (atomically oops >> putStrLn "Oh Noes!"))
  waitSem <- atomically (newTSem 0)
  forever (do
    forkIO (atomically setDog >> atomically (signalTSem waitSem))
    forkIO (atomically setCat >> atomically (signalTSem waitSem))
    atomically (waitTSem waitSem)
    atomically reset
    atomically (waitTSem waitSem)
    atomically reset)
12:9: Error: Use when
Found:
if (d || c) then retry else return ()
Why not:
when (d || c) retry
12:9: Warning: Redundant bracket
Found:
if (d || c) then retry else return ()
Why not:
if d || c then retry else return ()

skew? (annotation)

1
2
3
4
5
6
7
8
9
10
11
$ ghc --make -threaded Skew
[1 of 1] Compiling Main             ( Skew.hs, Skew.o )
Linking Skew ...
$ ./Skew +RTS -N2
Oh Noes!
Oh Noes!
Oh Noes!
Oh Noes!
Oh Noes!
Oh Noes!
....

skew? (annotation) (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
import           Control.Concurrent.STM
import           Control.Concurrent
import           Control.Concurrent.Async
import           Control.Monad            (guard, when)

unset :: TVar Bool -> TVar Bool -> STM ()
unset cat dog = do
  d <- readTVar dog
  c <- readTVar cat
  when (d || c) retry

setDog :: TVar Bool -> TVar Bool -> STM()
setDog cat dog = unset cat dog >> writeTVar dog True

setCat :: TVar Bool -> TVar Bool -> STM()
setCat cat dog = unset cat dog >> writeTVar cat True

oops :: TVar Bool -> TVar Bool -> STM ()
oops cat dog = do
  d <- readTVar dog
  c <- readTVar cat
  guard (d && c)

reset cat dog= do
  writeTVar dog False
  writeTVar cat False

skew = do
  dog <- newTVarIO False
  cat <- newTVarIO False
  forkIO (forever $ ((atomically $ oops cat dog) >> putStrLn "Oh Noes!"))
  forever $ do
         m  <- async $ (atomically $ setDog cat dog)
         m' <- async $ (atomically $ setCat cat dog)
         waitEither m m'
         atomically $ reset cat dog
         waitBoth m m'
         atomically $ reset cat dog
31:11: Warning: Redundant $
Found:
forever $ ((atomically $ oops cat dog) >> putStrLn "Oh Noes!")
Why not:
forever ((atomically $ oops cat dog) >> putStrLn "Oh Noes!")
31:22: Warning: Redundant $
Found:
(atomically $ oops cat dog) >> putStrLn "Oh Noes!"
Why not:
atomically (oops cat dog) >> putStrLn "Oh Noes!"
33:16: Warning: Redundant $
Found:
async $ (atomically $ setDog cat dog)
Why not:
async (atomically $ setDog cat dog)
33:16: Warning: Redundant $
Found:
async $ (atomically $ setDog cat dog)
Why not:
async $ atomically (setDog cat dog)
34:16: Warning: Redundant $
Found:
async $ (atomically $ setCat cat dog)
Why not:
async (atomically $ setCat cat dog)
34:16: Warning: Redundant $
Found:
async $ (atomically $ setCat cat dog)
Why not:
async $ atomically (setCat cat dog)