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.

11 files changed, 76 insertions, 12 deletions

diff --git a/compiler/GHC/Data/EnumSet.hs b/compiler/GHC/Data/EnumSet.hs
index d364dc05d7..de462e2337 100644
--- a/compiler/GHC/Data/EnumSet.hs
+++ b/compiler/GHC/Data/EnumSet.hs
@@ -15,11 +15,12 @@ module GHC.Data.EnumSet
 
 import GHC.Prelude
 import GHC.Utils.Binary
+import Control.DeepSeq
 
 import qualified Data.IntSet as IntSet
 
 newtype EnumSet a = EnumSet IntSet.IntSet
-  deriving (Semigroup, Monoid)
+  deriving (Semigroup, Monoid, NFData)
 
 member :: Enum a => a -> EnumSet a -> Bool
 member x (EnumSet s) = IntSet.member (fromEnum x) s
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index f45397d887..ed77b81ebd 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -26,6 +26,7 @@ import GHC.Utils.Outputable
 import GHC.Utils.Binary
 import GHC.Data.EnumSet as EnumSet
 
+import Control.DeepSeq
 import Control.Monad (guard)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (fromMaybe,mapMaybe)
@@ -40,6 +41,9 @@ instance Binary Language where
   put_ bh = put_ bh . fromEnum
   get bh = toEnum <$> get bh
 
+instance NFData Language where
+  rnf x = x `seq` ()
+
 -- | Debugging flags
 data DumpFlag
 -- See Note [Updating flag description in the User's Guide]
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)
 
diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs
index ab57c6f1a1..346cf4236c 100644
--- a/compiler/GHC/Types/Avail.hs
+++ b/compiler/GHC/Types/Avail.hs
@@ -50,6 +50,7 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Constants (debugIsOn)
 
+import Control.DeepSeq
 import Data.Data ( Data )
 import Data.Either ( partitionEithers )
 import Data.Functor.Classes ( liftCompare )
@@ -272,6 +273,10 @@ instance Outputable GreName where
   ppr (NormalGreName n) = ppr n
   ppr (FieldGreName fl) = ppr fl
 
+instance NFData GreName where
+  rnf (NormalGreName n) = rnf n
+  rnf (FieldGreName f) = rnf f
+
 instance HasOccName GreName where
   occName (NormalGreName n) = occName n
   occName (FieldGreName fl) = occName fl
@@ -385,6 +390,10 @@ instance Binary AvailInfo where
                       ac <- get bh
                       return (AvailTC ab ac)
 
+instance NFData AvailInfo where
+  rnf (Avail n) = rnf n
+  rnf (AvailTC a b) = rnf a `seq` rnf b
+
 instance Binary GreName where
     put_ bh (NormalGreName aa) = do
             putByte bh 0
@@ -399,3 +408,4 @@ instance Binary GreName where
                       return (NormalGreName aa)
               _ -> do ab <- get bh
                       return (FieldGreName ab)
+
diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs
index 2c654926ae..89bfd4afee 100644
--- a/compiler/GHC/Types/FieldLabel.hs
+++ b/compiler/GHC/Types/FieldLabel.hs
@@ -95,6 +95,7 @@ import GHC.Utils.Binary
 
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
+import Control.DeepSeq
 import Data.Bool
 import Data.Data
 
@@ -129,6 +130,8 @@ instance Outputable FieldLabelString where
 instance Uniquable FieldLabelString where
   getUnique (FieldLabelString fs) = getUnique fs
 
+instance NFData FieldLabel where
+  rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
 
 -- | Flag to indicate whether the DuplicateRecordFields extension is enabled.
 data DuplicateRecordFields
@@ -144,6 +147,8 @@ instance Outputable DuplicateRecordFields where
     ppr DuplicateRecordFields   = text "+dup"
     ppr NoDuplicateRecordFields = text "-dup"
 
+instance NFData DuplicateRecordFields where
+  rnf x = x `seq` ()
 
 -- | Flag to indicate whether the FieldSelectors extension is enabled.
 data FieldSelectors
@@ -159,6 +164,8 @@ instance Outputable FieldSelectors where
     ppr FieldSelectors   = text "+sel"
     ppr NoFieldSelectors = text "-sel"
 
