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

\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}

(And a pretty good illustration of quite a few things wrong with
Haskell. [WDP 94/11])
-}

{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module GHC.Types.Id.Info (
        -- * The IdDetails type
        IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,
        JoinArity, isJoinIdDetails_maybe,

        RecSelParent(..), recSelParentName, recSelFirstConName,
        recSelParentCons, idDetailsConcreteTvs,
        RecSelInfo(..), conLikesRecSelInfo,

        -- * The IdInfo type
        IdInfo,         -- Abstract
        vanillaIdInfo, noCafIdInfo,

        -- ** The OneShotInfo type
        OneShotInfo(..),
        oneShotInfo, noOneShotInfo, hasNoOneShotInfo,
        setOneShotInfo,

        -- ** Zapping various forms of Info
        zapLamInfo, zapFragileInfo,
        lazifyDemandInfo, floatifyDemandInfo,
        zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
        zapTailCallInfo, zapCallArityInfo, trimUnfolding,

        -- ** The ArityInfo type
        ArityInfo,
        unknownArity,
        arityInfo, setArityInfo, ppArityInfo,

        callArityInfo, setCallArityInfo,

        -- ** Demand and strictness Info
        dmdSigInfo, setDmdSigInfo,
        cprSigInfo, setCprSigInfo,
        demandInfo, setDemandInfo, pprStrictness,

        -- ** Unfolding Info
        realUnfoldingInfo, unfoldingInfo, setUnfoldingInfo, hasInlineUnfolding,

        -- ** The InlinePragInfo type
        InlinePragInfo,
        inlinePragInfo, setInlinePragInfo,

        -- ** The OccInfo type
        OccInfo(..),
        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
        occInfo, setOccInfo,

        InsideLam(..), BranchCount,

        TailCallInfo(..),
        tailCallInfo, isAlwaysTailCalled,

        -- ** The RuleInfo type
        RuleInfo(..),
        emptyRuleInfo,
        isEmptyRuleInfo, ruleInfoFreeVars,
        ruleInfoRules, setRuleInfoHead,
        ruleInfo, setRuleInfo, tagSigInfo,

        -- ** The CAFInfo type
        CafInfo(..),
        ppCafInfo, mayHaveCafRefs,
        cafInfo, setCafInfo,

        -- ** The LambdaFormInfo type
        LambdaFormInfo,
        lfInfo, setLFInfo, setTagSig,

        tagSig,

        -- ** Tick-box Info
        TickBoxOp(..), TickBoxId,
    ) where

import GHC.Prelude

import GHC.Core
import GHC.Core.Class
import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp)
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Type (mkTyConApp)
import GHC.Core.PatSyn
import GHC.Core.ConLike
import GHC.Types.ForeignCall
import GHC.Unit.Module
import GHC.Types.Demand
import GHC.Types.Cpr
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars, noConcreteTyVars )

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Stg.EnforceEpt.TagSig
import GHC.StgToCmm.Types (LambdaFormInfo)

import Data.Data ( Data )
import Data.Word
import Data.List as List( partition )

-- infixl so you can say (id `set` a `set` b)
infixl  1 `setRuleInfo`,
          `setArityInfo`,
          `setInlinePragInfo`,
          `setUnfoldingInfo`,
          `setOneShotInfo`,
          `setOccInfo`,
          `setCafInfo`,
          `setDmdSigInfo`,
          `setCprSigInfo`,
          `setDemandInfo`,
          `setLFInfo`
{-
************************************************************************
*                                                                      *
                     IdDetails
*                                                                      *
************************************************************************
-}

-- | Identifier Details
--
-- The 'IdDetails' of an 'Id' give stable, and necessary,
-- information about the Id.
data IdDetails
  = VanillaId

  -- | The 'Id' for a record selector
  | RecSelId
    { IdDetails -> RecSelParent
sel_tycon      :: RecSelParent
    , IdDetails -> FieldLabel
sel_fieldLabel :: FieldLabel
    , IdDetails -> Bool
sel_naughty    :: Bool    -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:
                                --    data T = forall a. MkT { x :: a }
                                -- See Note [Naughty record selectors] in GHC.Tc.TyCl
    , IdDetails -> RecSelInfo
sel_cons       :: RecSelInfo
                        -- Partiality info, cached here based on the RecSelParent.
    }

  | DataConWorkId DataCon       -- ^ The 'Id' is for a data constructor /worker/
  | DataConWrapId DataCon       -- ^ The 'Id' is for a data constructor /wrapper/

                                -- [the only reasons we need to know is so that
                                --  a) to support isImplicitId
                                --  b) when desugaring a RecordCon we can get
                                --     from the Id back to the data con]

  | ClassOpId                   -- ^ The 'Id' is a superclass selector or class operation
      Class                     --    for this class
      Bool                      --   True <=> given a non-bottom dictionary, the class op will
                                --            definitely return a non-bottom result
                                --   and Note [exprOkForSpeculation and type classes]
                                --       in GHC.Core.Utils

  -- | A representation-polymorphic pseudo-op.
  | RepPolyId
      { IdDetails -> ConcreteTyVars
id_concrete_tvs :: ConcreteTyVars }
        -- ^ Which type variables of this representation-polymorphic 'Id
        -- should be instantiated to concrete type variables?
        --
        -- See Note [Representation-polymorphism checking built-ins]
        -- in GHC.Tc.Utils.Concrete.

  -- | The 'Id' is for a primitive operator.
  | PrimOpId
     { IdDetails -> PrimOp
id_primop :: PrimOp
     , id_concrete_tvs :: ConcreteTyVars }
        -- ^ Which type variables of this primop should be instantiated
        -- to concrete type variables?
        --
        -- Only ever non-empty when the PrimOp has representation-polymorphic
        -- type variables.
        --
        -- See Note [Representation-polymorphism checking built-ins]
        -- in GHC.Tc.Utils.Concrete.

  | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.
                                -- Type will be simple: no type families, newtypes, etc

  | TickBoxOpId TickBoxOp       -- ^ The 'Id' is for a HPC tick box (both traditional and binary)

  | DFunId Bool                 -- ^ A dictionary function.
       -- Bool = True <=> the class has only one method, so may be
       --                  implemented with a newtype, so it might be bad
       --                  to be strict on this dictionary

  | CoVarId    -- ^ A coercion variable
               -- This only covers /un-lifted/ coercions, of type
               -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants
  | JoinId JoinArity (Maybe [CbvMark])
        -- ^ An 'Id' for a join point taking n arguments
        -- Note [Join points] in "GHC.Core"
        -- Can also work as a WorkerLikeId if given `CbvMark`s.
        -- See Note [CBV Function Ids]
        -- The [CbvMark] is always empty (and ignored) until after Tidy.
  | WorkerLikeId [CbvMark]
        -- ^ An 'Id' for a worker like function, which might expect some arguments to be
        -- passed both evaluated and tagged.
        -- Worker like functions are create by W/W and SpecConstr and we can expect that they
        -- aren't used unapplied.
        -- See Note [CBV Function Ids]
        -- See Note [EPT enforcement]
        -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current
        -- module.

