{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[Id]{@Ids@: Value and constructor identifiers}
-}



-- |
-- #name_types#
-- GHC uses several kinds of name internally:
--
-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types"
--
-- * 'GHC.Types.Name.Reader.RdrName': see "GHC.Types.Name.Reader#name_types"
--
-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types"
--
-- * 'GHC.Types.Id.Id' represents names that not only have a 'GHC.Types.Name.Name' but also a
--   'GHC.Core.TyCo.Rep.Type' and some additional details (a 'GHC.Types.Id.Info.IdInfo' and
--   one of LocalIdDetails or GlobalIdDetails) that are added,
--   modified and inspected by various compiler passes. These 'GHC.Types.Var.Var' names
--   may either be global or local, see "GHC.Types.Var#globalvslocal"
--
-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types"

module GHC.Types.Id (
        -- * The main types
        Var, Id, isId,

        -- * In and Out variants
        InVar,  InId,
        OutVar, OutId,

        -- ** Simple construction
        mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
        mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,
        mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,
        mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,
        mkUserLocal, mkUserLocalOrCoVar,
        mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
        mkScaledTemplateLocal,
        mkWorkerId,

        -- ** Taking an Id apart
        idName, idType, idMult, idScaledType, idUnique, idInfo, idDetails,
        recordSelectorTyCon,
        recordSelectorTyCon_maybe,

        -- ** Modifying an Id
        setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult,
        updateIdTypeButNotMult, updateIdTypeAndMult, updateIdTypeAndMultM,
        setIdExported, setIdNotExported,
        globaliseId, localiseId,
        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
        zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
        zapIdUsedOnceInfo, zapIdTailCallInfo,
        zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding,
        transferPolyIdInfo, scaleIdBy, scaleVarBy,

        -- ** Predicates on Ids
        isImplicitId, isDeadBinder,
        isStrictId,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector, isNaughtyRecordSelector,
        isPatSynRecordSelector,
        isDataConRecordSelector,
        isClassOpId,
        isClassOpId_maybe, isDFunId,
        isPrimOpId, isPrimOpId_maybe,
        isFCallId, isFCallId_maybe,
        isDataConWorkId, isDataConWorkId_maybe,
        isDataConWrapId, isDataConWrapId_maybe, dataConWrapUnfolding_maybe,
        isDataConId, isDataConId_maybe,
        idDataCon,
        isConLikeId, isWorkerLikeId, isDeadEndId, idIsFrom,
        hasNoBinding,

        -- ** Join variables
        JoinId, JoinPointHood,
        isJoinId, idJoinPointHood, idJoinArity,
        asJoinId, asJoinId_maybe, zapJoinId,

        -- ** Inline pragma stuff
        idInlinePragma, setInlinePragma, modifyInlinePragma,
        idInlineActivation, setInlineActivation, idRuleMatchInfo,

        -- ** One-shot lambdas
        setOneShotLambda, clearOneShotLambda,
        updOneShotInfo, setIdOneShotInfo,

        -- ** Reading 'IdInfo' fields
        idArity,
        idCallArity, idFunRepArity,
        idSpecialisation, idCoreRules, idHasRules,
        idCafInfo, idLFInfo_maybe,
        idOneShotInfo,
        idOccInfo,

        IdUnfoldingFun, idUnfolding, realIdUnfolding,
        alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun,

        -- ** Writing 'IdInfo' fields
        setIdUnfolding, zapIdUnfolding, setCaseBndrEvald,
        setIdArity,
        setIdCallArity,

        setIdSpecialisation,
        setIdCafInfo,
        setIdOccInfo, zapIdOccInfo,
        setIdLFInfo,

        setIdDemandInfo,
        setIdDmdSig,
        setIdCprSig,
        setIdCbvMarks,
        idCbvMarks_maybe,
        idCbvMarkArity,
        asWorkerLikeId, asNonWorkerLikeId,

        idDemandInfo,
        idDmdSig,
        idCprSig,

        idTagSig_maybe,
        setIdTagSig
    ) where

import GHC.Prelude

import GHC.Types.Id.Info
import GHC.Types.Basic

-- Imported and re-exported
import GHC.Types.Var( Id, CoVar, JoinId,
            InId,  InVar,
            OutId, OutVar,
            idInfo, idDetails, setIdDetails, globaliseId, idMult,
            isId, isLocalId, isGlobalId, isExportedId,
            setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM)
import qualified GHC.Types.Var as Var

import GHC.Core ( CoreExpr, CoreRule, Unfolding(..), IdUnfoldingFun
                , isStableUnfolding, isCompulsoryUnfolding, isEvaldUnfolding
                , hasSomeUnfolding, noUnfolding, evaldUnfolding )
import GHC.Core.Type
import GHC.Core.Predicate( isCoVarType )
import GHC.Core.DataCon
import GHC.Core.Class
import GHC.Core.Multiplicity

import GHC.Types.RepType
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Name
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc
import GHC.Types.Unique

import GHC.Stg.EnforceEpt.TagSig

import GHC.Unit.Module
import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp)
import GHC.Builtin.Uniques (mkBuiltinUnique)
import GHC.Types.Unique.Supply

import GHC.Data.Maybe
import GHC.Data.FastString

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic

-- infixl so you can say (id `set` a `set` b)
infixl  1 `setIdUnfolding`,
          `setIdArity`,
          `setIdCallArity`,
          `setIdOccInfo`,
          `setIdOneShotInfo`,

          `setIdSpecialisation`,
          `setInlinePragma`,
          `setInlineActivation`,
          `idCafInfo`,

          `setIdDemandInfo`,
          `setIdDmdSig`,
          `setIdCprSig`,

          `asJoinId`,
          `asJoinId_maybe`,
          `setIdCbvMarks`

{-
************************************************************************
*                                                                      *
\subsection{Basic Id manipulation}
*                                                                      *
************************************************************************
-}

idName   :: Id -> Name
idName :: Id -> Name
idName    = Id -> Name
Var.varName

idUnique :: Id -> Unique
idUnique :: Id -> Unique
idUnique  = Id -> Unique
Var.varUnique

idType   :: Id -> Kind
idType :: Id -> Kind
idType    = Id -> Kind
Var.varType

idScaledType :: Id -> Scaled Type
idScaledType :: Id -> Scaled Kind
idScaledType Id
id = Kind -> Kind -> Scaled Kind
forall a. Kind -> a -> Scaled a
Scaled (HasDebugCallStack => Id -> Kind
Id -> Kind
idMult Id
id) (Id -> Kind
idType Id
id)

scaleIdBy :: Mult -> Id -> Id
scaleIdBy :: Kind -> Id -> Id
scaleIdBy Kind
m Id
id = Id -> Kind -> Id
setIdMult Id
id (Kind
m Kind -> Kind -> Kind
`mkMultMul` HasDebugCallStack => Id -> Kind
Id -> Kind
idMult Id
id)

-- | Like 'scaleIdBy', but skips non-Ids. Useful for scaling
-- a mixed list of ids and tyvars.
scaleVarBy :: Mult -> Var -> Var
scaleVarBy :: Kind -> Id -> Id
scaleVarBy Kind
m Id
id
  | Id -> Bool
isId Id
id   = Kind -> Id -> Id
scaleIdBy Kind
m Id
id
  | Bool
otherwise = Id
id

setIdName :: Id -> Name -> Id
setIdName :: Id -> Name -> Id
setIdName = Id -> Name -> Id
Var.setVarName

setIdUnique :: Id -> Unique -> Id
setIdUnique :: Id -> Unique -> Id
setIdUnique = Id -> Unique -> Id
Var.setVarUnique

-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and
-- reduce space usage
setIdType :: Id -> Type -> Id
setIdType :: Id -> Kind -> Id
setIdType Id
id Kind
ty = Kind -> ()
seqType Kind
ty () -> Id -> Id
forall a b. a -> b -> b
`seq` Id -> Kind -> Id
Var.setVarType Id
id Kind
ty

