blob: d63d21e2dc5d02091a359dadfc215ac5d25f8a1e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
{-# OPTIONS_GHC -fno-full-laziness -fno-cse #-}
module Network.HTTP.Server.Mini.Internal.Instrument where
import Control.Concurrent
import Control.Monad (void)
import Data.IORef
import Data.Text qualified as T
import Data.Text.IO.Utf8 qualified as T
import Data.Text (Text)
import Data.Time.Clock.POSIX
import System.IO
import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE nextId #-}
nextId :: IORef Int
nextId = unsafePerformIO (newIORef 1)
-- Number of instrument blocks open
{-# NOINLINE numOpen #-}
numOpen :: IORef Int
numOpen = unsafePerformIO (newIORef 0)
{-# NOINLINE mutex #-}
mutex :: MVar ()
mutex = unsafePerformIO (newMVar ())
instrument :: String -> IO a -> IO a
instrument name action = do
idval <- atomicModifyIORef' nextId (\i -> (i+1, i))
atomicPrintS (show idval ++ "< " ++ name)
atomicModifyIORef' numOpen (\i -> (i+1, ()))
t1 <- getPOSIXTime
res <- action
t2 <- getPOSIXTime
numOpenAfter <- atomicModifyIORef' numOpen (\i -> (i-1, i-1))
atomicPrintS (show idval ++ "> " ++ name ++ " (" ++ show (t2 - t1) ++ ") (" ++ show numOpenAfter ++ ")")
return res
atomicPrintS :: String -> IO ()
atomicPrintS = atomicPrint . T.pack
atomicPrint :: Text -> IO ()
atomicPrint text =
withMVar mutex $ \() ->
T.putStrLn text >> hFlush stdout
atomicPrintNoWaitS :: String -> IO ()
atomicPrintNoWaitS = atomicPrintNoWait . T.pack
-- | Does not block, so if you've masked exceptions, nothing will come through here
atomicPrintNoWait :: Text -> IO ()
atomicPrintNoWait text = void $ forkIO $ atomicPrint text
|
