ghc/interpreter/test/exts/mvar.hs

   1 --!!! Testing the MVar primitives
   2
   3 -- I quickly converted some of this code to work in the new system.
   4 -- Many of the rest haven't been updated or tested much and you'll
   5 -- find that the claims about what they "should print" are  wrong
   6 -- being based on the old Hugs behaviour instead of assuming an
   7 -- arbitrary interleaving.
   8 --
   9 -- ADR - 5th nov 1998
  10
  11 module TestMVar(test1,test2,test3,test4,test5,test6,test7,test8) where
  12
  13 import Concurrent
  14
  15 -- should print "a" then deadlock
  16 test1 = do
  17   { v <- newEmptyMVar
  18   ; putMVar v 'a'
  19   ; get v
  20   ; get v
  21   }
  22
  23 -- Nondeterministic
  24 test2 = do
  25   { v <- newEmptyMVar
  26   ; forkIO (p1 v)
  27   ; p2 v
  28   }
  29  where
  30   p1 v = do { put v 'a'; get v     }
  31   p2 v = do { get v    ; put v 'b' }
  32
  33 -- should print "a"
  34 test3 =
  35   newEmptyMVar         >>= \ v ->
  36   forkIO (put v 'a')   >>
  37   get v
  38
  39 -- should print "ab"
  40 -- NB: it's important that p1 is called from the main thread to make sure
  41 -- that the final get is executed
  42 test4 = do
  43   { v1 <- newEmptyMVar
  44   ; v2 <- newEmptyMVar
  45   ; forkIO (p2 v1 v2)
  46   ; p1 v1 v2
  47   }
  48  where
  49   p1 v1 v2 = do { put v1 'a'; get v2     }
  50   p2 v1 v2 = do { get v1    ; put v2 'b' }
  51
  52 -- should abort: primPutMVar: full MVar
  53 test5 =
  54   newEmptyMVar    >>= \ v ->
  55   put v 'a'       >>
  56   put v 'b'
  57
  58 -- test blocking of two processes on the same variable.
  59 -- should print "aa"
  60 test6 = do
  61   { x <- newEmptyMVar
  62   ; ack <- newEmptyMVar
  63   ; forkIO (get x >> put ack 'X')
  64   ; forkIO (get x >> put ack 'X')
  65   ; put x 'a' >> get ack  -- use up one reader
  66   ; put x 'b' >> get ack  -- use up the other
  67   ; put x 'c' >> get ack  -- deadlock
  68   }
  69
  70 ----------------------------------------------------------------
  71 -- Non-deterministic tests below this point
  72 -- Must be tested interactively and probably don't work using
  73 -- "logical concurrency".
  74
  75
  76 -- should print interleaving of a's and b's
  77 -- (degree of interleaving depends on granularity of concurrency)
  78 test7 =
  79   forkIO a >> b
  80  where
  81   a = putStr "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
  82   b = putStr "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
  83
  84 -- should give infinite interleaving of a's and b's
  85 -- (degree of interleaving depends on granularity of concurrency)
  86 -- Ming's example.  The Hugs read-eval-print loop gets confused if
  87 -- there's no type signature
  88 test8 :: IO ()
  89 test8 =
  90   forkIO a >> b
  91  where
  92   -- symbols carefully chosen to make them look very different on screen
  93   a = putChar 'a' >> a
  94   b = putChar 'B' >> b
  95
  96 -- test blocking of two processes on the same variable.
  97 -- may print "aXbY{Deadlock}" or "aYbX{Deadlock}"
  98 test9 = do
  99   { x <- newEmptyMVar
 100   ; ack <- newEmptyMVar
 101   ; forkIO (get x >> put ack 'X')
 102   ; forkIO (get x >> put ack 'Y')
 103   ; put x 'a' >> get ack  -- use up one reader
 104   ; put x 'b' >> get ack  -- use up the other
 105   ; put x 'c' >> get ack  -- deadlock
 106   }
 107
 108 put v x =
 109   putMVar v x
 110
 111 get v =
 112   takeMVar v      >>= \ x ->
 113   putChar x