Ticket #4001: 0001-atomicReadMVar.3.patch

File 0001-atomicReadMVar.3.patch, 2.2 KB (added by ezyang, 22 months ago)

A set of tests (split me into three files)

  • tests/concurrent/should_run/all.T

    From f8dc6e1ced66e2b4b0078d8ea94a3901fd8b1225 Mon Sep 17 00:00:00 2001
    From: "Edward Z. Yang" <[email protected]>
    Date: Fri, 14 Jun 2013 14:21:02 -0700
    Subject: [PATCH] atomicReadMVar
    
    Signed-off-by: Edward Z. Yang <[email protected]>
    ---
     tests/concurrent/should_run/all.T             |    2 ++
     tests/concurrent/should_run/atomicreadmvar.hs |   44 +++++++++++++++++++++++++
     2 files changed, 46 insertions(+)
     create mode 100644 tests/concurrent/should_run/atomicreadmvar.hs
    
    diff --git a/tests/concurrent/should_run/all.T b/tests/concurrent/should_run/all.T
    index bb2bcd3..0c773d1 100644
    a b test('T5611', normal, compile_and_run, ['']) 
    7474test('T5238', normal, compile_and_run, ['']) 
    7575test('T5866', exit_code(1), compile_and_run, ['']) 
    7676 
     77test('atomicreadmvar', normal, compile_and_run, ['']) 
     78 
    7779# ----------------------------------------------------------------------------- 
    7880# These tests we only do for a full run 
    7981 
  • new file tests/concurrent/should_run/atomicreadmvar.hs

    diff --git a/tests/concurrent/should_run/atomicreadmvar.hs b/tests/concurrent/should_run/atomicreadmvar.hs
    new file mode 100644
    index 0000000..ed32056
    - +  
     1module Main where 
     2 
     3import GHC.MVar 
     4import Control.Concurrent 
     5 
     6-- test race-freeness 
     7test1 = do 
     8    let i = 1000000 
     9    m <- newMVar (0 :: Int) 
     10    let readloop 0 = return () 
     11        readloop i = do 
     12            atomicReadMVar m 
     13            readloop (i-1) 
     14        writeloop 0 = return () 
     15        writeloop i = do 
     16            readMVar m 
     17            writeloop (i-1) 
     18    forkIO $ readloop i 
     19    writeloop i 
     20 
     21-- test removal from queues on exception 
     22test2 = do 
     23    m <- newEmptyMVar 
     24    sync <- newEmptyMVar 
     25    let f = atomicReadMVar m 
     26    t1 <- forkIO (f >> error "FAILURE") 
     27    t2 <- forkIO (f >> putMVar sync ()) 
     28    killThread t1 
     29    putMVar m (0 :: Int) 
     30    atomicReadMVar sync 
     31 
     32-- example from 
     33-- http://www.haskell.org/pipermail/glasgow-haskell-users/2008-November/015878.html 
     34 
     35test3 = do 
     36    m <- newMVar (0 :: Int) 
     37    forkIO $ putMVar m 1 
     38    yield 
     39    r1 <- atomicReadMVar m 
     40    r2 <- takeMVar m 
     41    r3 <- takeMVar m 
     42    return () 
     43 
     44main = test1 >> test2 >> test3