优化一个Haskell XML解析器

Question

优化一个Haskell XML解析器

7

我目前正在尝试使用Haskell，非常喜欢这种体验，但是我要在一个有一些严格性能要求的真实项目中评估它。我的第一个任务是处理完整的维基百科转储（bzipped），总计约6GB压缩。在Python中，一个脚本来提取每个原始页面（总共约1000万个）需要大约30分钟（参考Scala实现使用pull解析器需要约40分钟）。我一直在尝试使用Haskell和ghc复制此性能，并一直努力匹配它。

我一直在使用Codec.Compression.BZip进行解压缩，使用hexpat进行解析。我使用惰性bytestrings作为hexpat的输入，使用严格bytestrings作为元素文本类型。为了提取每个页面的文本，我正在建立指向文本元素的Dlist，然后迭代此列表将其转储到stdout。我刚刚描述的代码已经通过多次分析/重构迭代（我很快从字符串移动到了bytestrings，然后从字符串连接移动到了指向文本的列表 - 然后是指向文本的dlists）。我认为我已经从原始代码中获得了约2个数量级的加速，但它仍需要超过一个半小时才能解析（虽然它具有可爱的小内存占用）。因此，我正在寻找社区的一些启示，以帮助我更进一步。代码如下（我将其分解为多个子函数，以便从分析器中获取更多详细信息）。请原谅我的Haskell-我只编码了几天（曾经用Real World Haskell花了一周时间）。提前感谢您！

import System.Exit
import Data.Maybe
import Data.List
import Data.DList (DList)
import qualified Data.DList as DList

import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Codec.Compression.BZip as BZip

import Text.XML.Expat.Proc
import Text.XML.Expat.Tree
import Text.XML.Expat.Format

testFile = "../data/enwiki-latest-pages-articles.xml.bz2"

validPage pageData = case pageData of
    (Just _, Just _) -> True
    (_, _) -> False

scanChildren :: [UNode ByteString] -> DList ByteString
scanChildren c = case c of
    h:t -> DList.append (getContent h) (scanChildren t)
    []  -> DList.fromList []

getContent :: UNode ByteString -> DList ByteString
getContent treeElement =
    case treeElement of
        (Element name attributes children)  -> scanChildren children
        (Text text)                         -> DList.fromList [text]

rawData t = ((getContent.fromJust.fst) t, (getContent.fromJust.snd) t)

extractText page = do
    revision <- findChild (BS.pack "revision") page
    text <- findChild (BS.pack "text") revision
    return text

pageDetails tree =
    let pageNodes = filterChildren relevantChildren tree in
    let getPageData page = (findChild (BS.pack "title") page, extractText page) in
    map rawData $ filter validPage $ map getPageData pageNodes
    where
        relevantChildren node = case node of
            (Element name attributes children) -> name == (BS.pack "page")
            (Text _) -> False

outputPages pagesText = do
    let flattenedPages = map DList.toList pagesText
    mapM_ (mapM_ BS.putStr) flattenedPages

readCompressed fileName = fmap BZip.decompress (LazyByteString.readFile fileName)
parseXml byteStream = parse defaultParseOptions byteStream :: (UNode ByteString, Maybe XMLParseError)

main = do
    rawContent <- readCompressed testFile
    let (tree, mErr) = parseXml rawContent
    let pages = pageDetails tree
    let pagesText = map snd pages
    outputPages pagesText
    putStrLn "Complete!"
    exitWith ExitSuccess

- Alex Wilson

1

你是否在编译程序时使用了优化等功能？你说你正在使用 ghci 这对性能来说是不好的。 - Tener

另外，我可以在哪里找到你的数据源？ - Tener

糟糕，我的错，我不小心打了一个i。我正在使用通过cabal --install编译的ghc，文档中说会将-O1传递给ghc。数据从这里下载：http://download.wikimedia.org/enwiki/latest/enwiki-latest-pages-articles.xml.bz2。谢谢。Alex - Alex Wilson

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Tener · Accepted Answer

运行程序后，我得到了一些奇怪的结果：

./wikiparse +RTS -s -A5m -H5m | tail ./wikiparse +RTS -s -A5m -H5m 堆中分配了3,604,204,828,592字节在GC期间复制了70,746,561,168字节最大常驻内存为39,505,112字节（37822个样本）最大松弛度为2,564,716字节总共使用了83 MB内存（由于碎片化而丢失了0 MB）

第0代：620343次收集，0个并行，15.84秒，368.69秒经过第1代：37822次收集，0个并行，1.08秒，33.08秒经过

初始化时间0.00秒（0.00秒经过） MUT时间243.85秒（4003.81秒经过） GC时间16.92秒（401.77秒经过）退出时间0.00秒（0.00秒经过）总时间260.77秒（4405.58秒经过）

