Improve haddock memory usage

5 files changed, 69 insertions, 51 deletions

diff --git a/haddock.cabal b/haddock.cabal
index 5c950f98..116ee00c 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -88,6 +88,7 @@ executable haddock
     directory,
     pretty,
     containers,
+    deepseq,
     array,
     xhtml >= 3000.2 && < 3000.3,
     Cabal >= 1.10,
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 64995a5f..32f287f5 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections, BangPatterns #-}
+{-# OPTIONS_GHC -Wwarn #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.Create
@@ -27,6 +28,7 @@ import Data.Maybe
 import Data.Monoid
 import Data.Ord
 import Control.Applicative
+import Control.DeepSeq
 import Control.Monad
 import qualified Data.Traversable as T
 
@@ -48,13 +50,13 @@ import FastString (unpackFS)
 createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
 createInterface tm flags modMap instIfaceMap = do
 
-  let ms            = pm_mod_summary . tm_parsed_module $ tm
-      mi            = moduleInfo tm
-      safety        = modInfoSafe mi
-      mdl           = ms_mod ms
-      dflags        = ms_hspp_opts ms
-      instances     = modInfoInstances mi
-      exportedNames = modInfoExports mi
+  let ms             = pm_mod_summary . tm_parsed_module $ tm
+      mi             = moduleInfo tm
+      !safety        = modInfoSafe mi
+      mdl            = ms_mod ms
+      dflags         = ms_hspp_opts ms
+      !instances     = modInfoInstances mi
+      !exportedNames = modInfoExports mi
 
       (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm
 
@@ -72,13 +74,13 @@ createInterface tm flags modMap instIfaceMap = do
         | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
         | otherwise = opts0
 
-  (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
+  (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
 
   let declsWithDocs = topDecls group_
       (decls, _) = unzip declsWithDocs
       localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
 
-  maps@(docMap, argMap, subMap, declMap) <-
+  maps@(!docMap, !argMap, !subMap, !declMap) <-
     liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
 
   let exports0 = fmap (reverse . map unLoc) mayExports
@@ -92,24 +94,25 @@ createInterface tm flags modMap instIfaceMap = do
   exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
                    instances instIfaceMap dflags
 
-  let visibleNames = mkVisibleNames exportItems opts
+  let !visibleNames = mkVisibleNames exportItems opts
 
   -- Measure haddock documentation coverage.
   let prunedExportItems0 = pruneExportItems exportItems
-      haddockable = 1 + length exportItems -- module + exports
-      haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
-      coverage = (haddockable, haddocked)
+      !haddockable = 1 + length exportItems -- module + exports
+      !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+      !coverage = (haddockable, haddocked)
 
   -- Prune the export list to just those declarations that have
   -- documentation, if the 'prune' option is on.
-  let prunedExportItems
+  let prunedExportItems'
         | OptPrune `elem` opts = prunedExportItems0
         | otherwise = exportItems
+      !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
 
-  let aliases =
+  let !aliases =
         mkAliasMap dflags $ tm_renamed_source tm
 
-  return Interface {
+  return $! Interface {
     ifaceMod             = mdl,
     ifaceOrigFilename    = msHsFilePath ms,
     ifaceInfo            = info,
@@ -179,7 +182,7 @@ moduleWarning ws =
   case ws of
     NoWarnings -> Nothing
     WarnSome _ -> Nothing
-    WarnAll w  -> Just (warnToDoc w)
+    WarnAll w  -> Just $! warnToDoc w
 
 
 warnToDoc :: WarningTxt -> Doc id
@@ -187,7 +190,8 @@ warnToDoc w = case w of
   (DeprecatedTxt msg) -> format "Deprecated: " msg
   (WarningTxt    msg) -> format "Warning: "    msg
   where
-    format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs
+    format x xs = let !str = force $ concat (x : map unpackFS xs)
+                  in DocWarning $ DocParagraph $ DocString str
 
 
 -------------------------------------------------------------------------------
@@ -254,7 +258,12 @@ mkMaps dflags gre instances decls = do
           am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
           sm = [ (n, subNs) | n <- ns ]
           cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
-      return (dm, am, sm, cm)
+      seqList ns `seq`
+          seqList subNs `seq`
+          doc `seq`
+          seqList subDocs `seq`
+          seqList subArgs `seq`
+          return (dm, am, sm, cm)
 
     instanceMap :: Map SrcSpan Name
     instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
@@ -774,7 +783,8 @@ pruneExportItems = filter hasDoc
 mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]
 mkVisibleNames exports opts
   | OptHide `elem` opts = []
-  | otherwise = concatMap exportName exports
+  | otherwise = let ns = concatMap exportName exports
+                in seqList ns `seq` ns
   where
     exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs
       where subs = map fst (expItemSubDocs e)
@@ -782,6 +792,9 @@ mkVisibleNames exports opts
                                     -- we don't want links to go to them.
     exportName _ = []
 
+seqList :: [a] -> ()
+seqList [] = ()
+seqList (x : xs) = x `seq` seqList xs
 
 -- | Find a stand-alone documentation comment by its name.
 findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index a5eb1143..3ad9719e 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE BangPatterns #-}
   -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.LexParseRn
@@ -78,7 +80,8 @@ processModuleHeader dflags gre safety mayStr = do
             tell ["haddock module header parse failed: " ++ msg]
             return failure
           Right (hmi, doc) -> do
-            let hmi' = hmi { hmi_description = rename dflags gre <$> hmi_description hmi }
+            let !descr = rename dflags gre <$> hmi_description hmi
+                hmi' = hmi { hmi_description = descr }
                 doc' = rename dflags gre doc
             return (hmi', Just doc')
   return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc)
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 411b6661..18f4c768 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wwarn #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.ParseModuleHeader
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index e1e7ce4b..fbd05fae 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -59,10 +59,10 @@ type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 data Interface = Interface
   {
     -- | The module behind this interface.
-    ifaceMod             :: Module
+    ifaceMod             :: !Module
 
     -- | Original file name of the module.
-  , ifaceOrigFilename    :: FilePath
+  , ifaceOrigFilename    :: !FilePath
 
     -- | Textual information about the module.
   , ifaceInfo            :: !(HaddockModInfo Name)
@@ -71,7 +71,7 @@ data Interface = Interface
   , ifaceDoc             :: !(Documentation Name)
 
     -- | Documentation header with cross-reference information.
-  , ifaceRnDoc           :: Documentation DocName
+  , ifaceRnDoc           :: !(Documentation DocName)
 
     -- | Haddock options for this module (prune, ignore-exports, etc).
   , ifaceOptions         :: ![DocOption]
@@ -79,22 +79,22 @@ data Interface = Interface
     -- | Declarations originating from the module. Excludes declarations without
     -- names (instances and stand-alone documentation comments). Includes
     -- names of subordinate declarations mapped to their parent declarations.
-  , ifaceDeclMap         :: Map Name [LHsDecl Name]
+  , ifaceDeclMap         :: !(Map Name [LHsDecl Name])
 
     -- | Documentation of declarations originating from the module (including
     -- subordinates).
-  , ifaceDocMap          :: DocMap Name
-  , ifaceArgMap          :: ArgMap Name
+  , ifaceDocMap          :: !(DocMap Name)
+  , ifaceArgMap          :: !(ArgMap Name)
 
     -- | Documentation of declarations originating from the module (including
     -- subordinates).
-  , ifaceRnDocMap        :: DocMap DocName
-  , ifaceRnArgMap        :: ArgMap DocName
+  , ifaceRnDocMap        :: !(DocMap DocName)
+  , ifaceRnArgMap        :: !(ArgMap DocName)
 
-  , ifaceSubMap          :: Map Name [Name]
+  , ifaceSubMap          :: !(Map Name [Name])
 
   , ifaceExportItems     :: ![ExportItem Name]
-  , ifaceRnExportItems   :: [ExportItem DocName]
+  , ifaceRnExportItems   :: ![ExportItem DocName]
 
     -- | All names exported by the module.
   , ifaceExports         :: ![Name]
@@ -105,14 +105,14 @@ data Interface = Interface
   , ifaceVisibleExports  :: ![Name]
 
     -- | Aliases of module imports as in @import A.B.C as C@.
-  , ifaceModuleAliases   :: AliasMap
+  , ifaceModuleAliases   :: !AliasMap
 
     -- | Instances exported by the module.
   , ifaceInstances       :: ![ClsInst]
 
     -- | The number of haddockable and haddocked items in the module, as a
     -- tuple. Haddockable items are the exports and the module itself.
-  , ifaceHaddockCoverage :: (Int,Int)
+  , ifaceHaddockCoverage :: !(Int, Int)
   }
 
 
@@ -172,51 +172,51 @@ data ExportItem name
   = ExportDecl
       {
         -- | A declaration.
-        expItemDecl :: LHsDecl name
+        expItemDecl :: !(LHsDecl name)
 
         -- | Maybe a doc comment, and possibly docs for arguments (if this
         -- decl is a function or type-synonym).
-      , expItemMbDoc :: DocForDecl name
+      , expItemMbDoc :: !(DocForDecl name)
 
         -- | Subordinate names, possibly with documentation.
-      , expItemSubDocs :: [(name, DocForDecl name)]
+      , expItemSubDocs :: ![(name, DocForDecl name)]
 
         -- | Instances relevant to this declaration, possibly with
         -- documentation.
-      , expItemInstances :: [DocInstance name]
+      , expItemInstances :: ![DocInstance name]
       }
 
   -- | An exported entity for which we have no documentation (perhaps because it
   -- resides in another package).
   | ExportNoDecl
-      { expItemName :: name
+      { expItemName :: !name
 
         -- | Subordinate names.
-      , expItemSubs :: [name]
+      , expItemSubs :: ![name]
       }
 
   -- | A section heading. 
   | ExportGroup
       {
         -- | Section level (1, 2, 3, ...).
-        expItemSectionLevel :: Int
+        expItemSectionLevel :: !Int
 
         -- | Section id (for hyperlinks).
-      , expItemSectionId :: String
+      , expItemSectionId :: !String
 
         -- | Section heading text.
-      , expItemSectionText :: Doc name
+      , expItemSectionText :: !(Doc name)
       }
 
   -- | Some documentation.
-  | ExportDoc (Doc name)
+  | ExportDoc !(Doc name)
 
   -- | A cross-reference to another module.
-  | ExportModule Module
+  | ExportModule !Module
 
 data Documentation name = Documentation
   { documentationDoc :: Maybe (Doc name)
-  , documentationWarning :: Maybe (Doc name)
+  , documentationWarning :: !(Maybe (Doc name))
   } deriving Functor
 
 
@@ -355,11 +355,11 @@ data DocMarkup id a = Markup
 
 
 data HaddockModInfo name = HaddockModInfo
-  { hmi_description :: Maybe (Doc name)
-  , hmi_portability :: Maybe String
-  , hmi_stability   :: Maybe String
-  , hmi_maintainer  :: Maybe String
-  , hmi_safety      :: Maybe String
+  { hmi_description :: (Maybe (Doc name))
+  , hmi_portability :: (Maybe String)
+  , hmi_stability   :: (Maybe String)
+  , hmi_maintainer  :: (Maybe String)
+  , hmi_safety      :: (Maybe String)
   }