module Counter (tests) where

-- This was formerly CounterCommon and #include-ed to test the different
-- counter implementations which have been removed. 
-- TODO clean up remnants of that approach.
import qualified Data.Atomics.Counter as C

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)

name = "Unboxed"

default_seq_tries  = 10 * numElems
-- Things are MUCH slower with contention:
default_conc_tries = numElems

--------------------------------------------------------------------------------
-- 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
 ]