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

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

{-# LANGUAGE CPP #-}

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

module Id (
        -- * The main types
        Var, Id, isId,

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

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

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

        -- ** Modifying an Id
        setIdName, setIdUnique, Id.setIdType,
        setIdExported, setIdNotExported,
        globaliseId, localiseId,
        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
        zapIdUsedOnceInfo, zapIdTailCallInfo,
        zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,
        transferPolyIdInfo,

        -- ** Predicates on Ids
        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,

        -- ** Join variables
        JoinId, isJoinId, isJoinId_maybe, idJoinArity,
        asJoinId, asJoinId_maybe, zapJoinId,

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

        -- ** One-shot lambdas
        isOneShotBndr, isProbablyOneShotLambda,
        setOneShotLambda, clearOneShotLambda,
        updOneShotInfo, setIdOneShotInfo,
        isStateHackType, stateHackOneShot, typeOneShot,

        -- ** Reading 'IdInfo' fields
        idArity,
        idCallArity, idFunRepArity,
        idUnfolding, realIdUnfolding,
        idSpecialisation, idCoreRules, idHasRules,
        idCafInfo,
        idOneShotInfo, idStateHackOneShotInfo,
        idOccInfo,
        isNeverLevPolyId,

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

        setIdSpecialisation,
        setIdCafInfo,
        setIdOccInfo, zapIdOccInfo,

        setIdDemandInfo,
        setIdStrictness,

        idDemandInfo,
        idStrictness,

    ) where

#include "GhclibHsVersions.h"

import GhcPrelude

import DynFlags
import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding,
                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )

import IdInfo
import BasicTypes

