[Git][ghc/ghc][master] Force the Docs structure to prevent leaks in GHCi with -haddock without -fwrite-interface
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jan 4 04:27:00 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
62b9a7b2 by Zubin Duggal at 2023-01-03T12:22:11+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.
- - - - -
11 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
- compiler/Language/Haskell/Syntax/Basic.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
=====================================
@@ -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
=====================================
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` ()
=====================================
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)
{-
************************************************************************
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62b9a7b23b20f5cf0a2de14251c2096098009f10
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62b9a7b23b20f5cf0a2de14251c2096098009f10
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/20230103/f3cb4b8b/attachment-0001.html>
More information about the ghc-commits
mailing list