Haskell, Parsec 2 и тормоза

[thedeemon]

Помня о том, какое бурление вызвало сравнение скорости Лиспа с другими языками в прошлом номере ПФП, прошу помощи зала не допустить несправедливости. Я сейчас доделываю сравнение скорости разных методов парсинга, сделал вариант на Хаскеле на базе Parsec2, и получившаяся скорость мне совсем не нравится. До этого на Хаскеле не писал, поэтому наверняка мог сильно налажать. Исходник (~70 строк) выложил здесь.
Суть программы - чтение карты формата OpenStreetMap и вычисление ее реальных границ - минимальных и максимальных значений широты и долготы встреченных точек. Собирал ее с GHC 6.8.3 и 6.10.1, Parsec 2.1.0.1, команда для сборки:

ghc -O2 -package parsec bounds.hs -o bounds

Сейчас скорость получается около 3 МБ/с.
Пример простой карты тут. Скорость тестировал на карте Сингапура (архив 1.2 МБ).

Прошу более опытных товарищей глянуть на исходник и указать на явные косяки. Можно ли заметно ускорить программу без сильных изменений описанной там грамматики?

Comments

[thesz.livejournal.com]

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as Token
import Text.ParserCombinators.Parsec.Language (emptyDef)
import System.CPUTime
import System.Environment 

data Bounds = Bounds { minlat, maxlat, minlon, maxlon :: !Double } deriving (Show)

update_lat lat bnd = bnd { 
    minlat = min lat (minlat bnd),  maxlat = max lat (maxlat bnd) }

update_lon lon bnd = bnd { 
    minlon = min lon (minlon bnd), maxlon = max lon (maxlon bnd) }

lexer = Token.makeTokenParser emptyDef
p_positive_float = Token.float lexer
p_float =  ((char '-' >> return negate) <|> (return id)) >>= \f -> p_positive_float >>= (return . f)

latlon = do
  param <- do
     name <- many1 letter
     char '='
     char '"'
     return name
  case param of
    "lat" -> p_float >>= (updateState . update_lat)
    "lon" -> p_float >>= (updateState . update_lon)
    _ -> (many $ noneOf "\"") >> return ()
  char '"'
  return ()

p_param = do
  many1 letter
  string "=\""
  many $ noneOf "\""
  char '"'
  return ()
  
p_node_param = latlon
  
p_endnode = 
  try (string "/>") <|> manyTill anyChar (try (string ""))
  
p_ws = many $ oneOf " \t\n"
  
p_node = do
  string "

[Error: Irreparable invalid markup ('<node">') in entry. Owner must fix manually. Raw contents below.]

<pre
>import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as Token
import Text.ParserCombinators.Parsec.Language (emptyDef)
import System.CPUTime
import System.Environment

data Bounds = Bounds { minlat, maxlat, minlon, maxlon :: !Double } deriving (Show)

update_lat lat bnd = bnd {
minlat = min lat (minlat bnd), maxlat = max lat (maxlat bnd) }

update_lon lon bnd = bnd {
minlon = min lon (minlon bnd), maxlon = max lon (maxlon bnd) }

lexer = Token.makeTokenParser emptyDef
p_positive_float = Token.float lexer
p_float = ((char '-' >> return negate) <|> (return id)) >>= \f -> p_positive_float >>= (return . f)

latlon = do
param <- do
name <- many1 letter
char '='
char '"'
return name
case param of
"lat" -> p_float >>= (updateState . update_lat)
"lon" -> p_float >>= (updateState . update_lon)
_ -> (many $ noneOf "\"") >> return ()
char '"'
return ()

p_param = do
many1 letter
string "=\""
many $ noneOf "\""
char '"'
return ()

p_node_param = latlon

p_endnode =
try (string "/>") <|> manyTill anyChar (try (string "</node>"))

p_ws = many $ oneOf " \t\n"

p_node = do
string "<node"
many (p_ws >> p_node_param)
p_endnode

p_tag = between (char '<') (char '>') (many (noneOf ">"))

p_osm = do
many $ (try p_node <|> p_tag) >> p_ws
bnd <- getState
return $ show bnd

bnd0 = Bounds 1000.0 (-1000.0) 1000.0 (-1000.0)

parse_osm_file fname = do
input <- readFile fname
case runParser p_osm bnd0 fname input of
Right str -> putStrLn str
Left err -> do
putStr "parse error at "
print err

main = do
args <- getArgs
case args of
[] -> putStrLn "usage: bounds osmfile"
fname:_ -> do
t0 <- getCPUTime
parse_osm_file fname
t1 <- getCPUTime
putStrLn $ show $ 1.0e-12 * (fromInteger $ t1 - t0)
</pre
>Вот такой вариант.

ghc -O3 -o bounds --make -fvia-C -funbox-strict-fields -optc-ffast-math -optc-O3 -optc-mfpmath=sse b.hs

ghc 6.10.1

+10..15% к скорости. Правда, ругается, что SSE отключен.

Есть у меня подозрение, что дело в работе с плавающей точкой, а не в самом разборщике.

[thedeemon.livejournal.com]

Спасибо!

[thesz.livejournal.com]

Но я ещё посмотрю, что можно сделать.