{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, CPP, BangPatterns, OverlappingInstances 
    , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances
  #-}

-- | This test has three different modes which can be toggled via the
-- C preprocessor.  Any subset of the three may be activated.

import Control.Monad
import Control.Exception
import Control.Concurrent.MVar
import GHC.Conc
import Data.IORef
import Data.Word
import Data.CAS.Internal.Class
import Data.Time.Clock
import System.Environment
import System.Mem.StableName
import GHC.IO (unsafePerformIO)

#ifdef T1
import qualified Data.CAS.Internal.Native  as A
#endif
#ifdef T2
import qualified Data.CAS.Internal.Fake    as B
#endif
#ifdef T3
import qualified Data.CAS.Internal.Foreign as C
#endif

import Text.Printf

----------------------------------------------------------------------------------------------------
-- TODO:
--  * Switch the [Bool] implementation to use a BitList.
--  
----------------------------------------------------------------------------------------------------

{-# NOINLINE zer #-}
zer = 0

-- iters = 100
-- iters = 10000
default_iters = 100000
-- iters = 1000000

----------------------------------------------------------------------------------------------------
-- Helpers

printBits = print . map pb
 where pb True  = '1' 
       pb False = '0'

forkJoin :: Int -> (IO b) -> IO [b]
forkJoin numthreads action = 
  do
     answers <- sequence (replicate numthreads newEmptyMVar) -- padding?
     printf "Forking %d threads.\n" numthreads
    
     forM_ answers $ \ mv -> 
 	forkIO (action >>= putMVar mv)

     -- Reading answers:
     ls <- mapM readMVar answers
     printf "All %d thread(s) completed\n" numthreads
     return ls

-- Describe a structure of forking and joining threads for tests:
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


timeit ioact = do 
   start <- getCurrentTime
   res <- ioact
   end   <- getCurrentTime
   putStrLn$ "  Time elapsed: " ++ show (diffUTCTime end start)
   return res

----------------------------------------------------------------------------------------------------

-- The element type for our CAS test.
-- type ElemTy = Int
type ElemTy = Word32 -- This will trigger CAS.Foreign's specialization.

{-# INLINE testCAS1 #-}
-- First test: Run a simple CAS a small number of times.
testCAS1 :: CASable ref ElemTy => ref ElemTy -> IO [Bool]
testCAS1 r = 
  do 
     bitls <- newIORef []
--     let zer = (0::Int)

--     r :: CASRef Int <- newCASable zer 
     let loop 0 = return ()
	 loop n = do

          (b,v) <- cas r zer 100  -- Must use "zer" here.
          atomicModifyIORef bitls (\x -> (b:x, ()))

--          (b,v) <- casIORef r zer 100  -- Must use "zer" here.
--          (b,v) <- casStrict r 0 100  -- Otherwise this is nondeterministic based on compiler opts.
		   -- Sometimes the latter version works on the SECOND evaluation of testCAS.  Interesting.
          putStrLn$ "  After CAS " ++ show (b,v)
          loop (n-1)
     loop 10

     x <- readCASable r
     putStrLn$ "  Finished with loop, read cell: " ++ show x
     writeCASable r 111
     y <- readCASable r
     putStrLn$ "  Wrote and read again read: " ++ show y

     ls <- readIORef bitls
     return (reverse ls)


----------------------------------------------------------------------------------------------------

-- This version hammers on CASref from all threads, then checks to see
-- if enough threads succeeded enough of the time.

-- If each thread tries K attempts, there should be at least K
-- successes.  To establish this consider the inductive argument.  One
-- thread should succeed all the 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.

testCAS2 :: CASable ref ElemTy => Int -> ref ElemTy -> IO [[Bool]]
testCAS2 iters ref = 
  forkJoin numCapabilities $ 
    do 
       let loop 0 expected !acc = return (reverse acc)
	   loop n expected !acc = do
            -- let bumped = expected+1 -- Must do this only once, should be NOINLINE
	    bumped <- evaluate$ expected+1 
	    (b,v) <- cas ref expected bumped
            when (iters < 30) $ 
              putStrLn$ "  Attempted to CAS "++show bumped ++" for "++ show expected ++ " (#"++show (unsafeName expected)++"): " 
			++ show b ++ " found " ++ show v ++ " (#"++show (unsafeName v)++")"
	    if b 
             then loop (n-1) bumped (b:acc)
             else loop (n-1) v      (b:acc)

       init <- readCASable ref
       loop iters init []


--------------------------------------------------------------------------------

-- UNFINISHED
-- This tests repeated atomicModifyIORefCAS operations.

testCAS3 :: Int -> IORef ElemTy -> IO [()]
testCAS3 iters ref = 
  forkJoin numCapabilities (loop iters)
 where 
   loop 0  = return ()
   loop n  = do
	-- let bumped = expected+1 -- Must do this only once, should be NOINLINE
--        let bump !x !y = x+y
#ifdef T1
	A.atomicModifyIORefCAS_ ref (+1)
#endif
#ifdef T2
--	B.atomicModifyIORefCAS_ ref (+1)
--	B.atomicModifyIORefCAS_ ref (bump 1)
	x <- atomicModifyIORef ref (\x -> (x+1,x))
        evaluate x -- Avoid stack leak.
#endif
	loop (n-1)

----------------------------------------------------------------------------------------------------       
-- This version uses a non-scalar type for CAS.  It instead
-- manipulates the tail pointers of a simple linked-list.

#if 0
data List k = Null | Cons Int (k (List k))

type ListA = List A.CASRef
type ListB = List B.CASRef
type ListC = List C.CASRef

-- testCAS4 :: CASable ref Int => List ref -> IO [Bool]
testCAS4 :: CASable ref Int => Int -> ref (List ref) -> IO ()
testCAS4 iters ref = do 
  forkJoin numCapabilities $ do
     -- From each thread, attempt to extend the list 'iters' times:
     ref' <- readCASable ref
     nl   <- newIORef Null
     loop iters (Cons (-1) nl) ref'
     return ()

  return ()
 where 
  loop 0 _ _ = return ()
  loop n new (Cons _ tl) = do
    tl' <- readCASable tl
    case tl' of 
      Null -> do (b,v) <- cas tl tl' new
		 if b then loop (n-1) v
		      else loop v
      cons -> loop cons tl'
  loop n _ Null = error "too short"
#endif


----------------------------------------------------------------------------------------------------
-- Test Oracles

checkOutput1 msg ls =
  if ls == True : replicate (9) False
  then return ()
  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 
  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.." 

checkOutput3 :: String -> Int -> [[Bool]] -> ElemTy -> IO ()
checkOutput3 msg iters ls fin = do 

  return ()


----------------------------------------------------------------------------------------------------

main = do 
   args <- getArgs
   let iters = 
        case args of 
	 []  -> default_iters
	 [a] -> read a
	 ls  -> error$ "Wrong number of arguments to executable: " ++ show ls
 
#ifdef T1
   putStrLn$ "\nTesting Raw, native CAS:"
   o1A <- (newCASable zer :: IO (A.CASRef ElemTy)) >>= testCAS1
   checkOutput1 "Raw 1"     o1A
#endif
#ifdef T2
   putStrLn$ "\nTesting Fake CAS, based on atomicModifyIORef:"
   o1B <- (newCASable zer :: IO (B.CASRef ElemTy)) >>= testCAS1
   checkOutput1 "Fake 1"    o1B
#endif
#ifdef T3
   putStrLn$ "\nTesting Foreign CAS, using mutable cells outside of the Haskell heap:"
--   o1C <- (newCASable zer :: IO (C.CASRef ElemTy)) >>= testCAS1
   o1C <- (newCASable zer :: IO (C.CASRef ElemTy)) >>= testCAS1
   checkOutput1 "Foreign 1" o1C
#endif

   ------------------------------------------------------------

#ifdef T1
   putStrLn$ "\nTesting Raw, native CAS:"
   ref   <- newCASable zer :: IO (A.CASRef ElemTy)
   o2A   <- timeit$ testCAS2 iters ref
   mapM_ (printBits . take 100) o2A
   fin2A <- readCASable ref
   checkOutput2 "Raw 1"     iters o2A fin2A
#endif
#ifdef T2
   putStrLn$ "\nTesting Fake CAS, based on atomicModifyIORef:"
   ref   <- newCASable zer :: IO (B.CASRef ElemTy)
   o2B   <- timeit$ testCAS2 iters ref
   mapM_ (printBits . take 100) o2B
   fin2B <- readCASable ref
   checkOutput2 "Fake 1"    iters o2B fin2B
#endif
#ifdef T3
   putStrLn$ "\nTesting Foreign CAS, using mutable cells outside of the Haskell heap:"
   ref   <- newCASable zer :: IO (C.CASRef ElemTy)
   o2C   <- timeit$ testCAS2 iters ref
   mapM_ (printBits . take 100) o2C
   fin2C <- readCASable ref
   checkOutput2 "Foreign 1" iters o2C fin2C
#endif

   ------------------------------------------------------------

#ifdef T1
   putStrLn$ "\nTesting atomicModifyIORefCAS, native CAS:"
--   ref   <- newCASable zer :: IO (A.CASRef ElemTy)
   ref   <- newIORef zer :: IO (IORef ElemTy)
   o3A   <- timeit$ testCAS3 iters ref
--   mapM_ (printBits . take 100) o3A
--   fin3A <- readCASable ref
   fin3A <- readIORef ref
--   checkOutput3 "Raw 2"     iters o3A fin3A
   putStrLn$ "  Final sum: "++ show fin3A
#endif
#ifdef T2
   putStrLn$ "\nTesting atomicModifyIORefCAS:"
--   ref   <- newCASable zer :: IO (B.CASRef ElemTy)
   ref   <- newIORef zer :: IO (IORef ElemTy)
   o3B   <- timeit$ testCAS3 iters ref
--   mapM_ (printBits . take 100) o3B
--   fin3B <- readCASable ref
   fin3B <- readIORef ref
--   checkOutput3 "Fake 2"    iters o3B fin3B
   putStrLn$ "  Final sum: "++ show fin3B
#endif
-- #ifdef T3
--    putStrLn$ "\nTesting Foreign CAS, using mutable cells outside of the Haskell heap:"
--    ref   <- newCASable zer :: IO (C.CASRef ElemTy)
--    o3C   <- testCAS3 iters ref
--    mapM_ (printBits . take 100) o3C
--    fin3C <- readCASable ref
--    checkOutput3 "Foreign 1" iters o3C fin3C
-- #endif

   ------------------------------------------------------------

   putStrLn$ "\nAll test outputs looked good."


{-
  [2011.11.10] 

Well... just got this output from the WRONG test:

"1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"
"1010101010101010101010101010101010101010101010101010101010101010101010010010100100101010101001001001"
CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!
"0101010101010100010101010101010101010101010101010101010101010101010101010101010101010101010101010101"
"0100010010001001001001001010101010101001010101010101010101010101010101010101010101001010101010101010"

The first problem is that this indicates a bug, the second is that it's coming from the WRONG PLACE.

Let me be more specific.  I'm testing three versions.  On Mac OS I see
the failure in the Foreign.hs, which is where the error message is
located and where it's coming from!

     Testing Raw, native CAS:
     Forking 2 threads.
     All threads 2 completed
     "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"
     "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"

     Testing Fake CAS, based on atomicModifyIORef:
     Forking 2 threads.
     All threads 2 completed
     "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
     "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"

     Testing Foreign CAS, using mutable cells outside of the Haskell heap:
     Forking 2 threads.
     All threads 2 completed
     CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!
     "1010101010101010101010101010101010101010101010101010101010101010101010101001001001001001001001001001"
     "0100100100100100100100100100101010101010101010101010101010101010101010101010101010101010101010101010"

But on Linux I see this error coming from the test for A.CASRef!

    Testing Raw, native CAS:
    Forking 4 threads.
    All threads 4 completed
    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"
    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"
    CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!
    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"
    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"

    Testing Fake CAS, based on atomicModifyIORef:
    Forking 4 threads.
    All threads 4 completed
    "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
    "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
    "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
    "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"

    Testing Foreign CAS, using mutable cells outside of the Haskell heap:
    Forking 4 threads.
    All threads 4 completed
    "0010010100101000101010101000101010100101010010101010010100101010100000100100100010101010100101001010"
    "1010101010101010100001000101001010010101000100101010000001000010000100010000001000000001000001010001"
    "0010010010000010000000010000000000010000100001000100101001010001000100100010010010101001001010001001"
    "0010101010100100101001000100101000001000100001000100100010001001010101010101010101010101010101010101"
    Final value 200, Total successes 200
    Final value 2, Total successes 2
    test.exe: ERROR in "Fake 1" expected at least 100 successful CAS's..

As though the instances are getting mixed up or selected in a nondeterministic way.

A.CASRef B.CASRef and C.CASRef should be unique types which do not unify with one another....

If I pump up the numbers I start seeing segfaults, which appear to be
coming from the foreign version but I think that's just because they get swapped!...

OR it's possible that I'm being silly and that I have not put
sufficient barriers between the phases to FORCE all work to complete
and therefore all print messages to be printed out in order.

    Testing Foreign CAS, using mutable cells outside of the Haskell heap:
    Forking 4 threads.
    Segmentation fault

I'm ALSO seeing failures of insufficient successes on my laptop at iters=10K...

------------------------------------------------------------

Ok, going to attempt to tease this out by first testing only one implementation at a time:

  Data.CAS -- insufficient successes occasionally (10K), 
              insufficient successes always (100K),
	      stack overflow for this test (1M)


 -}



-- test x = do
--   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" 
-- 	 (unsafeCoerce b :: Word)
-- 	 ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr b) :: Int)


-- main = test 3