Optimization

[Lucu.git] / Network / HTTP / Lucu / ResponseWriter.hs

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 7891db1d4216230374dd767c3adde35155f28f35..a676e1549cfee2d17916140b5178b4ffcb9dcd1c 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -1,4 +1,3 @@
--- #hide
 module Network.HTTP.Lucu.ResponseWriter
     ( responseWriter
     )
@@ -13,6 +12,7 @@ import qualified Data.Sequence as S
 import           Data.Sequence (ViewR(..))
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Format
+import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Postprocess
@@ -33,7 +33,8 @@ responseWriter cnf h tQueue readerTID
     where
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
-          = do action
+          = {-# SCC "awaitSomethingToWrite" #-}
+            do action
                    <- atomically $!
                       do -- キューが空でなくなるまで待つ
                          queue <- readTVar tQueue
@@ -57,7 +58,8 @@ responseWriter cnf h tQueue readerTID
 
       writeContinueIfNecessary :: Interaction -> STM (IO ())
       writeContinueIfNecessary itr
-          = itr `seq`
+          = {-# SCC "writeContinueIfNecessary" #-}
+            itr `seq`
             do expectedContinue <- readItr itr itrExpectedContinue id
                if expectedContinue then
                    do wroteContinue <- readItr itr itrWroteContinue id
@@ -79,11 +81,12 @@ responseWriter cnf h tQueue readerTID
           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
           -- 空でなければ、それを出力する。空である時は、もし状態が
           -- Done であれば後処理をする。
-          = itr `seq`
+          = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
+            itr `seq`
             do wroteHeader <- readItr itr itrWroteHeader id
                
                if not wroteHeader then
-                   return $ writeHeader itr
+                   return $! writeHeader itr
                  else
                    do bodyToSend <- readItr itr itrBodyToSend id
 
@@ -99,11 +102,12 @@ responseWriter cnf h tQueue readerTID
 
       writeContinue :: Interaction -> IO ()
       writeContinue itr
-          = itr `seq`
+          = {-# SCC "writeContinue" #-}
+            itr `seq`
             do let cont = Response {
                             resVersion = HttpVersion 1 1
                           , resStatus  = Continue
-                          , resHeaders = []
+                          , resHeaders = emptyHeaders
                           }
                cont' <- completeUnconditionalHeaders cnf cont
                hPutResponse h cont'
@@ -113,7 +117,8 @@ responseWriter cnf h tQueue readerTID
 
       writeHeader :: Interaction -> IO ()
       writeHeader itr
-          = itr `seq`
+          = {-# SCC "writeHeader" #-}
+            itr `seq`
             do res <- atomically $! do writeItr itr itrWroteHeader True
                                        readItr itr itrResponse id
                hPutResponse h res
@@ -122,7 +127,8 @@ responseWriter cnf h tQueue readerTID
       
       writeBodyChunk :: Interaction -> IO ()
       writeBodyChunk itr
-          = itr `seq`
+          = {-# SCC "writeBodyChunk" #-}
+            itr `seq`
             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
@@ -141,7 +147,8 @@ responseWriter cnf h tQueue readerTID
 
       finishBodyChunk :: Interaction -> IO ()
       finishBodyChunk itr
-          = itr `seq`
+          = {-# SCC "finishBodyChunk" #-}
+            itr `seq`
             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                when (not willDiscardBody && willChunkBody)
@@ -149,7 +156,8 @@ responseWriter cnf h tQueue readerTID
 
       finalize :: Interaction -> IO ()
       finalize itr
-          = itr `seq`
+          = {-# SCC "finalize" #-}
+            itr `seq`
             do finishBodyChunk itr
                willClose <- atomically $!
                             do queue <- readTVar tQueue