[Git][ghc/ghc][wip/issue-23516] Add `IfaceWarnings` to represent the `ModIface`-storable parts
Gergő Érdi (@cactus)
gitlab at gitlab.haskell.org
Wed Jun 14 01:07:15 UTC 2023
Gergő Érdi pushed to branch wip/issue-23516 at Glasgow Haskell Compiler / GHC
Commits:
e60e57d5 by Gergő Érdi at 2023-06-14T02:07:03+01:00
Add `IfaceWarnings` to represent the `ModIface`-storable parts
of a `Warnings GhcRn`.
Fixes #23516
- - - - -
8 changed files:
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Types/SourceText.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Unit/Module/Warnings.hs
Changes:
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -102,7 +102,6 @@ import GHC.Types.PkgQual
import GHC.Unit.External
import GHC.Unit.Module
-import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import GHC.Unit.State
@@ -1206,16 +1205,6 @@ pprTrustInfo trust = text "trusted:" <+> ppr trust
pprTrustPkg :: Bool -> SDoc
pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg
-instance Outputable (Warnings pass) where
- ppr = pprWarns
-
-pprWarns :: Warnings pass -> SDoc
-pprWarns NoWarnings = Outputable.empty
-pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt
-pprWarns (WarnSome prs) = text "Warnings:"
- <+> vcat (map pprWarning prs)
- where pprWarning (name, txt) = ppr name <+> ppr txt
-
pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
= ppr target <+> text "annotated by" <+> ppr serialized
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -66,6 +66,8 @@ import GHC.Types.SourceFile
import GHC.Types.TyThing
import GHC.Types.HpcInfo
import GHC.Types.CompleteMatch
+import GHC.Types.SourceText
+import GHC.Types.SrcLoc ( unLoc )
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -291,7 +293,7 @@ mkIface_ hsc_env
-- The order of fixities returned from nonDetNameEnvElts is not
-- deterministic, so we sort by OccName to canonicalize it.
-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details.
- warns = src_warns
+ warns = toIfaceWarnings src_warns
iface_rules = map coreRuleToIfaceRule rules
iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts)
iface_fam_insts = map famInstToIfaceFamInst fam_insts
@@ -393,6 +395,21 @@ ifaceRoughMatchTcs tcs = map do_rough tcs
do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n)
--------------------------
+toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings
+toIfaceWarnings NoWarnings = IfNoWarnings
+toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt)
+toIfaceWarnings (WarnSome prs) = IfWarnSome [(occ, toIfaceWarningTxt txt) | (occ, txt) <- prs]
+
+toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
+toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc <$> mb_cat) (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+
+toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
+toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
+
+toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral
+toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs
+
coreRuleToIfaceRule :: CoreRule -> IfaceRule
-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should
-- ensure that there's another CoreDoPluginPass that removes the rule.
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -962,7 +962,7 @@ addFingerprints hsc_env iface0
eps <- hscEPS hsc_env
let
decls = mi_decls iface0
- warn_fn = mkIfaceWarnCache (mi_warns iface0)
+ warn_fn = mkIfaceWarnCache (fromIfaceWarnings $ mi_warns iface0)
fix_fn = mkIfaceFixCache (mi_fixities iface0)
-- The ABI of a declaration represents everything that is made
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -16,6 +16,7 @@ module GHC.Iface.Syntax (
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..),
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClassBody(..),
IfaceBang(..),
@@ -32,6 +33,7 @@ module GHC.Iface.Syntax (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
+ fromIfaceWarnings,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -65,13 +67,17 @@ import GHC.Types.ForeignCall
import GHC.Types.Annotations( AnnPayload, AnnTarget )
import GHC.Types.Basic
import GHC.Unit.Module
+import GHC.Unit.Module.Warnings
import GHC.Types.SrcLoc
+import GHC.Types.SourceText
import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike )
import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.InferTags.TagSig
+import GHC.Hs.Extension ( GhcRn )
+import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
import GHC.Utils.Lexeme (isLexSym)
import GHC.Utils.Fingerprint
@@ -323,6 +329,18 @@ data IfaceRule
ifRuleOrph :: IsOrphan -- Just like IfaceClsInst
}
+data IfaceWarnings
+ = IfNoWarnings
+ | IfWarnAll IfaceWarningTxt
+ | IfWarnSome [(OccName, IfaceWarningTxt)]
+
+data IfaceWarningTxt
+ = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])]
+ | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])]
+
+data IfaceStringLiteral
+ = IfStringLiteral SourceText FastString
+
data IfaceAnnotation
= IfaceAnnotation {
ifAnnotatedTarget :: IfaceAnnTarget,
@@ -549,6 +567,24 @@ ifaceDeclFingerprints hash decl
unsafeDupablePerformIO
. computeFingerprint (panic "ifaceDeclFingerprints")
+fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn
+fromIfaceWarnings = \case
+ IfNoWarnings -> NoWarnings
+ IfWarnAll txt -> WarnAll (fromIfaceWarningTxt txt)
+ IfWarnSome prs -> WarnSome [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- prs]
+
+fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
+fromIfaceWarningTxt = \case
+ IfWarningTxt mb_cat src strs -> WarningTxt (noLoc <$> mb_cat) (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+ IfDeprecatedTxt src strs -> DeprecatedTxt (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+
+fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
+fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)
+
+fromIfaceStringLiteral :: IfaceStringLiteral -> StringLiteral
+fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing
+
+
{-
************************************************************************
* *
@@ -700,6 +736,23 @@ pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs
text "--" <+> text "incompatible with:"
<+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps
+instance Outputable IfaceWarnings where
+ ppr = \case
+ IfNoWarnings -> empty
+ IfWarnAll txt -> text "Warn all" <+> ppr txt
+ IfWarnSome prs -> text "Warnings:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- prs]
+
+instance Outputable IfaceWarningTxt where
+ ppr = \case
+ IfWarningTxt _ _ ws -> pp_ws ws
+ IfDeprecatedTxt _ ds -> pp_ws ds
+ where
+ pp_ws [msg] = ppr (snd msg)
+ pp_ws msgs = brackets $ vcat . punctuate comma . map (ppr . snd) $ msgs
+
+instance Outputable IfaceStringLiteral where
+ ppr (IfStringLiteral st fs) = pprWithSourceText st (ftext fs)
+
instance Outputable IfaceAnnotation where
ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value
@@ -2236,6 +2289,28 @@ instance Binary IfaceRule where
a8 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
+instance Binary IfaceWarnings where
+ put_ bh = \case
+ IfNoWarnings -> putByte bh 0
+ IfWarnAll txt -> putByte bh 1 *> put_ bh txt
+ IfWarnSome prs -> putByte bh 2 *> put_ bh prs
+ get bh = getByte bh >>= \case
+ 0 -> pure IfNoWarnings
+ 1 -> pure IfWarnAll <*> get bh
+ _ -> pure IfWarnSome <*> get bh
+
+instance Binary IfaceWarningTxt where
+ put_ bh = \case
+ IfWarningTxt a1 a2 a3 -> putByte bh 0 *> put_ bh a1 *> put_ bh a2 *> put_ bh a3
+ IfDeprecatedTxt a1 a2 -> putByte bh 1 *> put_ bh a1 *> put_ bh a2
+ get bh = getByte bh >>= \case
+ 0 -> pure IfWarningTxt <*> get bh <*> get bh <*> get bh
+ _ -> pure IfDeprecatedTxt <*> get bh <*> get bh
+
+instance Binary IfaceStringLiteral where
+ put_ bh (IfStringLiteral a1 a2) = put_ bh a1 *> put_ bh a2
+ get bh = IfStringLiteral <$> get bh <*> get bh
+
instance Binary IfaceAnnotation where
put_ bh (IfaceAnnotation a1 a2) = do
put_ bh a1
@@ -2786,5 +2861,19 @@ instance NFData IfaceClsInst where
rnf (IfaceClsInst f1 f2 f3 f4 f5) =
f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` ()
+instance NFData IfaceWarnings where
+ rnf = \case
+ IfNoWarnings -> ()
+ IfWarnAll txt -> rnf txt
+ IfWarnSome txts -> rnf txts
+
+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
+
+instance NFData IfaceStringLiteral where
+ rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2
+
instance NFData IfaceAnnotation where
rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` ()
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -47,6 +47,7 @@ import GHC.Tc.Zonk.TcType ( tcInitTidyEnv )
import GHC.Hs
import GHC.Iface.Load ( loadSrcInterface )
+import GHC.Iface.Syntax ( fromIfaceWarnings )
import GHC.Builtin.Names
import GHC.Parser.PostProcess ( setRdrNameSpace )
import GHC.Core.Type
@@ -422,7 +423,7 @@ rnImportDecl this_mod
imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv)
-- Complain if we import a deprecated module
- case mi_warns iface of
+ case fromIfaceWarnings (mi_warns iface) of
WarnAll txt -> addDiagnostic (TcRnDeprecatedModule imp_mod_name txt)
_ -> return ()
=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -1,5 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Source text
--
@@ -39,6 +41,7 @@ import Data.Function (on)
import Data.Data
import GHC.Real ( Ratio(..) )
import GHC.Types.SrcLoc
+import Control.DeepSeq
{-
Note [Pragma source text]
@@ -107,6 +110,11 @@ instance Outputable SourceText where
ppr (SourceText s) = text "SourceText" <+> ftext s
ppr NoSourceText = text "NoSourceText"
+instance NFData SourceText where
+ rnf = \case
+ SourceText s -> rnf s
+ NoSourceText -> ()
+
instance Binary SourceText where
put_ bh NoSourceText = putByte bh 0
put_ bh (SourceText s) = do
@@ -315,12 +323,3 @@ instance Eq StringLiteral where
instance Outputable StringLiteral where
ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
-
-instance Binary StringLiteral where
- put_ bh (StringLiteral st fs _) = do
- put_ bh st
- put_ bh fs
- get bh = do
- st <- get bh
- fs <- get bh
- return (StringLiteral st fs Nothing)
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -185,7 +185,7 @@ data ModIface_ (phase :: ModIfacePhase)
-- ^ Fixities
-- NOT STRICT! we read this field lazily from the interface file
- mi_warns :: (Warnings GhcRn),
+ mi_warns :: IfaceWarnings,
-- ^ Warnings
-- NOT STRICT! we read this field lazily from the interface file
@@ -479,7 +479,7 @@ instance Binary ModIface where
mi_finsts = hasFamInsts,
mi_exp_hash = exp_hash,
mi_orphan_hash = orphan_hash,
- mi_warn_fn = mkIfaceWarnCache warns,
+ mi_warn_fn = mkIfaceWarnCache $ fromIfaceWarnings warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls
}})
@@ -498,7 +498,7 @@ emptyPartialModIface mod
mi_exports = [],
mi_used_th = False,
mi_fixities = [],
- mi_warns = NoWarnings,
+ mi_warns = IfNoWarnings,
mi_anns = [],
mi_insts = [],
mi_fam_insts = [],
@@ -567,7 +567,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
`seq` mi_exports
`seq` rnf mi_used_th
`seq` mi_fixities
- `seq` mi_warns
+ `seq` rnf mi_warns
`seq` rnf mi_anns
`seq` rnf mi_decls
`seq` rnf mi_extra_decls
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE LambdaCase #-}
-- | Warnings for a module
module GHC.Unit.Module.Warnings
@@ -40,7 +41,6 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Hs.Doc
-import GHC.Hs.Extension
import GHC.Utils.Outputable
import GHC.Utils.Binary
@@ -51,6 +51,7 @@ import Language.Haskell.Syntax.Extension
import Data.Data
import Data.List (isPrefixOf)
import GHC.Generics ( Generic )
+import Control.DeepSeq
{-
@@ -103,7 +104,7 @@ the possibility of them being infinite.
-- See Note [Warning categories]
newtype WarningCategory = WarningCategory FastString
- deriving (Binary, Data, Eq, Outputable, Show, Uniquable)
+ deriving (Binary, Data, Eq, Outputable, Show, Uniquable, NFData)
mkWarningCategory :: FastString -> WarningCategory
mkWarningCategory = WarningCategory
@@ -203,29 +204,6 @@ instance Outputable (WarningTxt pass) where
NoSourceText -> pp_ws ds
SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
-instance Binary (WarningTxt GhcRn) where
- put_ bh (WarningTxt c s w) = do
- putByte bh 0
- put_ bh $ unLoc <$> c
- put_ bh $ unLoc s
- put_ bh $ unLoc <$> w
- put_ bh (DeprecatedTxt s d) = do
- putByte bh 1
- put_ bh $ unLoc s
- put_ bh $ unLoc <$> d
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do c <- fmap noLoc <$> get bh
- s <- noLoc <$> get bh
- w <- fmap noLoc <$> get bh
- return (WarningTxt c s w)
- _ -> do s <- noLoc <$> get bh
- d <- fmap noLoc <$> get bh
- return (DeprecatedTxt s d)
-
-
pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [l] = ppr $ unLoc l
pp_ws ws
@@ -271,24 +249,6 @@ data Warnings pass
deriving instance Eq (IdP pass) => Eq (Warnings pass)
-instance Binary (Warnings GhcRn) where
- put_ bh NoWarnings = putByte bh 0
- put_ bh (WarnAll t) = do
- putByte bh 1
- put_ bh t
- put_ bh (WarnSome ts) = do
- putByte bh 2
- put_ bh ts
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoWarnings
- 1 -> do aa <- get bh
- return (WarnAll aa)
- _ -> do aa <- get bh
- return (WarnSome aa)
-
-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)
mkIfaceWarnCache NoWarnings = \_ -> Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e60e57d5e3e2979fc91edd2c9bc62c41b4311041
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e60e57d5e3e2979fc91edd2c9bc62c41b4311041
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/20230613/81b2e592/attachment-0001.html>
More information about the ghc-commits
mailing list