[Git][ghc/ghc][master] interfaces: Ensure that forceModIface deeply forces a ModIface
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Mar 13 05:47:20 UTC 2025
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
915a6781 by Matthew Pickering at 2025-03-13T01:46:41-04:00
interfaces: Ensure that forceModIface deeply forces a ModIface
A ModIface is the result of compilation that we keep for a long time in
memory. 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 uses 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 (#15111)
This patch adds all the missing NFData instances for all the places I
could find where we weren't deeply forcing the structure.
- - - - -
29 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Data/Strict.hs
- compiler/GHC/Driver/Flags.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/GREInfo.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
- compiler/Language/Haskell/Syntax/Type.hs
- compiler/Language/Haskell/Syntax/Type.hs-boot
- libraries/ghc-boot/GHC/Serialized.hs
- utils/haddock/haddock-api/src/Haddock/Types.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]
@@ -1078,6 +1079,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/TyCo/Rep.hs
=====================================
@@ -994,6 +994,11 @@ instance Outputable FunSel where
ppr SelArg = text "arg"
ppr SelRes = text "res"
+instance NFData FunSel where
+ rnf SelMult = ()
+ rnf SelArg = ()
+ rnf SelRes = ()
+
instance Binary CoSel where
put_ bh (SelTyCon n r) = do { putByte bh 0; put_ bh n; put_ bh r }
put_ bh SelForAll = putByte bh 1
@@ -1010,9 +1015,9 @@ instance Binary CoSel where
_ -> return (SelFun SelRes) }
instance NFData CoSel where
- rnf (SelTyCon n r) = n `seq` r `seq` ()
+ rnf (SelTyCon n r) = rnf n `seq` rnf r `seq` ()
rnf SelForAll = ()
- rnf (SelFun fs) = fs `seq` ()
+ rnf (SelFun fs) = rnf fs `seq` ()
-- | A semantically more meaningful type to represent what may or may not be a
-- useful 'Coercion'.
=====================================
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(..))
@@ -731,6 +732,11 @@ instance Binary TyConBndrVis where
0 -> return AnonTCB
_ -> do { vis <- get bh; return (NamedTCB vis) } }
+instance NFData TyConBndrVis where
+ rnf AnonTCB = ()
+ rnf (NamedTCB vis) = rnf vis
+
+
{- *********************************************************************
* *
@@ -2916,6 +2922,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/Driver/Flags.hs
=====================================
@@ -76,7 +76,10 @@ instance Binary Language where
get bh = toEnum <$> get bh
instance NFData Language where
- rnf x = x `seq` ()
+ rnf Haskell98 = ()
+ rnf Haskell2010 = ()
+ rnf GHC2021 = ()
+ rnf GHC2024 = ()
data OnOff a = On a
| Off a
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -111,7 +111,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
=====================================
@@ -94,7 +94,7 @@ import GHC.Utils.Binary.Typeable () -- instance Binary AnnPayload
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
- seqList, zipWithEqual )
+ zipWithEqual )
import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))
@@ -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` rnf 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` rnf 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` rnf 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` rnf 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,19 +3113,22 @@ 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
IfVanillaId -> ()
- IfWorkerLikeId dmds -> dmds `seqList` ()
+ IfWorkerLikeId dmds -> rnf dmds `seq` ()
IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d
IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d
IfDFunId -> ()
@@ -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
@@ -3149,16 +3160,16 @@ instance NFData IfaceExpr where
IfaceExt nm -> rnf nm
IfaceType ty -> rnf ty
IfaceCo co -> rnf co
- IfaceTuple sort exprs -> sort `seq` rnf exprs
+ IfaceTuple sort exprs -> rnf 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
@@ -3170,7 +3181,7 @@ instance (NFData b, NFData a) => NFData (IfaceBindingX a b) where
IfaceRec binds -> rnf binds
instance NFData IfaceTopBndrInfo where
- rnf (IfGblTopBndr n) = n `seq` ()
+ rnf (IfGblTopBndr n) = rnf n `seq` ()
rnf (IfLclTopBndr fs ty info dets) = rnf fs `seq` rnf ty `seq` rnf info `seq` rnf dets `seq` ()
instance NFData IfaceMaybeRhs 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,18 +2577,23 @@ 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` ()
IfaceTyVar f1 -> rnf f1
IfaceLitTy f1 -> rnf f1
IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2
- IfaceFunTy f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4
- IfaceForAllTy f1 f2 -> f1 `seq` rnf f2
+ IfaceFunTy f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4
+ IfaceForAllTy f1 f2 -> rnf f1 `seq` rnf f2
IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2
IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2
IfaceCoercionTy f1 -> rnf f1
- IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3
+ IfaceTupleTy f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
instance NFData IfaceTyLit where
rnf = \case
@@ -2599,21 +2604,25 @@ instance NFData IfaceTyLit where
instance NFData IfaceCoercion where
rnf = \case
IfaceReflCo f1 -> rnf f1
- IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3
- IfaceFunCo f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4
- IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3
+ IfaceGReflCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
+ IfaceFunCo f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4
+ IfaceTyConAppCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2
IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5
IfaceCoVarCo f1 -> rnf f1
IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2
- IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps
+ IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps
IfaceSymCo f1 -> rnf f1
IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2
IfaceSelCo f1 f2 -> rnf f1 `seq` rnf f2
- IfaceLRCo f1 f2 -> f1 `seq` rnf f2
+ IfaceLRCo f1 f2 -> rnf f1 `seq` rnf f2
IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2
IfaceKindCo f1 -> rnf f1
IfaceSubCo f1 -> rnf f1
+ -- These are not deeply forced because they are not used in ModIface,
+ -- these constructors are for pretty-printing.
+ -- See Note [Free TyVars and CoVars in IfaceType]
+ -- See Note [Holes in IfaceCoercion]
IfaceFreeCoVar f1 -> f1 `seq` ()
IfaceHoleCo f1 -> f1 `seq` ()
@@ -2624,15 +2633,17 @@ instance NFData IfaceAxiomRule where
IfaceAR_B n i -> rnf n `seq` rnf i
instance NFData IfaceMCoercion where
- rnf x = seq x ()
+ rnf IfaceMRefl = ()
+ rnf (IfaceMCo c) = rnf c
instance NFData IfaceOneShot where
- rnf x = seq x ()
+ rnf IfaceOneShot = ()
+ rnf IfaceNoOneShot = ()
instance NFData IfaceTyConSort where
rnf = \case
IfaceNormalTyCon -> ()
- IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` ()
+ IfaceTupleTyCon arity sort -> rnf arity `seq` rnf sort `seq` ()
IfaceSumTyCon arity -> rnf arity
IfaceEqualityTyCon -> ()
@@ -2640,7 +2651,7 @@ instance NFData IfLclName where
rnf (IfLclName lfs) = rnf lfs
instance NFData IfaceTyConInfo where
- rnf (IfaceTyConInfo f s) = f `seq` rnf s
+ rnf (IfaceTyConInfo f s) = rnf f `seq` rnf s
instance NFData IfaceTyCon where
rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info
@@ -2653,4 +2664,4 @@ instance NFData IfaceBndr where
instance NFData IfaceAppArgs where
rnf = \case
IA_Nil -> ()
- IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3
+ IA_Arg f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
=====================================
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
=====================================
@@ -167,6 +167,11 @@ instance Binary LeftOrRight where
0 -> return CLeft
_ -> return CRight }
+instance NFData LeftOrRight where
+ rnf CLeft = ()
+ rnf CRight = ()
+
+
{-
************************************************************************
@@ -529,6 +534,10 @@ instance Binary FunctionOrData where
1 -> return IsData
_ -> panic "Binary FunctionOrData"
+instance NFData FunctionOrData where
+ rnf IsFunction = ()
+ rnf IsData = ()
+
{-
************************************************************************
* *
@@ -612,6 +621,11 @@ instance Binary CbvMark where
1 -> return MarkedCbv
_ -> panic "Invalid binary format"
+instance NFData CbvMark where
+ rnf MarkedCbv = ()
+ rnf NotMarkedCbv = ()
+
+
isMarkedCbv :: CbvMark -> Bool
isMarkedCbv MarkedCbv = True
isMarkedCbv NotMarkedCbv = False
@@ -871,6 +885,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 +896,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
@@ -1032,6 +1057,11 @@ instance Binary TupleSort where
1 -> return UnboxedTuple
_ -> return ConstraintTuple
+instance NFData TupleSort where
+ rnf BoxedTuple = ()
+ rnf UnboxedTuple = ()
+ rnf ConstraintTuple = ()
+
tupleSortBoxity :: TupleSort -> Boxity
tupleSortBoxity BoxedTuple = Boxed
@@ -1860,6 +1890,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 +1910,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 +1949,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 +1976,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 +2071,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 +2222,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 -> ()
{- *********************************************************************
* *
@@ -2209,18 +2283,6 @@ instance Outputable (TyConFlavour tc) where
go BuiltInTypeFlavour = "built-in type"
go PromotedDataConFlavour = "promoted data constructor"
-instance NFData tc => NFData (TyConFlavour tc) where
- rnf ClassFlavour = ()
- rnf (TupleFlavour !_) = ()
- rnf SumFlavour = ()
- rnf DataTypeFlavour = ()
- rnf NewtypeFlavour = ()
- rnf AbstractTypeFlavour = ()
- rnf (OpenFamilyFlavour !_ mb_tc) = rnf mb_tc
- rnf ClosedTypeFamilyFlavour = ()
- rnf TypeSynonymFlavour = ()
- rnf BuiltInTypeFlavour = ()
- rnf PromotedDataConFlavour = ()
-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour
tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc
=====================================
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/GREInfo.hs
=====================================
@@ -126,12 +126,6 @@ data GREInfo
deriving Data
-instance NFData GREInfo where
- rnf Vanilla = ()
- rnf UnboundGRE = ()
- rnf (IAmTyCon tc) = rnf tc
- rnf (IAmConLike info) = rnf info
- rnf (IAmRecField info) = rnf info
plusGREInfo :: GREInfo -> GREInfo -> GREInfo
plusGREInfo Vanilla Vanilla = Vanilla
=====================================
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,19 @@ 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
@@ -499,6 +500,12 @@ instance Binary FunTyFlag where
2 -> return FTF_C_T
_ -> return FTF_C_C
+instance NFData FunTyFlag where
+ rnf FTF_T_T = ()
+ rnf FTF_T_C = ()
+ rnf FTF_C_T = ()
+ rnf FTF_C_C = ()
+
mkFunTyFlag :: TypeOrConstraint -> TypeOrConstraint -> FunTyFlag
mkFunTyFlag TypeLike torc = visArg torc
mkFunTyFlag ConstraintLike torc = invisArg torc
@@ -734,6 +741,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
=====================================
@@ -655,57 +655,50 @@ mkIfaceHashCache pairs
emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache _occ = Nothing
--- Take care, this instance only forces to the degree necessary to
--- avoid major space leaks.
+-- ModIface is completely forced since it will live in memory for a long time.
+-- If forcing it uses a lot of memory, then store less things in ModIface.
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 :: IfaceBinHandle phase)
+ `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` ()
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -79,6 +79,7 @@ import Data.Bool
import Data.Char
import Prelude (Integer)
import Data.Ord (Ord)
+import Control.DeepSeq
{-
************************************************************************
@@ -98,6 +99,10 @@ isPromoted :: PromotionFlag -> Bool
isPromoted IsPromoted = True
isPromoted NotPromoted = False
+instance NFData PromotionFlag where
+ rnf NotPromoted = ()
+ rnf IsPromoted = ()
+
{-
************************************************************************
* *
=====================================
compiler/Language/Haskell/Syntax/Type.hs-boot
=====================================
@@ -4,6 +4,8 @@ import Data.Bool
import Data.Eq
import Data.Ord
+import Control.DeepSeq
+
{-
************************************************************************
* *
@@ -19,5 +21,6 @@ data PromotionFlag
instance Eq PromotionFlag
instance Ord PromotionFlag
+instance NFData PromotionFlag
isPromoted :: PromotionFlag -> Bool
=====================================
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)
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -52,7 +52,6 @@ import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC
-import qualified GHC.Data.Strict as Strict
import GHC.Data.BooleanFormula (BooleanFormula)
import GHC.Driver.Session (Language)
import qualified GHC.LanguageExtensions as LangExt
@@ -61,7 +60,7 @@ import GHC.Types.Fixity (Fixity (..))
import GHC.Types.Name (stableNameCmp)
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader (RdrName (..))
-import GHC.Types.SrcLoc (BufPos (..), BufSpan (..), srcSpanToRealSrcSpan)
+import GHC.Types.SrcLoc (srcSpanToRealSrcSpan)
import GHC.Types.Var (Specificity)
import GHC.Utils.Outputable
@@ -987,15 +986,6 @@ instance NFData RdrName where
rnf (Orig m on) = m `deepseq` on `deepseq` ()
rnf (Exact n) = rnf n
-instance NFData FixityDirection where
- rnf InfixL = ()
- rnf InfixR = ()
- rnf InfixN = ()
-
-instance NFData Fixity where
- rnf (Fixity n dir) =
- n `deepseq` dir `deepseq` ()
-
instance NFData (EpAnn NameAnn) where
rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` ()
@@ -1065,15 +1055,6 @@ instance NFData EpaCommentTok where
rnf (EpaLineComment s) = rnf s
rnf (EpaBlockComment s) = rnf s
-instance NFData a => NFData (Strict.Maybe a) where
- rnf Strict.Nothing = ()
- rnf (Strict.Just x) = rnf x
-
-instance NFData BufSpan where
- rnf (BufSpan p1 p2) = p1 `deepseq` p2 `deepseq` ()
-
-instance NFData BufPos where
- rnf (BufPos n) = rnf n
instance NFData DeltaPos where
rnf (SameLine n) = rnf n
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/915a6781cb0c8c7a0c832dcf2a8a769431aa8da0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/915a6781cb0c8c7a0c832dcf2a8a769431aa8da0
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/20250313/20f17f9f/attachment-0001.html>
More information about the ghc-commits
mailing list