module Control.Monad.Par.Meta.Resources.Debugging ( dbg
, dbgTaggedMsg
, dbgDelay
, dbgCharMsg
, meaningless_alloc
, taggedmsg_global_mode
, verbosity
) where
import Foreign.C (CString)
import GHC.Exts (traceEvent#, Ptr(Ptr))
import GHC.IO (IO(IO))
import qualified Data.ByteString.Char8 as BS
import Data.IORef (IORef, newIORef, readIORef)
import Data.Monoid (mappend, Monoid)
import Control.Monad (when)
import Control.Concurrent (myThreadId, threadDelay)
import System.IO (hFlush, stderr)
import System.IO.Unsafe (unsafePerformIO)
import System.Environment (getEnvironment)
#define TMPDBG
#define EVENTLOG
verbosity :: Int
verbosity = unsafePerformIO$ do
env <- getEnvironment
case lookup "VERBOSITY" env of
Just "" -> return 1
Just s -> do let n = read s
when (n >= 2)$ putStrLn "(!) Responding to VERBOSITY environment variable!"
return n
#ifdef DEBUG
Nothing -> return 5
#else
Nothing -> do
return 1
#endif
binaryEventLog :: Bool
binaryEventLog = unsafePerformIO$ do
env <- getEnvironment
case lookup "EVENTLOG" env of
Nothing -> return False
Just "" -> return False
Just "0" -> return False
Just _ -> return True
dbg :: Bool
#ifdef DEBUG
dbg = True
#else
dbg = False
#endif
whenVerbosity :: Monad m => Int -> m () -> m ()
whenVerbosity n action = when (verbosity >= n) action
dbgTaggedMsg :: Int -> BS.ByteString -> IO ()
dbgTaggedMsg = if binaryEventLog then binaryLogMsg else textLogMsg
textLogMsg :: Int -> BS.ByteString -> IO ()
textLogMsg lvl s =
whenVerbosity lvl $
do m <- readIORef taggedmsg_global_mode
tid <- myThreadId
BS.putStrLn$ " [distmeta" +++ m +++" "+++ sho tid +++"] "+++s
(+++) :: Monoid a => a -> a -> a
(+++) = mappend
sho :: Show a => a -> BS.ByteString
sho = BS.pack . show
binaryLogMsg :: Int -> BS.ByteString -> IO ()
binaryLogMsg lvl s = do
whenVerbosity lvl $ do
m <- readIORef taggedmsg_global_mode
tid <- myThreadId
let msg = " [distmeta"+++m+++" "+++ sho tid+++"] "+++s
BS.useAsCString msg myTraceEvent
return ()
myTraceEvent :: CString -> IO ()
myTraceEvent (Ptr msg) = IO $ \s -> case traceEvent# msg s of s' -> (# s', () #)
dbgCharMsg :: Int -> BS.ByteString -> BS.ByteString -> IO ()
dbgCharMsg lvl tag fullmsg =
if binaryEventLog
then dbgTaggedMsg lvl fullmsg
else whenVerbosity lvl $ do BS.hPutStr stderr tag; hFlush stderr
dbgDelay :: BS.ByteString -> IO ()
dbgDelay _ =
if dbg
then threadDelay (200*1000)
else return ()
meaningless_alloc :: IO ()
meaningless_alloc =
case length (fibls 5) of
0 -> return (error "Never happen!")
_ -> return ()
where
fibls :: Int -> [Int]
fibls n | n <= 1 = [1::Int]
fibls n = fibls (n1) ++ fibls (n2)
taggedmsg_global_mode :: IORef BS.ByteString
taggedmsg_global_mode = unsafePerformIO$ newIORef "_M"