[Git][ghc/ghc][wip/nfdata-forcing] interfaces: Ensure that forceModIface deeply forces a ModIface
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Mar 7 19:18:25 UTC 2025
Matthew Pickering pushed to branch wip/nfdata-forcing at Glasgow Haskell Compiler / GHC
Commits:
2fbdfc58 by Matthew Pickering at 2025-03-07T19:18:01+00:00
interfaces: Ensure that forceModIface deeply forces a ModIface
A ModIface is the result of compilation that we keep for a long time on
disk. Therefore, it's very important to manage what we are going to
retain and remove any external references to things which we might have
captured compilation.
If storing your ModIface in memory usages too much space, then store
less things or make it use a more efficient representation.
In the past there have been many space leak bugs by not sufficiently
forcing a ModIface.
This patch adds all the missing NFData instances for all the places I
could find where we weren't deeply forcing the structure.
- - - - -
23 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Data/Strict.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Types/Annotations.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/GHC/Types/CostCentre/State.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/SourceFile.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Unit/Types.hs
- compiler/Language/Haskell/Syntax/Basic.hs
- libraries/ghc-boot/GHC/Serialized.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -120,6 +120,8 @@ import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Word
+import Control.DeepSeq
+
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
@@ -1185,6 +1187,10 @@ instance Binary IsOrphan where
n <- get bh
return $ NotOrphan n
+instance NFData IsOrphan where
+ rnf IsOrphan = ()
+ rnf (NotOrphan n) = rnf n
+
{-
Note [Orphans]
~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Coercion/Axiom.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Types.SrcLoc
import qualified Data.Data as Data
import Data.Array
import Data.List ( mapAccumL )
+import Control.DeepSeq
{-
Note [Coercion axiom branches]
@@ -559,6 +560,11 @@ instance Binary Role where
3 -> return Phantom
_ -> panic ("get Role " ++ show tag)
+instance NFData Role where
+ rnf Nominal = ()
+ rnf Representational = ()
+ rnf Phantom = ()
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -112,6 +112,7 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.Data as Data
import Data.Char
import Data.List( find )
+import Control.DeepSeq
{-
Note [Data constructor representation]
@@ -1075,6 +1076,16 @@ instance Binary SrcUnpackedness where
1 -> return SrcUnpack
_ -> return NoSrcUnpack
+instance NFData SrcStrictness where
+ rnf SrcLazy = ()
+ rnf SrcStrict = ()
+ rnf NoSrcStrict = ()
+
+instance NFData SrcUnpackedness where
+ rnf SrcNoUnpack = ()
+ rnf SrcUnpack = ()
+ rnf NoSrcUnpack = ()
+
-- | Compare strictness annotations
eqHsBang :: HsImplBang -> HsImplBang -> Bool
eqHsBang HsLazy HsLazy = True
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -181,6 +181,7 @@ import GHC.Settings.Constants
import GHC.Utils.Misc
import GHC.Types.Unique.Set
import GHC.Unit.Module
+import Control.DeepSeq
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
@@ -2916,6 +2917,10 @@ instance Binary Injectivity where
_ -> do { xs <- get bh
; return (Injective xs) } }
+instance NFData Injectivity where
+ rnf NotInjective = ()
+ rnf (Injective xs) = rnf xs
+
-- | Returns whether or not this 'TyCon' is definite, or a hole
-- that may be filled in at some later point. See Note [Skolem abstract data]
tyConSkolem :: TyCon -> Bool
=====================================
compiler/GHC/Data/Strict.hs
=====================================
@@ -22,10 +22,15 @@ import GHC.Prelude hiding (Maybe(..), Either(..))
import Control.Applicative
import Data.Semigroup
import Data.Data
+import Control.DeepSeq
data Maybe a = Nothing | Just !a
deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+instance NFData a => NFData (Maybe a) where
+ rnf Nothing = ()
+ rnf (Just x) = rnf x
+
fromMaybe :: a -> Maybe a -> a
fromMaybe d Nothing = d
fromMaybe _ (Just x) = x
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -106,7 +106,5 @@ instance Outputable ModIfaceSelfRecomp where
])]
instance NFData ModIfaceSelfRecomp where
- -- Note (MP): does not deeply force Usages but the old ModIface logic didn't either, so
- -- I left it as a shallow force.
rnf (ModIfaceSelfRecomp src_hash usages flag_hash opt_hash hpc_hash plugin_hash)
- = src_hash `seq` usages `seq` flag_hash `seq` opt_hash `seq` hpc_hash `seq` plugin_hash `seq` ()
\ No newline at end of file
+ = rnf src_hash `seq` rnf usages `seq` rnf flag_hash `seq` rnf opt_hash `seq` rnf hpc_hash `seq` rnf plugin_hash `seq` ()
\ No newline at end of file
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -539,6 +539,14 @@ instance Binary IfaceLFInfo where
4 -> pure IfLFUnlifted
_ -> panic "Invalid byte"
+instance NFData IfaceLFInfo where
+ rnf = \case
+ IfLFReEntrant arity -> rnf arity
+ IfLFThunk updatable mb_fun -> rnf updatable `seq` rnf mb_fun
+ IfLFCon con -> rnf con
+ IfLFUnknown fun_flag -> rnf fun_flag
+ IfLFUnlifted -> ()
+
{-
Note [Versioning of instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2767,6 +2775,10 @@ getUnfoldingCache bh = do
return (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
, uf_is_work_free = wf, uf_expandable = exp })
+seqUnfoldingCache :: IfUnfoldingCache -> ()
+seqUnfoldingCache (UnfoldingCache hnf conlike wf exp) =
+ rnf hnf `seq` rnf conlike `seq` rnf wf `seq` rnf exp `seq` ()
+
infixl 9 .<<|.
(.<<|.) :: (Num a, Bits a) => a -> Bool -> a
x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
@@ -2837,12 +2849,10 @@ instance Binary IfaceExpr where
putByte bh 13
put_ bh a
put_ bh b
- put_ bh (IfaceLitRubbish TypeLike r) = do
+ put_ bh (IfaceLitRubbish torc r) = do
putByte bh 14
put_ bh r
- put_ bh (IfaceLitRubbish ConstraintLike r) = do
- putByte bh 15
- put_ bh r
+ put_ bh torc
get bh = do
h <- getByte bh
case h of
@@ -2886,9 +2896,8 @@ instance Binary IfaceExpr where
b <- get bh
return (IfaceECase a b)
14 -> do r <- get bh
- return (IfaceLitRubbish TypeLike r)
- 15 -> do r <- get bh
- return (IfaceLitRubbish ConstraintLike r)
+ torc <- get bh
+ return (IfaceLitRubbish torc r)
_ -> panic ("get IfaceExpr " ++ show h)
instance Binary IfaceTickish where
@@ -3047,31 +3056,31 @@ instance NFData IfaceDecl where
rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4
IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 ->
- f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq`
+ rnf f1 `seq` seqList f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq`
rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9
IfaceSynonym f1 f2 f3 f4 f5 ->
- rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5
+ rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5
IfaceFamily f1 f2 f3 f4 f5 f6 ->
- rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` ()
+ rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` ()
IfaceClass f1 f2 f3 f4 f5 ->
- rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5
+ rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5
IfaceAxiom nm tycon role ax ->
rnf nm `seq`
rnf tycon `seq`
- role `seq`
+ rnf role `seq`
rnf ax
IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 ->
- rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq`
- rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` ()
+ rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq`
+ rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` ()
instance NFData IfaceAxBranch where
rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) =
- rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7
+ rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7
instance NFData IfaceClassBody where
rnf = \case
@@ -3089,7 +3098,7 @@ instance NFData IfaceAT where
rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2
instance NFData IfaceClassOp where
- rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` ()
+ rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` ()
instance NFData IfaceTyConParent where
rnf = \case
@@ -3104,14 +3113,17 @@ instance NFData IfaceConDecls where
instance NFData IfaceConDecl where
rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) =
- rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq`
- rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11
+ rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq`
+ rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11
instance NFData IfaceSrcBang where
- rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` ()
+ rnf (IfSrcBang f1 f2) = rnf f1 `seq` rnf f2 `seq` ()
instance NFData IfaceBang where
- rnf x = x `seq` ()
+ rnf IfNoBang = ()
+ rnf IfStrict = ()
+ rnf IfUnpack = ()
+ rnf (IfUnpackCo co) = rnf co
instance NFData IfaceIdDetails where
rnf = \case
@@ -3125,23 +3137,22 @@ instance NFData IfaceInfoItem where
rnf = \case
HsArity a -> rnf a
HsDmdSig str -> seqDmdSig str
- HsInline p -> p `seq` () -- TODO: seq further?
+ HsInline p -> rnf p `seq` ()
HsUnfold b unf -> rnf b `seq` rnf unf
HsNoCafRefs -> ()
- HsCprSig cpr -> cpr `seq` ()
- HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
- HsTagSig sig -> sig `seq` ()
+ HsCprSig cpr -> seqCprSig cpr `seq` ()
+ HsLFInfo lf_info -> rnf lf_info `seq` ()
+ HsTagSig sig -> seqTagSig sig `seq` ()
instance NFData IfGuidance where
rnf = \case
IfNoGuidance -> ()
- IfWhen a b c -> a `seq` b `seq` c `seq` ()
+ IfWhen a b c -> rnf a `seq` rnf b `seq` rnf c `seq` ()
instance NFData IfaceUnfolding where
rnf = \case
- IfCoreUnfold src cache guidance expr -> src `seq` cache `seq` rnf guidance `seq` rnf expr
+ IfCoreUnfold src cache guidance expr -> rnf src `seq` seqUnfoldingCache cache `seq` rnf guidance `seq` rnf expr
IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs
- -- See Note [UnfoldingCache] in GHC.Core for why it suffices to merely `seq` on cache
instance NFData IfaceExpr where
rnf = \case
@@ -3152,13 +3163,13 @@ instance NFData IfaceExpr where
IfaceTuple sort exprs -> sort `seq` rnf exprs
IfaceLam bndr expr -> rnf bndr `seq` rnf expr
IfaceApp e1 e2 -> rnf e1 `seq` rnf e2
- IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts
+ IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts
IfaceECase e ty -> rnf e `seq` rnf ty
IfaceLet bind e -> rnf bind `seq` rnf e
IfaceCast e co -> rnf e `seq` rnf co
- IfaceLit l -> l `seq` () -- FIXME
- IfaceLitRubbish tc r -> tc `seq` rnf r `seq` ()
- IfaceFCall fc ty -> fc `seq` rnf ty
+ IfaceLit l -> rnf l `seq` ()
+ IfaceLitRubbish tc r -> rnf tc `seq` rnf r `seq` ()
+ IfaceFCall fc ty -> rnf fc `seq` rnf ty
IfaceTick tick e -> rnf tick `seq` rnf e
instance NFData IfaceAlt where
@@ -3192,22 +3203,22 @@ instance NFData IfaceFamTyConFlav where
instance NFData IfaceTickish where
rnf = \case
IfaceHpcTick m i -> rnf m `seq` rnf i
- IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2
- IfaceSource src str -> src `seq` rnf str
+ IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2
+ IfaceSource src str -> rnf src `seq` rnf str
IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs
instance NFData IfaceConAlt where
rnf = \case
IfaceDefaultAlt -> ()
IfaceDataAlt nm -> rnf nm
- IfaceLitAlt lit -> lit `seq` ()
+ IfaceLitAlt lit -> rnf lit `seq` ()
instance NFData IfaceCompleteMatch where
rnf (IfaceCompleteMatch f1 mtc) = rnf f1 `seq` rnf mtc
instance NFData IfaceRule where
rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) =
- rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` ()
+ rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` ()
instance NFData IfaceDefault where
rnf (IfaceDefault f1 f2 f3) =
@@ -3215,11 +3226,11 @@ instance NFData IfaceDefault where
instance NFData IfaceFamInst where
rnf (IfaceFamInst f1 f2 f3 f4) =
- rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` ()
+ rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` ()
instance NFData IfaceClsInst where
rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) =
- f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` rnf f6
+ rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6
instance NFData IfaceWarnings where
rnf = \case
@@ -3227,12 +3238,12 @@ instance NFData IfaceWarnings where
IfWarnSome vs ds -> rnf vs `seq` rnf ds
instance NFData IfaceWarningTxt where
- rnf = \case
- IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
- IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2
+ rnf = \case
+ IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
+ IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2
instance NFData IfaceStringLiteral where
- rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2
+ rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2
instance NFData IfaceAnnotation where
- rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` ()
+ rnf (IfaceAnnotation f1 f2) = rnf f1 `seq` rnf f2 `seq` ()
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -2577,6 +2577,11 @@ instance Binary (DefMethSpec IfaceType) where
0 -> return VanillaDM
_ -> do { t <- get bh; return (GenericDM t) }
+instance NFData (DefMethSpec IfaceType) where
+ rnf = \case
+ VanillaDM -> ()
+ GenericDM t -> rnf t
+
instance NFData IfaceType where
rnf = \case
IfaceFreeTyVar f1 -> f1 `seq` ()
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -148,6 +148,7 @@ import qualified GHC.Boot.TH.Ppr as TH
#if defined(HAVE_INTERNAL_INTERPRETER)
import Unsafe.Coerce ( unsafeCoerce )
import GHC.Desugar ( AnnotationWrapper(..) )
+import Control.DeepSeq
#endif
import Control.Monad
@@ -1039,11 +1040,7 @@ convertAnnotationWrapper fhv = do
-- annotation are exposed at this point. This is also why we are
-- doing all this stuff inside the context of runMeta: it has the
-- facilities to deal with user error in a meta-level expression
- seqSerialized serialized `seq` serialized
-
--- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
-seqSerialized :: Serialized -> ()
-seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
+ rnf serialized `seq` serialized
#endif
=====================================
compiler/GHC/Types/Annotations.hs
=====================================
@@ -31,7 +31,7 @@ import Control.Monad
import Data.Maybe
import Data.Typeable
import Data.Word ( Word8 )
-
+import Control.DeepSeq
-- | Represents an annotation after it has been sufficiently desugared from
-- it's initial form of 'GHC.Hs.Decls.AnnDecl'
@@ -71,6 +71,10 @@ instance Binary name => Binary (AnnTarget name) where
0 -> liftM NamedTarget $ get bh
_ -> liftM ModuleTarget $ get bh
+instance NFData name => NFData (AnnTarget name) where
+ rnf (NamedTarget n) = rnf n
+ rnf (ModuleTarget m) = rnf m
+
instance Outputable Annotation where
ppr ann = ppr (ann_target ann)
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -529,6 +529,10 @@ instance Binary FunctionOrData where
1 -> return IsData
_ -> panic "Binary FunctionOrData"
+instance NFData FunctionOrData where
+ rnf IsFunction = ()
+ rnf IsData = ()
+
{-
************************************************************************
* *
@@ -871,6 +875,9 @@ data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv
instance Outputable OverlapFlag where
ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
+instance NFData OverlapFlag where
+ rnf (OverlapFlag mode safe) = rnf mode `seq` rnf safe
+
instance Outputable OverlapMode where
ppr (NoOverlap _) = empty
ppr (Overlappable _) = text "[overlappable]"
@@ -879,6 +886,14 @@ instance Outputable OverlapMode where
ppr (Incoherent _) = text "[incoherent]"
ppr (NonCanonical _) = text "[noncanonical]"
+instance NFData OverlapMode where
+ rnf (NoOverlap s) = rnf s
+ rnf (Overlappable s) = rnf s
+ rnf (Overlapping s) = rnf s
+ rnf (Overlaps s) = rnf s
+ rnf (Incoherent s) = rnf s
+ rnf (NonCanonical s) = rnf s
+
instance Binary OverlapMode where
put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s
put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s
@@ -1860,6 +1875,14 @@ instance Binary Activation where
ab <- get bh
return (ActiveAfter src ab)
+instance NFData Activation where
+ rnf = \case
+ AlwaysActive -> ()
+ NeverActive -> ()
+ ActiveBefore src aa -> rnf src `seq` rnf aa
+ ActiveAfter src ab -> rnf src `seq` rnf ab
+ FinalActive -> ()
+
instance Outputable RuleMatchInfo where
ppr ConLike = text "CONLIKE"
ppr FunLike = text "FUNLIKE"
@@ -1872,6 +1895,11 @@ instance Binary RuleMatchInfo where
if h == 1 then return ConLike
else return FunLike
+instance NFData RuleMatchInfo where
+ rnf = \case
+ ConLike -> ()
+ FunLike -> ()
+
instance Outputable InlineSpec where
ppr (Inline src) = text "INLINE" <+> pprWithSourceText src empty
ppr (NoInline src) = text "NOINLINE" <+> pprWithSourceText src empty
@@ -1906,6 +1934,14 @@ instance Binary InlineSpec where
s <- get bh
return (Opaque s)
+instance NFData InlineSpec where
+ rnf = \case
+ Inline s -> rnf s
+ NoInline s -> rnf s
+ Inlinable s -> rnf s
+ Opaque s -> rnf s
+ NoUserInlinePrag -> ()
+
instance Outputable InlinePragma where
ppr = pprInline
@@ -1925,6 +1961,9 @@ instance Binary InlinePragma where
d <- get bh
return (InlinePragma s a b c d)
+instance NFData InlinePragma where
+ rnf (InlinePragma s a b c d) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+
-- | Outputs string for pragma name for any of INLINE/INLINABLE/NOINLINE. This
-- differs from the Outputable instance for the InlineSpec type where the pragma
-- name string as well as the accompanying SourceText (if any) is printed.
@@ -2017,6 +2056,13 @@ instance Binary UnfoldingSource where
2 -> return StableSystemSrc
_ -> return VanillaSrc
+instance NFData UnfoldingSource where
+ rnf = \case
+ CompulsorySrc -> ()
+ StableUserSrc -> ()
+ StableSystemSrc -> ()
+ VanillaSrc -> ()
+
instance Outputable UnfoldingSource where
ppr CompulsorySrc = text "Compulsory"
ppr StableUserSrc = text "StableUser"
@@ -2161,6 +2207,19 @@ data TypeOrConstraint
= TypeLike | ConstraintLike
deriving( Eq, Ord, Data )
+instance Binary TypeOrConstraint where
+ put_ bh = \case
+ TypeLike -> putByte bh 0
+ ConstraintLike -> putByte bh 1
+ get bh = getByte bh >>= \case
+ 0 -> pure TypeLike
+ 1 -> pure ConstraintLike
+ _ -> panic "TypeOrConstraint.get: invalid value"
+
+instance NFData TypeOrConstraint where
+ rnf = \case
+ TypeLike -> ()
+ ConstraintLike -> ()
{- *********************************************************************
* *
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Utils.Outputable
import GHC.Types.SrcLoc
import GHC.Data.FastString
import GHC.Types.CostCentre.State
+import Control.DeepSeq
import Data.Data
@@ -395,6 +396,21 @@ instance Binary CostCentre where
-- CostCentre in the original module, it is not used by importing
-- modules.
+instance NFData CostCentre where
+ rnf (NormalCC aa ab ac ad) = rnf aa `seq` rnf ab `seq` rnf ac `seq` rnf ad
+ rnf (AllCafsCC ae ad) = rnf ae `seq` rnf ad
+
+instance NFData CCFlavour where
+ rnf CafCC = ()
+ rnf (IndexedCC flav i) = rnf flav `seq` rnf i
+
+instance NFData IndexedCCFlavour where
+ rnf ExprCC = ()
+ rnf DeclCC = ()
+ rnf HpcCC = ()
+ rnf LateCC = ()
+ rnf CallerCC = ()
+
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC this_mod =
let
=====================================
compiler/GHC/Types/CostCentre/State.hs
=====================================
@@ -15,6 +15,7 @@ import GHC.Data.FastString.Env
import Data.Data
import GHC.Utils.Binary
+import Control.DeepSeq
-- | Per-module state for tracking cost centre indices.
--
@@ -29,6 +30,9 @@ newCostCentreState = CostCentreState emptyFsEnv
newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int }
deriving (Eq, Ord, Data, Binary)
+instance NFData CostCentreIndex where
+ rnf (CostCentreIndex i) = rnf i
+
-- | Get a new index for a given cost centre name.
getCCIndex :: FastString
-> CostCentreState
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -30,6 +30,8 @@ import GHC.Types.SourceText ( SourceText, pprWithSourceText )
import Data.Char
import Data.Data
+import Control.DeepSeq (NFData(..))
+
{-
************************************************************************
* *
@@ -344,3 +346,31 @@ instance Binary Header where
get bh = do s <- get bh
h <- get bh
return (Header s h)
+
+instance NFData ForeignCall where
+ rnf (CCall c) = rnf c
+
+instance NFData Safety where
+ rnf PlaySafe = ()
+ rnf PlayInterruptible = ()
+ rnf PlayRisky = ()
+
+instance NFData CCallSpec where
+ rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s
+
+instance NFData CCallTarget where
+ rnf (StaticTarget s a b c) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c
+ rnf DynamicTarget = ()
+
+instance NFData CCallConv where
+ rnf CCallConv = ()
+ rnf StdCallConv = ()
+ rnf PrimCallConv = ()
+ rnf CApiConv = ()
+ rnf JavaScriptCallConv = ()
+
+instance NFData CType where
+ rnf (CType s mh fs) = rnf s `seq` rnf mh `seq` rnf fs
+
+instance NFData Header where
+ rnf (Header s h) = rnf s `seq` rnf h
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -84,6 +84,7 @@ import Data.Char
import Data.Data ( Data )
import GHC.Exts( isTrue#, dataToTag#, (<#) )
import Numeric ( fromRat )
+import Control.DeepSeq
{-
************************************************************************
@@ -204,6 +205,20 @@ instance Binary LitNumType where
h <- getByte bh
return (toEnum (fromIntegral h))
+instance NFData LitNumType where
+ rnf (LitNumBigNat) = ()
+ rnf (LitNumInt) = ()
+ rnf (LitNumInt8) = ()
+ rnf (LitNumInt16) = ()
+ rnf (LitNumInt32) = ()
+ rnf (LitNumInt64) = ()
+ rnf (LitNumWord) = ()
+ rnf (LitNumWord8) = ()
+ rnf (LitNumWord16) = ()
+ rnf (LitNumWord32) = ()
+ rnf (LitNumWord64) = ()
+
+
{-
Note [BigNum literals]
~~~~~~~~~~~~~~~~~~~~~~
@@ -288,6 +303,16 @@ instance Binary Literal where
return (LitNumber nt i)
_ -> pprPanic "Binary:Literal" (int (fromIntegral h))
+instance NFData Literal where
+ rnf (LitChar c) = rnf c
+ rnf (LitNumber nt i) = rnf nt `seq` rnf i
+ rnf (LitString s) = rnf s
+ rnf LitNullAddr = ()
+ rnf (LitFloat r) = rnf r
+ rnf (LitDouble r) = rnf r
+ rnf (LitLabel l1 k2) = rnf l1 `seq` rnf k2
+ rnf (LitRubbish {}) = () -- LitRubbish is not contained within interface files.
+ -- See Note [Rubbish literals].
instance Outputable Literal where
ppr = pprLiteral id
=====================================
compiler/GHC/Types/SourceFile.hs
=====================================
@@ -13,6 +13,7 @@ where
import GHC.Prelude
import GHC.Utils.Binary
import GHC.Unit.Types
+import Control.DeepSeq
{- Note [HscSource types]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -53,6 +54,10 @@ data HsBootOrSig
| Hsig -- ^ .hsig file
deriving (Eq, Ord, Show)
+instance NFData HsBootOrSig where
+ rnf HsBoot = ()
+ rnf Hsig = ()
+
data HscSource
-- | .hs file
= HsSrcFile
@@ -73,6 +78,10 @@ hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot HsBootFile = IsBoot
hscSourceToIsBoot _ = NotBoot
+instance NFData HscSource where
+ rnf HsSrcFile = ()
+ rnf (HsBootOrSig h) = rnf h
+
instance Binary HscSource where
put_ bh HsSrcFile = putByte bh 0
put_ bh HsBootFile = putByte bh 1
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -223,7 +223,8 @@ data RealSrcLoc
-- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock
-- comments with parts of the AST using location information (#17544).
newtype BufPos = BufPos { bufPos :: Int }
- deriving (Eq, Ord, Show, Data)
+ deriving (Eq, Ord, Show, Data, NFData)
+
-- | Source Location
data SrcLoc
@@ -373,11 +374,13 @@ data RealSrcSpan
}
deriving Eq
--- | StringBuffer Source Span
data BufSpan =
BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }
deriving (Eq, Ord, Show, Data)
+instance NFData BufSpan where
+ rnf (BufSpan a1 a2) = rnf a1 `seq` rnf a2
+
instance Semigroup BufSpan where
BufSpan start1 end1 <> BufSpan start2 end2 =
BufSpan (min start1 start2) (max end1 end2)
@@ -439,8 +442,18 @@ instance ToJson RealSrcSpan where
end = JSObject [ ("line", JSInt srcSpanELine),
("column", JSInt srcSpanECol) ]
+instance NFData RealSrcSpan where
+ rnf (RealSrcSpan' file line col endLine endCol) = rnf file `seq` rnf line `seq` rnf col `seq` rnf endLine `seq` rnf endCol
instance NFData SrcSpan where
- rnf x = x `seq` ()
+ rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2
+ rnf (UnhelpfulSpan a1) = rnf a1
+
+instance NFData UnhelpfulSpanReason where
+ rnf (UnhelpfulNoLocationInfo) = ()
+ rnf (UnhelpfulWiredIn) = ()
+ rnf (UnhelpfulInteractive) = ()
+ rnf (UnhelpfulGenerated) = ()
+ rnf (UnhelpfulOther a1) = rnf a1
getBufSpan :: SrcSpan -> Strict.Maybe BufSpan
getBufSpan (RealSrcSpan _ mbspan) = mbspan
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -132,6 +132,7 @@ import GHC.Utils.Panic
import GHC.Hs.Specificity ()
import Language.Haskell.Syntax.Specificity
+import Control.DeepSeq
import Data.Data
@@ -734,6 +735,9 @@ instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where
get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) }
+instance (NFData tv, NFData vis) => NFData (VarBndr tv vis) where
+ rnf (Bndr tv vis) = rnf tv `seq` rnf vis
+
instance NamedThing tv => NamedThing (VarBndr tv flag) where
getName (Bndr tv _) = getName tv
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -39,6 +39,7 @@ import Data.List (sortBy, sort, partition)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Bifunctor
+import Control.DeepSeq
-- | Dependency information about ALL modules and packages below this one
-- in the import hierarchy. This is the serialisable version of `ImportAvails`.
@@ -104,6 +105,18 @@ data Dependencies = Deps
-- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints
-- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies.
+instance NFData Dependencies where
+ rnf (Deps dmods dpkgs ppkgs hsigms tps bmods orphs finsts)
+ = rnf dmods
+ `seq` rnf dpkgs
+ `seq` rnf ppkgs
+ `seq` rnf hsigms
+ `seq` rnf tps
+ `seq` rnf bmods
+ `seq` rnf orphs
+ `seq` rnf finsts
+ `seq` ()
+
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
@@ -326,6 +339,13 @@ data Usage
-- And of course, for modules that aren't imported directly we don't
-- depend on their export lists
+instance NFData Usage where
+ rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` ()
+ rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` ()
+ rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` ()
+ rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` ()
+ rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
+
instance Binary Usage where
put_ bh usg at UsagePackageModule{} = do
putByte bh 0
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -660,52 +660,46 @@ emptyIfaceHashCache _occ = Nothing
instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
, NFData (IfaceDeclExts (phase :: ModIfacePhase))
) => NFData (ModIface_ phase) where
- rnf (PrivateModIface
- { mi_module_, mi_sig_of_, mi_hsc_src_, mi_hi_bytes_, mi_deps_
- , mi_exports_, mi_fixities_, mi_warns_, mi_anns_
- , mi_decls_, mi_defaults_, mi_extra_decls_, mi_foreign_, mi_top_env_, mi_insts_
- , mi_fam_insts_, mi_rules_, mi_trust_, mi_trust_pkg_
- , mi_complete_matches_, mi_docs_, mi_final_exts_
- , mi_ext_fields_ })
- = rnf mi_module_
- `seq` rnf mi_sig_of_
- `seq` mi_hsc_src_
- `seq` mi_hi_bytes_
- `seq` mi_deps_
- `seq` mi_exports_
- `seq` mi_fixities_
- `seq` rnf mi_warns_
- `seq` rnf mi_anns_
- `seq` rnf mi_decls_
- `seq` rnf mi_defaults_
- `seq` rnf mi_extra_decls_
- `seq` rnf mi_foreign_
- `seq` rnf mi_top_env_
- `seq` rnf mi_insts_
- `seq` rnf mi_fam_insts_
- `seq` rnf mi_rules_
- `seq` mi_trust_
- `seq` rnf mi_trust_pkg_
- `seq` rnf mi_complete_matches_
- `seq` rnf mi_docs_
- `seq` mi_final_exts_
- `seq` mi_ext_fields_
- `seq` ()
-
-instance NFData (ModIfaceBackend) where
- rnf (ModIfaceBackend{ mi_mod_hash
- , mi_orphan, mi_finsts, mi_exp_hash
- , mi_orphan_hash, mi_decl_warn_fn, mi_export_warn_fn, mi_fix_fn
- , mi_hash_fn})
- = rnf mi_mod_hash
- `seq` rnf mi_orphan
- `seq` rnf mi_finsts
- `seq` rnf mi_exp_hash
- `seq` rnf mi_orphan_hash
- `seq` rnf mi_decl_warn_fn
- `seq` rnf mi_export_warn_fn
- `seq` rnf mi_fix_fn
- `seq` rnf mi_hash_fn
+ rnf (PrivateModIface a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24)
+ = rnf a1
+ `seq` rnf a2
+ `seq` rnf a3
+ `seq` rnf a4
+ `seq` rnf a5
+ `seq` rnf a6
+ `seq` rnf a7
+ `seq` rnf a8
+ `seq` rnf a9
+ `seq` rnf a10
+ `seq` rnf a11
+ `seq` rnf a12
+ `seq` rnf a13
+ `seq` rnf a14
+ `seq` rnf a15
+ `seq` rnf a16
+ `seq` rnf a17
+ `seq` rnf a18
+ `seq` rnf a19
+ `seq` rnf a20
+ `seq` rnf a21
+ `seq` rnf a22
+ -- IfaceBinHandle
+ `seq` a23
+ `seq` rnf a24
+
+
+instance NFData ModIfaceBackend where
+ rnf (ModIfaceBackend a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+ = rnf a1
+ `seq` rnf a2
+ `seq` rnf a3
+ `seq` rnf a4
+ `seq` rnf a5
+ `seq` rnf a6
+ `seq` rnf a7
+ `seq` rnf a8
+ `seq` rnf a9
+ `seq` rnf a10
forceModIface :: ModIface -> IO ()
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -517,6 +517,9 @@ newtype UnitId = UnitId
}
deriving (Data)
+instance NFData UnitId where
+ rnf (UnitId fs) = rnf fs `seq` ()
+
instance Binary UnitId where
put_ bh (UnitId fs) = put_ bh fs
get bh = do fs <- get bh; return (UnitId fs)
@@ -704,6 +707,9 @@ data GenWithIsBoot mod = GWIB
-- IsBootInterface: this is assumed to perform filtering of non-boot modules,
-- e.g. in GHC.Driver.Env.hptModulesBelow
+instance NFData mod => NFData (GenWithIsBoot mod) where
+ rnf (GWIB mod isBoot) = rnf mod `seq` rnf isBoot `seq` ()
+
type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
type ModuleWithIsBoot = GenWithIsBoot Module
=====================================
compiler/Language/Haskell/Syntax/Basic.hs
=====================================
@@ -2,11 +2,11 @@
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module Language.Haskell.Syntax.Basic where
-import Data.Data
+import Data.Data (Data)
import Data.Eq
import Data.Ord
import Data.Bool
-import Data.Int (Int)
+import Prelude
import GHC.Data.FastString (FastString)
import Control.DeepSeq
@@ -134,5 +134,13 @@ data FixityDirection
| InfixN
deriving (Eq, Data)
+instance NFData FixityDirection where
+ rnf InfixL = ()
+ rnf InfixR = ()
+ rnf InfixN = ()
+
data Fixity = Fixity Int FixityDirection
deriving (Eq, Data)
+
+instance NFData Fixity where
+ rnf (Fixity i d) = rnf i `seq` rnf d `seq` ()
=====================================
libraries/ghc-boot/GHC/Serialized.hs
=====================================
@@ -22,11 +22,15 @@ import Prelude -- See note [Why do we import Prelude here?]
import Data.Bits
import Data.Word ( Word8 )
import Data.Data
+import Control.DeepSeq
-- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
data Serialized = Serialized TypeRep [Word8]
+instance NFData Serialized where
+ rnf (Serialized tr ws) = rnf tr `seq` rnf ws
+
-- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized serialize what = Serialized (typeOf what) (serialize what)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fbdfc58a13f190582f1f23b0c0b374d91b04b00
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fbdfc58a13f190582f1f23b0c0b374d91b04b00
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/20250307/6d999ccd/attachment-0001.html>
More information about the ghc-commits
mailing list