[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 22:24:03 UTC 2022
Matthew Pickering pushed to branch wip/force-docs at Glasgow Haskell Compiler / GHC
Commits:
abeed5eb by Zubin Duggal at 2022-12-07T22:23:46+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/abeed5ebfc5be78c7decc0bad7f7cf8f7d95cfc5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/abeed5ebfc5be78c7decc0bad7f7cf8f7d95cfc5
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/932fedb2/attachment-0001.html>
More information about the ghc-commits
mailing list