module Id (
Var, Id, isId,
InVar, InId,
OutVar, OutId,
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,
mkLocalIdOrCoVarWithInfo,
mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,
mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,
mkUserLocal, mkUserLocalOrCoVar,
mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
mkWorkerId,
idName, idType, idUnique, idInfo, idDetails,
recordSelectorTyCon,
setIdName, setIdUnique, Id.setIdType,
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
zapIdUsedOnceInfo, zapIdTailCallInfo,
zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,
transferPolyIdInfo,
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, isBottomingId, 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,
idOneShotInfo, idStateHackOneShotInfo,
idOccInfo,
isNeverLevPolyId,
setIdUnfolding, setCaseBndrEvald,
setIdArity,
setIdCallArity,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
setIdDemandInfo,
setIdStrictness,
idDemandInfo,
idStrictness,
) where
#include "HsVersions.h"
import GhcPrelude
import DynFlags
import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding,
isCompulsoryUnfolding, Unfolding( NoUnfolding ) )
import IdInfo
import BasicTypes
import Var( Id, CoVar, JoinId,
InId, InVar,
OutId, OutVar,
idInfo, idDetails, setIdDetails, globaliseId, varType,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
import Type
import RepType
import TysPrim
import DataCon
import Demand
import Name
import Module
import Class
import PrimOp (PrimOp)
import ForeignCall
import Maybes
import SrcLoc
import Outputable
import Unique
import UniqSupply
import FastString
import Util
infixl 1 `setIdUnfolding`,
`setIdArity`,
`setIdCallArity`,
`setIdOccInfo`,
`setIdOneShotInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
`setInlineActivation`,
`idCafInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
`asJoinId`,
`asJoinId_maybe`
idName :: Id -> Name
idName = Var.varName
idUnique :: Id -> Unique
idUnique = Var.varUnique
idType :: Id -> Kind
idType = Var.varType
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) (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 :: Name -> Type -> Id
mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
mkLocalCoVar :: Name -> Type -> CoVar
mkLocalCoVar name ty
= ASSERT( isCoVarType ty )
Var.mkLocalVar CoVarId name ty vanillaIdInfo
mkLocalIdOrCoVar :: Name -> Type -> Id
mkLocalIdOrCoVar name ty
| isCoVarType ty = mkLocalCoVar name ty
| otherwise = mkLocalId name ty
mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdOrCoVarWithInfo name ty info
= Var.mkLocalVar details name ty info
where
details | isCoVarType ty = CoVarId
| otherwise = VanillaId
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name 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 -> Type -> Id
mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) )
mkLocalId (mkSystemVarName uniq fs) ty
mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id
mkSysLocalOrCoVar fs uniq ty
= mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty
mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id
mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty))
mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM fs ty
= getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty))
mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id
mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) )
mkLocalId (mkInternalName uniq occ loc) ty
mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id
mkUserLocalOrCoVar occ uniq ty loc
= mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty
mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId uniq unwrkr ty
= mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) 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 _ -> False
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)
isBottomingId :: Var -> Bool
isBottomingId v
| isId v = isBottomingSig (idStrictness v)
| otherwise = False
idStrictness :: Id -> StrictSig
idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` 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
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 = isDataConWorkId 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 = increaseStrictSigArity arity_increase old_strictness
transfer new_info = new_info `setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
`setOccInfo` new_occ_info
`setStrictnessInfo` new_strictness
isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo