newFastLogger1 ensures the ordering of logs

fast-logger/System/Log/FastLogger.hs

@@ -109,8 +109,9 @@ newFastLogger :: LogType' v -> IO (v -> IO (), IO ())
 newFastLogger typ = newFastLoggerCore Nothing typ
 
 -- | Like `newFastLogger`, but creating a logger that uses only 1
--- capability. This scales less well on multi-core machines,
--- but provides time-ordered output.
+-- internal builder. This scales less on multi-core machines and
+-- consumes more memory because of an internal queue but provides
+-- time-ordered output.
 newFastLogger1 :: LogType' v -> IO (v -> IO (), IO ())
 newFastLogger1 typ = newFastLoggerCore (Just 1) typ
 

fast-logger/System/Log/FastLogger/Internal.hs

@@ -4,12 +4,16 @@ module System.Log.FastLogger.Internal
   ( module System.Log.FastLogger.IO
   , module System.Log.FastLogger.FileIO
   , module System.Log.FastLogger.LogStr
-  , module System.Log.FastLogger.Logger
+  , module System.Log.FastLogger.SingleLogger
+  , module System.Log.FastLogger.MultiLogger
+  , module System.Log.FastLogger.Write
   , module System.Log.FastLogger.LoggerSet
   ) where
 
 import System.Log.FastLogger.IO
 import System.Log.FastLogger.FileIO
 import System.Log.FastLogger.LogStr
-import System.Log.FastLogger.Logger
+import System.Log.FastLogger.SingleLogger
+import System.Log.FastLogger.MultiLogger
+import System.Log.FastLogger.Write
 import System.Log.FastLogger.LoggerSet

fast-logger/System/Log/FastLogger/LoggerSet.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module System.Log.FastLogger.LoggerSet (
   -- * Creating a logger set
@@ -23,26 +24,35 @@ module System.Log.FastLogger.LoggerSet (
   , replaceLoggerSet
   ) where
 
-import Control.Concurrent (MVar, getNumCapabilities, myThreadId, threadCapability, takeMVar, newMVar)
+import Control.Concurrent (getNumCapabilities)
 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceAction)
-import Data.Array (Array, listArray, (!), bounds)
 
 import System.Log.FastLogger.FileIO
 import System.Log.FastLogger.IO
 import System.Log.FastLogger.Imports
 import System.Log.FastLogger.LogStr
-import System.Log.FastLogger.Logger
+import System.Log.FastLogger.MultiLogger (MultiLogger)
+import qualified System.Log.FastLogger.MultiLogger as M
+import System.Log.FastLogger.SingleLogger (SingleLogger)
+import qualified System.Log.FastLogger.SingleLogger as S
+import System.Log.FastLogger.Write
+
+----------------------------------------------------------------
+
+data Logger = SL SingleLogger | ML MultiLogger
 
 ----------------------------------------------------------------
 
 -- | A set of loggers.
 --   The number of loggers is the capabilities of GHC RTS.
 --   You can specify it with \"+RTS -N\<x\>\".
 --   A buffer is prepared for each capability.
-data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD)
-                           BufSize (MVar Buffer)
-                           (Array Int Logger)
-                           (IO ())
+data LoggerSet = LoggerSet {
+    lgrsetFilePath :: Maybe FilePath
+  , lgrsetFdRef    :: IORef FD
+  , lgrsetLogger   :: Logger
+  , lgrsetDebounce :: IO ()
+  }
 
 -- | Creating a new 'LoggerSet' using a file.
 --
@@ -90,31 +100,33 @@ newFDLoggerSet size mn mfile fd = do
     n <- case mn of
       Just n' -> return n'
       Nothing -> getNumCapabilities
-    loggers <- replicateM n newLogger
-    let arr = listArray (0,n-1) loggers
-    fref <- newIORef fd
+    fdref <- newIORef fd
     let bufsiz = max 1 size
-    mbuf <- getBuffer bufsiz >>= newMVar
+    logger <- if n == 1 && mn == Just 1 then
+                  SL <$> S.newSingleLogger bufsiz fdref
+                else do
+                  ML <$> M.newMultiLogger n bufsiz fdref
     flush <- mkDebounce defaultDebounceSettings
