[Git][ghc/ghc][wip/haddock-mem-fixes] 2 commits: Memory usage fixes for Haddock

Finley McIlwaine (@FinleyMcIlwaine) gitlab at gitlab.haskell.org
Thu Jun 1 00:04:43 UTC 2023 


Finley McIlwaine pushed to branch wip/haddock-mem-fixes at Glasgow Haskell Compiler / GHC


Commits:
d3fe2047 by Finley McIlwaine at 2023-05-25T13:37:33-06:00
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 retention of GlobalRdrEnv
- Strictly evaluate fields of `IfaceTyConInfo`
- Update haddock perf tests to be more accurate and force evaluation of renamed
  doc thunks using `-fwrite-interface`
- Accept a higher increase (40%) in allocations in the renamer due to `-haddock`.
- Update Haddock submodule to move over to initial implementation of hi-haddock,
  including the other memory performance gains recently added to haddock.

- - - - -
8a4cef74 by Finley McIlwaine at 2023-05-31T18:02:25-06:00
Fix associated data family doc structure items

Associated data families were being given their own export DocStructureItems,
which resulted in them being documented separately from their classes in
haddocks. This commit fixes it.

Also bump haddock to latest dev commit.

- - - - -


10 changed files:

- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Doc.hs
- compiler/GHC/Types/Name/Occurrence.hs
- testsuite/tests/haddock/perf/Fold.hs
- testsuite/tests/haddock/perf/Makefile
- utils/haddock


Changes:

=====================================
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


=====================================
compiler/GHC/Hs/Doc.hs
=====================================
@@ -123,7 +123,7 @@ type LHsDoc pass = Located (HsDoc pass)
 data DocStructureItem
   = DsiSectionHeading !Int !(HsDoc GhcRn)
   | DsiDocChunk !(HsDoc GhcRn)
-  | DsiNamedChunkRef !(String)
+  | DsiNamedChunkRef !String
   | DsiExports !Avails
   | DsiModExport
       !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple


=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -31,18 +31,18 @@ import Data.Bifunctor (first)
 import Data.Foldable (toList)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IM
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Map.Strict (Map)
 import qualified Data.Map as M
-import qualified Data.Set as Set
 import Data.Maybe
+import qualified Data.Set as Set
 import Data.Semigroup
 import GHC.IORef (readIORef)
 import GHC.Unit.Types
 import GHC.Hs
 import GHC.Types.Avail
 import GHC.Unit.Module
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.List.NonEmpty (NonEmpty ((:|)))
 import GHC.Unit.Module.Imported
 import GHC.Driver.Session
 import GHC.Types.TypeEnv
@@ -192,7 +192,13 @@ mkDocStructureFromDecls env all_exports decls =
         Just loc -> L loc (DsiExports [avail])
         -- FIXME: This is just a workaround that we use when handling e.g.
         -- associated data families like in the html-test Instances.hs.
-        Nothing -> noLoc (DsiExports [avail])
+        Nothing -> noLoc (DsiExports [])
+
+        -- This causes the associated data family to be incorrectly documented
+        -- separately from its class:
+        -- Nothing -> noLoc (DsiExports [])
+
+        -- This panics on the associated data family:
         -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for"
         --                     (ppr avail)
 


=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -355,13 +355,13 @@ See Note [The equality types story] in GHC.Builtin.Types.Prim.
 -}
 
 data IfaceTyConInfo   -- Used only to guide pretty-printing
-  = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag
+  = IfaceTyConInfo { ifaceTyConIsPromoted :: !PromotionFlag
                       -- A PromotionFlag value of IsPromoted indicates
                       -- that the type constructor came from a data
                       -- constructor promoted by -XDataKinds, and thus
                       -- should be printed as 'D to distinguish it from
                       -- an existing type constructor D.
-                   , ifaceTyConSort       :: IfaceTyConSort }
+                   , ifaceTyConSort       :: !IfaceTyConSort }
     deriving (Eq)
 
 -- This smart constructor allows sharing of the two most common


=====================================
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
 
 


=====================================
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,11 @@ 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 GlobalRdrEnv
+  let !rn = force $ rnHsDocIdentifiers gre ids
+
+  pure (WithHsDocIdentifiers s rn)
 
 rnHsDocIdentifiers :: GlobalRdrEnv
                    -> [Located RdrName]


=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -600,7 +600,7 @@ unitOccEnv (OccName ns s) a = MkOccEnv $ unitFsEnv s (unitUFM ns a)
 -- | Add a single element to an 'OccEnv'.
 extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a
 extendOccEnv (MkOccEnv as) (OccName ns s) a =
-  MkOccEnv $ extendFsEnv_C plusUFM as s (unitUFM ns a)
+  MkOccEnv $ extendFsEnv_C plusUFM as s $! unitUFM ns a
 
 -- | Extend an 'OccEnv' by a list.
 --


=====================================
testsuite/tests/haddock/perf/Fold.hs
=====================================
@@ -143,6 +143,7 @@ import Prelude
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import Control.Monad as Monad
+import Control.Monad.Fix
 import Control.Monad.Reader
 import qualified Control.Monad.Reader as Reader
 import Data.Functor


=====================================
testsuite/tests/haddock/perf/Makefile
=====================================
@@ -4,12 +4,12 @@ include $(TOP)/mk/test.mk
 
 # We accept a 5% increase in parser allocations due to -haddock
 haddock_parser_perf :
-	WithHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -haddock -O0 Fold.hs 2>/dev/null | grep Parser | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ; \
-	WithoutHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -O0 Fold.hs 2>/dev/null | grep Parser | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ;  \
+	WithHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface -fforce-recomp -Wno-all -ddump-timings -haddock -O0 Fold.hs 2>/dev/null | grep Parser | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ; \
+	WithoutHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface -fforce-recomp -Wno-all -ddump-timings -O0 Fold.hs 2>/dev/null | grep Parser | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ;  \
 	  awk "BEGIN { ratio = ($$WithHaddock / $$WithoutHaddock); if (ratio > 1.05) {print \"-haddock allocation ratio too high:\", ratio; exit 1} else {exit 0} }"
 
-# Similarly for the renamer
+# We accept a 40% increase in renamer allocations due to -haddock
 haddock_renamer_perf :
-	WithoutHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -O0 Fold.hs 2>/dev/null | grep Renamer | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ; \
-	WithHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -haddock -O0 Fold.hs 2>/dev/null | grep Renamer | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ;  \
-	  awk "BEGIN { ratio = ($$WithHaddock / $$WithoutHaddock); if (ratio > 1.20) {print \"-haddock allocation ratio too high:\", ratio; exit 1} else {exit 0} }"
+	WithoutHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface -fforce-recomp -Wno-all -ddump-timings -O0 Fold.hs 2>/dev/null | grep Renamer | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ; \
+	WithHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface -fforce-recomp -Wno-all -ddump-timings -haddock -O0 Fold.hs 2>/dev/null | grep Renamer | grep -E -o 'alloc=[0-9]+' | cut -c7-  ) ;  \
+	  awk "BEGIN { ratio = ($$WithHaddock / $$WithoutHaddock); if (ratio > 1.40) {print \"-haddock allocation ratio too high:\", ratio; exit 1} else {exit 0} }"


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit e16e20d592a6f5d9ed1af17b77fafd6495242345
+Subproject commit e85b2a7be1e1d03ee5dfbb26b2a4bc3d0e455166



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0bf53ae8427973c0b29e858668b08a37ff5e760e...8a4cef74d1dab2c8698b54bdc4a30a3431cbb16c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0bf53ae8427973c0b29e858668b08a37ff5e760e...8a4cef74d1dab2c8698b54bdc4a30a3431cbb16c
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230531/8cbb5e9d/attachment-0001.html>

More information about the ghc-commits mailing list