Use primOpIds cache more often (#20857)

Use primOpId instead of mkPrimOpId in a few places to benefit from
Id caching.

I had to mess a little bit with the module hierarchy to fix cycles and
to avoid adding too many new dependencies to count-deps tests.

11 files changed, 120 insertions, 89 deletions

diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index c048482a8a..d1df0fbaf2 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -28,25 +28,30 @@ import GHC.Prelude
 
 import GHC.Builtin.Types.Prim
 import GHC.Builtin.Types
+import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )
+import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )
+
+import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )
+import GHC.Core.Type
 
 import GHC.Cmm.Type
+
 import GHC.Types.Demand
-import GHC.Types.Id      ( Id, mkVanillaGlobalWithInfo )
-import GHC.Types.Id.Info ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) )
+import GHC.Types.Id
+import GHC.Types.Id.Info
 import GHC.Types.Name
-import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )
-import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )
-import GHC.Core.Type
 import GHC.Types.RepType ( tyConPrimRep1 )
-import GHC.Types.Basic   ( Arity )
+import GHC.Types.Basic
 import GHC.Types.Fixity  ( Fixity(..), FixityDirection(..) )
 import GHC.Types.SrcLoc  ( wiredInSrcSpan )
 import GHC.Types.ForeignCall ( CLabelString )
 import GHC.Types.SourceText  ( SourceText(..) )
 import GHC.Types.Unique  ( Unique)
-import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )
+
 import GHC.Unit.Types    ( Unit )
+
 import GHC.Utils.Outputable
+
 import GHC.Data.FastString
 
 {-
diff --git a/compiler/GHC/Builtin/PrimOps/Ids.hs b/compiler/GHC/Builtin/PrimOps/Ids.hs
new file mode 100644
index 0000000000..cf6f846f77
--- /dev/null
+++ b/compiler/GHC/Builtin/PrimOps/Ids.hs
@@ -0,0 +1,80 @@
+-- | PrimOp's Ids
+module GHC.Builtin.PrimOps.Ids
+  ( primOpId
+  , allThePrimOpIds
+  )
+where
+
+import GHC.Prelude
+
+-- primop rules are attached to primop ids
+import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules)
+import GHC.Core.Type (mkForAllTys, mkVisFunTysMany)
+import GHC.Core.FVs (mkRuleInfo)
+
+import GHC.Builtin.PrimOps
+import GHC.Builtin.Uniques
+import GHC.Builtin.Names
+
+import GHC.Types.Basic
+import GHC.Types.Cpr
+import GHC.Types.Demand
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Types.TyThing
+import GHC.Types.Name
+
+import GHC.Data.SmallArray
+import Data.Maybe ( maybeToList )
+
+
+-- | Build a PrimOp Id
+mkPrimOpId :: PrimOp -> Id
+mkPrimOpId prim_op
+  = id
+  where
+    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
+    ty   = mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
+    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
+                         (mkPrimOpIdUnique (primOpTag prim_op))
+                         (AnId id) UserSyntax
+    id   = mkGlobalId (PrimOpId prim_op) name ty info
+
+    -- PrimOps don't ever construct a product, but we want to preserve bottoms
+    cpr
+      | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr
+      | otherwise                                   = topCpr
+
+    info = noCafIdInfo
+           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)
+           `setArityInfo`          arity
+           `setDmdSigInfo`         strict_sig
+           `setCprSigInfo`         mkCprSig arity cpr
+           `setInlinePragInfo`     neverInlinePragma
+           `setLevityInfoWithType` res_ty
+               -- We give PrimOps a NOINLINE pragma so that we don't
+               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule
+               -- test) about a RULE conflicting with a possible inlining
+               -- cf #7287
+
+
+-------------------------------------------------------------
+-- Cache of PrimOp's Ids
+-------------------------------------------------------------
+
+-- | A cache of the PrimOp Ids, indexed by PrimOp tag (0 indexed)
+primOpIds :: SmallArray Id
+{-# NOINLINE primOpIds #-}
+primOpIds = listToArray (maxPrimOpTag+1) primOpTag mkPrimOpId allThePrimOps
+
+-- | Get primop id.
+--
+-- Retrieve it from `primOpIds` cache.
+primOpId :: PrimOp -> Id
+{-# INLINE primOpId #-}
+primOpId op = indexSmallArray primOpIds (primOpTag op)
+
+-- | All the primop ids, as a list
+allThePrimOpIds :: [Id]
+{-# INLINE allThePrimOpIds #-}
+allThePrimOpIds = map (indexSmallArray primOpIds) [0..maxPrimOpTag]
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
index 4428716681..c577c46b75 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -31,11 +31,9 @@ module GHC.Builtin.Utils (
 
         -- * Miscellaneous
         wiredInIds, ghcPrimIds,
-        primOpRules, builtinRules,
 
         ghcPrimExports,
         ghcPrimDeclDocs,
-        primOpId,
 
         -- * Random other things
         maybeCharLikeCon, maybeIntLikeCon,
@@ -49,6 +47,7 @@ import GHC.Prelude
 
 import GHC.Builtin.Uniques
 import GHC.Builtin.PrimOps
+import GHC.Builtin.PrimOps.Ids
 import GHC.Builtin.Types
 import GHC.Builtin.Types.Literals ( typeNatTyCons )
 import GHC.Builtin.Types.Prim
@@ -56,7 +55,6 @@ import GHC.Builtin.Names.TH ( templateHaskellNames )
 import GHC.Builtin.Names
 
 import GHC.Core.ConLike ( ConLike(..) )
-import GHC.Core.Opt.ConstantFold
 import GHC.Core.DataCon
 import GHC.Core.Class
 import GHC.Core.TyCon
@@ -78,7 +76,6 @@ import GHC.Hs.Doc
 import GHC.Unit.Module.ModIface (IfaceExport)
 
 import GHC.Data.List.SetOps
-import GHC.Data.SmallArray
 
 import Control.Applicative ((<|>))
 import Data.List        ( intercalate , find )
@@ -230,30 +227,8 @@ knownNamesInfo = unitNameEnv coercibleTyConName $
 We let a lot of "non-standard" values be visible, so that we can make
 sense of them in interface pragmas. It's cool, though they all have
 "non-standard" names, so they won't get past the parser in user code.
-
-************************************************************************
-*                                                                      *
-                PrimOpIds
-*                                                                      *
-************************************************************************
 -}
 
--- | A cache of the PrimOp Ids, indexed by PrimOp tag (0 indexed)
-primOpIds :: SmallArray Id
-{-# NOINLINE primOpIds #-}
-primOpIds = listToArray (maxPrimOpTag+1) primOpTag mkPrimOpId allThePrimOps
-
--- | Get primop id.
---
--- Retrieve it from `primOpIds` cache without performing bounds checking.
-primOpId :: PrimOp -> Id
-primOpId op = indexSmallArray primOpIds (primOpTag op)
-
--- | All the primop ids, as a list
-allThePrimOpIds :: [Id]
-{-# INLINE allThePrimOpIds #-}
-allThePrimOpIds = map (indexSmallArray primOpIds) [0..maxPrimOpTag]
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 919520cb83..bb4ce7822b 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -34,7 +34,7 @@ import GHC.Prelude
 
 import GHC.Platform
 
-import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, voidPrimId )
+import GHC.Types.Id.Make ( voidPrimId )
 import GHC.Types.Id
 import GHC.Types.Literal
 import GHC.Types.Name.Occurrence ( occNameFS )
@@ -57,6 +57,7 @@ import GHC.Core.TyCon
 import GHC.Core.Map.Expr ( eqCoreExpr )
 
 import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
+import GHC.Builtin.PrimOps.Ids (primOpId)
 import GHC.Builtin.Types
 import GHC.Builtin.Types.Prim
 import GHC.Builtin.Names
@@ -437,9 +438,9 @@ primOpRules nm = \case
                                         platform <- getPlatform
                                         pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
                                           [ Lit (zeroi platform)
-                                          , mkCoreApps (Var (mkPrimOpId IntSubOp))
+                                          , mkCoreApps (Var (primOpId IntSubOp))
                                               [ Lit (zeroi platform)
-                                              , mkCoreApps (Var (mkPrimOpId IntSrlOp))
+                                              , mkCoreApps (Var (primOpId IntSrlOp))
                                                 [ other
                                                 , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1))
                                                 ]
@@ -1297,7 +1298,7 @@ subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
 this `subsumesPrimOp` that = do
   [Var primop_id `App` e] <- getArgs
   matchPrimOpId that primop_id
-  return (Var (mkPrimOpId this) `App` e)
+  return (Var (primOpId this) `App` e)
 
 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
 subsumedByPrimOp primop = do
@@ -1310,7 +1311,7 @@ extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr
 extendNarrowPassthrough narrow_primop n = do
   [Var primop_id `App` x] <- getArgs
   matchPrimOpId narrow_primop primop_id
-  return (Var (mkPrimOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n))
+  return (Var (primOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n))
 
 -- | narrow subsumes bitwise `and` with full mask (cf #16402):
 --
@@ -1328,7 +1329,7 @@ narrowSubsumesAnd and_primop narrw n = do
   let mask = bit n -1
       g v (Lit (LitNumber _ m)) = do
          guard (m .&. mask == mask)
-         return (Var (mkPrimOpId narrw) `App` v)
+         return (Var (primOpId narrw) `App` v)
       g _ _ = mzero
   g x y <|> g y x
 
@@ -1727,7 +1728,7 @@ strengthReduction two_lit add_op = do -- Note [Strength reduction]
               , do [Lit mult_lit, arg] <- getArgs
                    guard (mult_lit == two_lit)
                    return arg ]
-  return $ Var (mkPrimOpId add_op) `App` arg `App` arg
+  return $ Var (primOpId add_op) `App` arg `App` arg
 
 -- Note [Strength reduction]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2028,7 +2029,7 @@ builtinRules
           [arg, Lit (LitNumber LitNumInt d)] <- getArgs
           Just n <- return $ exactLog2 d
           platform <- getPlatform
-          return $ Var (mkPrimOpId IntSraOp) `App` arg `App` mkIntVal platform n
+          return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n
         ],
 
      mkBasicRule modIntName 2 $ msum
@@ -2038,7 +2039,7 @@ builtinRules
           [arg, Lit (LitNumber LitNumInt d)] <- getArgs
           Just _ <- return $ exactLog2 d
           platform <- getPlatform
-          return $ Var (mkPrimOpId IntAndOp)
+          return $ Var (primOpId IntAndOp)
             `App` arg `App` mkIntVal platform (d - 1)
         ]
      ]
@@ -3005,7 +3006,7 @@ pattern BinOpApp x op y = OpVal op `App` x `App` y
 -- | Match a primop
 pattern OpVal:: PrimOp  -> Arg CoreBndr
 pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where
-   OpVal op = Var (mkPrimOpId op)
+   OpVal op = Var (primOpId op)
 
 -- | Match a literal
 pattern L :: Integer -> Arg CoreBndr
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs-boot b/compiler/GHC/Core/Opt/ConstantFold.hs-boot
new file mode 100644
index 0000000000..216af660ae
--- /dev/null
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs-boot
@@ -0,0 +1,8 @@
+module GHC.Core.Opt.ConstantFold where
+
+import GHC.Prelude
+import GHC.Core
+import GHC.Builtin.PrimOps
+import GHC.Types.Name
+
+primOpRules ::  Name -> PrimOp -> Maybe CoreRule
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index e3932e835e..763157ef82 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -30,6 +30,7 @@ import GHC.Unit
 
 import GHC.Builtin.Names
 import GHC.Builtin.PrimOps
+import GHC.Builtin.PrimOps.Ids (primOpId)
 import GHC.Builtin.Types
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
 
@@ -67,7 +68,7 @@ import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Id
 import GHC.Types.Id.Info
-import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
+import GHC.Types.Id.Make ( realWorldPrimId )
 import GHC.Types.Basic
 import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )
 import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
@@ -1021,7 +1022,7 @@ cpeApp top_env expr
              ; (floats, k') <- case k of
                   Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2)
                   _          -> cpe_app env k (CpeApp s0 : rest) (n-1)
-             ; let touchId = mkPrimOpId TouchOp
+             ; let touchId = primOpId TouchOp
                    expr = Case k' y result_ty [Alt DEFAULT [] rhs]
                    rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId]
                          in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)]
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index 3e027d07b5..a69fe69872 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -42,6 +42,7 @@ import GHC.Types.ForeignCall
 import GHC.Core
 import GHC.Types.Literal
 import GHC.Builtin.PrimOps
+import GHC.Builtin.PrimOps.Ids (primOpId)
 import GHC.Core.Type
 import GHC.Types.RepType
 import GHC.Core.DataCon
@@ -54,7 +55,6 @@ import GHC.Core.TyCo.Ppr ( pprType )
 import GHC.Utils.Error
 import GHC.Types.Unique
 import GHC.Builtin.Uniques
-import GHC.Builtin.Utils ( primOpId )
 import GHC.Data.FastString
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index a061674af9..7d5ae9d763 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -53,13 +53,13 @@ import GHC.Types.Name
 import GHC.Types.SourceText
 
 import GHC.Driver.Session
-import GHC.Builtin.Utils
 import GHC.Tc.Instance.Family
 import GHC.Core.FamInstEnv
 import GHC.Builtin.Names
 import GHC.Builtin.Names.TH
 import GHC.Types.Id.Make ( coerceId )
 import GHC.Builtin.PrimOps
