Avoid MVar access in dput & dtrace

1 files changed, 19 insertions, 4 deletions

diff --git a/src/DPut.hs b/src/DPut.hs
index 94a237f8..73d142b7 100644
--- a/src/DPut.hs
+++ b/src/DPut.hs
@@ -3,13 +3,15 @@ module DPut where
 import Control.Monad.IO.Class
 import Control.Concurrent.STM
 import qualified Data.Map.Strict as Map
-import System.IO (stderr,hPutStrLn)
 import Data.Maybe
+import Data.IORef
+import System.IO (stderr,hPutStrLn)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Log.Logger
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import Debug.Trace
 
 -- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last
 data DebugTag
@@ -41,16 +43,29 @@ dput tag msg = liftIO $ debugM (appName <.> show tag) msg
 dputB :: MonadIO m => DebugTag -> B.ByteString -> m ()
 dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
 
+{-# NOINLINE verbosityMap #-}
+verbosityMap :: IORef (Map.Map DebugTag Bool)
+verbosityMap = unsafePerformIO $ newIORef (Map.empty)
+
 -- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO.
 tput :: Applicative m => DebugTag -> String -> m ()
-tput tag msg = (unsafePerformIO $ dput tag msg) `seq` pure ()
+tput tag msg =
+  let mp = unsafePerformIO $ readIORef verbosityMap
+    in if fromMaybe True (Map.lookup tag mp)
+        then trace msg (pure ())
+        else pure ()
 
 -- | like 'trace' but parameterized with 'DebugTag'
 dtrace :: DebugTag -> String -> a -> a
-dtrace tag msg result = (unsafePerformIO $ dput tag msg) `seq` result
+dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap
+                            in if fromMaybe True (Map.lookup tag mp)
+                                then trace msg result
+                                else result
 
 setTagLevel :: Priority -> DebugTag -> IO ()
-setTagLevel level tag = updateGlobalLogger (appName <.> show tag) (setLevel level)
+setTagLevel level tag = do
+    updateGlobalLogger (appName <.> show tag) (setLevel level)
+    modifyIORef verbosityMap (Map.insert tag (level <= DEBUG))
 
 setQuiet :: DebugTag -> IO ()
 setQuiet = setTagLevel WARNING