From bc57ee2686dfe011a631bec9f64cb86f03545d3d Mon Sep 17 00:00:00 2001
From: Finley McIlwaine <finleymcilwaine@gmail.com>
Date: Wed, 17 May 2023 13:43:54 -0600
Subject: Memory usage fixes for Haddock

- Do not include `mi_globals` in the `NoBackend` backend. It was only included
  for Haddock, but Haddock does not actually need it. This causes a 200MB
  reduction in max residency when generating haddocks on the Agda codebase
  (roughly 1GB to 800MB).
- Strictly evaluate some SrcSpans in mkDoc{Next,Prev} to avoid thunks
- Strictly evaluate names in rnHsDoc to avoid retaining entire GlobalRdrEnv
- Update Haddock submodule
---
 compiler/GHC/Driver/Backend.hs             | 7 ++-----
 compiler/GHC/Parser/PostProcess/Haddock.hs | 8 ++++++--
 compiler/GHC/Rename/Doc.hs                 | 9 ++++++++-
 utils/haddock                              | 2 +-
 4 files changed, 17 insertions(+), 9 deletions(-)

diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs
index e59f0a51f7..ab3cf3ce8d 100644
--- a/compiler/GHC/Driver/Backend.hs
+++ b/compiler/GHC/Driver/Backend.hs
@@ -551,17 +551,14 @@ backendRespectsSpecialise (Named NoBackend)   = False
 
 -- | This back end wants the `mi_globals` field of a
 -- `ModIface` to be populated (with the top-level bindings
--- of the original source).  True for the interpreter, and
--- also true for "no backend", which is used by Haddock.
--- (After typechecking a module, Haddock wants access to
--- the module's `GlobalRdrEnv`.)
+-- of the original source).  Only true for the interpreter.
 backendWantsGlobalBindings :: Backend -> Bool
 backendWantsGlobalBindings (Named NCG)         = False
 backendWantsGlobalBindings (Named LLVM)        = False
 backendWantsGlobalBindings (Named ViaC)        = False
 backendWantsGlobalBindings (Named JavaScript)  = False
+backendWantsGlobalBindings (Named NoBackend)   = False
 backendWantsGlobalBindings (Named Interpreter) = True
-backendWantsGlobalBindings (Named NoBackend)   = True
 
 -- | The back end targets a technology that implements
 -- `switch` natively.  (For example, LLVM or C.) Therefore
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 706423c099..82af8bbb03 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -1360,11 +1360,15 @@ mkDocIE (L l_comment hdk_comment) =
         span = mkSrcSpanPs l_comment
 
 mkDocNext :: PsLocated HdkComment -> Maybe (Located HsDocString)
-mkDocNext (L l (HdkCommentNext doc)) = Just (L (mkSrcSpanPs l) doc)
+mkDocNext (L l (HdkCommentNext doc)) =
+    let !src_span = mkSrcSpanPs l
+    in Just (L src_span doc)
 mkDocNext _ = Nothing
 
 mkDocPrev :: PsLocated HdkComment -> Maybe (Located HsDocString)
-mkDocPrev (L l (HdkCommentPrev doc)) = Just (L (mkSrcSpanPs l) doc)
+mkDocPrev (L l (HdkCommentPrev doc)) =
+    let !src_span = mkSrcSpanPs l
+    in Just (L src_span doc)
 mkDocPrev _ = Nothing
 
 
diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs
index 006bc2689b..d476b1782e 100644
--- a/compiler/GHC/Rename/Doc.hs
+++ b/compiler/GHC/Rename/Doc.hs
@@ -1,5 +1,7 @@
 module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnLDocDecl, rnDocDecl ) where
 
+import Control.DeepSeq (force)
+
 import GHC.Prelude
 
 import GHC.Tc.Types
@@ -33,7 +35,12 @@ rnDocDecl (DocGroup i doc) = do
 rnHsDoc :: WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)
 rnHsDoc (WithHsDocIdentifiers s ids) = do
   gre <- tcg_rdr_env <$> getGblEnv
-  pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids))
+
+  -- This is forced to avoid retention of the entire GlobalRdrEnv
+  let !rn = force $ rnHsDocIdentifiers gre ids
+
+  pure (WithHsDocIdentifiers s rn)
+
 
 rnHsDocIdentifiers :: GlobalRdrEnv
                    -> [Located RdrName]
diff --git a/utils/haddock b/utils/haddock
index e16e20d592..04e9d6048b 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit e16e20d592a6f5d9ed1af17b77fafd6495242345
+Subproject commit 04e9d6048bb297de5831651e60d496217525ef62
-- 
cgit v1.2.1