-        { debounceAction = flushLogStrRaw fref bufsiz mbuf arr
+        { debounceAction = flushLogStrRaw logger
         }
-    return $ LoggerSet mfile fref bufsiz mbuf arr flush
+    return $ LoggerSet {
+        lgrsetFilePath = mfile
+      , lgrsetFdRef    = fdref
+      , lgrsetLogger   = logger
+      , lgrsetDebounce = flush
+      }
 
 -- | Writing a log message to the corresponding buffer.
 --   If the buffer becomes full, the log messages in the buffer
 --   are written to its corresponding file, stdout, or stderr.
 pushLogStr :: LoggerSet -> LogStr -> IO ()
-pushLogStr (LoggerSet _ fdref size mbuf arr flush) logmsg = do
-    (i, _) <- myThreadId >>= threadCapability
-    -- The number of capability could be dynamically changed.
-    -- So, let's check the upper boundary of the array.
-    let u = snd $ bounds arr
-        lim = u + 1
-        j | i < lim   = i
-          | otherwise = i `mod` lim
-    let logger = arr ! j
-    pushLog fdref size mbuf logger logmsg
-    flush
+pushLogStr LoggerSet{..} logmsg = case lgrsetLogger of
+  SL sl -> do
+      pushLog sl logmsg
+      lgrsetDebounce
+  ML ml -> do
+      pushLog ml logmsg
+      lgrsetDebounce
 
 -- | Same as 'pushLogStr' but also appends a newline.
 pushLogStrLn :: LoggerSet -> LogStr -> IO ()
@@ -130,41 +142,36 @@ pushLogStrLn loggerSet logStr = pushLogStr loggerSet (logStr <> "\n")
 --   function can be used to force flushing outside of the debounced
 --   flush calls.
 flushLogStr :: LoggerSet -> IO ()
-flushLogStr (LoggerSet _ fref size mbuf arr _) = flushLogStrRaw fref size mbuf arr
+flushLogStr LoggerSet{..} = flushLogStrRaw lgrsetLogger
 
-flushLogStrRaw :: IORef FD -> BufSize -> MVar Buffer -> Array Int Logger -> IO ()
-flushLogStrRaw fdref size mbuf arr = do
-    let (l,u) = bounds arr
-    mapM_ flushIt [l .. u]
-  where
-    flushIt i = flushLog fdref size mbuf (arr ! i)
+flushLogStrRaw :: Logger -> IO ()
+flushLogStrRaw (SL sl) = flushAllLog sl
+flushLogStrRaw (ML ml) = flushAllLog ml
 
 -- | Renewing the internal file information in 'LoggerSet'.
 --   This does nothing for stdout and stderr.
 renewLoggerSet :: LoggerSet -> IO ()
-renewLoggerSet (LoggerSet Nothing     _    _ _ _ _) = return ()
-renewLoggerSet (LoggerSet (Just file) fref _ _ _ _) = do
-    newfd <- openFileFD file
-    oldfd <- atomicModifyIORef' fref (\fd -> (newfd, fd))
-    closeFD oldfd
+renewLoggerSet LoggerSet{..} = case lgrsetFilePath of
+  Nothing -> return ()
+  Just file -> do
+      newfd <- openFileFD file
+      oldfd <- atomicModifyIORef' lgrsetFdRef (\fd -> (newfd, fd))
+      closeFD oldfd
 
 -- | Flushing the buffers, closing the internal file information
 --   and freeing the buffers.
 rmLoggerSet :: LoggerSet -> IO ()
-rmLoggerSet (LoggerSet mfile fdref size mbuf arr _) = do
-    fd <- readIORef fdref
+rmLoggerSet LoggerSet{..} = do
+    fd <- readIORef lgrsetFdRef
     when (isFDValid fd) $ do
-        let (l,u) = bounds arr
-        let nums = [l .. u]
-        mapM_ flushIt nums
-        takeMVar mbuf >>= freeBuffer
-        when (isJust mfile) $ closeFD fd
-        writeIORef fdref invalidFD
-  where
-    flushIt i = flushLog fdref size mbuf(arr ! i)
+        case lgrsetLogger of
+          SL sl -> stopLoggers sl
+          ML ml -> stopLoggers ml
+        when (isJust lgrsetFilePath) $ closeFD fd
+        writeIORef lgrsetFdRef invalidFD
 
 -- | Replacing the file path in 'LoggerSet' and returning a new
 --   'LoggerSet' and the old file path.
 replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
-replaceLoggerSet (LoggerSet current_path a b c d e) new_file_path =
-    (LoggerSet (Just new_file_path) a b c d e, current_path)
+replaceLoggerSet lgrset@LoggerSet{..} new_file_path =
+    (lgrset { lgrsetFilePath = Just new_file_path }, lgrsetFilePath)

fast-logger/System/Log/FastLogger/MultiLogger.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module System.Log.FastLogger.MultiLogger (
+    MultiLogger
+  , newMultiLogger
+  ) where
+
+
+import Control.Concurrent (myThreadId, threadCapability, MVar, newMVar, withMVar, takeMVar)
+import Data.Array (Array, listArray, (!), bounds)
+
+import System.Log.FastLogger.FileIO
+import System.Log.FastLogger.IO
+import System.Log.FastLogger.Imports
+import System.Log.FastLogger.LogStr
+import System.Log.FastLogger.Write
+
+----------------------------------------------------------------
+
+newtype MLogger = MLogger {
+    lgrRef :: IORef LogStr
+  }
+
+-- | A scale but non-time-ordered logger.
+data MultiLogger = MultiLogger {
+    mlgrArray   :: Array Int MLogger
+  , mlgrMBuffer :: MVar Buffer
+  , mlgrBufSize :: BufSize
+  , mlgrFdRef   :: IORef FD
+  }
+
+instance Loggers MultiLogger where
+    stopLoggers = System.Log.FastLogger.MultiLogger.stopLoggers
+    pushLog     = System.Log.FastLogger.MultiLogger.pushLog
+    flushAllLog = System.Log.FastLogger.MultiLogger.flushAllLog
+
+----------------------------------------------------------------
+
+newMLogger :: IO MLogger
+newMLogger = MLogger <$> newIORef mempty
+
+-- | Creating `MultiLogger`.
+--   The first argument is the number of the internal builders.
+newMultiLogger :: Int -> BufSize -> IORef FD -> IO MultiLogger
+newMultiLogger n bufsize fdref= do
+    mbuf <- getBuffer bufsize >>= newMVar
+    arr <- listArray (0,n-1) <$> replicateM n newMLogger
+    return $ MultiLogger {
+        mlgrArray   = arr
+      , mlgrMBuffer = mbuf
+      , mlgrBufSize = bufsize
+      , mlgrFdRef   = fdref
+      }
+
+----------------------------------------------------------------
+
+pushLog :: MultiLogger -> LogStr -> IO ()
+pushLog ml@MultiLogger{..} logmsg = do
+    (i, _) <- myThreadId >>= threadCapability
+    -- The number of capability could be dynamically changed.
+    -- So, let's check the upper boundary of the array.
+    let u = snd $ bounds mlgrArray
+        lim = u + 1
+        j | i < lim   = i
+          | otherwise = i `mod` lim
+    let logger = mlgrArray ! j
+    pushLog' logger logmsg
+  where
+    pushLog' logger@MLogger{..} nlogmsg@(LogStr nlen _)
+      | nlen > mlgrBufSize = do
+          flushLog ml logger
+          -- Make sure we have a large enough buffer to hold the entire
+          -- contents, thereby allowing for a single write system call and
+          -- avoiding interleaving. This does not address the possibility
+          -- of write not writing the entire buffer at once.
+          writeBigLogStr' ml nlogmsg
+      | otherwise = do
+        action <- atomicModifyIORef' lgrRef checkBuf
+        action
+      where
+        checkBuf ologmsg@(LogStr olen _)
+          | mlgrBufSize < olen + nlen = (nlogmsg, writeLogStr' ml ologmsg)
+          | otherwise                 = (ologmsg <> nlogmsg, return ())
+
+----------------------------------------------------------------
+
+flushAllLog :: MultiLogger -> IO ()
+flushAllLog ml@MultiLogger{..} = do
+    let flushIt i = flushLog ml (mlgrArray ! i)
+        (l,u) = bounds mlgrArray
+        nums = [l .. u]
+    mapM_ flushIt nums
+
+flushLog :: MultiLogger -> MLogger -> IO ()
+flushLog ml MLogger{..} = do
+    -- If a special buffer is prepared for flusher, this MVar could
+    -- be removed. But such a code does not contribute logging speed
+    -- according to experiment. And even with the special buffer,
+    -- there is no grantee that this function is exclusively called
+    -- for a buffer. So, we use MVar here.
+    -- This is safe and speed penalty can be ignored.
+    old <- atomicModifyIORef' lgrRef (\old -> (mempty, old))
+    writeLogStr' ml old
+
+----------------------------------------------------------------
+
+stopLoggers :: MultiLogger -> IO ()
+stopLoggers ml@MultiLogger{..} = do
+  System.Log.FastLogger.MultiLogger.flushAllLog ml
+  takeMVar mlgrMBuffer >>= freeBuffer
+
+----------------------------------------------------------------
+
+writeLogStr' :: MultiLogger -> LogStr -> IO ()
+writeLogStr' MultiLogger{..} logstr =
+    withMVar mlgrMBuffer $ \buf -> writeLogStr buf mlgrFdRef logstr
+
+writeBigLogStr' :: MultiLogger -> LogStr -> IO ()
+writeBigLogStr' MultiLogger{..} logstr =
+    withMVar mlgrMBuffer $ \_ -> writeBigLogStr mlgrFdRef logstr