diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for bytelog +## 0.1.3.1 -- 2024-02-02 + +* Update package metadata. + ## 0.1.2.0 -- 2024-01-09 * Add `chunks`. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bytelog.cabal b/bytelog.cabal --- a/bytelog.cabal +++ b/bytelog.cabal @@ -1,26 +1,37 @@ -cabal-version: 2.4 -name: bytelog -version: 0.1.2.0 -synopsis: Fast logging -bug-reports: https://github.com/byteverse/bytelog -license: BSD-3-Clause -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2020 Andrew Martin -category: Data -build-type: Simple -extra-source-files: CHANGELOG.md +cabal-version: 2.4 +name: bytelog +version: 0.1.3.1 +synopsis: Fast logging +description: Fast logging. +homepage: https://github.com/byteverse/bytelog +bug-reports: https://github.com/byteverse/bytelog/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2020 Andrew Martin +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md +common build-settings + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages + library + import: build-settings exposed-modules: Logger build-depends: - , base >=4.12 && <5 - , bytebuild >=0.3.4 - , byteslice >=0.2.2 - , natural-arithmetic >=0.1.2 - , posix-api >=0.3.4 - , primitive >=0.7 - hs-source-dirs: src - ghc-options: -O2 -Wall - default-language: Haskell2010 + , base >=4.12 && <5 + , bytebuild >=0.3.4 + , byteslice >=0.2.2 + , natural-arithmetic >=0.1.2 + , posix-api >=0.3.4 + , primitive >=0.7 + + hs-source-dirs: src + ghc-options: -O2 + +source-repository head + type: git + location: git://github.com/byteverse/bytelog.git diff --git a/src/Logger.hs b/src/Logger.hs --- a/src/Logger.hs +++ b/src/Logger.hs @@ -1,14 +1,16 @@ -{-# language BangPatterns #-} -{-# language MagicHash #-} -{-# language LambdaCase #-} -{-# language ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} module Logger ( -- * Types Logger + -- * Open , fromHandle , fromFd + -- * Log , builder , boundedBuilder @@ -17,31 +19,32 @@ , byteArray , cstring , cstring# + -- * Flush , flush ) where -import Control.Concurrent (MVar,threadWaitWrite,putMVar,newMVar,tryTakeMVar,rtsSupportsBoundThreads) -import Control.Exception (SomeException,toException,onException,mask) +import Control.Concurrent (MVar, newMVar, putMVar, rtsSupportsBoundThreads, threadWaitWrite, tryTakeMVar) +import Control.Exception (SomeException, mask, onException, toException) import Control.Monad (when) import Data.Bits ((.&.)) import Data.Bytes.Builder (Builder) import Data.Bytes.Chunks (Chunks) -import Data.Bytes.Types (Bytes(Bytes)) -import Data.IORef (IORef,atomicModifyIORef',newIORef) -import Data.Primitive (MutablePrimArray,ByteArray) -import Foreign.C.Error (eINTR,eWOULDBLOCK,eAGAIN,eBADF) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.Primitive (ByteArray, MutablePrimArray) +import Foreign.C.Error (eAGAIN, eBADF, eINTR, eWOULDBLOCK) import Foreign.C.String (CString) -import GHC.Exts (Ptr(Ptr),RealWorld,Addr#) -import GHC.IO (IO(IO)) -import Posix.File (uninterruptibleWriteByteArray,uninterruptibleGetStatusFlags) +import GHC.Exts (Addr#, Ptr (Ptr), RealWorld) +import GHC.IO (IO (IO)) +import Posix.File (uninterruptibleGetStatusFlags, uninterruptibleWriteByteArray) import System.IO (Handle) -import System.Posix.Types (Fd(Fd)) +import System.Posix.Types (Fd (Fd)) import qualified Arithmetic.Types as Arithmetic +import qualified Data.Bytes as Bytes import qualified Data.Bytes.Builder as Builder import qualified Data.Bytes.Builder.Bounded as BB -import qualified Data.Bytes as Bytes import qualified Data.Bytes.Chunks as Chunks import qualified Data.Primitive as PM import qualified GHC.Exts as Exts @@ -49,53 +52,59 @@ import qualified GHC.IO.Handle.FD as FD import qualified Posix.File as File --- | An output channel for logs. The intent is that there is only --- one logger per application, opened at load time and shared across --- all threads. -data Logger = Logger - {-# UNPACK #-} !Fd - -- ^ Output file descriptor, often stdout or stderr. Must be - -- in nonblocking mode. This is checked when the logger is opened. - {-# UNPACK #-} !Int - -- ^ The number 1 if file descriptor is nonblocking. The number 0 - -- if it is blocking. Notably, stderr will almost certainly be in - -- blocking mode. - {-# UNPACK #-} !(MVar ()) - -- ^ Lock, only used when flushing. - {-# UNPACK #-} !(IORef Chunks) - -- ^ Chunks to be written out. This is only ever accessed by - -- thread-safe atomicModify functions. - {-# UNPACK #-} !(MutablePrimArray RealWorld Int) - -- ^ Singleton array with a counter. This is used as a heuristic - -- for when to flush. This is accessed in a non-thread-safe way - -- where updates can be overridden. This is fine since logs will - -- eventually get flushed anyway. Note that this is based on a - -- number of units atomically written to the logger, not based - -- on a byte count. Intuitively, it is deeply wrong to decide - -- when to flush like this, but small-bytearray-builder is not - -- able to provide the number of bytes that result from running - -- a builder, so we use this hack instead. +{- | An output channel for logs. The intent is that there is only +one logger per application, opened at load time and shared across +all threads. +-} +data Logger + = Logger + -- | Output file descriptor, often stdout or stderr. Must be + -- in nonblocking mode. This is checked when the logger is opened. + {-# UNPACK #-} !Fd + -- | The number 1 if file descriptor is nonblocking. The number 0 + -- if it is blocking. Notably, stderr will almost certainly be in + -- blocking mode. + {-# UNPACK #-} !Int + -- | Lock, only used when flushing. + {-# UNPACK #-} !(MVar ()) + -- | Chunks to be written out. This is only ever accessed by + -- thread-safe atomicModify functions. + {-# UNPACK #-} !(IORef Chunks) + -- | Singleton array with a counter. This is used as a heuristic + -- for when to flush. This is accessed in a non-thread-safe way + -- where updates can be overridden. This is fine since logs will + -- eventually get flushed anyway. Note that this is based on a + -- number of units atomically written to the logger, not based + -- on a byte count. Intuitively, it is deeply wrong to decide + -- when to flush like this, but small-bytearray-builder is not + -- able to provide the number of bytes that result from running + -- a builder, so we use this hack instead. + {-# UNPACK #-} !(MutablePrimArray RealWorld Int) --- | Convert a 'Handle' to a logger by extracting its file descriptor. --- Warning: the caller must ensure that the handle does not get garbage --- collected. This is very dangerous. +{- | Convert a 'Handle' to a logger by extracting its file descriptor. +Warning: the caller must ensure that the handle does not get garbage +collected. This is very dangerous. +-} fromHandle :: Handle -> IO Logger fromHandle h = do - FD.FD{FD.fdFD=fd} <- FD.handleToFd h + FD.FD {FD.fdFD = fd} <- FD.handleToFd h fromFd (Fd fd) -- | Convert a file descriptor to a logger. fromFd :: Fd -> IO Logger fromFd !fd = do when (not rtsSupportsBoundThreads) (die threadedRuntimeRequired) - status <- uninterruptibleGetStatusFlags fd >>= \case - Left _ -> die flagsFailure - Right status -> pure status - when (not (File.isWriteOnly status || File.isReadWrite status)) + status <- + uninterruptibleGetStatusFlags fd >>= \case + Left _ -> die flagsFailure + Right status -> pure status + when + (not (File.isWriteOnly status || File.isReadWrite status)) (die statusWriteFailure) - let !nonblocking = if File.nonblocking .&. status == File.nonblocking - then 1 - else 0 + let !nonblocking = + if File.nonblocking .&. status == File.nonblocking + then 1 + else 0 !lock <- newMVar () !ref <- newIORef Chunks.ChunksNil !counterRef <- PM.newPrimArray 1 @@ -109,24 +118,26 @@ cstring :: Logger -> CString -> IO () cstring g str = builder g (Builder.cstring str) --- | Log a @NUL@-terminated C string. Takes the unboxed equivalent of @CString@. --- This improves legibility in a common case: --- --- > cstring logger (Ptr "Initializing..."#) --- --- This can be written more succinctly as: --- --- > cstring# logger "Initializing..."# +{- | Log a @NUL@-terminated C string. Takes the unboxed equivalent of @CString@. +This improves legibility in a common case: + +> cstring logger (Ptr "Initializing..."#) + +This can be written more succinctly as: + +> cstring# logger "Initializing..."# +-} cstring# :: Logger -> Addr# -> IO () cstring# g str = builder g (Builder.cstring (Ptr str)) chunks :: Logger -> Chunks -> IO () -{-# noinline chunks #-} +{-# NOINLINE chunks #-} chunks logger@(Logger _ _ _ ref counterRef) ch = do - atomicModifyIORef' ref - (\cs0 -> - let !cs1 = Chunks.reverseOnto cs0 ch - in (cs1,()) + atomicModifyIORef' + ref + ( \cs0 -> + let !cs1 = Chunks.reverseOnto cs0 ch + in (cs1, ()) ) !counter <- bumpCounter counterRef when (counter >= threshold) $ do @@ -137,13 +148,14 @@ -- | Log the chunks that result from executing the byte builder. builder :: Logger -> Builder -> IO () builder logger@(Logger _ _ _ ref counterRef) bldr = do - atomicModifyIORef' ref - (\cs0 -> - -- Why use reversedOnto? The chunks are arranged backwards. - -- in the buffer. When we flush, they get reversed and end - -- up in the correct order. - let !cs1 = Builder.reversedOnto 240 bldr cs0 - in (cs1,()) + atomicModifyIORef' + ref + ( \cs0 -> + -- Why use reversedOnto? The chunks are arranged backwards. + -- in the buffer. When we flush, they get reversed and end + -- up in the correct order. + let !cs1 = Builder.reversedOnto 240 bldr cs0 + in (cs1, ()) ) !counter <- bumpCounter counterRef when (counter >= threshold) $ do @@ -151,16 +163,18 @@ PM.writePrimArray counterRef 0 0 flush logger --- | Log the unsliced byte array that results from executing --- the bounded builder. +{- | Log the unsliced byte array that results from executing +the bounded builder. +-} boundedBuilder :: Logger -> Arithmetic.Nat n -> BB.Builder n -> IO () boundedBuilder logger n b = byteArray logger (BB.run n b) -- | Log a byte sequence. bytes :: Logger -> Bytes -> IO () bytes logger@(Logger _ _ _ ref counterRef) !b = do - atomicModifyIORef' ref - (\cs0 -> let !cs1 = Chunks.ChunksCons b cs0 in (cs1,())) + atomicModifyIORef' + ref + (\cs0 -> let !cs1 = Chunks.ChunksCons b cs0 in (cs1, ())) !counter <- bumpCounter counterRef when (counter >= threshold) (flush logger) @@ -177,40 +191,43 @@ -- | Flush any pending logs out to the file descriptor. flush :: Logger -> IO () -{-# noinline flush #-} -flush (Logger fd nonblocking lock ref _) = mask $ \restore -> tryTakeMVar lock >>= \case - -- Try to take the lock. This cannot be interrupted by async exceptions. - -- If we cannot take the lock immidiately, someone else is already flushing - -- logs, so we just give up. - Nothing -> pure () - Just (_ :: ()) -> do - -- Atomically remove all logs from the batch. GHC guarantees - -- that this cannot be interrupted by async exceptions - -- inside of mask. - yanked <- atomicModifyIORef' ref (\cs -> (Chunks.ChunksNil,cs)) - -- When cleaning up after an exception, we put all the logs - -- back. This means that logs may end up duplicated. That is - -- in addition to the inevitable chance of a torn log that - -- was being written out when throwTo delivered the exception. - -- The decision about the ordering of @cs@ and @yanked@ during - -- cleanup is arbitrary. - onException - (restore (action yanked)) - (do atomicModifyIORef' ref (\cs -> (cs <> yanked,())) - putMVar lock () - ) - putMVar lock () - where - action yanked = case nonblocking of - 1 -> writeNonblocking fd yanked - _ -> writeBlocking fd yanked +{-# NOINLINE flush #-} +flush (Logger fd nonblocking lock ref _) = mask $ \restore -> + tryTakeMVar lock >>= \case + -- Try to take the lock. This cannot be interrupted by async exceptions. + -- If we cannot take the lock immidiately, someone else is already flushing + -- logs, so we just give up. + Nothing -> pure () + Just (_ :: ()) -> do + -- Atomically remove all logs from the batch. GHC guarantees + -- that this cannot be interrupted by async exceptions + -- inside of mask. + yanked <- atomicModifyIORef' ref (\cs -> (Chunks.ChunksNil, cs)) + -- When cleaning up after an exception, we put all the logs + -- back. This means that logs may end up duplicated. That is + -- in addition to the inevitable chance of a torn log that + -- was being written out when throwTo delivered the exception. + -- The decision about the ordering of @cs@ and @yanked@ during + -- cleanup is arbitrary. + onException + (restore (action yanked)) + ( do + atomicModifyIORef' ref (\cs -> (cs <> yanked, ())) + putMVar lock () + ) + putMVar lock () + where + action yanked = case nonblocking of + 1 -> writeNonblocking fd yanked + _ -> writeBlocking fd yanked writeNonblocking :: Fd -> Chunks -> IO () writeNonblocking !fd yanked = go off0 len0 + where -- TODO: Use writev so that we do not have to allocate -- memory to concatenate the chunks. This would need to -- be added to posix-api. - where + Bytes arr off0 len0 = Chunks.concat (Chunks.reverse yanked) go off len = do -- Remember, the file descriptor is known to be in non-blocking mode, @@ -231,9 +248,10 @@ writeBlocking :: Fd -> Chunks -> IO () writeBlocking !fd yanked = go off0 len0 + where -- Note: we concatenate the chunks into pinned memory. Pinned memory -- is required since we use the safe FFI. - where + Bytes arr off0 len0 = Chunks.concatPinned (Chunks.reverse yanked) go off len = do -- The file descriptor is known to be in blocking mode, @@ -247,27 +265,29 @@ else go (off + written) (len - written) die :: SomeException -> IO a -{-# inline die #-} +{-# INLINE die #-} die e = IO (Exts.raiseIO# e) flagsFailure :: SomeException -{-# noinline flagsFailure #-} -flagsFailure = toException - (userError "Logger: fcntl failed") +{-# NOINLINE flagsFailure #-} +flagsFailure = + toException + (userError "Logger: fcntl failed") statusWriteFailure :: SomeException -{-# noinline statusWriteFailure #-} -statusWriteFailure = toException - (userError "Logger: descriptor must have O_WRONLY or O_RDWR") +{-# NOINLINE statusWriteFailure #-} +statusWriteFailure = + toException + (userError "Logger: descriptor must have O_WRONLY or O_RDWR") flushFailure :: SomeException -{-# noinline flushFailure #-} +{-# NOINLINE flushFailure #-} flushFailure = toException (userError "Logger: flush encountered unknown error") flushBadFdFailure :: SomeException -{-# noinline flushBadFdFailure #-} +{-# NOINLINE flushBadFdFailure #-} flushBadFdFailure = toException (userError "Logger: EBADF while flushing") threadedRuntimeRequired :: SomeException -{-# noinline threadedRuntimeRequired #-} +{-# NOINLINE threadedRuntimeRequired #-} threadedRuntimeRequired = toException (userError "Logger: threaded runtime required")