summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-12-20 15:19:20 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-01-06 02:24:54 -0500
commitec26c38bfac24d958377abbae6fce3a6fcf4ae39 (patch)
tree42f27638f1605424be0cfc4323922ed01985a551 /compiler
parentc080b44314248545c6ddea0c0eff02f8c9edbca4 (diff)
downloadhaskell-ec26c38bfac24d958377abbae6fce3a6fcf4ae39.tar.gz
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.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Builtin/PrimOps.hs19
-rw-r--r--compiler/GHC/Builtin/PrimOps/Ids.hs80
-rw-r--r--compiler/GHC/Builtin/Utils.hs27
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs21
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs-boot8
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs5
-rw-r--r--compiler/GHC/StgToByteCode.hs2
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs2
-rw-r--r--compiler/GHC/Types/Id/Make.hs40
-rw-r--r--compiler/GHC/Types/Id/Make.hs-boot4
-rw-r--r--compiler/ghc.cabal.in1
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