From: pho Date: Wed, 5 Sep 2007 17:59:32 +0000 (+0900) Subject: Slight speed improvement X-Git-Tag: RELEASE-0_2_1~36 X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=47206637d664f163316dc9bb20983440ae4b138f;p=Lucu.git Slight speed improvement darcs-hash:20070905175932-62b54-c94ecd66ffaa692a3e41bb6ad8e4e1a9d06f8684.gz --- diff --git a/Lucu.cabal b/Lucu.cabal index 8429cfa..93381ab 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -54,7 +54,8 @@ Extra-Source-Files: examples/Makefile ghc-options: -fglasgow-exts -fwarn-missing-signatures -fwarn-unused-imports -funbox-strict-fields -O3 + --Executable: HelloWorld --Main-Is: HelloWorld.hs --Hs-Source-Dirs: ., examples ---ghc-options: -threaded -fglasgow-exts -O3 +--ghc-options: -fglasgow-exts -O3 -prof -auto-all diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index e1ed0f3..bd904e8 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -32,7 +32,11 @@ httpVersionP = do string "HTTP/" major <- many1 digit char '.' minor <- many1 digit - return $ HttpVersion (read major) (read minor) + return $ HttpVersion (read' major) (read' minor) + where + read' "1" = 1 -- この二つが + read' "0" = 0 -- 壓倒的に頻出する + read' s = read s hPutHttpVersion :: Handle -> HttpVersion -> IO () diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 174a289..80d7707 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -20,6 +20,8 @@ module Network.HTTP.Lucu.Parser ( Parser , ParserResult(..) + , failP + , parse , parseStr @@ -36,8 +38,6 @@ module Network.HTTP.Lucu.Parser , notFollowedBy , many , many1 - , manyTill - , many1Till , count , option , sepBy @@ -82,6 +82,10 @@ instance Monad Parser where return x = x `seq` Parser $! return $! Success x fail _ = Parser $! return $! IllegalInput +-- |@'failP'@ is just a synonym for @'Prelude.fail Prelude.undefined'@. +failP :: Parser a +failP = fail undefined + -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result, -- remaining)@. parse :: Parser a -> ByteString -> (ParserResult a, ByteString) @@ -104,9 +108,8 @@ anyChar = Parser $! if B.null input then return ReachedEOF else - do let c = B.head input - put (B.tail input, isEOFFatal) - return (Success c) + do put (B.tail input, isEOFFatal) + return (Success $! B.head input) eof :: Parser () @@ -134,8 +137,10 @@ allowEOF f = f `seq` satisfy :: (Char -> Bool) -> Parser Char satisfy f = f `seq` do c <- anyChar - unless (f c) (fail "") - return c + if f c then + return c + else + failP char :: Char -> Parser Char @@ -169,12 +174,12 @@ f <|> g oneOf :: [Char] -> Parser Char -oneOf = foldl (<|>) (fail "") . map char +oneOf = foldl (<|>) failP . map char notFollowedBy :: Parser a -> Parser () notFollowedBy p = p `seq` - p >>= fail "" <|> return () + (p >> failP) <|> return () digit :: Parser Char @@ -182,7 +187,7 @@ digit = do c <- anyChar if c >= '0' && c <= '9' then return c else - fail "" + failP hexDigit :: Parser Char @@ -192,7 +197,7 @@ hexDigit = do c <- anyChar (c >= 'A' && c <= 'F') then return c else - fail "" + failP many :: Parser a -> Parser [a] @@ -206,26 +211,9 @@ many p = p `seq` many1 :: Parser a -> Parser [a] many1 p = p `seq` - do ret <- many p - case ret of - [] -> fail "" - xs -> return xs - - -manyTill :: Parser a -> Parser end -> Parser [a] -manyTill p end - = p `seq` end `seq` - many $! do x <- p - end - return x - - -many1Till :: Parser a -> Parser end -> Parser [a] -many1Till p end - = p `seq` end `seq` - many1 $! do x <- p - end - return x + do x <- p + xs <- many p + return (x:xs) count :: Int -> Parser a -> Parser [a] diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs index 9962c16..580691b 100644 --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -70,12 +70,12 @@ parseHTTPDateTime src httpDateTime :: Parser ClockTime -httpDateTime = do foldl (<|>) (fail "") (map string week) +httpDateTime = do foldl (<|>) failP (map string week) char ',' char ' ' day <- liftM read (count 2 digit) char ' ' - mon <- foldl (<|>) (fail "") (map tryEqToFst (zip month [1..])) + mon <- foldl (<|>) failP (map tryEqToFst (zip month [1..])) char ' ' year <- liftM read (count 4 digit) char ' ' diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index b316730..3fc0164 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -76,7 +76,7 @@ methodP = (let methods = [ ("OPTIONS", OPTIONS) , ("TRACE" , TRACE ) , ("CONNECT", CONNECT) ] - in foldl (<|>) (fail "") $ map (\ (str, mth) + in foldl (<|>) failP $ map (\ (str, mth) -> string str >> return mth) methods) <|> token >>= return . ExtensionMethod @@ -85,5 +85,5 @@ methodP = (let methods = [ ("OPTIONS", OPTIONS) uriP :: Parser URI uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' ')) case parseURIReference str of - Nothing -> fail "" + Nothing -> failP Just uri -> return uri \ No newline at end of file diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index d1505e8..091a3a2 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -41,7 +41,8 @@ requestReader cnf tree h addr tQueue acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 - = do atomically $ do queue <- readTVar tQueue + = {-# SCC "acceptRequest" #-} + do atomically $ do queue <- readTVar tQueue when (S.length queue >= cnfMaxPipelineDepth cnf) retry @@ -55,7 +56,8 @@ requestReader cnf tree h addr tQueue acceptNonparsableRequest :: StatusCode -> IO () acceptNonparsableRequest status - = do itr <- newInteraction cnf addr Nothing + = {-# SCC "acceptNonparsableRequest" #-} + do itr <- newInteraction cnf addr Nothing atomically $ do updateItr itr itrResponse $ \ res -> res { resStatus = status @@ -68,7 +70,8 @@ requestReader cnf tree h addr tQueue acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req input - = do itr <- newInteraction cnf addr (Just req) + = {-# SCC "acceptParsableRequest" #-} + do itr <- newInteraction cnf addr (Just req) action <- atomically $ do preprocess itr @@ -86,7 +89,8 @@ requestReader cnf tree h addr tQueue acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) acceptSemanticallyInvalidRequest itr input - = do writeItr itr itrState Done + = {-# SCC "acceptSemanticallyInvalidRequest" #-} + do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr @@ -94,7 +98,8 @@ requestReader cnf tree h addr tQueue acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) acceptRequestForNonexistentResource itr input - = do updateItr itr itrResponse + = {-# SCC "acceptRequestForNonexistentResource" #-} + do updateItr itr itrResponse $ \res -> res { resStatus = NotFound } @@ -106,7 +111,8 @@ requestReader cnf tree h addr tQueue acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ()) acceptRequestForExistentResource oldItr input rsrcPath rsrcDef - = do let itr = oldItr { itrResourcePath = Just rsrcPath } + = {-# SCC "acceptRequestForExistentResource" #-} + do let itr = oldItr { itrResourcePath = Just rsrcPath } requestHasBody <- readItr itr itrRequestHasBody id enqueue itr return $ do runResource rsrcDef itr @@ -117,7 +123,8 @@ requestReader cnf tree h addr tQueue observeRequest :: Interaction -> ByteString -> IO () observeRequest itr input - = do isChunked <- atomically $ readItr itr itrRequestIsChunked id + = {-# SCC "observeRequest" #-} + do isChunked <- atomically $ readItr itr itrRequestIsChunked id if isChunked then observeChunkedRequest itr input else @@ -125,7 +132,8 @@ requestReader cnf tree h addr tQueue observeChunkedRequest :: Interaction -> ByteString -> IO () observeChunkedRequest itr input - = do action + = {-# SCC "observeChunkedRequest" #-} + do action <- atomically $ do isOver <- readItr itr itrReqChunkIsOver id if isOver then @@ -195,7 +203,8 @@ requestReader cnf tree h addr tQueue seekNextChunk :: Interaction -> ByteString -> STM (IO ()) seekNextChunk itr input - = case parse chunkHeaderP input of + = {-# SCC "seekNextChunk" #-} + case parse chunkHeaderP input of -- 最終チャンク (中身が空) (Success 0, input') -> case parse chunkTrailerP input' of @@ -217,7 +226,8 @@ requestReader cnf tree h addr tQueue chunkWasMalformed :: Interaction -> IO () chunkWasMalformed itr - = atomically $ do updateItr itr itrResponse + = {-# SCC "chunkWasMalformed" #-} + atomically $ do updateItr itr itrResponse $ \ res -> res { resStatus = BadRequest } @@ -228,7 +238,8 @@ requestReader cnf tree h addr tQueue observeNonChunkedRequest :: Interaction -> ByteString -> IO () observeNonChunkedRequest itr input - = do action + = {-# SCC "observeNonChunkedRequest" #-} + do action <- atomically $ do wantedM <- readItr itr itrReqBodyWanted id if wantedM == Nothing then @@ -273,5 +284,6 @@ requestReader cnf tree h addr tQueue action enqueue :: Interaction -> STM () - enqueue itr = do queue <- readTVar tQueue + enqueue itr = {-# SCC "enqueue" #-} + do queue <- readTVar tQueue writeTVar tQueue (itr <| queue) \ No newline at end of file diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index a3a6af1..be9f370 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -32,7 +32,8 @@ responseWriter cnf h tQueue readerTID where awaitSomethingToWrite :: IO () awaitSomethingToWrite - = do action + = {-# SCC "awaitSomethingToWrite" #-} + do action <- atomically $! do -- キューが空でなくなるまで待つ queue <- readTVar tQueue @@ -56,7 +57,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 @@ -78,11 +80,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 @@ -98,7 +101,8 @@ 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 @@ -112,7 +116,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 @@ -121,7 +126,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 @@ -140,7 +146,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) @@ -148,7 +155,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