Re: [GHC] #12790: GHC 8.0.1 uses copious amounts of RAM and time when trying to compile lambdabot-haskell-plugins

6 Dec 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@. Returns a list of values returned by @p@.
 --
 -- >  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@. Returns a list of values returned by @p@.

 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