[Git][ghc/ghc][wip/force-docs] Force the Docs structure to prevent leaks in GHCi with -haddock without -fwrite-interface

Matthew Pickering (@mpickering) gitlab at gitlab.haskell.org
Wed Dec 7 16:56:31 UTC 2022



Matthew Pickering pushed to branch wip/force-docs at Glasgow Haskell Compiler / GHC


Commits:
73139d39 by Zubin Duggal at 2022-12-07T16:56:06+00:00
Force the Docs structure to prevent leaks in GHCi with -haddock without -fwrite-interface

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.

- - - - -


10 changed files:

- compiler/GHC/Data/EnumSet.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Types/Avail.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Name.hs-boot
- compiler/GHC/Types/SrcLoc.hs
- compiler/GHC/Types/Unique/Map.hs
- compiler/GHC/Unit/Module/ModIface.hs


Changes:

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


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


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


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


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


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


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


=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -735,6 +735,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


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


=====================================
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` ()
 
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73139d390b1c7d8391747fd6094dd4d119c28234

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73139d390b1c7d8391747fd6094dd4d119c28234
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/20221207/b3a58535/attachment-0001.html>


More information about the ghc-commits mailing list