primops: Ensure that deprecations are properly tracked

We previously failed to insert DEPRECATION pragmas into GHC.Prim's
ModIface, meaning that they would appear in the Haddock documentation
but not issue warnings. Fix this.

Fixes #19629.

7 files changed, 67 insertions, 7 deletions

diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index 99a4f1ba43..5be89479b6 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -17,6 +17,7 @@ module GHC.Builtin.PrimOps (
         primOpOutOfLine, primOpCodeSize,
         primOpOkForSpeculation, primOpOkForSideEffects,
         primOpIsCheap, primOpFixity, primOpDocs,
+        primOpDeprecations,
 
         getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..),
 
@@ -154,12 +155,15 @@ primOpFixity :: PrimOp -> Maybe Fixity
 *                                                                      *
 ************************************************************************
 
-See Note [GHC.Prim Docs]
+See Note [GHC.Prim Docs] in genprimopcode's Main.hs
 -}
 
 primOpDocs :: [(FastString, String)]
 #include "primop-docs.hs-incl"
 
+primOpDeprecations :: [(OccName, String)]
+#include "primop-deprecations.hs-incl"
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index b52498129f..04786d4da1 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -70,7 +70,7 @@ import GHC.Settings.Constants
 
 import GHC.Builtin.Names
 import GHC.Builtin.Utils
-import GHC.Builtin.PrimOps    ( allThePrimOps, primOpFixity, primOpOcc )
+import GHC.Builtin.PrimOps    ( allThePrimOps, primOpFixity, primOpOcc, primOpDeprecations )
 
 import GHC.Core.Rules
 import GHC.Core.TyCon
@@ -1007,8 +1007,12 @@ ghcPrimIface
         mi_exports  = ghcPrimExports,
         mi_decls    = [],
         mi_fixities = fixities,
-        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },
-        mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs]
+        mi_decl_docs = ghcPrimDeclDocs, -- See Note [GHC.Prim Docs]
+        mi_warns = warns,
+        mi_final_exts = (mi_final_exts empty_iface)
+          { mi_warn_fn = mkIfaceWarnCache warns
+          , mi_fix_fn = mkIfaceFixCache fixities
+          }
         }
   where
     empty_iface = emptyFullModIface gHC_PRIM
@@ -1018,7 +1022,19 @@ ghcPrimIface
     fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
              : mapMaybe mkFixity allThePrimOps
     mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
-
+    -- See Note [GHC.Prim deprecations] in genprimopcode's Main.hs
+    warns
+      | null primOpDeprecations
+      = NoWarnings
+      | otherwise
+      = WarnSome
+        [ (occ, warnTxt)
+        | (occ, deprMsg) <- primOpDeprecations
+        , let stxt = SourceText deprMsg
+              warnTxt = DeprecatedTxt
+                (noLoc stxt)
+                [noLoc $ StringLiteral stxt (fsLit deprMsg) Nothing]
+        ]
 {-
 *********************************************************
 *                                                      *
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 2751218adf..e7e3f869c8 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -122,7 +122,8 @@ PRIMOP_BITS_NAMES = primop-data-decl.hs-incl        \
                     primop-vector-tys.hs-incl       \
                     primop-vector-tys-exports.hs-incl \
                     primop-vector-tycons.hs-incl    \
-                    primop-docs.hs-incl
+                    primop-docs.hs-incl             \
+                    primop-deprecations.hs-incl
 
 PRIMOP_BITS_STAGE1 = $(addprefix compiler/stage1/build/,$(PRIMOP_BITS_NAMES))
 PRIMOP_BITS_STAGE2 = $(addprefix compiler/stage2/build/,$(PRIMOP_BITS_NAMES))
@@ -171,6 +172,8 @@ compiler/stage$1/build/primop-vector-tycons.hs-incl: compiler/stage$1/build/prim
 	"$$(genprimopcode_INPLACE)" --primop-vector-tycons      < $$< > $$@
 compiler/stage$1/build/primop-docs.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE)
 	"$$(genprimopcode_INPLACE)" --wired-in-docs             < $$< > $$@
+compiler/stage$1/build/primop-deprecations.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE)
+	"$$(genprimopcode_INPLACE)" --wired-in-deprecations     < $$< > $$@
 
 # Usages aren't used any more; but the generator
 # can still generate them if we want them back
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index 6e4335fbc2..373fac1224 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -69,6 +69,7 @@ compilerDependencies = do
                   , "primop-vector-tys.hs-incl"
                   , "primop-vector-uniques.hs-incl"
                   , "primop-docs.hs-incl"
