[commit: base] master: Add pure traceEvent and re-export from Debug.Trace (3c9c0ae)

[Duncan Coutts]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/3c9c0aeb58ef6990ee59b5e8a4c58ee68012752d

>---------------------------------------------------------------

commit 3c9c0aeb58ef6990ee59b5e8a4c58ee68012752d
Author: Duncan Coutts <duncan at well-typed.com>
Date:   Wed Oct 26 13:33:48 2011 +0100

    Add pure traceEvent and re-export from Debug.Trace
    
    Previously traceEvent was exported only from GHC.Exts and had an IO
    type. The new scheme is:
    
      GHC.Exts.traceEventIO    :: String -> IO ()
    
      Debug.Trace.traceEventIO :: String -> IO ()
      Debug.Trace.traceEvent   :: String -> a -> a
    
    The new traceEvent has a pure type like Debug.Trace.trace and can be
    used in pure code. The previous GHC.Exts.traceEvent is deprecated.

>---------------------------------------------------------------

 Debug/Trace.hs |   37 ++++++++++++++++++++++++++++++++++++-
 GHC/Exts.hs    |   13 +++++++++----
 2 files changed, 45 insertions(+), 5 deletions(-)

diff --git a/Debug/Trace.hs b/Debug/Trace.hs
index 8242b15..3187d0a 100644
--- a/Debug/Trace.hs
+++ b/Debug/Trace.hs
@@ -19,7 +19,11 @@ module Debug.Trace (
         -- * Tracing
         putTraceMsg,      -- :: String -> IO ()
         trace,            -- :: String -> a -> a
-        traceShow
+        traceShow,
+
+        -- * Eventlog tracing
+        traceEvent,
+        traceEventIO,
   ) where
 
 import Prelude
@@ -27,6 +31,7 @@ import System.IO.Unsafe
 
 #ifdef __GLASGOW_HASKELL__
 import Foreign.C.String
+import qualified GHC.Exts as GHC
 #else
 import System.IO (hPutStrLn,stderr)
 #endif
@@ -72,3 +77,33 @@ Like 'trace', but uses 'show' on the argument to convert it to a 'String'.
 traceShow :: (Show a) => a -> b -> b
 traceShow = trace . show
 
+
+{-# NOINLINE traceEvent #-}
+-- | The 'traceEvent' function behaves like 'trace' with the difference that
+-- the message is emitted to the eventlog, if eventlog profiling is available
+-- and enabled at runtime.
+--
+-- It is suitable for use in pure code. In an IO context use 'traceEventIO'
+-- instead.
+--
+-- Note that when using GHC's SMP runtime, it is possible (but rare) to get
+-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk
+-- that uses 'traceEvent'.
+--
+traceEvent :: String -> a -> a
+traceEvent msg expr = unsafeDupablePerformIO $ do
+    traceEventIO msg
+    return expr
+
+-- | The 'traceEventIO' function emits a message to the eventlog, if eventlog
+-- profiling is available and enabled at runtime.
+--
+-- Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to
+-- other IO actions.
+--
+traceEventIO :: String -> IO ()
+#ifdef __GLASGOW_HASKELL__
+traceEventIO = GHC.traceEventIO
+#else
+traceEventIO msg = (return $! length msg) >> return ()
+#endif
diff --git a/GHC/Exts.hs b/GHC/Exts.hs
index e40807c..72d4f78 100644
--- a/GHC/Exts.hs
+++ b/GHC/Exts.hs
@@ -47,6 +47,7 @@ module GHC.Exts
         Down(..), groupWith, sortWith, the,
 
         -- * Event logging
+        traceEventIO,
         traceEvent,
 
         -- * SpecConstr annotations
@@ -62,9 +63,10 @@ import GHC.Magic
 import GHC.Word
 import GHC.Int
 import GHC.Ptr
+import GHC.Foreign
+import GHC.IO.Encoding
 import Data.String
 import Data.List
-import Foreign.C
 import Data.Data
 
 -- XXX This should really be in Data.Tuple, where the definitions are
@@ -112,11 +114,14 @@ groupByFB c n eq xs0 = groupByFBCore xs0
 -- -----------------------------------------------------------------------------
 -- tracing
 
-traceEvent :: String -> IO ()
-traceEvent msg = do
-  withCString msg $ \(Ptr p) -> IO $ \s ->
+traceEventIO :: String -> IO ()
+traceEventIO msg = do
+  withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
     case traceEvent# p s of s' -> (# s', () #)
 
+traceEvent :: String -> IO ()
+traceEvent = traceEventIO
+{-# DEPRECATED traceEvent "Use Debug.Trace.traceEvent or Debug.Trace.traceEventIO" #-}
 
 
 {- **********************************************************************