[GHC] #12790: GHC 8.0.1 uses copious amounts of RAM and time when trying to compile lambdabot-haskell-plugins
GHC
ghc-devs at haskell.org
Wed Dec 7 02:30:46 UTC 2016
#12790: GHC 8.0.1 uses copious amounts of RAM and time when trying to compile
lambdabot-haskell-plugins
-------------------------------------+-------------------------------------
Reporter: clint | Owner:
Type: bug | Status: new
Priority: normal | Milestone:
Component: Compiler | Version: 8.0.1
Resolution: | Keywords:
Operating System: Unknown/Multiple | Architecture:
Type of failure: Compile-time | Unknown/Multiple
performance bug | Test Case:
Blocked By: | Blocking:
Related Tickets: | Differential Rev(s):
Wiki Page: |
-------------------------------------+-------------------------------------
Comment (by RyanGlScott):
Weirdly enough, I tried inlining the relevant `parsec` bits (which isn't
an easy task, by the way—there's a surprising amount of things you have to
bring in!). But after inlining them, I couldn't reproduce the issue
anymore!
If you don't believe me, here's a "reduced" example that you can try for
yourself:
{{{#!hs
-- Parsec.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Parsec (Parser, sepBy, try) where
import Control.Applicative (Alternative(empty, (<|>)))
import Control.Monad (MonadPlus(..), ap)
import Data.Functor.Identity (Identity)
------------------------
-- Copied from parsec --
------------------------
type Parser = Parsec String ()
type Parsec s u = ParsecT s u Identity
newtype ParsecT s u m a
= ParsecT {unParser :: forall b .
State s u
-> (a -> State s u -> ParseError -> m b) -- consumed ok
-> (ParseError -> m b) -- consumed err
-> (a -> State s u -> ParseError -> m b) -- empty ok
-> (ParseError -> m b) -- empty err
-> m b
}
data State s u = State {
stateInput :: s,
statePos :: !SourcePos,
stateUser :: !u
}
data Message = SysUnExpect !String -- @ library generated unexpect
| UnExpect !String -- @ unexpected something
| Expect !String -- @ expecting something
| Message !String -- @ raw message
data ParseError = ParseError !SourcePos [Message]
data SourcePos = SourcePos SourceName !Line !Column
deriving (Eq, Ord)
type SourceName = String
type Line = Int
type Column = Int
instance Functor (ParsecT s u m) where
fmap f p = parsecMap f p
parsecMap :: (a -> b) -> ParsecT s u m a -> ParsecT s u m b
parsecMap f p
= ParsecT $ \s cok cerr eok eerr ->
unParser p s (cok . f) cerr (eok . f) eerr
instance Applicative (ParsecT s u m) where
pure = return
(<*>) = ap -- TODO: Can this be optimized?
instance Alternative (ParsecT s u m) where
empty = mzero
(<|>) = mplus
instance Monad (ParsecT s u m) where
return x = parserReturn x
p >>= f = parserBind p f
fail msg = parserFail msg
parserReturn :: a -> ParsecT s u m a
parserReturn x
= ParsecT $ \s _ _ eok _ ->
eok x s (unknownError s)
parserBind :: ParsecT s u m a -> (a -> ParsecT s u m b) -> ParsecT s u m b
{-# INLINE parserBind #-}
parserBind m k
= ParsecT $ \s cok cerr eok eerr ->
let
-- consumed-okay case for m
mcok x s err =
let
-- if (k x) consumes, those go straigt up
pcok = cok
pcerr = cerr
-- if (k x) doesn't consume input, but is okay,
-- we still return in the consumed continuation
peok x s err' = cok x s (mergeError err err')
-- if (k x) doesn't consume input, but errors,
-- we return the error in the 'consumed-error'
-- continuation
peerr err' = cerr (mergeError err err')
in unParser (k x) s pcok pcerr peok peerr
-- empty-ok case for m
meok x s err =
let
-- in these cases, (k x) can return as empty
pcok = cok
peok x s err' = eok x s (mergeError err err')
pcerr = cerr
peerr err' = eerr (mergeError err err')
in unParser (k x) s pcok pcerr peok peerr
-- consumed-error case for m
mcerr = cerr
-- empty-error case for m
meerr = eerr
in unParser m s mcok mcerr meok meerr
parserFail :: String -> ParsecT s u m a
parserFail msg
= ParsecT $ \s _ _ _ eerr ->
eerr $ newErrorMessage (Message msg) (statePos s)
instance MonadPlus (ParsecT s u m) where
mzero = parserZero
mplus p1 p2 = parserPlus p1 p2
parserZero :: ParsecT s u m a
parserZero
= ParsecT $ \s _ _ _ eerr ->
eerr $ unknownError s
parserPlus :: ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
{-# INLINE parserPlus #-}
parserPlus m n
= ParsecT $ \s cok cerr eok eerr ->
let
meerr err =
let
neok y s' err' = eok y s' (mergeError err err')
neerr err' = eerr $ mergeError err err'
in unParser n s cok cerr neok neerr
in unParser m s cok cerr eok meerr
newErrorUnknown :: SourcePos -> ParseError
newErrorUnknown pos
= ParseError pos []
unknownError :: State s u -> ParseError
unknownError state = newErrorUnknown (statePos state)
newErrorMessage :: Message -> SourcePos -> ParseError
newErrorMessage msg pos
= ParseError pos [msg]
mergeError :: ParseError -> ParseError -> ParseError
mergeError e1@(ParseError pos1 msgs1) e2@(ParseError pos2 msgs2)
-- prefer meaningful errors
| null msgs2 && not (null msgs1) = e1
| null msgs1 && not (null msgs2) = e2
| otherwise
= case pos1 `compare` pos2 of
-- select the longest match
EQ -> ParseError pos1 (msgs1 ++ msgs2)
GT -> e1
LT -> e2
try :: ParsecT s u m a -> ParsecT s u m a
try p =
ParsecT $ \s cok _ eok eerr ->
unParser p s cok eerr eok eerr
class (Monad m) => Stream s m t | s -> t where
uncons :: s -> m (Maybe (t,s))
instance (Monad m) => Stream [tok] m tok where
uncons [] = return $ Nothing
uncons (t:ts) = return $ Just (t,ts)
{-# INLINE uncons #-}
-- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated
-- by @sep at . Returns a list of values returned by @p at .
--
-- > commaSep p = p `sepBy` (symbol ",")
sepBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT
s u m [a]
sepBy p sep = sepBy1 p sep <|> return []
-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated
-- by @sep at . Returns a list of values returned by @p at .
sepBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep ->
ParsecT s u m [a]
sepBy1 p sep = do{ x <- p
; xs <- many (sep >> p)
; return (x:xs)
}
many :: ParsecT s u m a -> ParsecT s u m [a]
many p
= do xs <- manyAccum (:) p
return (reverse xs)
manyAccum :: (a -> [a] -> [a])
-> ParsecT s u m a
-> ParsecT s u m [a]
manyAccum acc p =
ParsecT $ \s cok cerr eok eerr ->
let walk xs x s' err =
unParser p s'
(seq xs $ walk $ acc x xs) -- consumed-ok
cerr -- consumed-err
manyErr -- empty-ok
(\e -> cok (acc x xs) s' e) -- empty-err
in unParser p s (walk []) cerr manyErr (\e -> eok [] s e)
manyErr = error "Text.ParserCombinators.Parsec.Prim.many: combinator
'many' is applied to
a parser that accepts an empty string."
}}}
{{{#!hs
module Lambdabot.Plugin.Haskell.Pl.Parser (list) where
import Data.Foldable (asum)
import Parsec (Parser, sepBy, try)
data Expr
= Var Fixity String
| App Expr Expr
data Fixity = Pref | Inf
cons, nil :: Expr
cons = Var Inf ":"
nil = Var Pref "[]"
brackets :: Parser a -> Parser a
brackets = undefined
symbol :: String -> Parser String
symbol = undefined
list :: Parser Expr
list = asum (map (try . brackets) plist) where
plist = [
foldr (\e1 e2 -> cons `App` e1 `App` e2) nil `fmap`
(myParser False `sepBy` symbol ","),
do e <- myParser False
_ <- symbol ".."
return $ Var Pref "enumFrom" `App` e,
do e <- myParser False
_ <- symbol ","
e' <- myParser False
_ <- symbol ".."
return $ Var Pref "enumFromThen" `App` e `App` e',
do e <- myParser False
_ <- symbol ".."
e' <- myParser False
return $ Var Pref "enumFromTo" `App` e `App` e',
do e <- myParser False
_ <- symbol ","
e' <- myParser False
_ <- symbol ".."
e'' <- myParser False
return $ Var Pref "enumFromThenTo" `App` e `App` e' `App` e''
]
myParser :: Bool -> Parser Expr
myParser = undefined
}}}
--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/12790#comment:11>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler
More information about the ghc-tickets
mailing list