diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 3.1.0 + +* Having a single Buffer in LoggerSet for locking [#197](https://github.com/kazu-yamamoto/logger/pull/197. + This would have performance penalty. So, the major version bumps up. If you see performance regression, please register an issue on github. + ## 3.0.5 * recovering backward compatibility for newFileLoggerSet. diff --git a/System/Log/FastLogger/IO.hs b/System/Log/FastLogger/IO.hs --- a/System/Log/FastLogger/IO.hs +++ b/System/Log/FastLogger/IO.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ <= 708 @@ -34,7 +33,7 @@ freeBuffer = free toBufIOWith :: Buffer -> BufSize -> (Buffer -> Int -> IO ()) -> Builder -> IO () -toBufIOWith buf !size io builder = loop $ BBE.runBuilder builder +toBufIOWith buf size io builder = loop $ BBE.runBuilder builder where loop writer = do (len, next) <- writer buf size diff --git a/System/Log/FastLogger/Logger.hs b/System/Log/FastLogger/Logger.hs --- a/System/Log/FastLogger/Logger.hs +++ b/System/Log/FastLogger/Logger.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} @@ -10,7 +9,7 @@ ) where -import Control.Concurrent (MVar, newMVar, withMVar) +import Control.Concurrent (MVar, withMVar) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (plusPtr) @@ -21,20 +20,19 @@ ---------------------------------------------------------------- -data Logger = Logger !BufSize (MVar Buffer) (IORef LogStr) +newtype Logger = Logger (IORef LogStr) ---------------------------------------------------------------- -newLogger :: BufSize -> IO Logger -newLogger size = Logger size <$> (getBuffer size >>= newMVar) - <*> newIORef mempty +newLogger :: IO Logger +newLogger = Logger <$> newIORef mempty ---------------------------------------------------------------- -pushLog :: IORef FD -> Logger -> LogStr -> IO () -pushLog fdref logger@(Logger size mbuf ref) nlogmsg@(LogStr nlen nbuilder) +pushLog :: IORef FD -> BufSize -> MVar Buffer -> Logger -> LogStr -> IO () +pushLog fdref size mbuf logger@(Logger ref) nlogmsg@(LogStr nlen nbuilder) | nlen > size = do - flushLog fdref logger + flushLog fdref size mbuf 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 @@ -53,8 +51,8 @@ ---------------------------------------------------------------- -flushLog :: IORef FD -> Logger -> IO () -flushLog fdref (Logger size mbuf lref) = do +flushLog :: IORef FD -> BufSize -> MVar Buffer -> Logger -> IO () +flushLog fdref size mbuf (Logger lref) = do logmsg <- atomicModifyIORef' lref (\old -> (mempty, old)) -- If a special buffer is prepared for flusher, this MVar could -- be removed. But such a code does not contribute logging speed @@ -81,7 +79,7 @@ write :: IORef FD -> Buffer -> Int -> IO () write fdref buf len' = loop buf (fromIntegral len') where - loop bf !len = do + loop bf len = do written <- writeRawBufferPtr2FD fdref bf len when (0 <= written && written < len) $ loop (bf `plusPtr` fromIntegral written) (len - written) diff --git a/System/Log/FastLogger/LoggerSet.hs b/System/Log/FastLogger/LoggerSet.hs --- a/System/Log/FastLogger/LoggerSet.hs +++ b/System/Log/FastLogger/LoggerSet.hs @@ -20,8 +20,8 @@ , replaceLoggerSet ) where +import Control.Concurrent (MVar, getNumCapabilities, myThreadId, threadCapability, takeMVar, newMVar) import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceAction) -import Control.Concurrent (getNumCapabilities, myThreadId, threadCapability, takeMVar) import Data.Array (Array, listArray, (!), bounds) import System.Log.FastLogger.FileIO @@ -36,7 +36,10 @@ -- The number of loggers is the capabilities of GHC RTS. -- You can specify it with \"+RTS -N\\". -- A buffer is prepared for each capability. -data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD) (Array Int Logger) (IO ()) +data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD) + BufSize (MVar Buffer) + (Array Int Logger) + (IO ()) -- | Creating a new 'LoggerSet' using a file. newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet @@ -68,19 +71,21 @@ n <- case mn of Just n' -> return n' Nothing -> getNumCapabilities - loggers <- replicateM n $ newLogger (max 1 size) + loggers <- replicateM n newLogger let arr = listArray (0,n-1) loggers fref <- newIORef fd + let bufsiz = max 1 size + mbuf <- getBuffer bufsiz >>= newMVar flush <- mkDebounce defaultDebounceSettings - { debounceAction = flushLogStrRaw fref arr + { debounceAction = flushLogStrRaw fref bufsiz mbuf arr } - return $ LoggerSet mfile fref arr flush + return $ LoggerSet mfile fref bufsiz mbuf arr 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 arr flush) logmsg = do +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. @@ -89,7 +94,7 @@ j | i < lim = i | otherwise = i `mod` lim let logger = arr ! j - pushLog fdref logger logmsg + pushLog fdref size mbuf logger logmsg flush -- | Same as 'pushLogStr' but also appends a newline. @@ -106,20 +111,20 @@ -- function can be used to force flushing outside of the debounced -- flush calls. flushLogStr :: LoggerSet -> IO () -flushLogStr (LoggerSet _ fref arr _) = flushLogStrRaw fref arr +flushLogStr (LoggerSet _ fref size mbuf arr _) = flushLogStrRaw fref size mbuf arr -flushLogStrRaw :: IORef FD -> Array Int Logger -> IO () -flushLogStrRaw fdref arr = do +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 (arr ! i) + flushIt i = flushLog fdref size mbuf (arr ! i) -- | 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 +renewLoggerSet (LoggerSet Nothing _ _ _ _ _) = return () +renewLoggerSet (LoggerSet (Just file) fref _ _ _ _) = do newfd <- openFileFD file oldfd <- atomicModifyIORef' fref (\fd -> (newfd, fd)) closeFD oldfd @@ -127,23 +132,20 @@ -- | Flushing the buffers, closing the internal file information -- and freeing the buffers. rmLoggerSet :: LoggerSet -> IO () -rmLoggerSet (LoggerSet mfile fdref arr _) = do +rmLoggerSet (LoggerSet mfile fdref size mbuf arr _) = do fd <- readIORef fdref when (isFDValid fd) $ do let (l,u) = bounds arr let nums = [l .. u] mapM_ flushIt nums - mapM_ freeIt nums + takeMVar mbuf >>= freeBuffer when (isJust mfile) $ closeFD fd writeIORef fdref invalidFD where - flushIt i = flushLog fdref (arr ! i) - freeIt i = do - let (Logger _ mbuf _) = arr ! i - takeMVar mbuf >>= freeBuffer + flushIt i = flushLog fdref size mbuf(arr ! i) -- | 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) new_file_path = - (LoggerSet (Just new_file_path) a b c, current_path) +replaceLoggerSet (LoggerSet current_path a b c d e) new_file_path = + (LoggerSet (Just new_file_path) a b c d e, current_path) diff --git a/fast-logger.cabal b/fast-logger.cabal --- a/fast-logger.cabal +++ b/fast-logger.cabal @@ -1,5 +1,5 @@ Name: fast-logger -Version: 3.0.5 +Version: 3.1.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3