Undo attempt at speeding up FastLogger.

src/System/FastLogger.hs

@@ -14,87 +14,27 @@ module System.FastLogger
 import           Control.Concurrent
 import           Control.Exception
 import           Control.Monad
-import           Data.Binary.Put
-import           Data.Bits
 import           Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as S
 import qualified Data.ByteString.Lazy.Char8 as L
+import           Data.ByteString.Internal (c2w)
 import           Data.DList (DList)
 import qualified Data.DList as D
-import           Data.Function
 import           Data.Int
 import           Data.IORef
 import           Data.Maybe
-import           Data.Ord
-import qualified Data.Vector as V
-import           Data.Vector (Vector)
-import qualified Data.Vector.Algorithms.Merge as VA
-import           Data.Word
-import           Foreign.C.Types (CTime)
-import           GHC.Conc (numCapabilities)
+import           Data.Serialize.Put
 import           Prelude hiding (catch, show)
 import qualified Prelude
 import           System.IO
-import           Text.Show.ByteString
+import           Text.Show.ByteString hiding (runPut)
 
-------------------------------------------------------------------------------
-import           Data.Concurrent.HashMap (hashString, nextHighestPowerOf2)
 import           Snap.Internal.Http.Server.Date
 
 
-------------------------------------------------------------------------------
-defaultNumberOfLocks :: Word
-defaultNumberOfLocks = nextHighestPowerOf2 $ toEnum $ 4 * numCapabilities
-
-------------------------------------------------------------------------------
-hashToBucket :: Word -> Word
-hashToBucket x = x .&. (defaultNumberOfLocks-1)
-
-
-------------------------------------------------------------------------------
-type Queue = DList (CTime, ByteString)
-
-newtype MessageBuffer = MessageBuffer {
-      _queues :: Vector (MVar Queue)
-}
-
-------------------------------------------------------------------------------
-newMessageBuffer :: IO MessageBuffer
-newMessageBuffer = liftM MessageBuffer $
-                   V.replicateM (fromEnum defaultNumberOfLocks) (newMVar D.empty)
-
-
-getAllMessages :: MessageBuffer -> IO (Vector ByteString)
-getAllMessages (MessageBuffer queues) = do
-    vec  <- liftM (V.concat . V.toList) $ V.mapM grabQ queues
-    mvec <- V.unsafeThaw vec
-
-    -- sort the list so the messages are emitted in time order
-    VA.sortBy cmp mvec
-    dvec <- V.unsafeFreeze mvec
-    return $ V.map snd dvec
-
-  where
-    grabQ mv = modifyMVar mv $ \q -> return (D.empty, V.fromList $ D.toList q)
-    cmp      = compare `on` fst
-
-
-addMessageToQueue :: MVar Queue -> CTime -> ByteString -> IO ()
-addMessageToQueue mv tm s = modifyMVar_ mv $ \q -> return $ D.snoc q (tm,s)
-
-
-addMessage :: MessageBuffer -> CTime -> ByteString -> IO ()
-addMessage (MessageBuffer queues) tm !s = do
-    tid <- myThreadId
-    let hash = hashString $ Prelude.show tid
-    let bucket = hashToBucket hash
-    let mv = V.unsafeIndex queues $ fromEnum bucket
-    addMessageToQueue mv tm s
-
-
 -- | Holds the state for a logger.
 data Logger = Logger