-- Imported and re-exported
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 {-# SOURCE #-} PrimOp (PrimOp)
import ForeignCall
import Maybes
import SrcLoc
import Outputable
import Unique
import UniqSupply
import FastString
import Util

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

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

          `setIdDemandInfo`,
          `setIdStrictness`,

          `asJoinId`,
          `asJoinId_maybe`

{-
************************************************************************
*                                                                      *
\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

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
`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
  | ASSERT( isId id ) isLocalId id && isInternalName name
  = Id
id
  | Bool
otherwise
  = IdDetails -> Name -> Kind -> IdInfo -> Id
Var.mkLocalVar (Id -> IdDetails
idDetails Id
id) (Name -> Name
localiseName Name
name) (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
`seq` (Id -> IdInfo -> Id
lazySetIdInfo Id
id IdInfo
info)
        -- Try to avoid space leaks by seq'ing

modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo :: (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

{-
************************************************************************
*                                                                      *
\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 "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 :: Name -> Type -> Id
mkVanillaGlobal :: Name -> Kind -> Id
mkVanillaGlobal Name
name Kind
ty = Name -> Kind -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Kind
ty IdInfo
vanillaIdInfo

-- | Make a global 'Id' with no global information but some generic 'IdInfo'
mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo :: Name -> Kind -> IdInfo -> Id
mkVanillaGlobalWithInfo = IdDetails -> Name -> Kind -> IdInfo -> Id
mkGlobalId IdDetails
VanillaId


-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"
mkLocalId :: Name -> Type -> Id
mkLocalId :: Name -> Kind -> Id
mkLocalId Name
name Kind
ty = Name -> Kind -> IdInfo -> Id
mkLocalIdWithInfo Name
name Kind
ty IdInfo
vanillaIdInfo
 -- It's tempting to ASSERT( not (isCoVarType ty) ), but don't. Sometimes,
 -- the type is a panic. (Search invented_id)

-- | Make a local CoVar
mkLocalCoVar :: Name -> Type -> CoVar
mkLocalCoVar :: Name -> Kind -> Id
mkLocalCoVar Name
name Kind
ty
  = ASSERT( isCoVarType ty )
    IdDetails -> Name -> Kind -> IdInfo -> Id
Var.mkLocalVar IdDetails
CoVarId Name
name Kind
ty IdInfo
vanillaIdInfo

-- | Like 'mkLocalId', but checks the type to see if it should make a covar
mkLocalIdOrCoVar :: Name -> Type -> Id
mkLocalIdOrCoVar :: Name -> Kind -> Id
mkLocalIdOrCoVar Name
name Kind
ty
  | Kind -> Bool
isCoVarType Kind
ty = Name -> Kind -> Id
mkLocalCoVar Name
name Kind
ty
  | Bool
otherwise      = Name -> Kind -> Id
mkLocalId    Name
name Kind
ty

-- | Make a local id, with the IdDetails set to CoVarId if the type indicates
-- so.
mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdOrCoVarWithInfo :: Name -> Kind -> IdInfo -> Id
mkLocalIdOrCoVarWithInfo Name
name Kind
ty IdInfo
info
  = IdDetails -> Name -> Kind -> IdInfo -> Id
Var.mkLocalVar IdDetails
details Name
name Kind
ty IdInfo
info
  where
    details :: IdDetails
details | Kind -> Bool
isCoVarType Kind
ty = IdDetails
CoVarId
            | Bool
otherwise      = IdDetails
VanillaId

    -- proper ids only; no covars!
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo :: Name -> Kind -> IdInfo -> Id
mkLocalIdWithInfo Name
name Kind
ty IdInfo
info = IdDetails -> Name -> Kind -> IdInfo -> Id
Var.mkLocalVar IdDetails
VanillaId Name
name 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 = 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 -> Type -> Id
mkSysLocal :: FastString -> Unique -> Kind -> Id
mkSysLocal FastString
fs Unique
uniq Kind
ty = ASSERT( not (isCoVarType ty) )
                        Name -> Kind -> Id
mkLocalId (Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
fs) Kind
ty

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

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

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

-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize
mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id
mkUserLocal :: OccName -> Unique -> Kind -> SrcSpan -> Id
mkUserLocal OccName
occ Unique
uniq Kind
ty SrcSpan
loc = ASSERT( not (isCoVarType ty) )
                              Name -> Kind -> Id
mkLocalId (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
loc) Kind
ty

-- | Like 'mkUserLocal', but checks if we have a coercion type
mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id
mkUserLocalOrCoVar :: OccName -> Unique -> Kind -> SrcSpan -> Id
mkUserLocalOrCoVar OccName
occ Unique
uniq Kind
ty SrcSpan
loc
  = Name -> Kind -> Id
mkLocalIdOrCoVar (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
loc) 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
  = Name -> Kind -> Id
mkLocalIdOrCoVar ((OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName OccName -> OccName
mkWorkerOcc Unique
uniq (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
unwrkr)) 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 :: Int -> Kind -> Id
mkTemplateLocal Int
i Kind
ty = FastString -> Unique -> Kind -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"v") (Int -> Unique
mkBuiltinUnique Int
i) Kind
ty

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

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

************************************************************************
*                                                                      *
\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 -> IdDetails
Var.idDetails Id
id of
        RecSelId { sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelParent
parent } -> RecSelParent
parent
        IdDetails
_ -> String -> RecSelParent
forall a. String -> a
panic String
"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 -> 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_maybe :: Id -> Maybe Class
isClassOpId_maybe Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        ClassOpId Class
cls -> 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 PrimOp
_ -> 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 -> 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

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

isJoinId :: Var -> Bool
-- It is convenient in 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

isJoinId_maybe :: Var -> Maybe JoinArity
isJoinId_maybe :: Id -> Maybe Int
isJoinId_maybe Id
id
 | Id -> Bool
isId Id
id  = ASSERT2( isId id, ppr id )
              case Id -> IdDetails
Var.idDetails Id
id of
                JoinId Int
arity -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
arity
                IdDetails
_            -> Maybe Int
forall a. Maybe a
Nothing
 | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

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.
--
-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs.
-- for the history of this.
--
-- Note that CorePrep currently eta expands things no-binding things and this
-- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things
-- in CorePrep] in CorePrep for details.
--
-- EXCEPT: unboxed tuples, which definitely have no binding
hasNoBinding :: Id -> Bool
hasNoBinding Id
id = case Id -> IdDetails
Var.idDetails Id
id of
                        PrimOpId PrimOp
_       -> Bool
False   -- See Note [Primop wrappers] in PrimOp.hs
                        FCallId ForeignCall
_        -> Bool
True
                        DataConWorkId DataCon
dc -> DataCon -> Bool
isUnboxedTupleCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumCon DataCon
dc
                        IdDetails
_                -> Unfolding -> Bool
isCompulsoryUnfolding (Id -> Unfolding
idUnfolding Id
id)
                                            -- See Note [Levity-polymorphic Ids]

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)

{- Note [Levity-polymorphic Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some levity-polymorphic Ids must be applied and and inlined, not left
un-saturated.  Example:
  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b

This has a compulsory unfolding because we can't lambda-bind those
arguments.  But the compulsory unfolding may leave levity-polymorphic
lambdas if it is not applied to enough arguments; e.g. (#14561)
  bad :: forall (a :: TYPE r). a -> a
  bad = unsafeCoerce#

The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop.
And we want that magic to apply to levity-polymorphic compulsory-inline things.
The easiest way to do this is for hasNoBinding to return True of all things
that have compulsory unfolding.  Some Ids with a compulsory unfolding also
have a binding, but it does not harm to say they don't here, and its a very
simple way to fix #14561.
-}

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 -> Int
idJoinArity Id
id = Id -> Maybe Int
isJoinId_maybe Id
id Maybe Int -> Int -> Int
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> Int
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 -> Int -> Id
asJoinId Id
id Int
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
id Id -> IdDetails -> Id
`setIdDetails` Int -> IdDetails
JoinId Int
arity
  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
                              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 (Id
jid Id -> IdDetails -> Id
`setIdDetails` IdDetails
VanillaId)
                                 -- Core Lint may complain if still marked
                                 -- as AlwaysTailCalled
              | Bool
otherwise    = Id
jid

asJoinId_maybe :: Id -> Maybe JoinArity -> Id
asJoinId_maybe :: Id -> Maybe Int -> Id
asJoinId_maybe Id
id (Just Int
arity) = Id -> Int -> Id
asJoinId Id
id Int
arity
asJoinId_maybe Id
id Maybe Int
Nothing      = Id -> Id
zapJoinId Id
id

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

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

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

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

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

idFunRepArity :: Id -> RepArity
idFunRepArity :: Id -> Int
idFunRepArity Id
x = Int -> Kind -> Int
countFunRepArgs (Id -> Int
idArity Id
x) (Id -> Kind
idType Id
x)

-- | Returns true if an application to n args would diverge
isBottomingId :: Var -> Bool
isBottomingId :: Id -> Bool
isBottomingId Id
v
  | Id -> Bool
isId Id
v    = StrictSig -> Bool
isBottomingSig (Id -> StrictSig
idStrictness Id
v)
  | Bool
otherwise = Bool
False

-- | Accesses the 'Id''s 'strictnessInfo'.
idStrictness :: Id -> StrictSig
idStrictness :: Id -> StrictSig
idStrictness Id
id = IdInfo -> StrictSig
strictnessInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness Id
id StrictSig
sig = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
sig) Id
id

zapIdStrictness :: Id -> Id
zapIdStrictness :: Id -> Id
zapIdStrictness Id
id = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
nopSig) Id
id

-- | This predicate says whether the 'Id' has a strict demand placed on it or
-- has a type such that it can always be evaluated strictly (i.e an
-- unlifted type, as of GHC 7.6).  We need to
-- check separately whether the 'Id' has a so-called \"strict type\" because if
-- 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@.
isStrictId :: Id -> Bool
isStrictId :: Id -> Bool
isStrictId Id
id
  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
         Bool -> Bool
not (Id -> Bool
isJoinId Id
id) Bool -> Bool -> Bool
&& (
           (HasDebugCallStack => Kind -> Bool
Kind -> Bool
isStrictType (Id -> Kind
idType Id
id)) Bool -> Bool -> Bool
||
           -- Take the best of both strictnesses - old and new
           (JointDmd (Str StrDmd) (Use UseDmd) -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd (Id -> JointDmd (Str StrDmd) (Use UseDmd)
idDemandInfo Id
id))
         )

        ---------------------------------
        -- UNFOLDING
idUnfolding :: Id -> Unfolding
-- Do not expose the unfolding of a loop breaker!
idUnfolding :: Id -> Unfolding
idUnfolding Id
id
  | OccInfo -> Bool
isStrongLoopBreaker (IdInfo -> OccInfo
occInfo IdInfo
info) = Unfolding
NoUnfolding
  | Bool
otherwise                          = IdInfo -> Unfolding
unfoldingInfo IdInfo
info
  where
    info :: IdInfo
info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id

realIdUnfolding :: Id -> Unfolding
-- Expose the unfolding if there is one, including for loop breakers
realIdUnfolding :: Id -> Unfolding
realIdUnfolding Id
id = IdInfo -> Unfolding
unfoldingInfo (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 -> JointDmd (Str StrDmd) (Use UseDmd)
idDemandInfo       Id
id = IdInfo -> JointDmd (Str StrDmd) (Use UseDmd)
demandInfo (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo :: Id -> JointDmd (Str StrDmd) (Use UseDmd) -> Id
setIdDemandInfo Id
id JointDmd (Str StrDmd) (Use UseDmd)
dmd = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> JointDmd (Str StrDmd) (Use UseDmd) -> IdInfo
`setDemandInfo` JointDmd (Str StrDmd) (Use UseDmd)
dmd) 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

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

-- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs

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

        ---------------------------------
        -- 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 = Id -> Bool
isDataConWorkId Id
id Bool -> Bool -> Bool
|| 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)

-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account
-- See Note [The state-transformer hack] in CoreArity
idStateHackOneShotInfo :: Id -> OneShotInfo
idStateHackOneShotInfo :: Id -> OneShotInfo
idStateHackOneShotInfo Id
id
    | Kind -> Bool
isStateHackType (Id -> Kind
idType Id
id) = OneShotInfo
stateHackOneShot
    | Bool
otherwise                   = Id -> OneShotInfo
idOneShotInfo Id
id

-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once
-- This one is the "business end", called externally.
-- It works on type variables as well as Ids, returning True
-- Its main purpose is to encapsulate the Horrible State Hack
-- See Note [The state-transformer hack] in CoreArity
isOneShotBndr :: Var -> Bool
isOneShotBndr :: Id -> Bool
isOneShotBndr Id
var
  | Id -> Bool
isTyVar Id
var                              = Bool
True
  | OneShotInfo
OneShotLam <- Id -> OneShotInfo
idStateHackOneShotInfo Id
var = Bool
True
  | Bool
otherwise                                = Bool
False

-- | Should we apply the state hack to values of this 'Type'?
stateHackOneShot :: OneShotInfo
stateHackOneShot :: OneShotInfo
stateHackOneShot = OneShotInfo
OneShotLam

typeOneShot :: Type -> OneShotInfo
typeOneShot :: Kind -> OneShotInfo
typeOneShot Kind
ty
   | Kind -> Bool
isStateHackType Kind
ty = OneShotInfo
stateHackOneShot
   | Bool
otherwise          = OneShotInfo
NoOneShotInfo

isStateHackType :: Type -> Bool
isStateHackType :: Kind -> Bool
isStateHackType Kind
ty
  | DynFlags -> Bool
hasNoStateHack DynFlags
unsafeGlobalDynFlags
  = Bool
False
  | Bool
otherwise
  = case Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
ty of
        Just TyCon
tycon -> TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
statePrimTyCon
        Maybe TyCon
_          -> Bool
False
        -- This is a gross hack.  It claims that
        -- every function over realWorldStatePrimTy is a one-shot
        -- function.  This is pretty true in practice, and makes a big
        -- difference.  For example, consider
        --      a `thenST` \ r -> ...E...
        -- The early full laziness pass, if it doesn't know that r is one-shot
        -- will pull out E (let's say it doesn't mention r) to give
        --      let lvl = E in a `thenST` \ r -> ...lvl...
        -- When `thenST` gets inlined, we end up with
        --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...
        -- and we don't re-inline E.
        --
        -- It would be better to spot that r was one-shot to start with, but
        -- I don't want to rely on that.
        --
        -- Another good example is in fill_in in PrelPack.hs.  We should be able to
        -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.

isProbablyOneShotLambda :: Id -> Bool
isProbablyOneShotLambda :: Id -> Bool
isProbablyOneShotLambda Id
id = case Id -> OneShotInfo
idStateHackOneShotInfo Id
id of
                               OneShotInfo
OneShotLam    -> Bool
True
                               OneShotInfo
NoOneShotInfo -> Bool
False

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
  | Bool
do_upd    = Id -> OneShotInfo -> Id
setIdOneShotInfo Id
id OneShotInfo
one_shot
  | Bool
otherwise = Id
id
  where
    do_upd :: Bool
do_upd = case (Id -> OneShotInfo
idOneShotInfo Id
id, OneShotInfo
one_shot) of
                (OneShotInfo
NoOneShotInfo, OneShotInfo
_) -> Bool
True
                (OneShotInfo
OneShotLam,    OneShotInfo
_) -> Bool
False

-- 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

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

zapIdDemandInfo :: Id -> Id
zapIdDemandInfo :: Id -> Id
zapIdDemandInfo = (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo IdInfo -> Maybe IdInfo
zapDemandInfo

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)
        SimplUtils.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
  where
    arity_increase :: Int
arity_increase = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
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 :: Int
old_arity       = IdInfo -> Int
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 :: Int
new_arity       = Int
old_arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
arity_increase
    new_occ_info :: OccInfo
new_occ_info    = OccInfo -> OccInfo
zapOccTailCallInfo OccInfo
old_occ_info

    old_strictness :: StrictSig
old_strictness  = IdInfo -> StrictSig
strictnessInfo IdInfo
old_info
    new_strictness :: StrictSig
new_strictness  = Int -> StrictSig -> StrictSig
increaseStrictSigArity Int
arity_increase StrictSig
old_strictness

    transfer :: IdInfo -> IdInfo
transfer IdInfo
new_info = IdInfo
new_info IdInfo -> Int -> IdInfo
`setArityInfo` Int
new_arity
                                 IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
old_inline_prag
                                 IdInfo -> OccInfo -> IdInfo
`setOccInfo` OccInfo
new_occ_info
                                 IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
new_strictness

isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId = IdInfo -> Bool
isNeverLevPolyIdInfo (IdInfo -> Bool) -> (Id -> IdInfo) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo