[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