-    { _queuedMessages :: !MessageBuffer
+    { _queuedMessages :: !(IORef (DList ByteString))
     , _dataWaiting    :: !(MVar ())
     , _loggerPath     :: !(FilePath)
     , _loggingThread  :: !(MVar ThreadId) }
@@ -106,25 +46,24 @@ data Logger = Logger
 -- re-opened every 15 minutes to facilitate external log rotation.
 newLogger :: FilePath -> IO Logger
 newLogger fp = do
-    mb <- newMessageBuffer
+    q  <- newIORef D.empty
     dw <- newEmptyMVar
     th <- newEmptyMVar
 
-    let lg = Logger mb dw fp th
+    let lg = Logger q dw fp th
 
     tid <- forkIO $ loggingThread lg
     putMVar th tid
 
     return lg
 
-
 -- | Prepares a log message with the time prepended.
 timestampedLogEntry :: ByteString -> IO ByteString
 timestampedLogEntry msg = do
     timeStr <- getLogDateString
 
-    return $! S.concat $! L.toChunks $! runPut $! do
-        putAscii '['
+    return $! runPut $! do
+        putWord8 $ c2w '['
         putByteString timeStr
         putByteString "] "
         putByteString msg
@@ -144,29 +83,35 @@ combinedLogEntry :: ByteString        -- ^ remote host
                  -> IO ByteString
 combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !userAgent = do
     let user = fromMaybe "-" mbUser
+    let numBytes = maybe "-" (\s -> strict $ show s) mbNumBytes
     let referer = maybe "-" (\s -> S.concat ["\"", s, "\""]) mbReferer
 
     timeStr <- getLogDateString
 
-    return $ S.concat $ L.toChunks $ runPut $ do
-        putByteString host
-        putByteString " - "
-        putByteString user
-        putByteString " ["
-        putByteString timeStr
-        putByteString "] \""
-        putByteString req
-        putByteString "\" "
-        showp status
-        putAscii ' '
-        maybe (putAscii '-')
-              (showp)
-              mbNumBytes
-        putAscii ' '
-        putByteString referer
-        putByteString " \""
-        putByteString userAgent
-        putAscii '\"'
+    let !p = [ host
+            , " - "
+            , user
+            , " ["
+            , timeStr
+            , "] \""
+            , req
+            , "\" "
+            , strict $ show status
+            , " "
+            , numBytes
+            , " "
+            , referer
+            , " \""
+            , userAgent
+            , "\"" ]
+
+    let !output = S.concat p
+
+    return $! output
+
+
+  where
+    strict = S.concat . L.toChunks
 
 
 -- | Sends out a log message verbatim with a newline appended. Note:
@@ -175,8 +120,7 @@ combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !userAgent =
 logMsg :: Logger -> ByteString -> IO ()
 logMsg !lg !s = do
     let !s' = S.snoc s '\n'
-    tm <- getCurrentDateTime
-    addMessage (_queuedMessages lg) tm s'
+    atomicModifyIORef (_queuedMessages lg) $ \d -> (D.snoc d s',())
     tryPutMVar (_dataWaiting lg) () >> return ()
 
 
@@ -185,22 +129,16 @@ loggingThread (Logger queue notifier filePath _) = do
     initialize >>= go
 
   where
-    --------------------------------------------------------------------------
     openIt = if filePath == "-"
                then return stdout
                else if filePath == "stderr"
                       then return stderr
-                      else do
-                          h <- openFile filePath AppendMode
-                          hSetBuffering h $ BlockBuffering $ Just 32768
-                          return h
+                      else openFile filePath AppendMode
 
-    --------------------------------------------------------------------------
     closeIt h = if filePath == "-" || filePath == "stderr"
                   then return ()
                   else hClose h
 
-    --------------------------------------------------------------------------
     go (href, lastOpened) =
         (loop (href, lastOpened))
           `catches`
@@ -210,27 +148,28 @@ loggingThread (Logger queue notifier filePath _) = do
                 threadDelay 20000000
                 go (href, lastOpened) ]
 
-    --------------------------------------------------------------------------
+
     initialize = do
         lh   <- openIt
         href <- newIORef lh
         t    <- getCurrentDateTime
         tref <- newIORef t
         return (href, tref)
 
-    --------------------------------------------------------------------------
+
     killit (href, lastOpened) = do
         flushIt (href, lastOpened)
         h <- readIORef href
         closeIt h
 
-    --------------------------------------------------------------------------
+
     flushIt (!href, !lastOpened) = do
-        msgs <- getAllMessages queue
+        dl <- atomicModifyIORef queue $ \x -> (D.empty,x)
 
-        -- flush all messages out to buffer
+        let !msgs = D.toList dl
+        let !s = L.fromChunks msgs
         h <- readIORef href
-        V.mapM_ (S.hPut h) msgs
+        L.hPut h s
         hFlush h
 
         -- close the file every 15 minutes (for log rotation)