setIdExported :: Id -> Id
setIdExported :: Id -> Id
setIdExported = Id -> Id
Var.setIdExported

setIdNotExported :: Id -> Id
setIdNotExported :: Id -> Id
setIdNotExported = Id -> Id
Var.setIdNotExported

localiseId :: Id -> Id
-- Make an Id with the same unique and type as the
-- incoming Id, but with an *Internal* Name and *LocalId* flavour
localiseId :: Id -> Id
localiseId Id
id
  | Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isId Id
id) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Bool
isLocalId Id
id Bool -> Bool -> Bool
&& Name -> Bool
isInternalName Name
name
  = Id
id
  | Bool
otherwise
  = IdDetails -> Name -> Kind -> Kind -> IdInfo -> Id
Var.mkLocalVar (Id -> IdDetails
idDetails Id
id) (Name -> Name
localiseName Name
name) (HasDebugCallStack => Id -> Kind
Id -> Kind
Var.idMult Id
id) (Id -> Kind
idType Id
id) (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)
  where
    name :: Name
name = Id -> Name
idName Id
id

lazySetIdInfo :: Id -> IdInfo -> Id
lazySetIdInfo :: Id -> IdInfo -> Id
lazySetIdInfo = Id -> IdInfo -> Id
Var.lazySetIdInfo

setIdInfo :: Id -> IdInfo -> Id
setIdInfo :: Id -> IdInfo -> Id
setIdInfo Id
id IdInfo
info = IdInfo
info IdInfo -> Id -> Id
forall a b. a -> b -> b
`seq` (Id -> IdInfo -> Id
lazySetIdInfo Id
id IdInfo
info)
        -- Try to avoid space leaks by seq'ing

modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
fn Id
id = Id -> IdInfo -> Id
setIdInfo Id
id (IdInfo -> IdInfo
fn (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id))

-- maybeModifyIdInfo tries to avoid unnecessary thrashing
maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id
maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id
maybeModifyIdInfo (Just IdInfo
new_info) Id
id = Id -> IdInfo -> Id
lazySetIdInfo Id
id IdInfo
new_info
maybeModifyIdInfo Maybe IdInfo
Nothing         Id
id = Id
id

-- maybeModifyIdInfo tries to avoid unnecessary thrashing
maybeModifyIdDetails :: Maybe IdDetails  -> Id -> Id
maybeModifyIdDetails :: Maybe IdDetails -> Id -> Id
maybeModifyIdDetails (Just IdDetails
new_details) Id
id = Id -> IdDetails -> Id
setIdDetails Id
id IdDetails
new_details
maybeModifyIdDetails Maybe IdDetails
Nothing         Id
id = Id
id

{-
************************************************************************
*                                                                      *
\subsection{Simple Id construction}
*                                                                      *
************************************************************************

Absolutely all Ids are made by mkId.  It is just like Var.mkId,
but in addition it pins free-tyvar-info onto the Id's type,
where it can easily be found.

Note [Free type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~
At one time we cached the free type variables of the type of an Id
at the root of the type in a TyNote.  The idea was to avoid repeating
the free-type-variable calculation.  But it turned out to slow down
the compiler overall. I don't quite know why; perhaps finding free
type variables of an Id isn't all that common whereas applying a
substitution (which changes the free type variables) is more common.
Anyway, we removed it in March 2008.
-}

-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var.Var#globalvslocal"
mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId :: IdDetails -> Name -> Kind -> IdInfo -> Id
mkGlobalId = IdDetails -> Name -> Kind -> IdInfo -> Id
Var.mkGlobalVar

-- | Make a global 'Id' without any extra information at all
mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id
mkVanillaGlobal :: HasDebugCallStack => Name -> Kind -> Id
mkVanillaGlobal Name
name Kind
ty = HasDebugCallStack => Name -> Kind -> IdInfo -> Id
Name -> Kind -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Kind
ty IdInfo
vanillaIdInfo

-- | Make a global 'Id' with no global information but some generic 'IdInfo'
mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Kind -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
nm =
  Bool -> SDoc -> (Kind -> IdInfo -> Id) -> Kind -> IdInfo -> Id
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ NameSpace -> Bool
isFieldNameSpace (NameSpace -> Bool) -> NameSpace -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> NameSpace
nameNameSpace Name
nm)
    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mkVanillaGlobalWithInfo called on record field:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm) ((Kind -> IdInfo -> Id) -> Kind -> IdInfo -> Id)
-> (Kind -> IdInfo -> Id) -> Kind -> IdInfo -> Id
forall a b. (a -> b) -> a -> b
$
    IdDetails -> Name -> Kind -> IdInfo -> Id
mkGlobalId IdDetails
VanillaId Name
nm

-- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal"
mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id
mkLocalId :: HasDebugCallStack => Name -> Kind -> Kind -> Id
mkLocalId Name
name Kind
w Kind
ty = HasDebugCallStack => Name -> Kind -> Kind -> IdInfo -> Id
Name -> Kind -> Kind -> IdInfo -> Id
mkLocalIdWithInfo Name
name Kind
w (Bool -> Kind -> Kind
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Kind -> Bool
isCoVarType Kind
ty)) Kind
ty) IdInfo
vanillaIdInfo

-- | Make a local CoVar
mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar
mkLocalCoVar :: HasDebugCallStack => Name -> Kind -> Id
mkLocalCoVar Name
name Kind
ty
  = Bool -> Id -> Id
forall a. HasCallStack => Bool -> a -> a
assert (Kind -> Bool
isCoVarType Kind
ty) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
    IdDetails -> Name -> Kind -> Kind -> IdInfo -> Id
Var.mkLocalVar IdDetails
CoVarId Name
name Kind
ManyTy Kind
ty IdInfo
vanillaIdInfo

-- | Like 'mkLocalId', but checks the type to see if it should make a covar
mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id
mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Kind -> Kind -> Id
mkLocalIdOrCoVar Name
name Kind
w Kind
ty
  -- We should assert (eqType w Many) in the isCoVarType case.
  -- However, currently this assertion does not hold.
  -- In tests with -fdefer-type-errors, such as T14584a,
  -- we create a linear 'case' where the scrutinee is a coercion
  -- (see castBottomExpr). This problem is covered by #17291.
  | Kind -> Bool
isCoVarType Kind
ty = HasDebugCallStack => Name -> Kind -> Id
Name -> Kind -> Id
mkLocalCoVar Name
name   Kind
ty
  | Bool
otherwise      = HasDebugCallStack => Name -> Kind -> Kind -> Id
Name -> Kind -> Kind -> Id
mkLocalId    Name
name Kind
w Kind
ty

    -- proper ids only; no covars!
mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id
mkLocalIdWithInfo :: HasDebugCallStack => Name -> Kind -> Kind -> IdInfo -> Id
mkLocalIdWithInfo Name
name Kind
w Kind
ty IdInfo
info =
  IdDetails -> Name -> Kind -> Kind -> IdInfo -> Id
Var.mkLocalVar IdDetails
VanillaId Name
name Kind
w (Bool -> Kind -> Kind
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Kind -> Bool
isCoVarType Kind
ty)) Kind
ty) IdInfo
info
        -- Note [Free type variables]

-- | Create a local 'Id' that is marked as exported.
-- This prevents things attached to it from being removed as dead code.
-- See Note [Exported LocalIds]
mkExportedLocalId :: IdDetails -> Name -> Type -> Id
mkExportedLocalId :: IdDetails -> Name -> Kind -> Id
mkExportedLocalId IdDetails
details Name
name Kind
ty = IdDetails -> Name -> Kind -> IdInfo -> Id
Var.mkExportedLocalVar IdDetails
details Name
name Kind
ty IdInfo
vanillaIdInfo
        -- Note [Free type variables]

mkExportedVanillaId :: Name -> Type -> Id
mkExportedVanillaId :: Name -> Kind -> Id
mkExportedVanillaId Name
name Kind
ty =
  Bool -> SDoc -> Id -> Id
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ NameSpace -> Bool
isFieldNameSpace (NameSpace -> Bool) -> NameSpace -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> NameSpace
nameNameSpace Name
name)
    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mkExportedVanillaId called on record field:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
    IdDetails -> Name -> Kind -> IdInfo -> Id
Var.mkExportedLocalVar IdDetails
VanillaId Name
name Kind
ty IdInfo
vanillaIdInfo
        -- Note [Free type variables]


-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")
-- that are created by the compiler out of thin air
mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id
mkSysLocal :: FastString -> Unique -> Kind -> Kind -> Id
mkSysLocal FastString
fs Unique
uniq Kind
w Kind
ty = Bool -> Id -> Id
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Kind -> Bool
isCoVarType Kind
ty)) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
                        HasDebugCallStack => Name -> Kind -> Kind -> Id
Name -> Kind -> Kind -> Id
mkLocalId (Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
fs) Kind
w Kind
ty

-- | Like 'mkSysLocal', but checks to see if we have a covar type
mkSysLocalOrCoVar :: FastString -> Unique -> Mult -> Type -> Id
mkSysLocalOrCoVar :: FastString -> Unique -> Kind -> Kind -> Id
mkSysLocalOrCoVar FastString
fs Unique
uniq Kind
w Kind
ty
  = HasDebugCallStack => Name -> Kind -> Kind -> Id
Name -> Kind -> Kind -> Id
mkLocalIdOrCoVar (Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
fs) Kind
w Kind
ty

mkSysLocalM :: MonadUnique m => FastString -> Mult -> Type -> m Id
mkSysLocalM :: forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Id
mkSysLocalM FastString
fs Kind
w Kind
ty = m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM m Unique -> (Unique -> m Id) -> m Id
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Unique
uniq -> Id -> m Id
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Kind -> Kind -> Id
mkSysLocal FastString
fs Unique
uniq Kind
w Kind
ty))

mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Mult -> Type -> m Id
mkSysLocalOrCoVarM :: forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Id
mkSysLocalOrCoVarM FastString
fs Kind
w Kind
ty
  = m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM m Unique -> (Unique -> m Id) -> m Id
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Unique
uniq -> Id -> m Id
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Kind -> Kind -> Id
mkSysLocalOrCoVar FastString
fs Unique
uniq Kind
w Kind
ty))

-- | Create a user local 'Id'. These are local 'Id's (see "GHC.Types.Var#globalvslocal") with a name and location that the user might recognize
mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id
mkUserLocal :: OccName -> Unique -> Kind -> Kind -> SrcSpan -> Id
mkUserLocal OccName
occ Unique
uniq Kind
w Kind
ty SrcSpan
loc = Bool -> Id -> Id
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Kind -> Bool
isCoVarType Kind
ty)) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
                                HasDebugCallStack => Name -> Kind -> Kind -> Id
Name -> Kind -> Kind -> Id
mkLocalId (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
loc) Kind
w Kind
ty

-- | Like 'mkUserLocal', but checks if we have a coercion type
mkUserLocalOrCoVar :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id
mkUserLocalOrCoVar :: OccName -> Unique -> Kind -> Kind -> SrcSpan -> Id
mkUserLocalOrCoVar OccName
occ Unique
uniq Kind
w Kind
ty SrcSpan
loc
  = HasDebugCallStack => Name -> Kind -> Kind -> Id
Name -> Kind -> Kind -> Id
mkLocalIdOrCoVar (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
loc) Kind
w Kind
ty

{-
Make some local @Ids@ for a template @CoreExpr@.  These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
-}

-- | Workers get local names. "CoreTidy" will externalise these if necessary
mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId :: Unique -> Id -> Kind -> Id
mkWorkerId Unique
uniq Id
unwrkr Kind
ty
  = HasDebugCallStack => Name -> Kind -> Kind -> Id
Name -> Kind -> Kind -> Id
mkLocalId ((OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName OccName -> OccName
mkWorkerOcc Unique
uniq (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
unwrkr)) Kind
ManyTy Kind
ty

-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal :: Arity -> Kind -> Id
mkTemplateLocal Arity
i Kind
ty = Arity -> Scaled Kind -> Id
mkScaledTemplateLocal Arity
i (Kind -> Scaled Kind
forall a. a -> Scaled a
unrestricted Kind
ty)

mkScaledTemplateLocal :: Int -> Scaled Type -> Id
mkScaledTemplateLocal :: Arity -> Scaled Kind -> Id
mkScaledTemplateLocal Arity
i (Scaled Kind
w Kind
ty) = FastString -> Unique -> Kind -> Kind -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"v") (Arity -> Unique
mkBuiltinUnique Arity
i) Kind
w Kind
ty
   -- "OrCoVar" since this is used in a superclass selector,
   -- and "~" and "~~" have coercion "superclasses".

-- | Create a template local for a series of types
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals :: [Kind] -> [Id]
mkTemplateLocals = Arity -> [Kind] -> [Id]
mkTemplateLocalsNum Arity
1

-- | Create a template local for a series of type, but start from a specified template local
mkTemplateLocalsNum :: Int -> [Type] -> [Id]
mkTemplateLocalsNum :: Arity -> [Kind] -> [Id]
mkTemplateLocalsNum Arity
n [Kind]
tys = (Arity -> Kind -> Id) -> [Arity] -> [Kind] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Arity -> Kind -> Id
mkTemplateLocal [Arity
n..] [Kind]
tys

{- Note [Exported LocalIds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use mkExportedLocalId for things like
 - Dictionary functions (DFunId)
 - Wrapper and matcher Ids for pattern synonyms
 - Default methods for classes
 - Pattern-synonym matcher and builder Ids
 - etc

They marked as "exported" in the sense that they should be kept alive
even if apparently unused in other bindings, and not dropped as dead
code by the occurrence analyser.  (But "exported" here does not mean
"brought into lexical scope by an import declaration". Indeed these
things are always internal Ids that the user never sees.)

It's very important that they are *LocalIds*, not GlobalIds, for lots
of reasons:

 * We want to treat them as free variables for the purpose of
   dependency analysis (e.g. GHC.Core.FVs.exprFreeVars).

 * Look them up in the current substitution when we come across
   occurrences of them (in Subst.lookupIdSubst). Lacking this we
   can get an out-of-date unfolding, which can in turn make the
   simplifier go into an infinite loop (#9857)

 * Ensure that for dfuns that the specialiser does not float dict uses
   above their defns, which would prevent good simplifications happening.

 * The strictness analyser treats a occurrence of a GlobalId as
   imported and assumes it contains strictness in its IdInfo, which
   isn't true if the thing is bound in the same module as the
   occurrence.

In CoreTidy we must make all these LocalIds into GlobalIds, so that in
importing modules (in --make mode) we treat them as properly global.
That is what is happening in, say tidy_insts in GHC.Iface.Tidy.

************************************************************************
*                                                                      *
\subsection{Special Ids}
*                                                                      *
************************************************************************
-}

-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise.
recordSelectorTyCon :: Id -> RecSelParent
recordSelectorTyCon :: Id -> RecSelParent
recordSelectorTyCon Id
id
  = case Id -> Maybe RecSelParent
recordSelectorTyCon_maybe Id
id of
        Just RecSelParent
parent -> RecSelParent
parent
        Maybe RecSelParent
_ -> String -> RecSelParent
forall a. HasCallStack => String -> a
panic String
"recordSelectorTyCon"

recordSelectorTyCon_maybe :: Id -> Maybe RecSelParent
recordSelectorTyCon_maybe :: Id -> Maybe RecSelParent
recordSelectorTyCon_maybe Id
id
  = case Id -> IdDetails
Var.idDetails Id
id of
        RecSelId { sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelParent
parent } -> RecSelParent -> Maybe RecSelParent
forall a. a -> Maybe a
Just RecSelParent
parent
        IdDetails
_ -> Maybe RecSelParent
forall a. Maybe a
Nothing

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             :: 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 -> Bool
isRecordSelector Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        RecSelId {}     -> Bool
True
                        IdDetails
_               -> Bool
False

isDataConRecordSelector :: Id -> Bool
isDataConRecordSelector Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        RecSelId {sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelData TyCon
_} -> Bool
True
                        IdDetails
_                                   -> Bool
False

isPatSynRecordSelector :: Id -> Bool
isPatSynRecordSelector Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        RecSelId {sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelPatSyn PatSyn
_} -> Bool
True
                        IdDetails
_                                     -> Bool
False

isNaughtyRecordSelector :: Id -> Bool
isNaughtyRecordSelector Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        RecSelId { sel_naughty :: IdDetails -> Bool
sel_naughty = Bool
n } -> Bool
n
                        IdDetails
_                            -> Bool
False

isClassOpId :: Id -> Bool
isClassOpId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        ClassOpId {} -> Bool
True
                        IdDetails
_other       -> Bool
False

isClassOpId_maybe :: Id -> Maybe Class
isClassOpId_maybe Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        ClassOpId Class
cls Bool
_ -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
                        IdDetails
_other          -> Maybe Class
forall a. Maybe a
Nothing

isPrimOpId :: Id -> Bool
isPrimOpId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        PrimOpId {} -> Bool
True
                        IdDetails
_           -> Bool
False

isDFunId :: Id -> Bool
isDFunId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        DFunId {} -> Bool
True
                        IdDetails
_         -> Bool
False

isPrimOpId_maybe :: Id -> Maybe PrimOp
isPrimOpId_maybe Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        PrimOpId PrimOp
op ConcreteTyVars
_ -> PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
op
                        IdDetails
_             -> Maybe PrimOp
forall a. Maybe a
Nothing

isFCallId :: Id -> Bool
isFCallId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        FCallId ForeignCall
_ -> Bool
True
                        IdDetails
_         -> Bool
False

isFCallId_maybe :: Id -> Maybe ForeignCall
isFCallId_maybe Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        FCallId ForeignCall
call -> ForeignCall -> Maybe ForeignCall
forall a. a -> Maybe a
Just ForeignCall
call
                        IdDetails
_            -> Maybe ForeignCall
forall a. Maybe a
Nothing

isDataConWorkId :: Id -> Bool
isDataConWorkId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        DataConWorkId DataCon
_ -> Bool
True
                        IdDetails
_               -> Bool
False

isDataConWorkId_maybe :: Id -> Maybe DataCon
isDataConWorkId_maybe Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        DataConWorkId DataCon
con -> DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
con
                        IdDetails
_                 -> Maybe DataCon
forall a. Maybe a
Nothing

isDataConWrapId :: Id -> Bool
isDataConWrapId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        DataConWrapId DataCon
_ -> Bool
True
                        IdDetails
_               -> Bool
False

isDataConWrapId_maybe :: Id -> Maybe DataCon
isDataConWrapId_maybe Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        DataConWrapId DataCon
con -> DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
con
                        IdDetails
_                 -> Maybe DataCon
forall a. Maybe a
Nothing

dataConWrapUnfolding_maybe :: Id -> Maybe CoreExpr
dataConWrapUnfolding_maybe :: Id -> Maybe CoreExpr
dataConWrapUnfolding_maybe Id
id
  | DataConWrapId {} <- Id -> IdDetails
idDetails Id
id
  , CoreUnfolding { uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
unf } <- Id -> Unfolding
realIdUnfolding Id
id
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
unf
  | Bool
otherwise
  = Maybe CoreExpr
forall a. Maybe a
Nothing

isDataConId_maybe :: Id -> Maybe DataCon
isDataConId_maybe :: Id -> Maybe DataCon
isDataConId_maybe Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                         DataConWorkId DataCon
con -> DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
con
                         DataConWrapId DataCon
con -> DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
con
                         IdDetails
_                 -> Maybe DataCon
forall a. Maybe a
Nothing

isDataConId :: Id -> Bool
isDataConId :: Id -> Bool
isDataConId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                         DataConWorkId {} -> Bool
True
                         DataConWrapId {} -> Bool
True
                         IdDetails
_                 -> Bool
False

-- | An Id for which we might require all callers to pass strict arguments properly tagged + evaluated.
--
-- See Note [CBV Function Ids]
isWorkerLikeId :: Id -> Bool
isWorkerLikeId :: Id -> Bool
isWorkerLikeId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
  WorkerLikeId [CbvMark]
_  -> Bool
True
  JoinId Arity
_ Just{}   -> Bool
True
  IdDetails
_                 -> Bool
False

isJoinId :: Var -> Bool
-- It is convenient in GHC.Core.Opt.SetLevels.lvlMFE to apply isJoinId
-- to the free vars of an expression, so it's convenient
-- if it returns False for type variables
isJoinId :: Id -> Bool
isJoinId Id
id
  | Id -> Bool
isId Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                JoinId {} -> Bool
True
                IdDetails
_         -> Bool
False
  | Bool
otherwise = Bool
False

-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood :: Id -> JoinPointHood
idJoinPointHood Id
id
 | Id -> Bool
isId Id
id  = case Id -> IdDetails
Var.idDetails Id
id of
                JoinId Arity
arity Maybe [CbvMark]
_marks -> Arity -> JoinPointHood
JoinPoint Arity
arity
                IdDetails
_                   -> JoinPointHood
NotJoinPoint
 | Bool
otherwise = JoinPointHood
NotJoinPoint

idDataCon :: Id -> DataCon
-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.
--
-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
idDataCon :: Id -> DataCon
idDataCon Id
id = Id -> Maybe DataCon
isDataConId_maybe Id
id Maybe DataCon -> DataCon -> DataCon
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> DataCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"idDataCon" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id)

hasNoBinding :: Id -> Bool
-- ^ Returns @True@ of an 'Id' which may not have a
-- binding, even though it is defined in this module.

-- Data constructor workers used to be things of this kind, but they aren't any
-- more.  Instead, we inject a binding for them at the CorePrep stage. The
-- exception to this is unboxed tuples and sums datacons, which definitely have
-- no binding
hasNoBinding :: Id -> Bool
hasNoBinding Id
id = case Id -> IdDetails
Var.idDetails Id
id of

-- TEMPORARILY make all primops hasNoBinding, to avoid #20155
-- The goal is to understand #20155 and revert to the commented out version
                        PrimOpId PrimOp
_ ConcreteTyVars
_ -> Bool
True    -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps
--                        PrimOpId _ lev_poly -> lev_poly    -- TEMPORARILY commented out

                        FCallId ForeignCall
_        -> Bool
True
                        DataConWorkId DataCon
dc -> DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
                        IdDetails
_                -> Unfolding -> Bool
isCompulsoryUnfolding (Id -> Unfolding
realIdUnfolding Id
id)
  -- Note: this function must be very careful not to force
  -- any of the fields that aren't the 'uf_src' field of
  -- the 'Unfolding' of the 'Id'. This is because these fields are computed
  -- in terms of the 'uf_tmpl' field, which is not available
  -- until we have finished Core Lint for the unfolding, which calls 'hasNoBinding'
  -- in 'checkCanEtaExpand'.
  --
  -- In particular, calling 'idUnfolding' rather than 'realIdUnfolding' here can
  -- force the 'uf_tmpl' field, because 'trimUnfolding' forces the 'uf_is_value' field,
  -- and this field is usually computed in terms of the 'uf_tmpl' field,
  -- so we will force that as well.
  --
  -- See Note [Lazily checking Unfoldings] in GHC.IfaceToCore.

isImplicitId :: Id -> Bool
-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other
-- declarations, so we don't need to put its signature in an interface
-- file, even if it's mentioned in some other interface unfolding.
isImplicitId :: Id -> Bool
isImplicitId Id
id
  = case Id -> IdDetails
Var.idDetails Id
id of
        FCallId {}       -> Bool
True
        ClassOpId {}     -> Bool
True
        PrimOpId {}      -> Bool
True
        DataConWorkId {} -> Bool
True
        DataConWrapId {} -> Bool
True
                -- These are implied by their type or class decl;
                -- remember that all type and class decls appear in the interface file.
                -- The dfun id is not an implicit Id; it must *not* be omitted, because
                -- it carries version info for the instance decl
        IdDetails
_               -> Bool
False

idIsFrom :: Module -> Id -> Bool
idIsFrom :: Module -> Id -> Bool
idIsFrom Module
mod Id
id = Module -> Name -> Bool
nameIsLocalOrFrom Module
mod (Id -> Name
idName Id
id)

isDeadBinder :: Id -> Bool
isDeadBinder :: Id -> Bool
isDeadBinder Id
bndr | Id -> Bool
isId Id
bndr = OccInfo -> Bool
isDeadOcc (Id -> OccInfo
idOccInfo Id
bndr)
                  | Bool
otherwise = Bool
False   -- TyVars count as not dead

{-
************************************************************************
*                                                                      *
              Join variables
*                                                                      *
************************************************************************
-}

idJoinArity :: JoinId -> JoinArity
idJoinArity :: Id -> Arity
idJoinArity Id
id = case Id -> JoinPointHood
idJoinPointHood Id
id of
                   JoinPoint Arity
ar -> Arity
ar
                   JoinPointHood
NotJoinPoint -> String -> SDoc -> Arity
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"idJoinArity" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id)

asJoinId :: Id -> JoinArity -> JoinId
asJoinId :: Id -> Arity -> Id
asJoinId Id
id Arity
arity = Bool -> String -> SDoc -> Id -> Id
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (Id -> Bool
isLocalId Id
id))
                         String
"global id being marked as join var"  (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
                    Bool -> String -> SDoc -> Id -> Id
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (Id -> Bool
is_vanilla_or_join Id
id))
                         String
"asJoinId"
                         (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> IdDetails -> SDoc
pprIdDetails (Id -> IdDetails
idDetails Id
id)) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
                    Id
id Id -> IdDetails -> Id
`setIdDetails` Arity -> Maybe [CbvMark] -> IdDetails
JoinId Arity
arity (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
id)
  where
    is_vanilla_or_join :: Id -> Bool
is_vanilla_or_join Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                              IdDetails
VanillaId -> Bool
True
                              -- Can workers become join ids? Yes!
                              WorkerLikeId {} -> String -> SDoc -> Bool -> Bool
forall a. String -> SDoc -> a -> a
pprTraceDebug String
"asJoinId (call by value function)" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id) Bool
True
                              JoinId {} -> Bool
True
                              IdDetails
_         -> Bool
False

zapJoinId :: Id -> Id
-- May be a regular id already
zapJoinId :: Id -> Id
zapJoinId Id
jid | Id -> Bool
isJoinId Id
jid = Id -> Id
zapIdTailCallInfo (IdDetails
newIdDetails IdDetails -> Id -> Id
forall a b. a -> b -> b
`seq` Id
jid Id -> IdDetails -> Id
`setIdDetails` IdDetails
newIdDetails)
                                 -- Core Lint may complain if still marked
                                 -- as AlwaysTailCalled
              | Bool
otherwise    = Id
jid
              where
                newIdDetails :: IdDetails
newIdDetails = case Id -> IdDetails
idDetails Id
jid of
                  -- We treat join points as CBV functions. Even after they are floated out.
                  -- See Note [Use CBV semantics only for join points and workers]
                  JoinId Arity
_ (Just [CbvMark]
marks) -> [CbvMark] -> IdDetails
WorkerLikeId [CbvMark]
marks
                  JoinId Arity
_ Maybe [CbvMark]
Nothing      -> [CbvMark] -> IdDetails
WorkerLikeId []
                  IdDetails
_                     -> String -> IdDetails
forall a. HasCallStack => String -> a
panic String
"zapJoinId: newIdDetails can only be used if Id was a join Id."


asJoinId_maybe :: Id -> JoinPointHood -> Id
asJoinId_maybe :: Id -> JoinPointHood -> Id
asJoinId_maybe Id
id (JoinPoint Arity
arity) = Id -> Arity -> Id
asJoinId Id
id Arity
arity
asJoinId_maybe Id
id JoinPointHood
NotJoinPoint      = Id -> Id
zapJoinId Id
id

{-
************************************************************************
*                                                                      *
\subsection{IdInfo stuff}
*                                                                      *
************************************************************************
-}

        ---------------------------------
        -- ARITY
idArity :: Id -> Arity
idArity :: Id -> Arity
idArity Id
id = IdInfo -> Arity
arityInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdArity :: Id -> Arity -> Id
setIdArity :: Id -> Arity -> Id
setIdArity Id
id Arity
arity = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> Arity -> IdInfo
`setArityInfo` Arity
arity) Id
id

idCallArity :: Id -> Arity
idCallArity :: Id -> Arity
idCallArity Id
id = IdInfo -> Arity
callArityInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdCallArity :: Id -> Arity -> Id
setIdCallArity :: Id -> Arity -> Id
setIdCallArity Id
id Arity
arity = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> Arity -> IdInfo
`setCallArityInfo` Arity
arity) Id
id

-- | This function counts all arguments post-unarisation, which includes
-- arguments with no runtime representation -- see Note [Unarisation and arity]
idFunRepArity :: Id -> RepArity
idFunRepArity :: Id -> Arity
idFunRepArity Id
x = Arity -> Kind -> Arity
countFunRepArgs (Id -> Arity
idArity Id
x) (Id -> Kind
idType Id
x)

-- | Returns true if an application to n args diverges or throws an exception
-- See Note [Dead ends] in "GHC.Types.Demand".
isDeadEndId :: Var -> Bool
isDeadEndId :: Id -> Bool
isDeadEndId Id
v
  | Id -> Bool
isId Id
v    = DmdSig -> Bool
isDeadEndSig (Id -> DmdSig
idDmdSig Id
v)
  | Bool
otherwise = Bool
False

-- | Accesses the 'Id''s 'dmdSigInfo'.
idDmdSig :: Id -> DmdSig
idDmdSig :: Id -> DmdSig
idDmdSig Id
id = IdInfo -> DmdSig
dmdSigInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdDmdSig :: Id -> DmdSig -> Id
setIdDmdSig :: Id -> DmdSig -> Id
setIdDmdSig Id
id DmdSig
sig = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
sig) Id
id

idCprSig :: Id -> CprSig
idCprSig :: Id -> CprSig
idCprSig Id
id = IdInfo -> CprSig
cprSigInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdCprSig :: Id -> CprSig -> Id
setIdCprSig :: Id -> CprSig -> Id
setIdCprSig Id
id CprSig
sig = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (\IdInfo
info -> IdInfo -> CprSig -> IdInfo
setCprSigInfo IdInfo
info CprSig
sig) Id
id

zapIdDmdSig :: Id -> Id
zapIdDmdSig :: Id -> Id
zapIdDmdSig Id
id = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
nopSig) Id
id

-- | `isStrictId` says whether either
--   (a) the 'Id' has a strict demand placed on it or
--   (b) definitely has a \"strict type\", such that it can always be
--       evaluated strictly (i.e an unlifted type)
-- We need to check (b) as well as (a), because when the demand for the
-- given `id` hasn't been computed yet but `id` has a strict
-- type, we still want `isStrictId id` to be `True`.
-- Returns False if the type is levity polymorphic; False is always safe.
isStrictId :: Id -> Bool
isStrictId :: Id -> Bool
isStrictId Id
id
  | Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isId Id
id) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"isStrictId: not an id: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    Id -> Bool
isJoinId Id
id = Bool
False
  | Bool
otherwise   = HasDebugCallStack => Kind -> Bool
Kind -> Bool
isStrictType (Id -> Kind
idType Id
id) Bool -> Bool -> Bool
||
                  Demand -> Bool
isStrUsedDmd (Id -> Demand
idDemandInfo Id
id)
                  -- Take the best of both strictnesses - old and new

idTagSig_maybe :: Id -> Maybe TagSig
idTagSig_maybe :: Id -> Maybe TagSig
idTagSig_maybe = IdInfo -> Maybe TagSig
tagSig (IdInfo -> Maybe TagSig) -> (Id -> IdInfo) -> Id -> Maybe TagSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo

---------------------------------
-- UNFOLDING

-- | Returns the 'Id's unfolding, but does not expose the unfolding of a strong
-- loop breaker. See 'unfoldingInfo'.
--
-- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'.
idUnfolding :: IdUnfoldingFun
idUnfolding :: Id -> Unfolding
idUnfolding Id
id = IdInfo -> Unfolding
unfoldingInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

noUnfoldingFun :: IdUnfoldingFun
noUnfoldingFun :: Id -> Unfolding
noUnfoldingFun Id
_id = Unfolding
noUnfolding

-- | Returns an unfolding only if
--   (a) not a strong loop breaker and
--   (b) always active
alwaysActiveUnfoldingFun :: IdUnfoldingFun
alwaysActiveUnfoldingFun :: Id -> Unfolding
alwaysActiveUnfoldingFun Id
id
  | Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
id) = Id -> Unfolding
idUnfolding Id
id
  | Bool
otherwise                              = Unfolding
noUnfolding

-- | Returns an unfolding only if
--   (a) not a strong loop breaker and
--   (b) active in according to is_active
whenActiveUnfoldingFun :: (Activation -> Bool) -> IdUnfoldingFun
whenActiveUnfoldingFun :: (Activation -> Bool) -> Id -> Unfolding
whenActiveUnfoldingFun Activation -> Bool
is_active Id
id
  | Activation -> Bool
is_active (Id -> Activation
idInlineActivation Id
id) = Id -> Unfolding
idUnfolding Id
id
  | Bool
otherwise                         = Unfolding
NoUnfolding

realIdUnfolding :: Id -> Unfolding
-- ^ Expose the unfolding if there is one, including for loop breakers
realIdUnfolding :: Id -> Unfolding
realIdUnfolding Id
id = IdInfo -> Unfolding
realUnfoldingInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding Id
id Unfolding
unfolding = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
unfolding) Id
id

idDemandInfo       :: Id -> Demand
idDemandInfo :: Id -> Demand
idDemandInfo       Id
id = IdInfo -> Demand
demandInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo Id
id Demand
dmd = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> Demand -> IdInfo
`setDemandInfo` Demand
dmd) Id
id

setIdTagSig :: Id -> TagSig -> Id
setIdTagSig :: Id -> TagSig -> Id
setIdTagSig Id
id TagSig
sig = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> TagSig -> IdInfo
`setTagSig` TagSig
sig) Id
id

-- | If all marks are NotMarkedStrict we just set nothing.
setIdCbvMarks :: Id -> [CbvMark] -> Id
setIdCbvMarks :: Id -> [CbvMark] -> Id
setIdCbvMarks Id
id [CbvMark]
marks
  | Bool -> Bool
not ((CbvMark -> Bool) -> [CbvMark] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CbvMark -> Bool
isMarkedCbv [CbvMark]
marks) = Id
id
  | Bool
otherwise =
      -- pprTrace "setMarks:" (ppr id <> text ":" <> ppr marks) $
      case Id -> IdDetails
idDetails Id
id of
        -- good ol (likely worker) function
        IdDetails
VanillaId ->      Id
id Id -> IdDetails -> Id
`setIdDetails` ([CbvMark] -> IdDetails
WorkerLikeId [CbvMark]
trimmedMarks)
        JoinId Arity
arity Maybe [CbvMark]
_ -> Id
id Id -> IdDetails -> Id
`setIdDetails` (Arity -> Maybe [CbvMark] -> IdDetails
JoinId Arity
arity ([CbvMark] -> Maybe [CbvMark]
forall a. a -> Maybe a
Just [CbvMark]
trimmedMarks))
        -- Updating an existing call by value function.
        WorkerLikeId [CbvMark]
_ -> Id
id Id -> IdDetails -> Id
`setIdDetails` ([CbvMark] -> IdDetails
WorkerLikeId [CbvMark]
trimmedMarks)
        -- Do nothing for these
        RecSelId{} -> Id
id
        DFunId{} -> Id
id
        IdDetails
_ -> String -> SDoc -> Id -> Id
forall a. String -> SDoc -> a -> a
pprTrace String
"setIdCbvMarks: Unable to set cbv marks for" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"marks:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CbvMark]
marks SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"idDetails:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> IdDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> IdDetails
idDetails Id
id)) Id
id

    where
      -- (Currently) no point in passing args beyond the arity unlifted.
      -- We would have to eta expand all call sites to (length marks).
      -- Perhaps that's sensible but for now be conservative.
      -- Similarly we don't need any lazy marks at the end of the list.
      -- This way the length of the list is always exactly number of arguments
      -- that must be visible to CodeGen. See See Note [CBV Function Ids]
      -- for more details.
      trimmedMarks :: [CbvMark]
trimmedMarks = (CbvMark -> Bool) -> [CbvMark] -> [CbvMark]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE (Bool -> Bool
not (Bool -> Bool) -> (CbvMark -> Bool) -> CbvMark -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CbvMark -> Bool
isMarkedCbv) ([CbvMark] -> [CbvMark]) -> [CbvMark] -> [CbvMark]
forall a b. (a -> b) -> a -> b
$ Arity -> [CbvMark] -> [CbvMark]
forall a. Arity -> [a] -> [a]
take (Id -> Arity
idArity Id
id) [CbvMark]
marks

idCbvMarks_maybe :: Id -> Maybe [CbvMark]
idCbvMarks_maybe :: Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
id = case Id -> IdDetails
idDetails Id
id of
  WorkerLikeId [CbvMark]
marks -> [CbvMark] -> Maybe [CbvMark]
forall a. a -> Maybe a
Just [CbvMark]
marks
  JoinId Arity
_arity Maybe [CbvMark]
marks  -> Maybe [CbvMark]
marks
  IdDetails
_                    -> Maybe [CbvMark]
forall a. Maybe a
Nothing

-- Id must be called with at least this arity in order to allow arguments to
-- be passed unlifted.
idCbvMarkArity :: Id -> Arity
idCbvMarkArity :: Id -> Arity
idCbvMarkArity Id
fn = Arity -> ([CbvMark] -> Arity) -> Maybe [CbvMark] -> Arity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Arity
0 [CbvMark] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fn)

-- | Remove any cbv marks on arguments from a given Id.
asNonWorkerLikeId :: Id -> Id
asNonWorkerLikeId :: Id -> Id
asNonWorkerLikeId Id
id =
  let details :: Maybe IdDetails
details = case Id -> IdDetails
idDetails Id
id of
        WorkerLikeId{}      -> IdDetails -> Maybe IdDetails
forall a. a -> Maybe a
Just (IdDetails -> Maybe IdDetails) -> IdDetails -> Maybe IdDetails
forall a b. (a -> b) -> a -> b
$ IdDetails
VanillaId
        JoinId Arity
arity Just{} -> IdDetails -> Maybe IdDetails
forall a. a -> Maybe a
Just (IdDetails -> Maybe IdDetails) -> IdDetails -> Maybe IdDetails
forall a b. (a -> b) -> a -> b
$ Arity -> Maybe [CbvMark] -> IdDetails
JoinId Arity
arity Maybe [CbvMark]
forall a. Maybe a
Nothing
        IdDetails
_                   -> Maybe IdDetails
forall a. Maybe a
Nothing
  in Maybe IdDetails -> Id -> Id
maybeModifyIdDetails Maybe IdDetails
details Id
id

-- | Turn this id into a WorkerLikeId if possible.
asWorkerLikeId :: Id -> Id
asWorkerLikeId :: Id -> Id
asWorkerLikeId Id
id =
  let details :: Maybe IdDetails
details = case Id -> IdDetails
idDetails Id
id of
        WorkerLikeId{}        -> Maybe IdDetails
forall a. Maybe a
Nothing
        JoinId Arity
_arity Just{}  -> Maybe IdDetails
forall a. Maybe a
Nothing
        JoinId Arity
arity Maybe [CbvMark]
Nothing  -> IdDetails -> Maybe IdDetails
forall a. a -> Maybe a
Just (Arity -> Maybe [CbvMark] -> IdDetails
JoinId Arity
arity ([CbvMark] -> Maybe [CbvMark]
forall a. a -> Maybe a
Just []))
        IdDetails
VanillaId             -> IdDetails -> Maybe IdDetails
forall a. a -> Maybe a
Just (IdDetails -> Maybe IdDetails) -> IdDetails -> Maybe IdDetails
forall a b. (a -> b) -> a -> b
$ [CbvMark] -> IdDetails
WorkerLikeId []
        IdDetails
_                     -> Maybe IdDetails
forall a. Maybe a
Nothing
  in Maybe IdDetails -> Id -> Id
maybeModifyIdDetails Maybe IdDetails
details Id
id

setCaseBndrEvald :: StrictnessMark -> Id -> Id
-- Used for variables bound by a case expressions, both the case-binder
-- itself, and any pattern-bound variables that are argument of a
-- strict constructor.  It just marks the variable as already-evaluated,
-- so that (for example) a subsequent 'seq' can be dropped
setCaseBndrEvald :: StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
str Id
id
  | StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str = Id
id Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
evaldUnfolding
  | Bool
otherwise          = Id
id

-- | Similar to trimUnfolding, but also removes evaldness info.
zapIdUnfolding :: Id -> Id
zapIdUnfolding :: Id -> Id
zapIdUnfolding Id
v
  | Id -> Bool
isId Id
v, Unfolding -> Bool
hasSomeUnfolding (Id -> Unfolding
idUnfolding Id
v) = Id -> Unfolding -> Id
setIdUnfolding Id
v Unfolding
noUnfolding
  | Bool
otherwise = Id
v

        ---------------------------------
        -- SPECIALISATION

-- See Note [Specialisations and RULES in IdInfo] in GHC.Types.Id.Info

idSpecialisation :: Id -> RuleInfo
idSpecialisation :: Id -> RuleInfo
idSpecialisation Id
id = IdInfo -> RuleInfo
ruleInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

idCoreRules :: Id -> [CoreRule]
idCoreRules :: Id -> [CoreRule]
idCoreRules Id
id = RuleInfo -> [CoreRule]
ruleInfoRules (Id -> RuleInfo
idSpecialisation Id
id)

idHasRules :: Id -> Bool
idHasRules :: Id -> Bool
idHasRules Id
id = Bool -> Bool
not (RuleInfo -> Bool
isEmptyRuleInfo (Id -> RuleInfo
idSpecialisation Id
id))

setIdSpecialisation :: Id -> RuleInfo -> Id
setIdSpecialisation :: Id -> RuleInfo -> Id
setIdSpecialisation Id
id RuleInfo
spec_info = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` RuleInfo
spec_info) Id
id

        ---------------------------------
        -- CAF INFO
idCafInfo :: Id -> CafInfo
idCafInfo :: Id -> CafInfo
idCafInfo Id
id = IdInfo -> CafInfo
cafInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo Id
id CafInfo
caf_info = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
caf_info) Id
id

        ---------------------------------
        -- Lambda form info

idLFInfo_maybe :: Id -> Maybe LambdaFormInfo
idLFInfo_maybe :: Id -> Maybe LambdaFormInfo
idLFInfo_maybe = IdInfo -> Maybe LambdaFormInfo
lfInfo (IdInfo -> Maybe LambdaFormInfo)
-> (Id -> IdInfo) -> Id -> Maybe LambdaFormInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo

setIdLFInfo :: Id -> LambdaFormInfo -> Id
setIdLFInfo :: Id -> LambdaFormInfo -> Id
setIdLFInfo Id
id LambdaFormInfo
lf = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> LambdaFormInfo -> IdInfo
`setLFInfo` LambdaFormInfo
lf) Id
id

        ---------------------------------
        -- Occurrence INFO
idOccInfo :: Id -> OccInfo
idOccInfo :: Id -> OccInfo
idOccInfo Id
id = IdInfo -> OccInfo
occInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdOccInfo :: Id -> OccInfo -> Id
setIdOccInfo :: Id -> OccInfo -> Id
setIdOccInfo Id
id OccInfo
occ_info = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> OccInfo -> IdInfo
`setOccInfo` OccInfo
occ_info) Id
id

zapIdOccInfo :: Id -> Id
zapIdOccInfo :: Id -> Id
zapIdOccInfo Id
b = Id
b Id -> OccInfo -> Id
`setIdOccInfo` OccInfo
noOccInfo

{-
        ---------------------------------
        -- INLINING
The inline pragma tells us to be very keen to inline this Id, but it's still
OK not to if optimisation is switched off.
-}

idInlinePragma :: Id -> InlinePragma
idInlinePragma :: Id -> InlinePragma
idInlinePragma Id
id = IdInfo -> InlinePragma
inlinePragInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setInlinePragma :: Id -> InlinePragma -> Id
setInlinePragma :: Id -> InlinePragma -> Id
setInlinePragma Id
id InlinePragma
prag = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
prag) Id
id

modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
modifyInlinePragma Id
id InlinePragma -> InlinePragma
fn = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (\IdInfo
info -> IdInfo
info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` (InlinePragma -> InlinePragma
fn (IdInfo -> InlinePragma
inlinePragInfo IdInfo
info))) Id
id

idInlineActivation :: Id -> Activation
idInlineActivation :: Id -> Activation
idInlineActivation Id
id = InlinePragma -> Activation
inlinePragmaActivation (Id -> InlinePragma
idInlinePragma Id
id)

setInlineActivation :: Id -> Activation -> Id
setInlineActivation :: Id -> Activation -> Id
setInlineActivation Id
id Activation
act = Id -> (InlinePragma -> InlinePragma) -> Id
modifyInlinePragma Id
id (\InlinePragma
prag -> InlinePragma -> Activation -> InlinePragma
setInlinePragmaActivation InlinePragma
prag Activation
act)

idRuleMatchInfo :: Id -> RuleMatchInfo
idRuleMatchInfo :: Id -> RuleMatchInfo
idRuleMatchInfo Id
id = InlinePragma -> RuleMatchInfo
inlinePragmaRuleMatchInfo (Id -> InlinePragma
idInlinePragma Id
id)

isConLikeId :: Id -> Bool
isConLikeId :: Id -> Bool
isConLikeId Id
id = RuleMatchInfo -> Bool
isConLike (Id -> RuleMatchInfo
idRuleMatchInfo Id
id)

{-
        ---------------------------------
        -- ONE-SHOT LAMBDAS
-}

idOneShotInfo :: Id -> OneShotInfo
idOneShotInfo :: Id -> OneShotInfo
idOneShotInfo Id
id = IdInfo -> OneShotInfo
oneShotInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setOneShotLambda :: Id -> Id
setOneShotLambda :: Id -> Id
setOneShotLambda Id
id = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` OneShotInfo
OneShotLam) Id
id

clearOneShotLambda :: Id -> Id
clearOneShotLambda :: Id -> Id
clearOneShotLambda Id
id = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` OneShotInfo
NoOneShotInfo) Id
id

setIdOneShotInfo :: Id -> OneShotInfo -> Id
setIdOneShotInfo :: Id -> OneShotInfo -> Id
setIdOneShotInfo Id
id OneShotInfo
one_shot = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` OneShotInfo
one_shot) Id
id

updOneShotInfo :: Id -> OneShotInfo -> Id
-- Combine the info in the Id with new info
updOneShotInfo :: Id -> OneShotInfo -> Id
updOneShotInfo Id
id OneShotInfo
one_shot
  | OneShotInfo
OneShotLam <- OneShotInfo
one_shot
  , OneShotInfo
NoOneShotInfo <- Id -> OneShotInfo
idOneShotInfo Id
id
  = Id -> OneShotInfo -> Id
setIdOneShotInfo Id
id OneShotInfo
OneShotLam
  | Bool
otherwise
  = Id
id

-- The OneShotLambda functions simply fiddle with the IdInfo flag
-- But watch out: this may change the type of something else
--      f = \x -> e
-- If we change the one-shot-ness of x, f's type changes

-- Replaces the id info if the zapper returns @Just idinfo@
zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapper Id
id = Maybe IdInfo -> Id -> Id
maybeModifyIdInfo (IdInfo -> Maybe IdInfo
zapper (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)) Id
id

zapLamIdInfo :: Id -> Id
zapLamIdInfo :: Id -> Id
zapLamIdInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapLamInfo

zapFragileIdInfo :: Id -> Id
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapFragileInfo

floatifyIdDemandInfo :: Id -> Id
-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels
floatifyIdDemandInfo :: Id -> Id
floatifyIdDemandInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
floatifyDemandInfo

zapIdUsageInfo :: Id -> Id
zapIdUsageInfo :: Id -> Id
zapIdUsageInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapUsageInfo

zapIdUsageEnvInfo :: Id -> Id
zapIdUsageEnvInfo :: Id -> Id
zapIdUsageEnvInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapUsageEnvInfo

zapIdUsedOnceInfo :: Id -> Id
zapIdUsedOnceInfo :: Id -> Id
zapIdUsedOnceInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapUsedOnceInfo

zapIdTailCallInfo :: Id -> Id
zapIdTailCallInfo :: Id -> Id
zapIdTailCallInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapTailCallInfo

zapStableUnfolding :: Id -> Id
zapStableUnfolding :: Id -> Id
zapStableUnfolding Id
id
 | Unfolding -> Bool
isStableUnfolding (Id -> Unfolding
realIdUnfolding Id
id) = Id -> Unfolding -> Id
setIdUnfolding Id
id Unfolding
NoUnfolding
 | Bool
otherwise                              = Id
id

{-
Note [transferPolyIdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~
This transfer is used in three places:
        FloatOut (long-distance let-floating)
        GHC.Core.Opt.Simplify.Utils.abstractFloats (short-distance let-floating)
        StgLiftLams (selectively lambda-lift local functions to top-level)

Consider the short-distance let-floating:

   f = /\a. let g = rhs in ...

Then if we float thus

   g' = /\a. rhs
   f = /\a. ...[g' a/g]....

we *do not* want to lose g's
  * strictness information
  * arity
  * inline pragma (though that is bit more debatable)
  * occurrence info

Mostly this is just an optimisation, but it's *vital* to
transfer the occurrence info.  Consider

   NonRec { f = /\a. let Rec { g* = ..g.. } in ... }

where the '*' means 'LoopBreaker'.  Then if we float we must get

   Rec { g'* = /\a. ...(g' a)... }
   NonRec { f = /\a. ...[g' a/g]....}

where g' is also marked as LoopBreaker.  If not, terrible things
can happen if we re-simplify the binding (and the Simplifier does
sometimes simplify a term twice); see #4345.

It's not so simple to retain
  * worker info
  * rules
so we simply discard those.  Sooner or later this may bite us.

If we abstract wrt one or more *value* binders, we must modify the
arity and strictness info before transferring it.  E.g.
      f = \x. e
-->
      g' = \y. \x. e
      + substitute (g' y) for g
Notice that g' has an arity one more than the original g
-}

transferPolyIdInfo :: Id        -- Original Id
                   -> [Var]     -- Abstract wrt these variables
                   -> Id        -- New Id
                   -> Id
transferPolyIdInfo :: Id -> [Id] -> Id -> Id
transferPolyIdInfo Id
old_id [Id]
abstract_wrt Id
new_id
  = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
transfer Id
new_id Id -> [CbvMark] -> Id
`setIdCbvMarks` [CbvMark]
new_cbv_marks
  where
    arity_increase :: Arity
arity_increase = (Id -> Bool) -> [Id] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count Id -> Bool
isId [Id]
abstract_wrt    -- Arity increases by the
                                                -- number of value binders

    old_info :: IdInfo
old_info        = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
old_id
    old_arity :: Arity
old_arity       = IdInfo -> Arity
arityInfo IdInfo
old_info
    old_inline_prag :: InlinePragma
old_inline_prag = IdInfo -> InlinePragma
inlinePragInfo IdInfo
old_info
    old_occ_info :: OccInfo
old_occ_info    = IdInfo -> OccInfo
occInfo IdInfo
old_info
    new_arity :: Arity
new_arity       = Arity
old_arity Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
arity_increase
    new_occ_info :: OccInfo
new_occ_info    = OccInfo -> OccInfo
zapOccTailCallInfo OccInfo
old_occ_info

    old_strictness :: DmdSig
old_strictness  = IdInfo -> DmdSig
dmdSigInfo IdInfo
old_info
    new_strictness :: DmdSig
new_strictness  = Arity -> DmdSig -> DmdSig
prependArgsDmdSig Arity
arity_increase DmdSig
old_strictness
    old_cpr :: CprSig
old_cpr         = IdInfo -> CprSig
cprSigInfo IdInfo
old_info
    new_cpr :: CprSig
new_cpr         = Arity -> CprSig -> CprSig
prependArgsCprSig Arity
arity_increase CprSig
old_cpr

    old_cbv_marks :: [CbvMark]
old_cbv_marks   = [CbvMark] -> Maybe [CbvMark] -> [CbvMark]
forall a. a -> Maybe a -> a
fromMaybe (Arity -> CbvMark -> [CbvMark]
forall a. Arity -> a -> [a]
replicate Arity
old_arity CbvMark
NotMarkedCbv) (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
old_id)
    abstr_cbv_marks :: [CbvMark]
abstr_cbv_marks = (Id -> Maybe CbvMark) -> [Id] -> [CbvMark]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Id -> Maybe CbvMark
getMark [Id]
abstract_wrt
    new_cbv_marks :: [CbvMark]
new_cbv_marks   = [CbvMark]
abstr_cbv_marks [CbvMark] -> [CbvMark] -> [CbvMark]
forall a. [a] -> [a] -> [a]
++ [CbvMark]
old_cbv_marks

    getMark :: Id -> Maybe CbvMark
getMark Id
v
      | Bool -> Bool
not (Id -> Bool
isId Id
v)
      = Maybe CbvMark
forall a. Maybe a
Nothing
      | Id -> Bool
isId Id
v
      , Unfolding -> Bool
isEvaldUnfolding (Id -> Unfolding
idUnfolding Id
v)
      , Kind -> Bool
mightBeLiftedType (Id -> Kind
idType Id
v)
      = CbvMark -> Maybe CbvMark
forall a. a -> Maybe a
Just CbvMark
MarkedCbv
      | Bool
otherwise = CbvMark -> Maybe CbvMark
forall a. a -> Maybe a
Just CbvMark
NotMarkedCbv
    transfer :: IdInfo -> IdInfo
transfer IdInfo
new_info = IdInfo
new_info IdInfo -> Arity -> IdInfo
`setArityInfo`      Arity
new_arity
                                 IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
old_inline_prag
                                 IdInfo -> OccInfo -> IdInfo
`setOccInfo`        OccInfo
new_occ_info
                                 IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo`     DmdSig
new_strictness
                                 IdInfo -> CprSig -> IdInfo
`setCprSigInfo`     CprSig
new_cpr