+instance NFData FieldSelectors where
+  rnf x = x `seq` ()
 
 -- | We need the @Binary Name@ constraint here even though there is an instance
 -- defined in "GHC.Types.Name", because the we have a SOURCE import, so the
diff --git a/compiler/GHC/Types/Name.hs-boot b/compiler/GHC/Types/Name.hs-boot
index ebc2efd34c..e7e4cf2c7b 100644
--- a/compiler/GHC/Types/Name.hs-boot
+++ b/compiler/GHC/Types/Name.hs-boot
@@ -8,6 +8,7 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence
 import GHC.Types.Unique
 import GHC.Utils.Outputable
 import Data.Data (Data)
+import Control.DeepSeq (NFData)
 
 data Name
 
@@ -15,6 +16,7 @@ instance Eq Name
 instance Data Name
 instance Uniquable Name
 instance Outputable Name
+instance NFData Name
 
 class NamedThing a where
     getOccName :: a -> OccName
diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs
index 30ff00deed..a78716a61e 100644
--- a/compiler/GHC/Types/SrcLoc.hs
+++ b/compiler/GHC/Types/SrcLoc.hs
@@ -738,6 +738,8 @@ pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
 data GenLocated l e = L l e
   deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)
+instance (NFData l, NFData e) => NFData (GenLocated l e) where
+  rnf (L l e) = rnf l `seq` rnf e
 
 type Located = GenLocated SrcSpan
 type RealLocated = GenLocated RealSrcSpan
diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs
index b889ba2bbd..4f79792811 100644
--- a/compiler/GHC/Types/Unique/Map.hs
+++ b/compiler/GHC/Types/Unique/Map.hs
@@ -59,6 +59,7 @@ import Data.Semigroup as Semi ( Semigroup(..) )
 import Data.Coerce
 import Data.Maybe
 import Data.Data
+import Control.DeepSeq
 
 -- | Maps indexed by 'Uniquable' keys
 newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) }
@@ -78,6 +79,9 @@ instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where
         [ ppr k <+> text "->" <+> ppr v
         | (k, v) <- nonDetEltsUFM m ]
 
+instance (NFData k, NFData a) => NFData (UniqMap k a) where
+  rnf (UniqMap fm) = seqEltsUFM rnf fm
+
 liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)
 liftC f (_, v) (k', v') = (k', f v v')
 
diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs
index 1d5280f4fa..d46160a1a6 100644
--- a/compiler/GHC/Unit/Module/ModIface.hs
+++ b/compiler/GHC/Unit/Module/ModIface.hs
@@ -240,7 +240,7 @@ data ModIface_ (phase :: ModIfacePhase)
                 -- See Note [Trust Own Package] in GHC.Rename.Names
         mi_complete_matches :: ![IfaceCompleteMatch],
 
-        mi_docs :: Maybe Docs,
+        mi_docs :: !(Maybe Docs),
                 -- ^ Docstrings and related data for use by haddock, the ghci
                 -- @:doc@ command, and other tools.
                 --
@@ -554,7 +554,7 @@ instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclE
                 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =
     rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`
     f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq`
-    rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` f21 `seq` f22 `seq` f23 `seq` rnf f24
+    rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` rnf f21 `seq` f22 `seq` f23 `seq` rnf f24
     `seq` ()
 
 
diff --git a/compiler/Language/Haskell/Syntax/Basic.hs b/compiler/Language/Haskell/Syntax/Basic.hs
index 77ad3fe0e0..687349d021 100644
--- a/compiler/Language/Haskell/Syntax/Basic.hs
+++ b/compiler/Language/Haskell/Syntax/Basic.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
 module Language.Haskell.Syntax.Basic where
 
 import Data.Data
@@ -8,6 +9,7 @@ import Data.Bool
 import Data.Int (Int)
 
 import GHC.Data.FastString (FastString)
+import Control.DeepSeq
 
 {-
 ************************************************************************
@@ -54,7 +56,7 @@ Field Labels
 -- | Field labels are just represented as strings;
 -- they are not necessarily unique (even within a module)
 newtype FieldLabelString = FieldLabelString { field_label:: FastString }
-  deriving (Data, Eq)
+  deriving (Data, Eq, NFData)
 
 {-
 ************************************************************************