summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Builtin/PrimOps/Ids.hs1
-rw-r--r--compiler/GHC/Core/Type.hs12
-rw-r--r--compiler/GHC/Core/Utils.hs1
-rw-r--r--compiler/GHC/CoreToIface.hs6
-rw-r--r--compiler/GHC/Iface/Syntax.hs5
-rw-r--r--compiler/GHC/IfaceToCore.hs1
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs6
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs3
-rw-r--r--compiler/GHC/Types/Id.hs4
-rw-r--r--compiler/GHC/Types/Id/Info.hs83
-rw-r--r--compiler/GHC/Types/Id/Make.hs21
11 files changed, 14 insertions, 129 deletions
diff --git a/compiler/GHC/Builtin/PrimOps/Ids.hs b/compiler/GHC/Builtin/PrimOps/Ids.hs
index cf6f846f77..9c6984a018 100644
--- a/compiler/GHC/Builtin/PrimOps/Ids.hs
+++ b/compiler/GHC/Builtin/PrimOps/Ids.hs
@@ -51,7 +51,6 @@ mkPrimOpId prim_op
`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
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index bc864c301f..fbe499ee79 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -149,7 +149,7 @@ module GHC.Core.Type (
Kind,
-- ** Finding the kind of a type
- typeKind, tcTypeKind, typeHasFixedRuntimeRep, resultHasFixedRuntimeRep,
+ typeKind, tcTypeKind, typeHasFixedRuntimeRep,
tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,
tcIsBoxedTypeKind, tcIsRuntimeTypeKind,
@@ -3194,16 +3194,6 @@ typeHasFixedRuntimeRep = go
go (ForAllTy _ ty) = go ty
go ty = isFixedRuntimeRepKind (typeKind ty)
--- | Looking past all pi-types, does the end result have a
--- fixed runtime rep, as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?
---
--- Examples:
---
--- * False for @(forall r (a :: TYPE r). String -> a)@
--- * True for @(forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)@
-resultHasFixedRuntimeRep :: Type -> Bool
-resultHasFixedRuntimeRep = typeHasFixedRuntimeRep . snd . splitPiTys
-
{- **********************************************************************
* *
Occurs check expansion
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 43dd5169e1..d6653fd387 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -2280,7 +2280,6 @@ diffIdInfo env bndr1 bndr2
&& occInfo info1 == occInfo info2
&& demandInfo info1 == demandInfo info2
&& callArityInfo info1 == callArityInfo info2
- && levityInfo info1 == levityInfo info2
= locBind "in unfolding of" bndr1 bndr2 $
diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2)
| otherwise
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 11fd63e0bc..de9d13d7aa 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -458,7 +458,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,
- inline_hsinfo, unfold_hsinfo, levity_hsinfo]
+ inline_hsinfo, unfold_hsinfo]
-- NB: strictness and arity must appear in the list before unfolding
-- See GHC.IfaceToCore.tcUnfolding
where
@@ -492,10 +492,6 @@ toIfaceIdInfo id_info
inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
| otherwise = Just (HsInline inline_prag)
- ------------ Representation polymorphism ----------
- levity_hsinfo | isNeverRepPolyIdInfo id_info = Just HsLevity
- | otherwise = Nothing
-
toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar
toIfaceJoinInfo Nothing = IfaceNotJoinPoint
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index c735a2f94f..9b89d7f145 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -351,7 +351,6 @@ data IfaceInfoItem
| HsUnfold Bool -- True <=> isStrongLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions]
| HsNoCafRefs
- | HsLevity -- Present <=> never representation-polymorphic
| HsLFInfo IfaceLFInfo
| HsTagSig TagSig
@@ -1478,7 +1477,6 @@ instance Outputable IfaceInfoItem where
ppr (HsDmdSig str) = text "Strictness:" <+> ppr str
ppr (HsCprSig cpr) = text "CPR:" <+> ppr cpr
ppr HsNoCafRefs = text "HasNoCafRefs"
- ppr HsLevity = text "Never levity-polymorphic"
ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info
ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig
@@ -2244,7 +2242,6 @@ instance Binary IfaceInfoItem where
put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
put_ bh HsNoCafRefs = putByte bh 4
- put_ bh HsLevity = putByte bh 5
put_ bh (HsCprSig cpr) = putByte bh 6 >> put_ bh cpr
put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info
put_ bh (HsTagSig sig) = putByte bh 8 >> put_ bh sig
@@ -2259,7 +2256,6 @@ instance Binary IfaceInfoItem where
return (HsUnfold lb ad)
3 -> liftM HsInline $ get bh
4 -> return HsNoCafRefs
- 5 -> return HsLevity
6 -> HsCprSig <$> get bh
7 -> HsLFInfo <$> get bh
_ -> HsTagSig <$> get bh
@@ -2607,7 +2603,6 @@ instance NFData IfaceInfoItem where
HsInline p -> p `seq` () -- TODO: seq further?
HsUnfold b unf -> rnf b `seq` rnf unf
HsNoCafRefs -> ()
- HsLevity -> ()
HsCprSig cpr -> cpr `seq` ()
HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
HsTagSig sig -> sig `seq` ()
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index a248cbf767..407f7b1980 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1662,7 +1662,6 @@ tcIdInfo ignore_prags toplvl name ty info = do
tcPrag info (HsDmdSig str) = return (info `setDmdSigInfo` str)
tcPrag info (HsCprSig cpr) = return (info `setCprSigInfo` cpr)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
- tcPrag info HsLevity = return (info `setNeverRepPoly` ty)
tcPrag info (HsLFInfo lf_info) = do
lf_info <- tcLFInfo lf_info
return (info `setLFInfo` lf_info)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 6e7316d544..46691958a6 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -43,7 +43,7 @@ import GHC.Data.FastString
import GHC.Types.Var
import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet )
import GHC.Types.Id
-import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType )
+import GHC.Types.Id.Info( RecSelParent(..) )
import GHC.Tc.Gen.Bind
import GHC.Types.Basic
import GHC.Tc.Solver
@@ -910,9 +910,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
Just (builder_name, builder_ty, need_dummy_arg) -> -- Normal case
do { -- Bidirectional, so patSynBuilder returns Just
- let pat_ty = patSynResultType patsyn
- builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $
- mkExportedVanillaId builder_name builder_ty
+ let builder_id = mkExportedVanillaId builder_name builder_ty
-- See Note [Exported LocalIds] in GHC.Types.Id
prags = lookupPragEnv prag_fn ps_name
-- See Note [Pragmas for pattern synonyms]
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 0747db57e4..eee43e8ed1 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -78,7 +78,6 @@ import GHC.Types.Name.Env
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Id
-import GHC.Types.Id.Info
import GHC.Types.TypeEnv
import GHC.Types.SourceText
import GHC.Types.Basic
@@ -385,7 +384,7 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env v
= do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v)
- return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w'))
+ return (setIdMult (setIdType v ty') w')
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 4d04c82a35..d5b308a550 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -99,7 +99,6 @@ module GHC.Types.Id (
idCafInfo, idLFInfo_maybe,
idOneShotInfo, idStateHackOneShotInfo,
idOccInfo,
- isNeverRepPolyId,
-- ** Writing 'IdInfo' fields
setIdUnfolding, setCaseBndrEvald,
@@ -1077,6 +1076,3 @@ transferPolyIdInfo old_id abstract_wrt new_id
`setOccInfo` new_occ_info
`setDmdSigInfo` new_strictness
`setCprSigInfo` old_cpr
-
-isNeverRepPolyId :: Id -> Bool
-isNeverRepPolyId = isNeverRepPolyIdInfo . idInfo
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 4bbf0ba86f..1b4ee7ae1c 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -83,10 +83,6 @@ module GHC.Types.Id.Info (
-- ** Tick-box Info
TickBoxOp(..), TickBoxId,
-
- -- ** Levity info
- LevityInfo, levityInfo, setNeverRepPoly, setLevityInfoWithType,
- isNeverRepPolyIdInfo
) where
import GHC.Prelude
@@ -100,13 +96,11 @@ import GHC.Types.Basic
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.PatSyn
-import GHC.Core.Type
import GHC.Types.ForeignCall
import GHC.Unit.Module
import GHC.Types.Demand
import GHC.Types.Cpr
-import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
@@ -126,9 +120,7 @@ infixl 1 `setRuleInfo`,
`setCafInfo`,
`setDmdSigInfo`,
`setCprSigInfo`,
- `setDemandInfo`,
- `setNeverRepPoly`,
- `setLevityInfoWithType`
+ `setDemandInfo`
{-
************************************************************************
* *
@@ -337,7 +329,7 @@ data IdInfo
demandInfo :: Demand,
-- ^ ID demand information
bitfield :: {-# UNPACK #-} !BitField,
- -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, LevityInfo, and
+ -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, and
-- call arity info in one 64-bit word. Packing these fields reduces size
-- of `IdInfo` from 12 words to 7 words and reduces residency by almost
-- 4% in some programs. See #17497 and associated MR.
@@ -349,12 +341,12 @@ data IdInfo
tagSig :: !(Maybe TagSig)
}
--- | Encodes arities, OneShotInfo, CafInfo and LevityInfo.
+-- | Encodes arities, OneShotInfo, CafInfo.
-- From least-significant to most-significant bits:
--
-- - Bit 0 (1): OneShotInfo
-- - Bit 1 (1): CafInfo
--- - Bit 2 (1): LevityInfo
+-- - Bit 2 (1): unused
-- - Bits 3-32(30): Call Arity info
-- - Bits 33-62(30): Arity info
--
@@ -371,10 +363,6 @@ bitfieldGetCafInfo :: BitField -> CafInfo
bitfieldGetCafInfo (BitField bits) =
if testBit bits 1 then NoCafRefs else MayHaveCafRefs
-bitfieldGetLevityInfo :: BitField -> LevityInfo
-bitfieldGetLevityInfo (BitField bits) =
- if testBit bits 2 then NeverLevityPolymorphic else NoLevityInfo
-
bitfieldGetCallArityInfo :: BitField -> ArityInfo
bitfieldGetCallArityInfo (BitField bits) =
fromIntegral (bits `shiftR` 3) .&. ((1 `shiftL` 30) - 1)
@@ -395,12 +383,6 @@ bitfieldSetCafInfo info (BitField bits) =
MayHaveCafRefs -> BitField (clearBit bits 1)
NoCafRefs -> BitField (setBit bits 1)
-bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField
-bitfieldSetLevityInfo info (BitField bits) =
- case info of
- NoLevityInfo -> BitField (clearBit bits 2)
- NeverLevityPolymorphic -> BitField (setBit bits 2)
-
bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetCallArityInfo info bf@(BitField bits) =
assert (info < 2^(30 :: Int) - 1) $
@@ -414,10 +396,6 @@ bitfieldSetArityInfo info (BitField bits) =
-- Getters
--- | When applied, will this Id ever have a representation-polymorphic type?
-levityInfo :: IdInfo -> LevityInfo
-levityInfo = bitfieldGetLevityInfo . bitfield
-
-- | Info about a lambda-bound variable, if the 'Id' is one
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo = bitfieldGetOneShotInfo . bitfield
@@ -520,7 +498,6 @@ vanillaIdInfo
bitfieldSetArityInfo unknownArity $
bitfieldSetCallArityInfo unknownArity $
bitfieldSetOneShotInfo NoOneShotInfo $
- bitfieldSetLevityInfo NoLevityInfo $
emptyBitField,
lfInfo = Nothing,
tagSig = Nothing
@@ -835,55 +812,3 @@ data TickBoxOp
instance Outputable TickBoxOp where
ppr (TickBox mod n) = text "tick" <+> ppr (mod,n)
-
-{-
-************************************************************************
-* *
- Levity
-* *
-************************************************************************
-
-Note [Levity info]
-~~~~~~~~~~~~~~~~~~
-
-Ids store whether or not they can be representation-polymorphic at any amount
-of saturation. This is helpful in optimizing representation polymorphism checks,
-allowing us to learn that something is not representation-polymorphic without
-actually figuring out its type.
-See exprHasFixedRuntimeRep in GHC.Core.Utils for where this info is used.
-
-Historical note: this was very important when representation polymorphism
-was checked in the desugarer (it was needed to prevent T5631 from blowing up).
-It's less important now that the checks happen in the typechecker, but remains useful.
-Refer to Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete for details
-about the new approach being used.
--}
-
--- See Note [Levity info]
-data LevityInfo = NoLevityInfo -- always safe
- | NeverLevityPolymorphic
- deriving Eq
-
-instance Outputable LevityInfo where
- ppr NoLevityInfo = text "NoLevityInfo"
- ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic"
-
--- | Marks an IdInfo describing an Id that is never representation-polymorphic
--- (even when applied). The Type is only there for checking that it's really
--- never representation-polymorphic.
-setNeverRepPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
-setNeverRepPoly info ty
- = assertPpr (resultHasFixedRuntimeRep ty) (ppr ty) $
- info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }
-
-setLevityInfoWithType :: IdInfo -> Type -> IdInfo
-setLevityInfoWithType info ty
- | resultHasFixedRuntimeRep ty
- = info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }
- | otherwise
- = info
-
-isNeverRepPolyIdInfo :: IdInfo -> Bool
-isNeverRepPolyIdInfo info
- | NeverLevityPolymorphic <- levityInfo info = True
- | otherwise = False
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index cfacdc9f70..4180e557c8 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -479,7 +479,6 @@ mkDictSelId name clas
`setArityInfo` 1
`setDmdSigInfo` strict_sig
`setCprSigInfo` topCprSig
- `setLevityInfoWithType` sel_ty
info | new_tycon
= base_info `setInlinePragInfo` alwaysInlinePragma
@@ -585,9 +584,6 @@ mkDataConWorkId wkr_name data_con
`setInlinePragInfo` wkr_inline_prag
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
- `setLevityInfoWithType` wkr_ty
- -- NB: unboxed tuples have workers, so we can't use
- -- setNeverRepPoly
wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike }
wkr_arity = dataConRepArity data_con
@@ -598,7 +594,6 @@ mkDataConWorkId wkr_name data_con
`setArityInfo` 1 -- Arity 1
`setInlinePragInfo` dataConWrapperInlinePragma
`setUnfoldingInfo` newtype_unf
- `setLevityInfoWithType` wkr_ty
id_arg1 = mkScaledTemplateLocal 1 (head arg_tys)
res_ty_args = mkTyCoVarTys univ_tvs
newtype_unf = assertPpr (isVanillaDataCon data_con && isSingleton arg_tys)
@@ -698,7 +693,6 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
-- We need to get the CAF info right here because GHC.Iface.Tidy
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
- `setLevityInfoWithType` wrap_ty
wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv
@@ -1323,7 +1317,6 @@ mkFCallId uniq fcall ty
`setArityInfo` arity
`setDmdSigInfo` strict_sig
`setCprSigInfo` topCprSig
- `setLevityInfoWithType` ty
(bndrs, _) = tcSplitPiTys ty
arity = count isAnonTyCoBinder bndrs
@@ -1411,8 +1404,7 @@ noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineI
proxyHashId :: Id
proxyHashId
= pcMiscPrelId proxyName ty
- (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
- `setNeverRepPoly` ty)
+ (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings]
where
-- proxy# :: forall {k} (a:k). Proxy# k a
--
@@ -1432,7 +1424,6 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts (Lit nullAddrLit)
- `setNeverRepPoly` addrPrimTy
------------------------------------------------
seqId :: Id -- See Note [seqId magic]
@@ -1466,13 +1457,13 @@ seqId = pcMiscPrelId seqName ty info
lazyId :: Id -- See Note [lazyId magic]
lazyId = pcMiscPrelId lazyIdName ty info
where
- info = noCafIdInfo `setNeverRepPoly` ty
+ info = noCafIdInfo
ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy)
noinlineId :: Id -- See Note [noinlineId magic]
noinlineId = pcMiscPrelId noinlineIdName ty info
where
- info = noCafIdInfo `setNeverRepPoly` ty
+ info = noCafIdInfo
ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy)
oneShotId :: Id -- See Note [The oneShot function]
@@ -1784,8 +1775,7 @@ inlined.
realWorldPrimId :: Id -- :: State# RealWorld
realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
- `setOneShotInfo` stateHackOneShot
- `setNeverRepPoly` realWorldStatePrimTy)
+ `setOneShotInfo` stateHackOneShot)
voidPrimId :: Id -- Global constant :: Void#
-- The type Void# is now the same as (# #) (ticket #18441),
@@ -1794,8 +1784,7 @@ voidPrimId :: Id -- Global constant :: Void#
-- We cannot define it in normal Haskell, since it's
-- a top-level unlifted value.
voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy
- (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs
- `setNeverRepPoly` unboxedUnitTy)
+ (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs)
where rhs = Var (dataConWorkId unboxedUnitDataCon)
View Lorry Controller Status