module Id (
Var, Id, isId,
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
mkLocalId, mkLocalIdWithInfo, mkExportedLocalId,
mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
mkDerivedLocalM,
mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
mkWorkerId, mkWiredInIdName,
idName, idType, idUnique, idInfo, idDetails, idRepArity,
recordSelectorFieldLabel,
setIdName, setIdUnique, Id.setIdType,
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
zapIdStrictness,
isImplicitId, isDeadBinder,
isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
isConLikeId, isBottomingId, idIsFrom,
hasNoBinding,
DictId, isDictId, dfunNSilent, isEvVar,
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
isOneShotBndr, isOneShotLambda, isProbablyOneShotLambda,
setOneShotLambda, clearOneShotLambda,
updOneShotInfo, setIdOneShotInfo,
isStateHackType, stateHackOneShot, typeOneShot,
idArity,
idCallArity,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
idOneShotInfo,
idOccInfo,
setIdUnfoldingLazily,
setIdUnfolding,
setIdArity,
setIdCallArity,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
setIdDemandInfo,
setIdStrictness,
idDemandInfo,
idStrictness,
) where
#include "HsVersions.h"
import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) )
import IdInfo
import BasicTypes
import Var( Id, DictId,
idInfo, idDetails, globaliseId, varType,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
import TyCon
import Type
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
import StaticFlags
infixl 1 `setIdUnfoldingLazily`,
`setIdUnfolding`,
`setIdArity`,
`setIdCallArity`,
`setIdOccInfo`,
`setIdOneShotInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
`setInlineActivation`,
`idCafInfo`,
`setIdDemandInfo`,
`setIdStrictness`
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
= mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id)
where
name = idName id
lazySetIdInfo :: Id -> IdInfo -> Id
lazySetIdInfo = Var.lazySetIdInfo
setIdInfo :: Id -> IdInfo -> Id
setIdInfo id info = seqIdInfo info `seq` (lazySetIdInfo id info)
modifyIdInfo :: (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 `setOneShotInfo` typeOneShot ty)
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
mkSysLocal :: FastString -> Unique -> Type -> Id
mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty
mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id
mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty))
mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id
mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id
mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc))
mkDerivedLocalM :: MonadUnique m => (OccName -> OccName) -> Id -> Type -> m Id
mkDerivedLocalM deriv_name id ty
= getUniqueM >>= (\uniq -> return (mkLocalId (mkDerivedInternalName deriv_name uniq (getName id)) ty))
mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName mod fs uniq id
= mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId uniq unwrkr ty
= mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocal (fsLit "tpl") (mkBuiltinUnique i) ty
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals = mkTemplateLocalsNum 1
mkTemplateLocalsNum :: Int -> [Type] -> [Id]
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
recordSelectorFieldLabel id
= case Var.idDetails id of
RecSelId { sel_tycon = tycon } -> (tycon, idName id)
_ -> panic "recordSelectorFieldLabel"
isRecordSelector :: Id -> Bool
isNaughtyRecordSelector :: Id -> Bool
isPrimOpId :: Id -> Bool
isFCallId :: Id -> Bool
isDataConWorkId :: 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
isRecordSelector id = case Var.idDetails id of
RecSelId {} -> 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
dfunNSilent :: Id -> Int
dfunNSilent id = case Var.idDetails id of
DFunId ns _ -> ns
_ -> pprPanic "dfunSilent: not a dfun:" (ppr id)
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
isDataConId_maybe :: Id -> Maybe DataCon
isDataConId_maybe id = case Var.idDetails id of
DataConWorkId con -> Just con
DataConWrapId con -> Just con
_ -> 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
_ -> False
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
isEvVar :: Var -> Bool
isEvVar var = isPredTy (varType var)
isDictId :: Id -> Bool
isDictId id = isDictTy (idType 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
idRepArity :: Id -> RepArity
idRepArity x = typeRepArity (idArity x) (idType x)
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingSig (idStrictness id)
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 )
(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)
setIdUnfoldingLazily :: Id -> Unfolding -> Id
setIdUnfoldingLazily id unfolding = modifyIdInfo (`setUnfoldingInfoLazily` unfolding) 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
idSpecialisation :: Id -> SpecInfo
idSpecialisation id = specInfo (idInfo id)
idCoreRules :: Id -> [CoreRule]
idCoreRules id = specInfoRules (idSpecialisation id)
idHasRules :: Id -> Bool
idHasRules id = not (isEmptySpecInfo (idSpecialisation id))
setIdSpecialisation :: Id -> SpecInfo -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` 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)
isOneShotBndr :: Var -> Bool
isOneShotBndr var
| isTyVar var = True
| otherwise = isOneShotLambda var
stateHackOneShot :: OneShotInfo
stateHackOneShot = OneShotLam
typeOneShot :: Type -> OneShotInfo
typeOneShot ty
| isStateHackType ty = stateHackOneShot
| otherwise = NoOneShotInfo
isStateHackType :: Type -> Bool
isStateHackType ty
| opt_NoStateHack
= False
| otherwise
= case tyConAppTyCon_maybe ty of
Just tycon -> tycon == statePrimTyCon
_ -> False
isOneShotLambda :: Id -> Bool
isOneShotLambda id = case idOneShotInfo id of
OneShotLam -> True
_ -> False
isProbablyOneShotLambda :: Id -> Bool
isProbablyOneShotLambda id = case idOneShotInfo id of
OneShotLam -> True
ProbOneShot -> 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
(_, NoOneShotInfo) -> False
_ -> True
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
zapDemandIdInfo :: Id -> Id
zapDemandIdInfo = zapInfo zapDemandInfo
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
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` old_occ_info
`setStrictnessInfo` new_strictness