module GHC.Types.Id (
Var, Id, isId,
InVar, InId,
OutVar, OutId,
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,
mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,
mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,
mkUserLocal, mkUserLocalOrCoVar,
mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
mkScaledTemplateLocal,
mkWorkerId,
idName, idType, idMult, idScaledType, idUnique, idInfo, idDetails,
recordSelectorTyCon,
setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult,
updateIdTypeButNotMult, updateIdTypeAndMult, updateIdTypeAndMultM,
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
zapIdUsedOnceInfo, zapIdTailCallInfo,
zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,
transferPolyIdInfo, scaleIdBy, scaleVarBy,
isImplicitId, isDeadBinder,
isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isPatSynRecordSelector,
isDataConRecordSelector,
isClassOpId_maybe, isDFunId,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe,
isDataConWrapId, isDataConWrapId_maybe,
isDataConId_maybe,
idDataCon,
isConLikeId, isDeadEndId, idIsFrom,
hasNoBinding,
JoinId, isJoinId, isJoinId_maybe, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
isOneShotBndr, isProbablyOneShotLambda,
setOneShotLambda, clearOneShotLambda,
updOneShotInfo, setIdOneShotInfo,
isStateHackType, stateHackOneShot, typeOneShot,
idArity,
idCallArity, idFunRepArity,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo, idLFInfo_maybe,
idOneShotInfo, idStateHackOneShotInfo,
idOccInfo,
isNeverLevPolyId,
setIdUnfolding, setCaseBndrEvald,
setIdArity,
setIdCallArity,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
setIdLFInfo,
setIdDemandInfo,
setIdStrictness,
setIdCprInfo,
idDemandInfo,
idStrictness,
idCprInfo,
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,
isCompulsoryUnfolding, Unfolding( NoUnfolding ) )
import GHC.Types.Id.Info
import GHC.Types.Basic
import GHC.Types.Var( Id, CoVar, JoinId,
InId, InVar,
OutId, OutVar,
idInfo, idDetails, setIdDetails, globaliseId,
isId, isLocalId, isGlobalId, isExportedId,
setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM)
import qualified GHC.Types.Var as Var
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Builtin.Types.Prim
import GHC.Core.DataCon
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Core.Class
import GHC.Builtin.PrimOps (PrimOp)
import GHC.Types.ForeignCall
import GHC.Data.Maybe
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Core.Multiplicity
infixl 1 `setIdUnfolding`,
`setIdArity`,
`setIdCallArity`,
`setIdOccInfo`,
`setIdOneShotInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
`setInlineActivation`,
`idCafInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdCprInfo`,
`asJoinId`,
`asJoinId_maybe`
idName :: Id -> Name
idName = Var.varName
idUnique :: Id -> Unique
idUnique = Var.varUnique
idType :: Id -> Kind
idType = Var.varType
idMult :: Id -> Mult
idMult = Var.varMult
idScaledType :: Id -> Scaled Type
idScaledType id = Scaled (idMult id) (idType id)
scaleIdBy :: Mult -> Id -> Id
scaleIdBy m id = setIdMult id (m `mkMultMul` idMult id)
scaleVarBy :: Mult -> Var -> Var
scaleVarBy m id
| isId id = scaleIdBy m id
| otherwise = id
setIdName :: Id -> Name -> Id
setIdName = Var.setVarName
setIdUnique :: Id -> Unique -> Id
setIdUnique = Var.setVarUnique
setIdType :: Id -> Type -> Id
setIdType id ty = seqType ty `seq` Var.setVarType id ty
setIdExported :: Id -> Id
setIdExported = Var.setIdExported
setIdNotExported :: Id -> Id
setIdNotExported = Var.setIdNotExported
localiseId :: Id -> Id
localiseId id
| ASSERT( isId id ) isLocalId id && isInternalName name
= id
| otherwise
= Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id)
where
name = idName id
lazySetIdInfo :: Id -> IdInfo -> Id
lazySetIdInfo = Var.lazySetIdInfo
setIdInfo :: Id -> IdInfo -> Id
setIdInfo id info = info `seq` (lazySetIdInfo id info)
modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo fn id = setIdInfo id (fn (idInfo id))
maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id
maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info
maybeModifyIdInfo Nothing id = id
mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId = Var.mkGlobalVar
mkVanillaGlobal :: Name -> Type -> Id
mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo
mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo = mkGlobalId VanillaId
mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id
mkLocalId name w ty = ASSERT( not (isCoVarType ty) )
mkLocalIdWithInfo name w ty vanillaIdInfo
mkLocalCoVar :: Name -> Type -> CoVar
mkLocalCoVar name ty
= ASSERT( isCoVarType ty )
Var.mkLocalVar CoVarId name Many ty vanillaIdInfo
mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id
mkLocalIdOrCoVar name w ty
| isCoVarType ty = mkLocalCoVar name ty
| otherwise = mkLocalId name w ty
mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id
mkLocalIdWithInfo name w ty info = ASSERT( not (isCoVarType ty) )
Var.mkLocalVar VanillaId name w ty info
mkExportedLocalId :: IdDetails -> Name -> Type -> Id
mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo
mkExportedVanillaId :: Name -> Type -> Id
mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id
mkSysLocal fs uniq w ty = ASSERT( not (isCoVarType ty) )
mkLocalId (mkSystemVarName uniq fs) w ty
mkSysLocalOrCoVar :: FastString -> Unique -> Mult -> Type -> Id
mkSysLocalOrCoVar fs uniq w ty
= mkLocalIdOrCoVar (mkSystemVarName uniq fs) w ty
mkSysLocalM :: MonadUnique m => FastString -> Mult -> Type -> m Id
mkSysLocalM fs w ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq w ty))
mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Mult -> Type -> m Id
mkSysLocalOrCoVarM fs w ty
= getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq w ty))
mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id
mkUserLocal occ uniq w ty loc = ASSERT( not (isCoVarType ty) )
mkLocalId (mkInternalName uniq occ loc) w ty
mkUserLocalOrCoVar :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id
mkUserLocalOrCoVar occ uniq w ty loc
= mkLocalIdOrCoVar (mkInternalName uniq occ loc) w ty
mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId uniq unwrkr ty
= mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) Many ty
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkScaledTemplateLocal i (unrestricted ty)
mkScaledTemplateLocal :: Int -> Scaled Type -> Id
mkScaledTemplateLocal i (Scaled w ty) = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) w ty
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals = mkTemplateLocalsNum 1
mkTemplateLocalsNum :: Int -> [Type] -> [Id]
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
recordSelectorTyCon :: Id -> RecSelParent
recordSelectorTyCon id
= case Var.idDetails id of
RecSelId { sel_tycon = parent } -> parent
_ -> panic "recordSelectorTyCon"
isRecordSelector :: Id -> Bool
isNaughtyRecordSelector :: Id -> Bool
isPatSynRecordSelector :: Id -> Bool
isDataConRecordSelector :: Id -> Bool
isPrimOpId :: Id -> Bool
isFCallId :: Id -> Bool
isDataConWorkId :: Id -> Bool
isDataConWrapId :: Id -> Bool
isDFunId :: Id -> Bool
isClassOpId_maybe :: Id -> Maybe Class
isPrimOpId_maybe :: Id -> Maybe PrimOp
isFCallId_maybe :: Id -> Maybe ForeignCall
isDataConWorkId_maybe :: Id -> Maybe DataCon
isDataConWrapId_maybe :: Id -> Maybe DataCon
isRecordSelector id = case Var.idDetails id of
RecSelId {} -> True
_ -> False
isDataConRecordSelector id = case Var.idDetails id of
RecSelId {sel_tycon = RecSelData _} -> True
_ -> False
isPatSynRecordSelector id = case Var.idDetails id of
RecSelId {sel_tycon = RecSelPatSyn _} -> True
_ -> False
isNaughtyRecordSelector id = case Var.idDetails id of
RecSelId { sel_naughty = n } -> n
_ -> False
isClassOpId_maybe id = case Var.idDetails id of
ClassOpId cls -> Just cls
_other -> Nothing
isPrimOpId id = case Var.idDetails id of
PrimOpId _ -> True
_ -> False
isDFunId id = case Var.idDetails id of
DFunId {} -> True
_ -> False
isPrimOpId_maybe id = case Var.idDetails id of
PrimOpId op -> Just op
_ -> Nothing
isFCallId id = case Var.idDetails id of
FCallId _ -> True
_ -> False
isFCallId_maybe id = case Var.idDetails id of
FCallId call -> Just call
_ -> Nothing
isDataConWorkId id = case Var.idDetails id of
DataConWorkId _ -> True
_ -> False
isDataConWorkId_maybe id = case Var.idDetails id of
DataConWorkId con -> Just con
_ -> Nothing
isDataConWrapId id = case Var.idDetails id of
DataConWrapId _ -> True
_ -> False
isDataConWrapId_maybe id = case Var.idDetails id of
DataConWrapId con -> Just con
_ -> Nothing
isDataConId_maybe :: Id -> Maybe DataCon
isDataConId_maybe id = case Var.idDetails id of
DataConWorkId con -> Just con
DataConWrapId con -> Just con
_ -> Nothing
isJoinId :: Var -> Bool
isJoinId id
| isId id = case Var.idDetails id of
JoinId {} -> True
_ -> False
| otherwise = False
isJoinId_maybe :: Var -> Maybe JoinArity
isJoinId_maybe id
| isId id = ASSERT2( isId id, ppr id )
case Var.idDetails id of
JoinId arity -> Just arity
_ -> Nothing
| otherwise = Nothing
idDataCon :: Id -> DataCon
idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
hasNoBinding :: Id -> Bool
hasNoBinding id = case Var.idDetails id of
PrimOpId _ -> True
FCallId _ -> True
DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
_ -> isCompulsoryUnfolding (idUnfolding id)
isImplicitId :: Id -> Bool
isImplicitId id
= case Var.idDetails id of
FCallId {} -> True
ClassOpId {} -> True
PrimOpId {} -> True
DataConWorkId {} -> True
DataConWrapId {} -> True
_ -> False
idIsFrom :: Module -> Id -> Bool
idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
isDeadBinder :: Id -> Bool
isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
| otherwise = False
idJoinArity :: JoinId -> JoinArity
idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)
asJoinId :: Id -> JoinArity -> JoinId
asJoinId id arity = WARN(not (isLocalId id),
text "global id being marked as join var:" <+> ppr id)
WARN(not (is_vanilla_or_join id),
ppr id <+> pprIdDetails (idDetails id))
id `setIdDetails` JoinId arity
where
is_vanilla_or_join id = case Var.idDetails id of
VanillaId -> True
JoinId {} -> True
_ -> False
zapJoinId :: Id -> Id
zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId)
| otherwise = jid
asJoinId_maybe :: Id -> Maybe JoinArity -> Id
asJoinId_maybe id (Just arity) = asJoinId id arity
asJoinId_maybe id Nothing = zapJoinId id
idArity :: Id -> Arity
idArity id = arityInfo (idInfo id)
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
idCallArity :: Id -> Arity
idCallArity id = callArityInfo (idInfo id)
setIdCallArity :: Id -> Arity -> Id
setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id
idFunRepArity :: Id -> RepArity
idFunRepArity x = countFunRepArgs (idArity x) (idType x)
isDeadEndId :: Var -> Bool
isDeadEndId v
| isId v = isDeadEndSig (idStrictness v)
| otherwise = False
idStrictness :: Id -> StrictSig
idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id
idCprInfo :: Id -> CprSig
idCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprSig -> Id
setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id
zapIdStrictness :: Id -> Id
zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id
isStrictId :: Id -> Bool
isStrictId id
= ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
not (isJoinId id) && (
(isStrictType (idType id)) ||
(isStrictDmd (idDemandInfo id))
)
idUnfolding :: Id -> Unfolding
idUnfolding id
| isStrongLoopBreaker (occInfo info) = NoUnfolding
| otherwise = unfoldingInfo info
where
info = idInfo id
realIdUnfolding :: Id -> Unfolding
realIdUnfolding id = unfoldingInfo (idInfo id)
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
idDemandInfo :: Id -> Demand
idDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id
setCaseBndrEvald :: StrictnessMark -> Id -> Id
setCaseBndrEvald str id
| isMarkedStrict str = id `setIdUnfolding` evaldUnfolding
| otherwise = id
idSpecialisation :: Id -> RuleInfo
idSpecialisation id = ruleInfo (idInfo id)
idCoreRules :: Id -> [CoreRule]
idCoreRules id = ruleInfoRules (idSpecialisation id)
idHasRules :: Id -> Bool
idHasRules id = not (isEmptyRuleInfo (idSpecialisation id))
setIdSpecialisation :: Id -> RuleInfo -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id
idCafInfo :: Id -> CafInfo
idCafInfo id = cafInfo (idInfo id)
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
idLFInfo_maybe :: Id -> Maybe LambdaFormInfo
idLFInfo_maybe = lfInfo . idInfo
setIdLFInfo :: Id -> LambdaFormInfo -> Id
setIdLFInfo id lf = modifyIdInfo (`setLFInfo` lf) id
idOccInfo :: Id -> OccInfo
idOccInfo id = occInfo (idInfo id)
setIdOccInfo :: Id -> OccInfo -> Id
setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
zapIdOccInfo :: Id -> Id
zapIdOccInfo b = b `setIdOccInfo` noOccInfo
idInlinePragma :: Id -> InlinePragma
idInlinePragma id = inlinePragInfo (idInfo id)
setInlinePragma :: Id -> InlinePragma -> Id
setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
idInlineActivation :: Id -> Activation
idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
setInlineActivation :: Id -> Activation -> Id
setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)
idRuleMatchInfo :: Id -> RuleMatchInfo
idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
isConLikeId :: Id -> Bool
isConLikeId id = isConLike (idRuleMatchInfo id)
idOneShotInfo :: Id -> OneShotInfo
idOneShotInfo id = oneShotInfo (idInfo id)
idStateHackOneShotInfo :: Id -> OneShotInfo
idStateHackOneShotInfo id
| isStateHackType (idType id) = stateHackOneShot
| otherwise = idOneShotInfo id
isOneShotBndr :: Var -> Bool
isOneShotBndr var
| isTyVar var = True
| OneShotLam <- idStateHackOneShotInfo var = True
| otherwise = False
stateHackOneShot :: OneShotInfo
stateHackOneShot = OneShotLam
typeOneShot :: Type -> OneShotInfo
typeOneShot ty
| isStateHackType ty = stateHackOneShot
| otherwise = NoOneShotInfo
isStateHackType :: Type -> Bool
isStateHackType ty
| hasNoStateHack unsafeGlobalDynFlags
= False
| otherwise
= case tyConAppTyCon_maybe ty of
Just tycon -> tycon == statePrimTyCon
_ -> False
isProbablyOneShotLambda :: Id -> Bool
isProbablyOneShotLambda id = case idStateHackOneShotInfo id of
OneShotLam -> True
NoOneShotInfo -> False
setOneShotLambda :: Id -> Id
setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id
clearOneShotLambda :: Id -> Id
clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id
setIdOneShotInfo :: Id -> OneShotInfo -> Id
setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id
updOneShotInfo :: Id -> OneShotInfo -> Id
updOneShotInfo id one_shot
| do_upd = setIdOneShotInfo id one_shot
| otherwise = id
where
do_upd = case (idOneShotInfo id, one_shot) of
(NoOneShotInfo, _) -> True
(OneShotLam, _) -> False
zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id
zapLamIdInfo :: Id -> Id
zapLamIdInfo = zapInfo zapLamInfo
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo
zapIdDemandInfo :: Id -> Id
zapIdDemandInfo = zapInfo zapDemandInfo
zapIdUsageInfo :: Id -> Id
zapIdUsageInfo = zapInfo zapUsageInfo
zapIdUsageEnvInfo :: Id -> Id
zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo
zapIdUsedOnceInfo :: Id -> Id
zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo
zapIdTailCallInfo :: Id -> Id
zapIdTailCallInfo = zapInfo zapTailCallInfo
zapStableUnfolding :: Id -> Id
zapStableUnfolding id
| isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding
| otherwise = id
transferPolyIdInfo :: Id
-> [Var]
-> Id
-> Id
transferPolyIdInfo old_id abstract_wrt new_id
= modifyIdInfo transfer new_id
where
arity_increase = count isId abstract_wrt
old_info = idInfo old_id
old_arity = arityInfo old_info
old_inline_prag = inlinePragInfo old_info
old_occ_info = occInfo old_info
new_arity = old_arity + arity_increase
new_occ_info = zapOccTailCallInfo old_occ_info
old_strictness = strictnessInfo old_info
new_strictness = prependArgsStrictSig arity_increase old_strictness
old_cpr = cprInfo old_info
transfer new_info = new_info `setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
`setOccInfo` new_occ_info
`setStrictnessInfo` new_strictness
`setCprInfo` old_cpr
isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo