Force the Docs structure to prevent leaks in GHCi with -haddock without -fwrite-interfacewip/force-docs

Involves adding many new NFData instances.

Without forcing Docs, references to the TcGblEnv for each module are retained
by the Docs structure. Usually these are forced when the ModIface is serialised
but not when we aren't writing the interface.

2 files changed, 40 insertions, 8 deletions

diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs
index 948341f89f..38271e3681 100644
--- a/compiler/GHC/Hs/Doc.hs
+++ b/compiler/GHC/Hs/Doc.hs
@@ -38,6 +38,7 @@ import GHC.Types.Avail
 import GHC.Types.Name.Set
 import GHC.Driver.Flags
 
+import Control.DeepSeq
 import Data.Data
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
@@ -74,6 +75,8 @@ data WithHsDocIdentifiers a pass = WithHsDocIdentifiers
 
 deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass)
 deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass)
+instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where
+  rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i
 
 -- | For compatibility with the existing @-ddump-parsed' output, we only show
 -- the docstring.
@@ -118,19 +121,19 @@ type LHsDoc pass = Located (HsDoc pass)
 
 -- | A simplified version of 'HsImpExp.IE'.
 data DocStructureItem
-  = DsiSectionHeading Int (HsDoc GhcRn)
-  | DsiDocChunk (HsDoc GhcRn)
-  | DsiNamedChunkRef String
-  | DsiExports Avails
+  = DsiSectionHeading !Int !(HsDoc GhcRn)
+  | DsiDocChunk !(HsDoc GhcRn)
+  | DsiNamedChunkRef !(String)
+  | DsiExports !Avails
   | DsiModExport
-      (NonEmpty ModuleName) -- ^ We might re-export avails from multiple
+      !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple
                             -- modules with a single export declaration. E.g.
                             -- when we have
                             --
                             -- > module M (module X) where
                             -- > import R0 as X
                             -- > import R1 as X
-      Avails
+      !Avails
 
 instance Binary DocStructureItem where
   put_ bh = \case
@@ -179,6 +182,15 @@ instance Outputable DocStructureItem where
     DsiModExport mod_names avails ->
       text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails)
 
+instance NFData DocStructureItem where
+  rnf = \case
+    DsiSectionHeading level doc -> rnf level `seq` rnf doc
+    DsiDocChunk doc -> rnf doc
+    DsiNamedChunkRef name -> rnf name
+    DsiExports avails -> rnf avails
+    DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails
+
+
 type DocStructure = [DocStructureItem]
 
 data Docs = Docs
@@ -203,6 +215,12 @@ data Docs = Docs
     -- ^ The full set of language extensions used in the module.
   }
 
+instance NFData Docs where
+  rnf (Docs mod_hdr decls args structure named_chunks haddock_opts language extentions)
+    = rnf mod_hdr `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks
+    `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions
+    `seq` ()
+
 instance Binary Docs where
   put_ bh docs = do
     put_ bh (docs_mod_hdr docs)
diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs
index c96165d178..8e42c4a8d8 100644
--- a/compiler/GHC/Hs/DocString.hs
+++ b/compiler/GHC/Hs/DocString.hs
@@ -1,5 +1,7 @@
 -- | An exactprintable structure for docstrings
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module GHC.Hs.DocString
   ( LHsDocString
@@ -27,6 +29,7 @@ import GHC.Utils.Binary
 import GHC.Utils.Encoding
 import GHC.Utils.Outputable as Outputable hiding ((<>))
 import GHC.Types.SrcLoc
+import Control.DeepSeq
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
@@ -59,6 +62,11 @@ data HsDocString
 instance Outputable HsDocString where
   ppr = text . renderHsDocString
 
+instance NFData HsDocString where
+  rnf (MultiLineDocString a b) = rnf a `seq` rnf b
+  rnf (NestedDocString a b) = rnf a `seq` rnf b
+  rnf (GeneratedDocString a) = rnf a
+
 -- | Annotate a pretty printed thing with its doc
 -- The docstring comes after if is 'HsDocStringPrevious'
 -- Otherwise it comes before.
@@ -101,6 +109,12 @@ data HsDocStringDecorator
 instance Outputable HsDocStringDecorator where
   ppr = text . printDecorator
 
+instance NFData HsDocStringDecorator where
+  rnf HsDocStringNext = ()
+  rnf HsDocStringPrevious = ()
+  rnf (HsDocStringNamed x) = rnf x
+  rnf (HsDocStringGroup x) = rnf x
+
 printDecorator :: HsDocStringDecorator -> String
 printDecorator HsDocStringNext = "|"
 printDecorator HsDocStringPrevious = "^"
@@ -126,7 +140,8 @@ type LHsDocStringChunk = Located HsDocStringChunk
 
 -- | A contiguous chunk of documentation
 newtype HsDocStringChunk = HsDocStringChunk ByteString
-  deriving (Eq,Ord,Data, Show)
+  deriving stock (Eq,Ord,Data, Show)
+  deriving newtype (NFData)
 
 instance Binary HsDocStringChunk where
   put_ bh (HsDocStringChunk bs) = put_ bh bs
@@ -135,7 +150,6 @@ instance Binary HsDocStringChunk where
 instance Outputable HsDocStringChunk where
   ppr = text . unpackHDSC
 
-
 mkHsDocStringChunk :: String -> HsDocStringChunk
 mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s)