data RecSelInfo
  = RSI { RecSelInfo -> [ConLike]
rsi_def   :: [ConLike]   -- Record selector defined for these
        , RecSelInfo -> [ConLike]
rsi_undef :: [ConLike]   -- Record selector not defined for these
        }

idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars
idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars
idDetailsConcreteTvs = \ case
    PrimOpId PrimOp
_ ConcreteTyVars
conc_tvs -> ConcreteTyVars
conc_tvs
    RepPolyId  ConcreteTyVars
conc_tvs -> ConcreteTyVars
conc_tvs
    DataConWorkId DataCon
dc    -> DataCon -> ConcreteTyVars
dataConConcreteTyVars DataCon
dc
    DataConWrapId DataCon
dc    -> DataCon -> ConcreteTyVars
dataConConcreteTyVars DataCon
dc
    IdDetails
_                   -> ConcreteTyVars
noConcreteTyVars

-- | The ConLikes that have *all* the given fields
conLikesRecSelInfo :: [ConLike] -> [FieldLabelString] -> RecSelInfo
conLikesRecSelInfo :: [ConLike] -> [FieldLabelString] -> RecSelInfo
conLikesRecSelInfo [ConLike]
con_likes [FieldLabelString]
lbls
  = RSI { rsi_def :: [ConLike]
rsi_def = [ConLike]
defs, rsi_undef :: [ConLike]
rsi_undef = [ConLike]
undefs }
  where
    !([ConLike]
defs,[ConLike]
undefs) = (ConLike -> Bool) -> [ConLike] -> ([ConLike], [ConLike])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ConLike -> Bool
has_flds [ConLike]
con_likes

    has_flds :: ConLike -> Bool
has_flds ConLike
dc = (FieldLabelString -> Bool) -> [FieldLabelString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ConLike -> FieldLabelString -> Bool
has_fld ConLike
dc) [FieldLabelString]
lbls
    has_fld :: ConLike -> FieldLabelString -> Bool
has_fld ConLike
dc FieldLabelString
lbl = (FieldLabel -> Bool) -> [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ FieldLabel
fl -> FieldLabel -> FieldLabelString
flLabel FieldLabel
fl FieldLabelString -> FieldLabelString -> Bool
forall a. Eq a => a -> a -> Bool
== FieldLabelString
lbl) (ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
dc)


