diff options
| -rw-r--r-- | compiler/GHC/Builtin/PrimOps.hs | 19 | ||||
| -rw-r--r-- | compiler/GHC/Builtin/PrimOps/Ids.hs | 80 | ||||
| -rw-r--r-- | compiler/GHC/Builtin/Utils.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 21 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs-boot | 8 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/StgToByteCode.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id/Make.hs | 40 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id/Make.hs-boot | 4 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | testsuite/tests/count-deps/CountDepsAst.stdout | 4 | ||||
| -rw-r--r-- | testsuite/tests/count-deps/CountDepsParser.stdout | 4 |
13 files changed, 126 insertions, 91 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 diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 05fb3712ae..a53b2d3f14 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,6 +1,7 @@ -Found 277 Language.Haskell.Syntax module dependencies +Found 279 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps +GHC.Builtin.PrimOps.Ids GHC.Builtin.Types GHC.Builtin.Types.Prim GHC.Builtin.Uniques @@ -77,6 +78,7 @@ GHC.Data.List.SetOps GHC.Data.Maybe GHC.Data.OrdList GHC.Data.Pair +GHC.Data.SmallArray GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 11b74ade5f..11fa8e2d08 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,6 +1,7 @@ -Found 283 GHC.Parser module dependencies +Found 285 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps +GHC.Builtin.PrimOps.Ids GHC.Builtin.Types GHC.Builtin.Types.Prim GHC.Builtin.Uniques @@ -77,6 +78,7 @@ GHC.Data.List.SetOps GHC.Data.Maybe GHC.Data.OrdList GHC.Data.Pair +GHC.Data.SmallArray GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer |