diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +## 0.8.2 [2018.03.08] +* Allow building with `base-4.11`. + ## 0.8.1.1 [2017.12.10] * Bundle `testing/Fetch.hs` with the package tarball diff --git a/Data/Atomics.hs b/Data/Atomics.hs --- a/Data/Atomics.hs +++ b/Data/Atomics.hs @@ -482,7 +482,7 @@ -------------------------------------------------------------------------------- --- | A drop-in replacement for `atomicModifyIORefCAS` that +-- | A drop-in replacement for `atomicModifyIORef` that -- optimistically attempts to compute the new value and CAS it into -- place without introducing new thunks or locking anything. Note -- that this is more STRICT than its standard counterpart and will only diff --git a/atomic-primops.cabal b/atomic-primops.cabal --- a/atomic-primops.cabal +++ b/atomic-primops.cabal @@ -1,5 +1,5 @@ Name: atomic-primops -Version: 0.8.1.1 +Version: 0.8.2 License: BSD3 License-file: LICENSE Author: Ryan Newton @@ -49,7 +49,7 @@ -- casMutVar# had a bug in GHC 7.2, thus we require GHC 7.4 or greater -- (base 4.5 or greater). We also need the "Any" kind. - build-depends: base >= 4.6.0.0 && < 4.11, ghc-prim, primitive + build-depends: base >= 4.6.0.0 && < 4.12, ghc-prim, primitive -- TODO: Try to push support back to 7.0, but make it default to an implementation -- other than Unboxed. diff --git a/testing/Test.hs b/testing/Test.hs --- a/testing/Test.hs +++ b/testing/Test.hs @@ -19,7 +19,11 @@ import GHC.Conc import GHC.STRef import GHC.IORef +#if MIN_VERSION_base(4,10,0) +import GHC.Stats (getRTSStats, RTSStats(..)) +#else import GHC.Stats (getGCStats, GCStats(..)) +#endif import System.Random (randomIO, randomRIO) import Test.HUnit (Assertion, assertEqual, assertBool) import Test.Framework (defaultMain,testGroup,mutuallyExclusive) @@ -31,7 +35,7 @@ import qualified Issue28 -import CommonTesting +import CommonTesting import qualified Counter import qualified Fetch @@ -40,10 +44,15 @@ expect_false_positive_on_GC :: Bool expect_false_positive_on_GC = False -getGCCount :: IO Int64 -getGCCount | expect_false_positive_on_GC = +getGCCount :: IO Int64 +getGCCount | expect_false_positive_on_GC = +#if MIN_VERSION_base(4,10,0) + do RTSStats{gcs} <- getRTSStats + return (fromIntegral gcs) +#else do GCStats{numGcs} <- getGCStats return numGcs +#endif | otherwise = return 0 main :: IO () @@ -54,7 +63,7 @@ let numcap = 4 when (numCapabilities /= numcap) $ setNumCapabilities numcap - defaultMain $ + defaultMain $ -- Make these run sequentially (hopefully), so we don't interfere with -- concurrent tests. TODO I guess: figure out how to run tests that -- don't fork in parallel, but forking tests sequentially @@ -103,7 +112,7 @@ mynum :: Int mynum = 33 --- Expected output: +-- Expected output: {--------------------------------------- Perform a CAS within a MutableArray# 1st try should succeed: (True,33) @@ -113,24 +122,24 @@ Done. -} case_casmutarray1 :: IO () -case_casmutarray1 = do +case_casmutarray1 = do putStrLn "Perform a CAS within a MutableArray#" arr <- newArray 5 mynum writeArray arr 4 33 putStrLn "Wrote array elements..." - + tick <- A.readArrayElem arr 4 putStrLn$ "(Peeking at array gave: "++show (peekTicket tick)++")" (res1,_tick2) <- A.casArrayElem arr 4 tick 44 (res2,_) <- A.casArrayElem arr 4 tick 44 -- res <- stToIO$ casArrayST arr 4 mynum 44 --- res2 <- stToIO$ casArrayST arr 4 mynum 44 +-- res2 <- stToIO$ casArrayST arr 4 mynum 44 putStrLn "Printing array:" forM_ [0..4] $ \ i -> do - x <- readArray arr i + x <- readArray arr i putStr (" "++show x) assertBool "1st try should succeed: " res1 @@ -138,27 +147,27 @@ -- case_casbytearray1 :: IO () --- case_casbytearray1 = do +-- case_casbytearray1 = do -- putStrLn "Perform a CAS within a MutableByteArray#" -- | This test uses a number of producer and consumer threads which push and pop -- elements from random positions in an array. test_random_array_comm :: Int -> Int -> Int -> IO () -test_random_array_comm threads size iters = do +test_random_array_comm threads size iters = do arr <- newArray size Nothing tick0 <- A.readArrayElem arr 0 for_ 1 size $ \ i -> do t2 <- A.readArrayElem arr i assertEqual "All initial Nothings in the array should be ticket-equal:" tick0 t2 - ls <- forkJoin threads $ \_tid -> do + ls <- forkJoin threads $ \_tid -> do localAcc <- newIORef 0 for_ 0 iters $ \iter -> do -- Randomly pick a position: ix <- randomRIO (0,size-1) :: IO Int -- Randomly either produce or consume: b <- randomIO :: IO Bool - if b then do + if b then do void $ A.casArrayElem arr ix tick0 (Just iter) else do -- Consume: tick <- A.readArrayElem arr ix @@ -169,7 +178,7 @@ Nothing -> return () return () readIORef localAcc - + let successes = sum ls -- Pidgeonhole principle. -- min_success = @@ -183,8 +192,8 @@ return () putStrLn "" return () - - + + ---------------------------------------------------------------------------------------------------- -- Simple, non-parameterized tests ---------------------------------------------------------------------------------------------------- @@ -193,20 +202,20 @@ case_casTicket1 = do dbgPrint 1 "\nUsing new 'ticket' based compare and swap:" - IORef (STRef mutvar) <- newIORef (3::Int) + IORef (STRef mutvar) <- newIORef (3::Int) tick <- A.readMutVarForCAS mutvar dbgPrint 1$"YAY, read the IORef, ticket "++show tick dbgPrint 1$" and the value was: "++show (peekTicket tick) - (True,tick2) <- A.casMutVar mutvar tick 99 + (True,tick2) <- A.casMutVar mutvar tick 99 dbgPrint 1$"Hoorah! Attempted compare and swap..." -- dbgPrint 1$" Result was: "++show (True,tick2) dbgPrint 1$"Ok, next take a look at a SECOND CAS attempt, to see if the ticket from the first works..." res2 <- A.casMutVar mutvar tick2 12345678 dbgPrint 1$"Result was: "++show res2 - --- res <- A.casMutVar mutvar tick 99 + +-- res <- A.casMutVar mutvar tick 99 res3 <- A.readMutVarForCAS mutvar dbgPrint 1$"To check contents, did a SECOND read: "++show res3 @@ -216,7 +225,7 @@ case_issue28_standalone = Issue28.main case_issue28_copied :: Assertion -case_issue28_copied = do +case_issue28_copied = do r <- newIORef "hi" t0 <- readForCAS r (True,_t1) <- casIORef r t0 "bye" @@ -267,18 +276,18 @@ tick <- A.readForCAS(counter) let nxt = peekTicket tick + 1 (b,was) <- A.casIORef counter tick nxt - if b then do + if b then do putStr $ show (peekTicket was) ++ "_" assertEqual "Check that the value written was the one we put in." nxt (peekTicket was) return (ix, unsafeName tick, unsafeName was, peekTicket tick, nxt) - else do - when (peekTicket was == peekTicket tick) $ + else do + when (peekTicket was == peekTicket tick) $ putStrLn ("(Spoofed by boxing, old val was indeed "++show was++")") putStr "!" -- putStrLn $ "("++ show ix ++ ": Fail when putting "++show nxt -- ++", was already "++show (peekTicket was) ++")" work ix - arr <- forkJoin 120 work + arr <- forkJoin 120 work ans <- readIORef counter let dups = [ n | (_,_,_,_,n) <- arr] \\ [1..120] @@ -299,17 +308,17 @@ ---------------------------------------------------------------------------------------------------- ---------------------------------------------------------------------------------------------------- --- Adapted Old tests from original CAS library: +-- Adapted Old tests from original CAS library: -- | First test: Run a simple CAS a small number of times. test_succeed_once :: (Show a, Num a, Eq a) => a -> Assertion -test_succeed_once initialVal = +test_succeed_once initialVal = do performGC -- We *ASSUME* GC does not happen below. performGC -- We *ASSUME* GC does not happen below. checkGCStats - gc1 <- getGCCount + gc1 <- getGCCount r <- newIORef initialVal bitls <- newIORef [] tick1 <- A.readForCAS r @@ -323,8 +332,8 @@ x <- readIORef r assertEqual "Finished with loop, read cell: " 100 x - - writeIORef r 111 + + writeIORef r 111 y <- readIORef r assertEqual "Wrote and read again read: " 111 y @@ -336,7 +345,7 @@ gc2 <- getGCCount if gc1 /= gc2 then putStrLn " [skipped] test couldn't be assessed properly due to GC." - else do + else do -- print scrubbed assertBool "Only first succeeds" (all (/= hd) tl) assertBool "All but first fail" (all (== head tl) (tail tl)) @@ -353,18 +362,18 @@ -- time. Adding a second thread can only foil the K attempts of the first thread by -- itself succeeding (leaving the total at or above K). Likewise for the third -- thread and so on. --- +-- -- Conversely, for N threads each aiming to complete K operations, -- there should be at most N*N*K total operations required. test_all_hammer_one :: (Show a, Num a, Eq a) => Int -> Int -> a -> Assertion test_all_hammer_one threads iters seed = do ref <- newIORef seed - logs::[[Bool]] <- forkJoin threads $ \_ -> + logs::[[Bool]] <- forkJoin threads $ \_ -> do checkGCStats let loop 0 _ _ !acc = return (reverse acc) loop n !ticket !expected !acc = do -- This line will result in boxing/unboxing and using extra memory locations: --- let bumped = expected + 1 +-- let bumped = expected + 1 bumped <- evaluate$ expected + 1 (res,tick) <- casIORef ref ticket bumped case res of @@ -375,10 +384,10 @@ False -> do let v = peekTicket tick when (iters < 30) $ - dbgPrint 1 $ + dbgPrint 1 $ " Fizzled CAS with ticket: "++show ticket ++" containing "++show v++ ", expected: "++ show expected ++ - " (#"++show (unsafeName expected)++"): " + " (#"++show (unsafeName expected)++"): " ++ " found " ++ show v ++ " (#"++show (unsafeName v)++", ticket "++show tick++")" loop (n-1) tick v (False:acc) @@ -403,7 +412,7 @@ ------------------------------------------------------------------------ -- Reads and Writes with full barriers: -{- +{- - WIP import Data.Atomics (atomicReadIntArray, atomicWriteIntArray) @@ -462,7 +471,7 @@ when (x < iters) go in go -- Peterson's lock: http://en.wikipedia.org/wiki/Peterson%27s_algorithm --- +-- -- TODO DEBUGGING see https://github.com/rrnewton/haskell-lockfree/issues/43#issuecomment-71294801 -- for a discussion of issues to be resolved here. test_atomic_read_write_barriers2 iters = do @@ -509,10 +518,10 @@ out1 <- newEmptyMVar out2 <- newEmptyMVar - void $ forkIO $ + void $ forkIO $ (replicateM iters $ petersonIncr flag0 flag1 1) >>= putMVar out1 - void $ forkIO $ + void $ forkIO $ (replicateM iters $ petersonIncr flag1 flag0 0) >>= putMVar out2 @@ -528,21 +537,21 @@ print $ numGaps (0::Int) (-1::Int) res1 print $ numGaps (0::Int) (-1::Int) res2 -- ------------------ - + -- if this fails, fix the test or call with more iters assertBool "test_atomic_read_write_barriers2 had enough interleaving to be legit" $ - numGaps (0::Int) (-1::Int) res1 > 10000 + numGaps (0::Int) (-1::Int) res1 > 10000 && numGaps (0::Int) (-1::Int) res2 > 10000 -- braindead merge check: - let ok = sort res1 == res1 - && sort res2 == res2 + let ok = sort res1 == res1 + && sort res2 == res2 && sort (res1++res2) == [0..iters*2-1] assertBool "test_atomic_read_write_barriers2" ok -} - + ---------------------------------------------------------------------------------------------------- {- @@ -550,9 +559,9 @@ -- This tests repeated atomicModifyIORefCAS operations. testCAS3 :: Int -> IORef ElemTy -> IO [()] -testCAS3 iters ref = +testCAS3 iters ref = forkJoin numCapabilities (loop iters) - where + where loop 0 = return () loop n = do -- let bumped = expected+1 -- Must do this only once, should be NOINLINE @@ -568,7 +577,7 @@ #endif loop (n-1) ----------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- -- This version uses a non-scalar type for CAS. It instead -- manipulates the tail pointers of a simple linked-list. @@ -581,7 +590,7 @@ -- testCAS4 :: CASable ref Int => List ref -> IO [Bool] testCAS4 :: CASable ref Int => Int -> ref (List ref) -> IO () -testCAS4 iters ref = do +testCAS4 iters ref = do forkJoin numCapabilities $ do -- From each thread, attempt to extend the list 'iters' times: ref' <- readCASable ref @@ -590,11 +599,11 @@ return () return () - where + where loop 0 _ _ = return () loop n new (Cons _ tl) = do tl' <- readCASable tl - case tl' of + case tl' of Null -> do (b,v) <- cas tl tl' new if b then loop (n-1) v else loop v @@ -612,14 +621,14 @@ else error$ "Test "++ msg ++ " failed to have the right CAS success pattern: " ++ show ls checkOutput2 :: String -> Int -> [[Bool]] -> ElemTy -> IO () -checkOutput2 msg iters ls fin = do +checkOutput2 msg iters ls fin = do let totalAttempts = sum $ map length ls putStrLn$ "Final value "++show fin++", Total successes "++ show (length $ filter id $ concat ls) when (fin < fromIntegral iters) $ - error$ "ERROR in "++ show msg ++ " expected at least "++show iters++" successful CAS's.." + error$ "ERROR in "++ show msg ++ " expected at least "++show iters++" successful CAS's.." checkOutput3 :: String -> Int -> [[Bool]] -> ElemTy -> IO () -checkOutput3 msg iters ls fin = do +checkOutput3 msg iters ls fin = do return () @@ -630,12 +639,12 @@ -- test x = do --- a <- newStablePtr x --- b <- newStablePtr x --- printf "First call, word %d IntPtr %d\n" +-- a <- newStablePtr x +-- b <- newStablePtr x +-- printf "First call, word %d IntPtr %d\n" -- (unsafeCoerce a :: Word) -- ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr a) :: Int) --- printf "Second call, word %d IntPtr %d\n" +-- printf "Second call, word %d IntPtr %d\n" -- (unsafeCoerce b :: Word) -- ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr b) :: Int) diff --git a/testing/test-atomic-primops.cabal b/testing/test-atomic-primops.cabal --- a/testing/test-atomic-primops.cabal +++ b/testing/test-atomic-primops.cabal @@ -86,5 +86,5 @@ atomic-primops >= 0.6.0.5, deepseq >= 1.3, time, HUnit, test-framework, test-framework-hunit - build-depends: criterion >= 1.0 + build-depends: criterion >= 1.2.1 main-is: MicroBench.hs