{- Note [CBV Function Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~
A WorkerLikeId essentially allows us to constrain the calling convention
for the given Id. Each such Id carries with it a list of CbvMarks
with each element representing a value argument. Arguments who have
a matching `MarkedCbv` entry in the list need to be passed evaluated+*properly tagged*.

CallByValueFunIds give us additional expressiveness which we use to improve
runtime. This is all part of the EPT enforcement work. See also Note [EPT enforcement].

They allows us to express the fact that an argument is not only evaluated to WHNF once we
entered it's RHS but also that an lifted argument is already *properly tagged* once we jump
into the RHS.
This means when e.g. branching on such an argument the RHS doesn't needed to perform
an eval check to ensure the argument isn't an indirection. All seqs on such an argument in
the functions body become no-ops as well.

The invariants around the arguments of call by value function like Ids are then:

* In any call `(f e1 .. en)`, if `f`'s i'th argument is marked `MarkedCbv`,
  then the caller must ensure that the i'th argument
  * points directly to the value (and hence is certainly evaluated before the call)
  * is a properly tagged pointer to that value

* The following functions (and only these functions) have `CbvMarks`:
  * Any `WorkerLikeId`
  * Some `JoinId` bindings.

This works analogous to the EPT Invariant. See also Note [EPT enforcement].

To make this work what we do is:
* During W/W and SpecConstr any worker/specialized binding we introduce
  is marked as a worker binding by `asWorkerLikeId`.
* W/W and SpecConstr further set OtherCon[] unfoldings on arguments which
  represent contents of a strict fields.
* During Tidy we look at all bindings.
  For any callByValueLike Id and join point we mark arguments as cbv if they
  Are strict. We don't do so for regular bindings.
  See Note [Use CBV semantics only for join points and workers] for why.
  We might have made some ids rhs *more* strict in order to make their arguments
  be passed CBV. See Note [Call-by-value for worker args] for why.
* During CorePrep calls to CallByValueFunIds are eta expanded.
* During Stg CodeGen:
  * When we see a call to a callByValueLike Id:
    * We check if all arguments marked to be passed unlifted are already tagged.
    * If they aren't we will wrap the call in case expressions which will evaluate+tag
      these arguments before jumping to the function.
* During Cmm codeGen:
  * When generating code for the RHS of a StrictWorker binding
    we omit tag checks when using arguments marked as tagged.

We only use this for workers and specialized versions of SpecConstr
But we also check other functions during tidy and potentially turn some of them into
call by value functions and mark some of their arguments as call-by-value by looking at
argument unfoldings.

NB: I choose to put the information into a new Id constructor since these are loaded
at all optimization levels. This makes it trivial to ensure the additional
calling convention demands are available at all call sites. Putting it into
IdInfo would require us at the very least to always decode the IdInfo
just to decide if we need to throw it away or not after.

Note [Use CBV semantics only for join points and workers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A function with cbv-semantics requires arguments to be visible
and if no arguments are visible requires us to eta-expand it's
call site. That is for a binding with three cbv arguments like
`w[WorkerLikeId[!,!,!]]` we would need to eta expand undersaturated
occurrences like `map w xs` into `map (\x1 x2 x3 -> w x1 x2 x3) xs.

In experiments it turned out that the code size increase of doing so
can outweigh the performance benefits of doing so.
So we only do this for join points, workers and
specialized functions (from SpecConstr).
Join points are naturally always called saturated so
this problem can't occur for them.
For workers and specialized functions there are also always at least
some applied arguments as we won't inline the wrapper/apply their rule
if there are unapplied occurrences like `map f xs`.
-}

-- | Parent of a record selector function.
--
-- Either the parent 'TyCon' or 'PatSyn' depending
-- on the origin of the record selector.
--
-- For a data family, this is the /instance/ 'TyCon',
-- **not** the family 'TyCon'.
data RecSelParent
  -- | Parent of a data constructor record field.
  --
  -- For a data family, this is the /instance/ 'TyCon'.
  = RecSelData TyCon
  -- | Parent of a pattern synonym record field:
  -- the 'PatSyn' itself.
  | RecSelPatSyn PatSyn
  deriving (RecSelParent -> RecSelParent -> Bool
(RecSelParent -> RecSelParent -> Bool)
-> (RecSelParent -> RecSelParent -> Bool) -> Eq RecSelParent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecSelParent -> RecSelParent -> Bool
== :: RecSelParent -> RecSelParent -> Bool
$c/= :: RecSelParent -> RecSelParent -> Bool
/= :: RecSelParent -> RecSelParent -> Bool
Eq, Typeable RecSelParent
Typeable RecSelParent =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> RecSelParent -> c RecSelParent)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c RecSelParent)
-> (RecSelParent -> Constr)
-> (RecSelParent -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c RecSelParent))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c RecSelParent))
-> ((forall b. Data b => b -> b) -> RecSelParent -> RecSelParent)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> RecSelParent -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> RecSelParent -> r)
-> (forall u. (forall d. Data d => d -> u) -> RecSelParent -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> RecSelParent -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent)
-> Data RecSelParent
RecSelParent -> Constr
RecSelParent -> DataType
(forall b. Data b => b -> b) -> RecSelParent -> RecSelParent
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> RecSelParent -> u
forall u. (forall d. Data d => d -> u) -> RecSelParent -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RecSelParent -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RecSelParent -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RecSelParent
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RecSelParent -> c RecSelParent
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RecSelParent)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RecSelParent)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RecSelParent -> c RecSelParent
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RecSelParent -> c RecSelParent
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RecSelParent
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RecSelParent
$ctoConstr :: RecSelParent -> Constr
toConstr :: RecSelParent -> Constr
$cdataTypeOf :: RecSelParent -> DataType
dataTypeOf :: RecSelParent -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RecSelParent)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RecSelParent)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RecSelParent)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c RecSelParent)
$cgmapT :: (forall b. Data b => b -> b) -> RecSelParent -> RecSelParent
gmapT :: (forall b. Data b => b -> b) -> RecSelParent -> RecSelParent
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RecSelParent -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RecSelParent -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RecSelParent -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RecSelParent -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RecSelParent -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> RecSelParent -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RecSelParent -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RecSelParent -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RecSelParent -> m RecSelParent
Data)

recSelParentName :: RecSelParent -> Name
recSelParentName :: RecSelParent -> Name
recSelParentName (RecSelData   TyCon
tc) = TyCon -> Name
tyConName TyCon
tc
recSelParentName (RecSelPatSyn PatSyn
ps) = PatSyn -> Name
patSynName PatSyn
ps

recSelFirstConName :: RecSelParent -> Name
recSelFirstConName :: RecSelParent -> Name
recSelFirstConName (RecSelData   TyCon
tc) = DataCon -> Name
dataConName (DataCon -> Name) -> DataCon -> Name
forall a b. (a -> b) -> a -> b
$ [DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head ([DataCon] -> DataCon) -> [DataCon] -> DataCon
forall a b. (a -> b) -> a -> b
$ TyCon -> [DataCon]
tyConDataCons TyCon
tc
recSelFirstConName (RecSelPatSyn PatSyn
ps) = PatSyn -> Name
patSynName PatSyn
ps

recSelParentCons :: RecSelParent -> [ConLike]
recSelParentCons :: RecSelParent -> [ConLike]
recSelParentCons (RecSelData TyCon
tc)
  | TyCon -> Bool
isAlgTyCon TyCon
tc
      = (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon ([DataCon] -> [ConLike]) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> a -> b
$ AlgTyConRhs -> [DataCon]
visibleDataCons
      (AlgTyConRhs -> [DataCon]) -> AlgTyConRhs -> [DataCon]
forall a b. (a -> b) -> a -> b
$ TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc
  | Bool
otherwise
      = []
recSelParentCons (RecSelPatSyn PatSyn
ps) = [PatSyn -> ConLike
PatSynCon PatSyn
ps]

instance Outputable RecSelParent where
  ppr :: RecSelParent -> SDoc
ppr RecSelParent
p = case RecSelParent
p of
    RecSelData TyCon
tc
      | Just (TyCon
parent_tc, [Type]
tys) <- TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tc
      -> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp TyCon
parent_tc [Type]
tys)
      | Bool
otherwise
      -> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
    RecSelPatSyn PatSyn
ps
      -> PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps

-- | Just a synonym for 'CoVarId'. Written separately so it can be
-- exported in the hs-boot file.
coVarDetails :: IdDetails
coVarDetails :: IdDetails
coVarDetails = IdDetails
CoVarId

-- | Check if an 'IdDetails' says 'CoVarId'.
isCoVarDetails :: IdDetails -> Bool
isCoVarDetails :: IdDetails -> Bool
isCoVarDetails IdDetails
CoVarId = Bool
True
isCoVarDetails IdDetails
_       = Bool
False

isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinArity, (Maybe [CbvMark]))
isJoinIdDetails_maybe :: IdDetails -> Maybe (Int, Maybe [CbvMark])
isJoinIdDetails_maybe (JoinId Int
join_arity Maybe [CbvMark]
marks) = (Int, Maybe [CbvMark]) -> Maybe (Int, Maybe [CbvMark])
forall a. a -> Maybe a
Just (Int
join_arity, Maybe [CbvMark]
marks)
isJoinIdDetails_maybe IdDetails
_                   = Maybe (Int, Maybe [CbvMark])
forall a. Maybe a
Nothing

instance Outputable IdDetails where
    ppr :: IdDetails -> SDoc
ppr = IdDetails -> SDoc
pprIdDetails

pprIdDetails :: IdDetails -> SDoc
pprIdDetails :: IdDetails -> SDoc
pprIdDetails IdDetails
VanillaId = SDoc
forall doc. IsOutput doc => doc
empty
pprIdDetails IdDetails
other     = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (IdDetails -> SDoc
pp IdDetails
other)
 where
   pp :: IdDetails -> SDoc
pp IdDetails
VanillaId               = String -> SDoc
forall a. HasCallStack => String -> a
panic String
"pprIdDetails"
   pp (WorkerLikeId [CbvMark]
dmds)     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StrictWorker" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CbvMark]
dmds)
   pp (DataConWorkId DataCon
_)       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DataCon"
   pp (DataConWrapId DataCon
_)       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DataConWrapper"
   pp (ClassOpId {})          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ClassOp"
   pp (RepPolyId {})          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RepPolyId"
   pp (PrimOpId {})           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"PrimOp"
   pp (FCallId ForeignCall
_)             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ForeignCall"
   pp (TickBoxOpId TickBoxOp
_)         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TickBoxOp"
   pp (DFunId Bool
nt)             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DFunId" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppWhen Bool
nt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(nt)")
   pp (RecSelId { sel_naughty :: IdDetails -> Bool
sel_naughty = Bool
is_naughty })
                              = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RecSel" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                                           Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppWhen Bool
is_naughty (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(naughty)")
   pp IdDetails
CoVarId                 = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CoVarId"
   pp (JoinId Int
arity Maybe [CbvMark]
marks)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"JoinId" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
arity) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Maybe [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe [CbvMark]
marks)

{-
************************************************************************
*                                                                      *
\subsection{The main IdInfo type}
*                                                                      *
************************************************************************
-}

-- | Identifier Information
--
-- An 'IdInfo' gives /optional/ information about an 'Id'.  If
-- present it never lies, but it may not be present, in which case there
-- is always a conservative assumption which can be made.
--
-- Two 'Id's may have different info even though they have the same
-- 'Unique' (and are hence the same 'Id'); for example, one might lack
-- the properties attached to the other.
--
-- Most of the 'IdInfo' gives information about the value, or definition, of
-- the 'Id', independent of its usage. Exceptions to this
-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'.
--
-- Performance note: when we update 'IdInfo', we have to reallocate this
-- entire record, so it is a good idea not to let this data structure get
-- too big.
data IdInfo
  = IdInfo {
        IdInfo -> RuleInfo
ruleInfo        :: RuleInfo,
        -- ^ Specialisations of the 'Id's function which exist.
        -- See Note [Specialisations and RULES in IdInfo]
        IdInfo -> Unfolding
realUnfoldingInfo   :: Unfolding,
        -- ^ The 'Id's unfolding
        IdInfo -> InlinePragma
inlinePragInfo  :: InlinePragma,
        -- ^ Any inline pragma attached to the 'Id'
        IdInfo -> OccInfo
occInfo         :: OccInfo,
        -- ^ How the 'Id' occurs in the program
        IdInfo -> DmdSig
dmdSigInfo      :: DmdSig,
        -- ^ A strictness signature. Describes how a function uses its arguments
        --   See Note [idArity varies independently of dmdTypeDepth]
        --       in GHC.Core.Opt.DmdAnal
        IdInfo -> CprSig
cprSigInfo      :: CprSig,
        -- ^ Information on whether the function will ultimately return a
        -- freshly allocated constructor.
        IdInfo -> Demand
demandInfo      :: Demand,
        -- ^ ID demand information
        IdInfo -> BitField
bitfield        :: {-# UNPACK #-} !BitField,
        -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, and
        -- call arity info in one 64-bit word. Packing these fields reduces size
        -- of `IdInfo` from 12 words to 7 words and reduces residency by almost
        -- 4% in some programs. See #17497 and associated MR.
        --
        -- See documentation of the getters for what these packed fields mean.
        IdInfo -> Maybe LambdaFormInfo
lfInfo          :: !(Maybe LambdaFormInfo),
        -- ^ If lfInfo = Just info, then the `info` is guaranteed /correct/.
        --   If lfInfo = Nothing, then we do not have a `LambdaFormInfo` for this Id,
        --                so (for imported Ids) we make a conservative version.
        --                See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure
        -- For locally-defined Ids other than DataCons, the `lfInfo` field is always Nothing.
        -- See also Note [LFInfo of DataCon workers and wrappers]

        -- See documentation of the getters for what these packed fields mean.
        IdInfo -> Maybe TagSig
tagSig          :: !(Maybe TagSig)
    }

-- | Encodes arities, OneShotInfo, CafInfo.
-- From least-significant to most-significant bits:
--
-- - Bit   0   (1):  OneShotInfo
-- - Bit   1   (1):  CafInfo
-- - Bit   2   (1):  unused
-- - Bits  3-32(30): Call Arity info
-- - Bits 33-62(30): Arity info
--
newtype BitField = BitField Word64

emptyBitField :: BitField
emptyBitField :: BitField
emptyBitField = Word64 -> BitField
BitField Word64
0

bitfieldGetOneShotInfo :: BitField -> OneShotInfo
bitfieldGetOneShotInfo :: BitField -> OneShotInfo
bitfieldGetOneShotInfo (BitField Word64
bits) =
    if Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
bits Int
0 then OneShotInfo
OneShotLam else OneShotInfo
NoOneShotInfo

bitfieldGetCafInfo :: BitField -> CafInfo
bitfieldGetCafInfo :: BitField -> CafInfo
bitfieldGetCafInfo (BitField Word64
bits) =
    if Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
bits Int
1 then CafInfo
NoCafRefs else CafInfo
MayHaveCafRefs

bitfieldGetCallArityInfo :: BitField -> ArityInfo
bitfieldGetCallArityInfo :: BitField -> Int
bitfieldGetCallArityInfo (BitField Word64
bits) =
    Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
bits Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
3) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. ((Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
30) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

bitfieldGetArityInfo :: BitField -> ArityInfo
bitfieldGetArityInfo :: BitField -> Int
bitfieldGetArityInfo (BitField Word64
bits) =
    Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
bits Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
33)

bitfieldSetOneShotInfo :: OneShotInfo -> BitField -> BitField
bitfieldSetOneShotInfo :: OneShotInfo -> BitField -> BitField
bitfieldSetOneShotInfo OneShotInfo
info (BitField Word64
bits) =
    case OneShotInfo
info of
      OneShotInfo
NoOneShotInfo -> Word64 -> BitField
BitField (Word64 -> Int -> Word64
forall a. (Num a, Bits a) => a -> Int -> a
clearBit Word64
bits Int
0)
      OneShotInfo
OneShotLam -> Word64 -> BitField
BitField (Word64 -> Int -> Word64
forall a. (Num a, Bits a) => a -> Int -> a
setBit Word64
bits Int
0)

bitfieldSetCafInfo :: CafInfo -> BitField -> BitField
bitfieldSetCafInfo :: CafInfo -> BitField -> BitField
bitfieldSetCafInfo CafInfo
info (BitField Word64
bits) =
    case CafInfo
info of
      CafInfo
MayHaveCafRefs -> Word64 -> BitField
BitField (Word64 -> Int -> Word64
forall a. (Num a, Bits a) => a -> Int -> a
clearBit Word64
bits Int
1)
      CafInfo
NoCafRefs -> Word64 -> BitField
BitField (Word64 -> Int -> Word64
forall a. (Num a, Bits a) => a -> Int -> a
setBit Word64
bits Int
1)

bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetCallArityInfo :: Int -> BitField -> BitField
bitfieldSetCallArityInfo Int
info bf :: BitField
bf@(BitField Word64
bits) =
    Bool -> BitField -> BitField
forall a. HasCallStack => Bool -> a -> a
assert (Int
info Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
30 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (BitField -> BitField) -> BitField -> BitField
forall a b. (a -> b) -> a -> b
$
    Int -> BitField -> BitField
bitfieldSetArityInfo (BitField -> Int
bitfieldGetArityInfo BitField
bf) (BitField -> BitField) -> BitField -> BitField
forall a b. (a -> b) -> a -> b
$
    Word64 -> BitField
BitField ((Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
info Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
3) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
bits Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0b111))

bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetArityInfo :: Int -> BitField -> BitField
bitfieldSetArityInfo Int
info (BitField Word64
bits) =
    Bool -> BitField -> BitField
forall a. HasCallStack => Bool -> a -> a
assert (Int
info Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
30 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (BitField -> BitField) -> BitField -> BitField
forall a b. (a -> b) -> a -> b
$
    Word64 -> BitField
BitField ((Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
info Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
33) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
bits Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. ((Word64
1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
33) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)))

-- Getters

-- | Info about a lambda-bound variable, if the 'Id' is one
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo = BitField -> OneShotInfo
bitfieldGetOneShotInfo (BitField -> OneShotInfo)
-> (IdInfo -> BitField) -> IdInfo -> OneShotInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> BitField
bitfield

-- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments
-- this 'Id' has to be applied to before it does any meaningful work.
arityInfo :: IdInfo -> ArityInfo
arityInfo :: IdInfo -> Int
arityInfo = BitField -> Int
bitfieldGetArityInfo (BitField -> Int) -> (IdInfo -> BitField) -> IdInfo -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> BitField
bitfield

-- | 'Id' CAF info
cafInfo :: IdInfo -> CafInfo
cafInfo :: IdInfo -> CafInfo
cafInfo = BitField -> CafInfo
bitfieldGetCafInfo (BitField -> CafInfo) -> (IdInfo -> BitField) -> IdInfo -> CafInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> BitField
bitfield

-- | How this is called. This is the number of arguments to which a binding can
-- be eta-expanded without losing any sharing. n <=> all calls have at least n
-- arguments
callArityInfo :: IdInfo -> ArityInfo
callArityInfo :: IdInfo -> Int
callArityInfo = BitField -> Int
bitfieldGetCallArityInfo (BitField -> Int) -> (IdInfo -> BitField) -> IdInfo -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> BitField
bitfield

tagSigInfo :: IdInfo -> Maybe TagSig
tagSigInfo :: IdInfo -> Maybe TagSig
tagSigInfo = IdInfo -> Maybe TagSig
tagSig

-- Setters

setRuleInfo :: IdInfo -> RuleInfo -> IdInfo
setRuleInfo :: IdInfo -> RuleInfo -> IdInfo
setRuleInfo       IdInfo
info RuleInfo
sp = RuleInfo
sp RuleInfo -> IdInfo -> IdInfo
forall a b. a -> b -> b
`seq` IdInfo
info { ruleInfo = sp }
setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo IdInfo
info InlinePragma
pr = InlinePragma
pr InlinePragma -> IdInfo -> IdInfo
forall a b. a -> b -> b
`seq` IdInfo
info { inlinePragInfo = pr }
setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo        IdInfo
info OccInfo
oc = OccInfo
oc OccInfo -> IdInfo -> IdInfo
forall a b. a -> b -> b
`seq` IdInfo
info { occInfo = oc }
        -- Try to avoid space leaks by seq'ing

-- | Essentially returns the 'realUnfoldingInfo' field, but does not expose the
-- unfolding of a strong loop breaker.
--
-- This is the right thing to call if you plan to decide whether an unfolding
-- will inline.
unfoldingInfo :: IdInfo -> Unfolding
unfoldingInfo :: IdInfo -> Unfolding
unfoldingInfo IdInfo
info
  | OccInfo -> Bool
isStrongLoopBreaker (IdInfo -> OccInfo
occInfo IdInfo
info) = Unfolding -> Unfolding
trimUnfolding (Unfolding -> Unfolding) -> Unfolding -> Unfolding
forall a b. (a -> b) -> a -> b
$ IdInfo -> Unfolding
realUnfoldingInfo IdInfo
info
  | Bool
otherwise                          =                 IdInfo -> Unfolding
realUnfoldingInfo IdInfo
info

setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo IdInfo
info Unfolding
uf
  = -- We don't seq the unfolding, as we generate intermediate
    -- unfoldings which are just thrown away, so evaluating them is a
    -- waste of time.
    -- seqUnfolding uf `seq`
    IdInfo
info { realUnfoldingInfo = uf }

hasInlineUnfolding :: IdInfo -> Bool
-- ^ True of a /non-loop-breaker/ Id that has a /stable/ unfolding that is
--   (a) always inlined; that is, with an `UnfWhen` guidance, or
--   (b) a DFunUnfolding which never needs to be inlined
hasInlineUnfolding :: IdInfo -> Bool
hasInlineUnfolding IdInfo
info = Unfolding -> Bool
isInlineUnfolding (IdInfo -> Unfolding
unfoldingInfo IdInfo
info)

setArityInfo :: IdInfo -> ArityInfo -> IdInfo
setArityInfo :: IdInfo -> Int -> IdInfo
setArityInfo IdInfo
info Int
ar =
    IdInfo
info { bitfield = bitfieldSetArityInfo ar (bitfield info) }

setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo
setCallArityInfo :: IdInfo -> Int -> IdInfo
setCallArityInfo IdInfo
info Int
ar =
    IdInfo
info { bitfield = bitfieldSetCallArityInfo ar (bitfield info) }

setCafInfo :: IdInfo -> CafInfo -> IdInfo
setCafInfo :: IdInfo -> CafInfo -> IdInfo
setCafInfo IdInfo
info CafInfo
caf =
    IdInfo
info { bitfield = bitfieldSetCafInfo caf (bitfield info) }

setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
setLFInfo IdInfo
info LambdaFormInfo
lf = IdInfo
info { lfInfo = Just lf }

setTagSig :: IdInfo -> TagSig -> IdInfo
setTagSig :: IdInfo -> TagSig -> IdInfo
setTagSig IdInfo
info TagSig
sig = IdInfo
info { tagSig = Just sig }

setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
setOneShotInfo IdInfo
info OneShotInfo
lb =
    IdInfo
info { bitfield = bitfieldSetOneShotInfo lb (bitfield info) }

setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo IdInfo
info Demand
dd = Demand
dd Demand -> IdInfo -> IdInfo
forall a b. a -> b -> b
`seq` IdInfo
info { demandInfo = dd }

setDmdSigInfo :: IdInfo -> DmdSig -> IdInfo
setDmdSigInfo :: IdInfo -> DmdSig -> IdInfo
setDmdSigInfo IdInfo
info DmdSig
dd = DmdSig
dd DmdSig -> IdInfo -> IdInfo
forall a b. a -> b -> b
`seq` IdInfo
info { dmdSigInfo = dd }

setCprSigInfo :: IdInfo -> CprSig -> IdInfo
setCprSigInfo :: IdInfo -> CprSig -> IdInfo
setCprSigInfo IdInfo
info CprSig
cpr = CprSig
cpr CprSig -> IdInfo -> IdInfo
forall a b. a -> b -> b
`seq` IdInfo
info { cprSigInfo = cpr }

-- | Basic 'IdInfo' that carries no useful information whatsoever
vanillaIdInfo :: IdInfo
vanillaIdInfo :: IdInfo
vanillaIdInfo
  = IdInfo {
            ruleInfo :: RuleInfo
ruleInfo       = RuleInfo
emptyRuleInfo,
            realUnfoldingInfo :: Unfolding
realUnfoldingInfo  = Unfolding
noUnfolding,
            inlinePragInfo :: InlinePragma
inlinePragInfo = InlinePragma
defaultInlinePragma,
            occInfo :: OccInfo
occInfo        = OccInfo
noOccInfo,
            demandInfo :: Demand
demandInfo     = Demand
topDmd,
            dmdSigInfo :: DmdSig
dmdSigInfo     = DmdSig
nopSig,
            cprSigInfo :: CprSig
cprSigInfo     = CprSig
topCprSig,
            bitfield :: BitField
bitfield       = CafInfo -> BitField -> BitField
bitfieldSetCafInfo CafInfo
vanillaCafInfo (BitField -> BitField) -> BitField -> BitField
forall a b. (a -> b) -> a -> b
$
                             Int -> BitField -> BitField
bitfieldSetArityInfo Int
unknownArity (BitField -> BitField) -> BitField -> BitField
forall a b. (a -> b) -> a -> b
$
                             Int -> BitField -> BitField
bitfieldSetCallArityInfo Int
unknownArity (BitField -> BitField) -> BitField -> BitField
forall a b. (a -> b) -> a -> b
$
                             OneShotInfo -> BitField -> BitField
bitfieldSetOneShotInfo OneShotInfo
NoOneShotInfo (BitField -> BitField) -> BitField -> BitField
forall a b. (a -> b) -> a -> b
$
                             BitField
emptyBitField,
            lfInfo :: Maybe LambdaFormInfo
lfInfo         = Maybe LambdaFormInfo
forall a. Maybe a
Nothing,
            tagSig :: Maybe TagSig
tagSig         = Maybe TagSig
forall a. Maybe a
Nothing
           }

-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
noCafIdInfo :: IdInfo
noCafIdInfo :: IdInfo
noCafIdInfo  = IdInfo
vanillaIdInfo IdInfo -> CafInfo -> IdInfo
`setCafInfo`    CafInfo
NoCafRefs
        -- Used for built-in type Ids in GHC.Types.Id.Make.

{-
************************************************************************
*                                                                      *
\subsection[arity-IdInfo]{Arity info about an @Id@}
*                                                                      *
************************************************************************

For locally-defined Ids, the code generator maintains its own notion
of their arities; so it should not be asking...  (but other things
besides the code-generator need arity info!)

Note [Arity and function types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The arity of an 'Id' must never exceed the number of arguments that
can be read off from the 'Id's type, possibly after expanding newtypes.

Examples:

  f1 :: forall a. a -> a

    idArity f1 <= 1: only one value argument, of type 'a'

  f2 :: forall a. Show a => Int -> a

    idArity f2 <= 2: two value arguments, of types 'Show a' and 'Int'.


  newtype Id a = MkId a
  f3 :: forall b. Id (Int -> b)

    idArity f3 <= 1: there is one value argument, of type 'Int', hidden under the newtype.

  newtype RecFun = MkRecFun (Int -> RecFun)
  f4 :: RecFun

    no constraint on the arity of f4: we can unwrap as many layers of the newtype as we want,
    to get arbitrarily many arguments of type 'Int'.
-}


-- | Arity Information
--
-- An 'ArityInfo' of @n@ tells us that partial application of this
-- 'Id' to up to @n-1@ value arguments does essentially no work.
--
-- That is not necessarily the same as saying that it has @n@ leading
-- lambdas, because coerces may get in the way.
--
-- The arity might increase later in the compilation process, if
-- an extra lambda floats up to the binding site.
--
-- /Invariant:/ the 'Arity' of an 'Id' must never exceed the number of
-- value arguments that appear in the type of the 'Id'.
-- See Note [Arity and function types].
type ArityInfo = Arity

-- | It is always safe to assume that an 'Id' has an arity of 0
unknownArity :: Arity
unknownArity :: Int
unknownArity = Int
0

ppArityInfo :: Int -> SDoc
ppArityInfo :: Int -> SDoc
ppArityInfo Int
0 = SDoc
forall doc. IsOutput doc => doc
empty
ppArityInfo Int
n = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Arity", Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n]

{-
************************************************************************
*                                                                      *
\subsection{Inline-pragma information}
*                                                                      *
************************************************************************
-}

-- | Inline Pragma Information
--
-- Tells when the inlining is active.
-- When it is active the thing may be inlined, depending on how
-- big it is.
--
-- If there was an @INLINE@ pragma, then as a separate matter, the
-- RHS will have been made to look small with a Core inline 'Note'
--
-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves
-- entirely as a way to inhibit inlining until we want it
type InlinePragInfo = InlinePragma

{-
************************************************************************
*                                                                      *
               Strictness
*                                                                      *
************************************************************************
-}

pprStrictness :: DmdSig -> SDoc
pprStrictness :: DmdSig -> SDoc
pprStrictness DmdSig
sig = DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr DmdSig
sig

{-
************************************************************************
*                                                                      *
        RuleInfo
*                                                                      *
************************************************************************

Note [Specialisations and RULES in IdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally speaking, a GlobalId has an *empty* RuleInfo.  All their
RULES are contained in the globally-built rule-base.  In principle,
one could attach the to M.f the RULES for M.f that are defined in M.
But we don't do that for instance declarations and so we just treat
them all uniformly.

The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is
just for convenience really.

However, LocalIds may have non-empty RuleInfo.  We treat them
differently because:
  a) they might be nested, in which case a global table won't work
  b) the RULE might mention free variables, which we use to keep things alive

In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off
and put in the global list.
-}

-- | Rule Information
--
-- Records the specializations of this 'Id' that we know about
-- in the form of rewrite 'CoreRule's that target them
data RuleInfo
  = RuleInfo
        [CoreRule]
        DVarSet         -- Locally-defined free vars of *both* LHS and RHS
                        -- of rules.  I don't think it needs to include the
                        -- ru_fn though.
                        -- Note [Rule dependency info] in "GHC.Core.Opt.OccurAnal"

-- | Assume that no specializations exist: always safe
emptyRuleInfo :: RuleInfo
emptyRuleInfo :: RuleInfo
emptyRuleInfo = [CoreRule] -> DVarSet -> RuleInfo
RuleInfo [] DVarSet
emptyDVarSet

isEmptyRuleInfo :: RuleInfo -> Bool
isEmptyRuleInfo :: RuleInfo -> Bool
isEmptyRuleInfo (RuleInfo [CoreRule]
rs DVarSet
_) = [CoreRule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rs

-- | Retrieve the locally-defined free variables of both the left and
-- right hand sides of the specialization rules
ruleInfoFreeVars :: RuleInfo -> DVarSet
ruleInfoFreeVars :: RuleInfo -> DVarSet
ruleInfoFreeVars (RuleInfo [CoreRule]
_ DVarSet
fvs) = DVarSet
fvs

ruleInfoRules :: RuleInfo -> [CoreRule]
ruleInfoRules :: RuleInfo -> [CoreRule]
ruleInfoRules (RuleInfo [CoreRule]
rules DVarSet
_) = [CoreRule]
rules

-- | Change the name of the function the rule is keyed on all of the 'CoreRule's
setRuleInfoHead :: Name -> RuleInfo -> RuleInfo
setRuleInfoHead :: Name -> RuleInfo -> RuleInfo
setRuleInfoHead Name
fn (RuleInfo [CoreRule]
rules DVarSet
fvs)
  = [CoreRule] -> DVarSet -> RuleInfo
RuleInfo ((CoreRule -> CoreRule) -> [CoreRule] -> [CoreRule]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> CoreRule -> CoreRule
setRuleIdName Name
fn) [CoreRule]
rules) DVarSet
fvs

{-
************************************************************************
*                                                                      *
\subsection[CG-IdInfo]{Code generator-related information}
*                                                                      *
************************************************************************
-}

-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs).

-- | Constant applicative form Information
--
-- Records whether an 'Id' makes Constant Applicative Form references
data CafInfo
        = MayHaveCafRefs                -- ^ Indicates that the 'Id' is for either:
                                        --
                                        -- 1. A function or static constructor
                                        --    that refers to one or more CAFs, or
                                        --
                                        -- 2. A real live CAF

        | NoCafRefs                     -- ^ A function or static constructor
                                        -- that refers to no CAFs.
        deriving (CafInfo -> CafInfo -> Bool
(CafInfo -> CafInfo -> Bool)
-> (CafInfo -> CafInfo -> Bool) -> Eq CafInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CafInfo -> CafInfo -> Bool
== :: CafInfo -> CafInfo -> Bool
$c/= :: CafInfo -> CafInfo -> Bool
/= :: CafInfo -> CafInfo -> Bool
Eq, Eq CafInfo
Eq CafInfo =>
(CafInfo -> CafInfo -> Ordering)
-> (CafInfo -> CafInfo -> Bool)
-> (CafInfo -> CafInfo -> Bool)
-> (CafInfo -> CafInfo -> Bool)
-> (CafInfo -> CafInfo -> Bool)
-> (CafInfo -> CafInfo -> CafInfo)
-> (CafInfo -> CafInfo -> CafInfo)
-> Ord CafInfo
CafInfo -> CafInfo -> Bool
CafInfo -> CafInfo -> Ordering
CafInfo -> CafInfo -> CafInfo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CafInfo -> CafInfo -> Ordering
compare :: CafInfo -> CafInfo -> Ordering
$c< :: CafInfo -> CafInfo -> Bool
< :: CafInfo -> CafInfo -> Bool
$c<= :: CafInfo -> CafInfo -> Bool
<= :: CafInfo -> CafInfo -> Bool
$c> :: CafInfo -> CafInfo -> Bool
> :: CafInfo -> CafInfo -> Bool
$c>= :: CafInfo -> CafInfo -> Bool
>= :: CafInfo -> CafInfo -> Bool
$cmax :: CafInfo -> CafInfo -> CafInfo
max :: CafInfo -> CafInfo -> CafInfo
$cmin :: CafInfo -> CafInfo -> CafInfo
min :: CafInfo -> CafInfo -> CafInfo
Ord)

-- | Assumes that the 'Id' has CAF references: definitely safe
vanillaCafInfo :: CafInfo
vanillaCafInfo :: CafInfo
vanillaCafInfo = CafInfo
MayHaveCafRefs

mayHaveCafRefs :: CafInfo -> Bool
mayHaveCafRefs :: CafInfo -> Bool
mayHaveCafRefs  CafInfo
MayHaveCafRefs = Bool
True
mayHaveCafRefs CafInfo
_               = Bool
False

instance Outputable CafInfo where
   ppr :: CafInfo -> SDoc
ppr = CafInfo -> SDoc
ppCafInfo

ppCafInfo :: CafInfo -> SDoc
ppCafInfo :: CafInfo -> SDoc
ppCafInfo CafInfo
NoCafRefs = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NoCafRefs"
ppCafInfo CafInfo
MayHaveCafRefs = SDoc
forall doc. IsOutput doc => doc
empty

{-
************************************************************************
*                                                                      *
\subsection{Bulk operations on IdInfo}
*                                                                      *
************************************************************************
-}

-- | This is used to remove information on lambda binders that we have
-- setup as part of a lambda group, assuming they will be applied all at once,
-- but turn out to be part of an unsaturated lambda as in e.g:
--
-- > (\x1. \x2. e) arg1
zapLamInfo :: IdInfo -> Maybe IdInfo
zapLamInfo :: IdInfo -> Maybe IdInfo
zapLamInfo info :: IdInfo
info@(IdInfo {occInfo :: IdInfo -> OccInfo
occInfo = OccInfo
occ, demandInfo :: IdInfo -> Demand
demandInfo = Demand
demand})
  | OccInfo -> Bool
is_safe_occ OccInfo
occ Bool -> Bool -> Bool
&& Demand -> Bool
is_safe_dmd Demand
demand
  = Maybe IdInfo
forall a. Maybe a
Nothing
  | Bool
otherwise
  = IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo
info {occInfo = safe_occ, demandInfo = topDmd})
  where
        -- The "unsafe" occ info is the ones that say I'm not in a lambda
        -- because that might not be true for an unsaturated lambda
    is_safe_occ :: OccInfo -> Bool
is_safe_occ OccInfo
occ | OccInfo -> Bool
isAlwaysTailCalled OccInfo
occ           = Bool
False
    is_safe_occ (OneOcc { occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
NotInsideLam }) = Bool
False
    is_safe_occ OccInfo
_other                                 = Bool
True

    safe_occ :: OccInfo
safe_occ = case OccInfo
occ of
                 OneOcc{} -> OccInfo
occ { occ_in_lam = IsInsideLam
                                 , occ_tail   = NoTailCallInfo }
                 IAmALoopBreaker{}
                          -> OccInfo
occ { occ_tail   = NoTailCallInfo }
                 OccInfo
_other   -> OccInfo
occ

    is_safe_dmd :: Demand -> Bool
is_safe_dmd Demand
dmd = Bool -> Bool
not (Demand -> Bool
isStrUsedDmd Demand
dmd)

-- | Lazify (remove the top-level demand, only) the demand in `IdInfo`
-- Keep nested demands; see Note [Floatifying demand info when floating]
-- in GHC.Core.Opt.SetLevels
lazifyDemandInfo :: IdInfo -> Maybe IdInfo
lazifyDemandInfo :: IdInfo -> Maybe IdInfo
lazifyDemandInfo info :: IdInfo
info@(IdInfo { demandInfo :: IdInfo -> Demand
demandInfo = Demand
dmd })
  = IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo
info {demandInfo = lazifyDmd dmd })

-- | Floatify the demand in `IdInfo`
-- But keep /nested/ demands; see Note [Floatifying demand info when floating]
-- in GHC.Core.Opt.SetLevels
floatifyDemandInfo :: IdInfo -> Maybe IdInfo
floatifyDemandInfo :: IdInfo -> Maybe IdInfo
floatifyDemandInfo info :: IdInfo
info@(IdInfo { demandInfo :: IdInfo -> Demand
demandInfo = Demand
dmd })
  = IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo
info {demandInfo = floatifyDmd dmd })

-- | Remove usage (but not strictness) info on the `IdInfo`
zapUsageInfo :: IdInfo -> Maybe IdInfo
zapUsageInfo :: IdInfo -> Maybe IdInfo
zapUsageInfo IdInfo
info = IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo
info {demandInfo = zapUsageDemand (demandInfo info)})

-- | Remove usage environment info from the strictness signature on the 'IdInfo'
zapUsageEnvInfo :: IdInfo -> Maybe IdInfo
zapUsageEnvInfo :: IdInfo -> Maybe IdInfo
zapUsageEnvInfo IdInfo
info
    | DmdSig -> Bool
hasDemandEnvSig (IdInfo -> DmdSig
dmdSigInfo IdInfo
info)
    = IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo
info {dmdSigInfo = zapDmdEnvSig (dmdSigInfo info)})
    | Bool
otherwise
    = Maybe IdInfo
forall a. Maybe a
Nothing

zapUsedOnceInfo :: IdInfo -> Maybe IdInfo
zapUsedOnceInfo :: IdInfo -> Maybe IdInfo
zapUsedOnceInfo IdInfo
info
    = IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo -> Maybe IdInfo) -> IdInfo -> Maybe IdInfo
forall a b. (a -> b) -> a -> b
$ IdInfo
info { dmdSigInfo = zapUsedOnceSig    (dmdSigInfo info)
                  , demandInfo     = zapUsedOnceDemand (demandInfo     info) }

zapFragileInfo :: IdInfo -> Maybe IdInfo
-- ^ Zap info that depends on free variables
zapFragileInfo :: IdInfo -> Maybe IdInfo
zapFragileInfo info :: IdInfo
info@(IdInfo { occInfo :: IdInfo -> OccInfo
occInfo = OccInfo
occ, realUnfoldingInfo :: IdInfo -> Unfolding
realUnfoldingInfo = Unfolding
unf })
  = Unfolding
new_unf Unfolding -> Maybe IdInfo -> Maybe IdInfo
forall a b. a -> b -> b
`seq`  -- The unfolding field is not (currently) strict, so we
                   -- force it here to avoid a (zapFragileUnfolding unf) thunk
                   -- which might leak space
    IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo
info IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` RuleInfo
emptyRuleInfo
               IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unf
               IdInfo -> OccInfo -> IdInfo
`setOccInfo`       OccInfo -> OccInfo
zapFragileOcc OccInfo
occ)
  where
    new_unf :: Unfolding
new_unf = Unfolding -> Unfolding
zapFragileUnfolding Unfolding
unf

zapFragileUnfolding :: Unfolding -> Unfolding
-- ^ Zaps any core unfolding, but /preserves/ evaluated-ness,
-- i.e. an unfolding of OtherCon
zapFragileUnfolding :: Unfolding -> Unfolding
zapFragileUnfolding Unfolding
unf
 -- N.B. isEvaldUnfolding catches *both* OtherCon [] *and* core unfoldings
 -- representing values.
 | Unfolding -> Bool
isEvaldUnfolding Unfolding
unf = Unfolding
evaldUnfolding
 | Bool
otherwise            = Unfolding
noUnfolding

trimUnfolding :: Unfolding -> Unfolding
-- Squash all unfolding info, preserving only evaluated-ness
trimUnfolding :: Unfolding -> Unfolding
trimUnfolding Unfolding
unf | Unfolding -> Bool
isEvaldUnfolding Unfolding
unf = Unfolding
evaldUnfolding
                  | Bool
otherwise            = Unfolding
noUnfolding

zapTailCallInfo :: IdInfo -> Maybe IdInfo
zapTailCallInfo :: IdInfo -> Maybe IdInfo
zapTailCallInfo IdInfo
info
  = case IdInfo -> OccInfo
occInfo IdInfo
info of
      OccInfo
occ | OccInfo -> Bool
isAlwaysTailCalled OccInfo
occ -> IdInfo -> Maybe IdInfo
forall a. a -> Maybe a
Just (IdInfo
info IdInfo -> OccInfo -> IdInfo
`setOccInfo` OccInfo
safe_occ)
          | Bool
otherwise              -> Maybe IdInfo
forall a. Maybe a
Nothing
        where
          safe_occ :: OccInfo
safe_occ = OccInfo
occ { occ_tail = NoTailCallInfo }

zapCallArityInfo :: IdInfo -> IdInfo
zapCallArityInfo :: IdInfo -> IdInfo
zapCallArityInfo IdInfo
info = IdInfo -> Int -> IdInfo
setCallArityInfo IdInfo
info Int
0

{-
************************************************************************
*                                                                      *
\subsection{TickBoxOp}
*                                                                      *
************************************************************************
-}

type TickBoxId = Int

-- | Tick box for Hpc-style coverage
data TickBoxOp
   = TickBox Module {-# UNPACK #-} !TickBoxId

instance Outputable TickBoxOp where
    ppr :: TickBoxOp -> SDoc
ppr (TickBox Module
mod Int
n)         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tick" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Module, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module
mod,Int
n)