atomic-primops-foreign 0.6 → 0.6.1

raw patch · 4 files changed

+317/−2 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• atomic-primops-foreign.cabal +3/−2
• testing/CommonTesting.hs +162/−0
• testing/CounterCommon.hs +138/−0
• testing/CounterForeign.hs +14/−0

@@ -1,5 +1,5 @@ Name:                atomic-primops-foreign-Version:             0.6+Version:             0.6.1 License:             BSD3 License-file:        LICENSE Author:              Ryan Newton@@ -27,7 +27,8 @@  Test-Suite test-atomic-primops-foreign     type:       exitcode-stdio-1.0-    main-is: testing/Main.hs+    main-is:    testing/Main.hs+    other-modules: CounterForeign, CounterCommon, CommonTesting     hs-source-dirs: testing/ ./      ghc-options: -threaded -rtsopts -with-rtsopts=-N4

@@ -0,0 +1,162 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, NamedFieldPuns, CPP #-}++-- Various utilities used during testing.++module CommonTesting  where++import Control.Monad+import Control.Concurrent.MVar+import GHC.Conc+import Data.Time.Clock+import Text.Printf+import GHC.IO (unsafePerformIO)+import System.CPUTime+import System.Mem.StableName (makeStableName, hashStableName)+import System.Environment (getEnvironment)+import System.IO        (stdout, stderr, hPutStrLn, hFlush)+import Debug.Trace      (trace)++-- import Test.Framework.TH (defaultMainGenerator)+++----------------------------------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------------------------------++checkGCStats :: IO ()+checkGCStats = return ()+    -- do b <- getGCStatsEnabled+    --    unless b $ error "Cannot run tests without +RTS -T !!"++dotdot :: Int -> String -> String+dotdot len chars = +  if length chars > len+  then take len chars ++ "..."+  else chars++printBits :: [Bool] -> IO ()+printBits = print . map pb+ where pb True  = '1' +       pb False = '0'++forkJoin :: Int -> (Int -> IO b) -> IO [b]+forkJoin numthreads action = +  do+     answers <- sequence (replicate numthreads newEmptyMVar) -- padding?+     dbgPrint 1 $ printf "Forking %d threads.\n" numthreads+    +     forM_ (zip [0..] answers) $ \ (ix,mv) -> + 	forkIO (action ix >>= putMVar mv)++     -- Reading answers:+     ls <- mapM readMVar answers+     dbgPrint 1 $ printf "All %d thread(s) completed\n" numthreads+     return ls++-- TODO: Here's an idea.  Describe a structure of forking and joining threads for+-- tests, then we can stress test it by running different interleavings explicitly.+data Forkable a = Fork Int (IO a)+                | Parallel (Forkable a) (Forkable a) -- Parallel composition+                | Sequence (Forkable a) (Forkable a) -- Sequential compositon, with barrier+--                | Barrier Forkable++-- | Grab a GC-invariant stable "address" for any value.+{-# NOINLINE unsafeName #-}+unsafeName :: a -> Int+unsafeName x = unsafePerformIO $ do +   sn <- makeStableName x+   return (hashStableName sn)+++-- | Measure realtime +timeit :: IO a -> IO a +timeit ioact = do +   start <- getCurrentTime+   res <- ioact+   end   <- getCurrentTime+   putStrLn$ "  Time elapsed: " ++ show (diffUTCTime end start)+   return res+++-- | Measure CPU time rather than realtime...+cputime :: IO t -> IO t+cputime a = do+    start <- getCPUTime+    v <- a+    end   <- getCPUTime+    let diff = (fromIntegral (end - start)) / (10^12)+    printf "SELFTIMED: %0.3f sec\n" (diff :: Double)+    return v+++-- | To make sure we get a simple loop...+nTimes :: Int -> IO () -> IO ()+-- nTimes :: Int -> IO a -> IO ()+-- Note: starting out I would get 163Mb allocation for 10M sequential incrs (on unboxed).+-- The problem was that the "Int" result from each incr was being allocated.+-- Weird thing is that inlining nTimes reduces the allocation to 323Mb.+-- But forcing it to take an (IO ()) gets rid of the allocation.+-- Egad, wait, no, I have to NOT inline nTimes to get rid of the allocation!?!?+-- Otherwise I'm still stuck with at least 163Mb of allocation.+-- In fact... the allocation is still there even if we use incrCounter_ !!+-- If we leave nTimes uninlined, we can get down to 3Mb allocation with either incrCounter or incrCounter_.+-------------------------+-- UPDATE:+-- As per http://www.haskell.org/pipermail/glasgow-haskell-users/2011-June/020472.html+--+--  INLINE should not affect recursive functions.  But here it seems to have a+--  deleterious effect!+nTimes 0 !c = return ()+nTimes !n !c = c >> nTimes (n-1) c++++----------------------------------------------------------------------------------------------------+-- DEBUGGING+----------------------------------------------------------------------------------------------------++-- | Debugging flag shared by all accelerate-backend-kit modules.+--   This is activated by setting the environment variable DEBUG=1..5+dbg :: Int+dbg = case lookup "DEBUG" unsafeEnv of+       Nothing  -> defaultDbg+       Just ""  -> defaultDbg+       Just "0" -> defaultDbg+       Just s   ->+         warnUsing (" DEBUG="++s)$+         case reads s of+           ((n,_):_) -> n+           [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s++-- | How many elements or iterations should the test use?+numElems :: Int+numElems = case lookup "NUMELEMS" unsafeEnv of +             Nothing  -> 1000 * 1000  -- A million by default.+             Just str -> warnUsing ("NUMELEMS = "++str) $ +                         read str++warnUsing :: String -> a -> a+warnUsing str a = trace ("  [Warning]: Using environment variable "++str) a++defaultDbg :: Int+defaultDbg = 0++unsafeEnv :: [(String,String)]+unsafeEnv = unsafePerformIO getEnvironment++-- | Print if the debug level is at or above a threshold.+dbgPrint :: Int -> String -> IO ()+dbgPrint lvl str = if dbg < lvl then return () else do+    hPutStrLn stderr str+    hFlush stderr++-- My own forM for numeric ranges (not requiring deforestation optimizations).+-- Inclusive start, exclusive end.+{-# INLINE for_ #-}+for_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+for_ start end _fn | start > end = error "for_: start is greater than end"+for_ start end fn = loop start+  where+   loop !i | i == end  = return ()+	   | otherwise = do fn i; loop (i+1)+

@@ -0,0 +1,138 @@++-- Common tests to the different counter implementations.++import Control.Monad+import GHC.Conc+import System.CPUTime+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertEqual, assertBool)+import Text.Printf+import Data.IORef  ++import CommonTesting (numElems, forkJoin, timeit, nTimes)++--------------------------------------------------------------------------------+-- Test the basics++case_basic1 = do +  r <- C.newCounter 0+  ret <- C.incrCounter 10 r+  assertEqual "incrCounter returns the NEW value" 10 ret++case_basic2 = do +  r <- C.newCounter 0+  t <- C.readCounterForCAS r+  (True,newt) <- C.casCounter r t 10+  assertEqual "casCounter returns new val/ticket on success" 10 (C.peekCTicket newt)++case_basic3 = do +  r <- C.newCounter 0+  t <- C.readCounterForCAS r+  _ <- C.incrCounter 1 r+  (False,oldt) <- C.casCounter r t 10+  assertEqual "casCounter returns read val on failure" 1 (C.peekCTicket oldt)++case_basic4 = do +  let tries = numElems `quot` 100+  r <- C.newCounter 0+  nTimes tries $ do+    t <- C.readCounterForCAS r+    (True,_) <- C.casCounter r t (C.peekCTicket t + 1)+    return ()+  cnt <- C.readCounter r+  assertEqual "Every CAS should succeed on one thread" tries cnt ++--------------------------------------------------------------------------------+-- Repeated increments++incrloop tries = do r <- C.newCounter 0; nTimes tries $ void$ C.incrCounter 1 r+                    C.readCounter r+case_incrloop = do +   cnt <- incrloop default_seq_tries+   assertEqual "incrloop sum" default_seq_tries cnt++-- | Here we do a loop to test the unboxing of results from incrCounter:+--   As of now [2013.07.19], it is successfully unboxing the results +--   for Data.Atomics.Counter.Unboxed.+incrloop4B tries = do+  putStrLn " [incrloop4B] A test where we use the result of each incr."+  r <- C.newCounter 1+  loop r tries 1+ where+   loop :: C.AtomicCounter -> Int -> Int -> IO ()+   loop r 0 _ = do v <- C.readCounter r+                   putStrLn$"Final value: "++show v+                   return ()+   loop r tries last = do+     n <- C.incrCounter last r+     if n == 2+       then loop r (tries-1) 2+       else loop r (tries-1) 1++-- | Here we let the counter overflow, which seems to be causing problems.+overflowTest tries = do+  putStrLn " [incrloop4B] A test where we use the result of each incr."+  r <- C.newCounter 1+  loop r tries 1+ where+   loop :: C.AtomicCounter -> Int -> Int -> IO ()+   loop r 0 _ = do v <- C.readCounter r+                   putStrLn$"Final value: "++show v+                   return ()+   loop r tries last = do+     putStrLn$ " [incrloop4B] Looping with tries left "++show tries +     n <- C.incrCounter last r+     -- This is HANGING afer passing 2,147,483,648.  (using Unboxed)+     -- Is there some defect wrt overflow?+     putStrLn$ " [incrloop4B] Done incr, received "++show n+     loop r (tries-1) n++--------------------------------------------------------------------------------+-- Parallel repeated increments+++{-# INLINE parIncrloop #-} +parIncrloop new incr iters = do+  numcap <- getNumCapabilities+  let (each,left) = iters `quotRem` numcap+  putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each+  r <- new 0+  forkJoin numcap $ \ ix -> do+    let mine = if ix==0 then each+left else each+    nTimes mine $ void $ incr 1 r+  C.readCounter r++case_parincrloop = do +  cnt <- parIncrloop C.newCounter C.incrCounter default_conc_tries+  assertEqual "incrloop sum" default_conc_tries cnt++-- | Use CAS instead of the real incr so we can compare the overhead.+case_parincrloop_wCAS = do +  cnt <- parIncrloop C.newCounter fakeIncr default_conc_tries+  assertEqual "incrloop sum" default_conc_tries cnt+ where+  fakeIncr delt r = do tick <- C.readCounterForCAS r+                       loop r delt tick+  loop r delt tick = do x <- C.casCounter r tick (C.peekCTicket tick + delt)+                        case x of +                          (True, newtick) -> return (C.peekCTicket newtick)+                          (False,newtick) -> loop r delt newtick+                   ++--------------------------------------------------------------------------------++tests = + [+   testCase (name++"basic1_incrCounter") $ case_basic1+ , testCase (name++"basic2_casCounter") $ case_basic2+ , testCase (name++"basic3_casCounter") $ case_basic3+ , testCase (name++"basic4_casCounter") $ case_basic4+   ----------------------------------------+ , testCase (name++"_single_thread_repeat_incr") $ timeit case_incrloop+ , testCase (name++"_incr_with_result_feedback") $ timeit (incrloop4B default_seq_tries)+   ----------------------------------------++   -- Parallel versions:+ , testCase (name++"_concurrent_repeat_incr") $ void$ timeit case_parincrloop+ , testCase (name++"_concurrent_repeat_incrCAS") $ void$ timeit case_parincrloop_wCAS+ ]

@@ -0,0 +1,14 @@+{-# LANGUAGE CPP, BangPatterns #-}+module CounterForeign (tests) where+import qualified Data.Atomics.Counter.Foreign as C++#include "CounterCommon.hs"++name = "Foreign"++-- This version is much slower than some of the others:+default_seq_tries  = 10 * base +default_conc_tries = base++base = numElems `quot` 15+