{-# 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)