%GC时间6.5％（9.1％经过）

分配速率为每MUT秒14,780,341,336字节

生产率为总用户的93.5％，总用时的5.5％

总时间超过我的预期：260秒比Python的30分钟要快得多。但是我真的不知道为什么整体时间这么长。我真的不认为读取6GB的文件需要超过一个小时才能完成。

我正在重新运行您的程序以检查结果是否一致。

如果4'20''的结果是正确的，那么我认为机器出了问题...或者这里有一些其他奇怪的影响。

该代码在GHC 7.0.2上编译。

编辑：我尝试了上述程序的各种版本。最重要的优化似乎是{-# INLINE #-} pragma和函数的特化。有些具有非常通用的类型，这已知对性能不利。另一方面，我相信内联应该足以触发特化，因此您应该进一步尝试进行实验。

我没有看到我尝试的GHC版本（6.12..HEAD）之间有任何显着差异。

Haskell绑定到bzlib似乎具有最佳性能。以下程序是标准程序的近乎完整的重新实现，速度与原始程序相同甚至更快。

module Main where

import qualified Data.ByteString.Lazy as BSL
import qualified Codec.Compression.BZip as BZip
import System.Environment (getArgs)

readCompressed fileName = fmap (BZip.decompress) (BSL.readFile fileName)

main :: IO ()
main = do
    files <- getArgs
    mapM_ (\f -> readCompressed f >>= BSL.putStr) files

在我的机器上，将测试文件解压到/dev/null大约需要1100秒。我能够得到的最快版本是基于SAX风格解析器的。但我不确定输出是否与原始文件匹配。在小输出上，结果是相同的，性能也相同。在原始文件上，SAX版本要稍快一些，完成时间为大约2400秒。您可以在下面找到它。

{-# LANGUAGE OverloadedStrings #-}

import System.Exit
import Data.Maybe

import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Codec.Compression.BZip as BZip

import System.IO

import Text.XML.Expat.SAX as SAX

type ByteStringL = BSL.ByteString
type Token = ByteString
type TokenParser = [SAXEvent Token Token] -> [[Token]]

testFile = "/tmp/enwiki-latest-pages-articles.xml.bz2"


readCompressed :: FilePath -> IO ByteStringL
readCompressed fileName = fmap (BZip.decompress) (BSL.readFile fileName)

{-# INLINE pageStart #-}
pageStart :: TokenParser
pageStart ((StartElement "page" _):xs) = titleStart xs
pageStart (_:xs) = pageStart xs
pageStart [] = []

{-# INLINE titleStart #-}
titleStart :: TokenParser
titleStart ((StartElement "title" _):xs) = finish "title" revisionStart xs
titleStart ((EndElement "page"):xs) = pageStart xs
titleStart (_:xs) = titleStart xs
titleStart [] = error "could not find <title>"


{-# INLINE revisionStart #-}
revisionStart :: TokenParser
revisionStart ((StartElement "revision" _):xs) = textStart xs
revisionStart ((EndElement "page"):xs) = pageStart xs
revisionStart (_:xs) = revisionStart xs
revisionStart [] = error "could not find <revision>"

{-# INLINE textStart #-}
textStart :: TokenParser
textStart ((StartElement "text" _):xs) = textNode [] xs
textStart ((EndElement "page"):xs) = pageStart xs
textStart (_:xs) = textStart xs
textStart [] = error "could not find <text>"

{-# INLINE textNode #-}
textNode :: [Token] -> TokenParser
textNode acc ((CharacterData txt):xs) = textNode (txt:acc) xs
textNode acc xs = (reverse acc) : textEnd xs

{-# INLINE textEnd #-}
textEnd {- , revisionEnd, pageEnd -} :: TokenParser
textEnd = finish "text" . finish "revision" . finish "page" $ pageStart
--revisionEnd = finish "revision" pageEnd
--pageEnd = finish "page" pageStart

{-# INLINE finish #-}
finish :: Token -> TokenParser -> TokenParser
finish tag cont ((EndElement el):xs) | el == tag = cont xs
finish tag cont (_:xs) = finish tag cont xs
finish tag _ [] = error (show (tag,("finish []" :: String)))

main :: IO ()
main = do
  rawContent <- readCompressed testFile
  let parsed = (pageStart (SAX.parse defaultParseOptions rawContent))
  mapM_ (mapM_ BS.putStr) ({- take 5000 -} parsed) -- remove comment to finish early
  putStrLn "Complete!"

一般来说，我怀疑Python和Scala的版本会提前完成。但是如果没有源代码，我无法验证这个说法。

总之，内联和特化应该能够合理地提高性能，大约可以增加两倍。