+                  , "primop-deprecations.hs-incl"
                   , "GHC/Platform/Constants.hs"
                   ] ]
 
diff --git a/hadrian/src/Rules/Lint.hs b/hadrian/src/Rules/Lint.hs
index f02a63b6b0..e24dfd0b24 100644
--- a/hadrian/src/Rules/Lint.hs
+++ b/hadrian/src/Rules/Lint.hs
@@ -91,6 +91,7 @@ hsIncls path = [ path </> "primop-vector-tycons.hs-incl"
                , path </> "primop-strictness.hs-incl"
                , path </> "primop-fixity.hs-incl"
                , path </> "primop-docs.hs-incl"
+               , path </> "primop-deprecations.hs-incl"
                , path </> "primop-primop-info.hs-incl"
                , path </> "primop-out-of-line.hs-incl"
                , path </> "primop-has-side-effects.hs-incl"
diff --git a/hadrian/src/Settings/Builders/GenPrimopCode.hs b/hadrian/src/Settings/Builders/GenPrimopCode.hs
index 2640ee14c7..5e5a3fc63f 100644
--- a/hadrian/src/Settings/Builders/GenPrimopCode.hs
+++ b/hadrian/src/Settings/Builders/GenPrimopCode.hs
@@ -22,4 +22,5 @@ genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat
     , output "//primop-vector-tys-exports.hs-incl" ? arg "--primop-vector-tys-exports"
     , output "//primop-vector-tycons.hs-incl"      ? arg "--primop-vector-tycons"
     , output "//primop-docs.hs-incl"               ? arg "--wired-in-docs"
+    , output "//primop-deprecations.hs-incl"       ? arg "--wired-in-deprecations"
     , output "//primop-usage.hs-incl"              ? arg "--usage" ]
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index f5b47125c7..a659c096fc 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -194,6 +194,9 @@ main = getArgs >>= \args ->
                       "--wired-in-docs"
                          -> putStr (gen_wired_in_docs p_o_specs)
 
+                      "--wired-in-deprecations"
+                         -> putStr (gen_wired_in_deprecations p_o_specs)
+
                       _ -> error "Should not happen, known_args out of sync?"
                    )
 
@@ -217,7 +220,8 @@ known_args
        "--make-haskell-wrappers",
        "--make-haskell-source",
        "--make-latex-doc",
-       "--wired-in-docs"
+       "--wired-in-docs",
+       "--wired-in-deprecations"
      ]
 
 ------------------------------------------------------------------
@@ -815,6 +819,36 @@ gen_wired_in_docs (Info _ entries)
       , not $ null $ desc po = Just $ "(fsLit " ++ show poName ++ "," ++ show (unlatex $ desc po) ++ ")"
       | otherwise = Nothing
 
+{-
+Note [GHC.Prim Deprecations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Like Haddock documentation, we must record deprecation pragmas in two places:
+in the GHC.Prim source module consumed by Haddock, and in the
+declarations wired-in to GHC. To do the following we generate
+GHC.Builtin.PrimOps.primOpDeprecations, a list of (OccName, DeprecationMessage)
+pairs. We insert these deprecations into the mi_warns field of GHC.Prim's ModIface,
+as though they were written in a source module.
+-}
+gen_wired_in_deprecations :: Info -> String
+gen_wired_in_deprecations (Info _ entries)
+  = "primOpDeprecations =\n  [ "
+    ++ intercalate "\n  , " (catMaybes $ map mkDep $ concatMap desugarVectorSpec entries)
+    ++ "\n  ]\n"
+    where
+      mkDep po
+        | Just poName <- getName po
+        , Just (OptionString _ depMsg) <- lookup_attrib "deprecated_msg" (opts po)
+        = let mkOcc =
+                case po of
+                  PrimOpSpec{}      -> "mkVarOcc"
+                  PrimVecOpSpec{}   -> "mkVarOcc"
+                  PseudoOpSpec{}    -> "mkVarOcc"
+                  PrimTypeSpec{}    -> "mkTcOcc"
+                  PrimVecTypeSpec{} -> "mkTcOcc"
+                  Section{}         -> error "impossible(Section)"
+          in Just $ "(" ++ mkOcc ++ " " ++ show poName ++ ", " ++ show depMsg ++ ")"
+        | otherwise = Nothing
+
 
 ------------------------------------------------------------------
 -- Create PrimOpInfo text from PrimOpSpecs -----------------------