+import GHC.Builtin.PrimOps.Ids (primOpId)
 import GHC.Types.SrcLoc
 import GHC.Core.TyCon
 import GHC.Tc.Utils.Env
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 085214bb50..3992c993fd 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -19,7 +19,7 @@ have a standard form, namely:
 module GHC.Types.Id.Make (
         mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
 
-        mkPrimOpId, mkFCallId,
+        mkFCallId,
 
         unwrapNewTypeBody, wrapFamInstBody,
         DataConBoxer(..), vanillaDataConBoxer,
@@ -33,16 +33,12 @@ module GHC.Types.Id.Make (
         coercionTokenId, coerceId,
         proxyHashId, noinlineId, noinlineIdName,
         coerceName, leftSectionName, rightSectionName,
-
-        -- Re-export error Ids
-        module GHC.Core.Opt.ConstantFold
     ) where
 
 import GHC.Prelude
 
 import GHC.Builtin.Types.Prim
 import GHC.Builtin.Types
-import GHC.Core.Opt.ConstantFold
 import GHC.Core.Type
 import GHC.Core.Multiplicity
 import GHC.Core.TyCo.Rep
@@ -61,17 +57,14 @@ import GHC.Core.TyCon
 import GHC.Core.Class
 import GHC.Types.Name.Set
 import GHC.Types.Name
-import GHC.Builtin.PrimOps
 import GHC.Types.ForeignCall
 import GHC.Core.DataCon
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Demand
 import GHC.Types.Cpr
-import GHC.Types.TyThing
 import GHC.Core
 import GHC.Types.Unique
-import GHC.Builtin.Uniques
 import GHC.Types.Unique.Supply
 import GHC.Builtin.Names
 import GHC.Types.Basic       hiding ( SuccessFlag(..) )
@@ -86,7 +79,6 @@ import GHC.Data.List.SetOps
 import GHC.Types.Var (VarBndr(Bndr))
 import qualified GHC.LanguageExtensions as LangExt
 
-import Data.Maybe       ( maybeToList )
 
 {-
 ************************************************************************
@@ -1284,39 +1276,11 @@ wrapFamInstBody tycon args body
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Primitive operations}
+* Foreign calls
 *                                                                      *
 ************************************************************************
 -}
 
-mkPrimOpId :: PrimOp -> Id
-mkPrimOpId prim_op
-  = id
-  where
-    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
-    ty   = mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
-    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
-                         (mkPrimOpIdUnique (primOpTag prim_op))
-                         (AnId id) UserSyntax
-    id   = mkGlobalId (PrimOpId prim_op) name ty info
-
-    -- PrimOps don't ever construct a product, but we want to preserve bottoms
-    cpr
-      | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr
-      | otherwise                                   = topCpr
-
-    info = noCafIdInfo
-           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)
-           `setArityInfo`          arity
-           `setDmdSigInfo`     strict_sig
-           `setCprSigInfo`            mkCprSig arity cpr
-           `setInlinePragInfo`     neverInlinePragma
-           `setLevityInfoWithType` res_ty
-               -- We give PrimOps a NOINLINE pragma so that we don't
-               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule
-               -- test) about a RULE conflicting with a possible inlining
-               -- cf #7287
-
 -- For each ccall we manufacture a separate CCallOpId, giving it
 -- a fresh unique, a type that is correct for this particular ccall,
 -- and a CCall structure that gives the correct details about calling
diff --git a/compiler/GHC/Types/Id/Make.hs-boot b/compiler/GHC/Types/Id/Make.hs-boot
index 6a3f5c44be..0e39a40e97 100644
--- a/compiler/GHC/Types/Id/Make.hs-boot
+++ b/compiler/GHC/Types/Id/Make.hs-boot
@@ -3,12 +3,8 @@ import GHC.Types.Name( Name )
 import GHC.Types.Var( Id )
 import GHC.Core.Class( Class )
 import {-# SOURCE #-} GHC.Core.DataCon( DataCon )
-import {-# SOURCE #-} GHC.Builtin.PrimOps( PrimOp )
 
 data DataConBoxer
 
 mkDataConWorkId :: Name -> DataCon -> Id
 mkDictSelId     :: Name -> Class   -> Id
-
-mkPrimOpId      :: PrimOp -> Id
-voidPrimId      :: Id
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 89c6bfb51f..8be3744846 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -152,6 +152,7 @@ Library
         GHC.Builtin.Names
         GHC.Builtin.Names.TH
         GHC.Builtin.PrimOps
+        GHC.Builtin.PrimOps.Ids
         GHC.Builtin.Types
         GHC.Builtin.Types.Literals
         GHC.Builtin.Types.Prim