{-
(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 CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BinaryLiterals #-}

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

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

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

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

        -- ** Zapping various forms of Info
        zapLamInfo, zapFragileInfo,
        zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
        zapTailCallInfo, zapCallArityInfo, zapUnfolding,

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

        callArityInfo, setCallArityInfo,

        -- ** Demand and strictness Info
        strictnessInfo, setStrictnessInfo,
        cprInfo, setCprInfo,
        demandInfo, setDemandInfo, pprStrictness,

        -- ** Unfolding Info
        unfoldingInfo, setUnfoldingInfo,

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

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

        -- ** The LambdaFormInfo type
        LambdaFormInfo(..),
        lfInfo, setLFInfo,

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

        -- ** Levity info
        LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,
        isNeverLevPolyIdInfo
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Core hiding( hasCoreUnfolding )
import GHC.Core( hasCoreUnfolding )

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.PatSyn
import GHC.Core.Type
import GHC.Types.ForeignCall
import GHC.Unit.Module
import GHC.Types.Demand
import GHC.Types.Cpr

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

import Data.Word

import GHC.StgToCmm.Types (LambdaFormInfo (..))

-- infixl so you can say (id `set` a `set` b)
infixl  1 `setRuleInfo`,
          `setArityInfo`,
          `setInlinePragInfo`,
          `setUnfoldingInfo`,
          `setOneShotInfo`,
          `setOccInfo`,
          `setCafInfo`,
          `setStrictnessInfo`,
          `setCprInfo`,
          `setDemandInfo`,
          `setNeverLevPoly`,
          `setLevityInfoWithType`

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

  | 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 Class             -- ^ The 'Id' is a superclass selector,
                                -- or class operation of a class

  | PrimOpId PrimOp             -- ^ The 'Id' is for a primitive operator
  | 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           -- ^ An 'Id' for a join point taking n arguments
       -- Note [Join points] in "GHC.Core"

-- | Recursive Selector Parent
data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving RecSelParent -> RecSelParent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RecSelParent -> RecSelParent -> Bool
$c/= :: RecSelParent -> RecSelParent -> Bool
== :: RecSelParent -> RecSelParent -> Bool
$c== :: RecSelParent -> RecSelParent -> Bool
Eq
  -- Either `TyCon` or `PatSyn` depending
  -- on the origin of the record selector.
  -- For a data type family, this is the
  -- /instance/ 'TyCon' not the family 'TyCon'

instance Outputable RecSelParent where
  ppr :: RecSelParent -> SDoc
ppr RecSelParent
p = case RecSelParent
p of
            RecSelData TyCon
ty_con -> forall a. Outputable a => a -> SDoc
ppr TyCon
ty_con
            RecSelPatSyn PatSyn
ps   -> 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
isJoinIdDetails_maybe :: IdDetails -> Maybe Int
isJoinIdDetails_maybe (JoinId Int
join_arity) = forall a. a -> Maybe a
Just Int
join_arity
isJoinIdDetails_maybe IdDetails
_                   = 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
empty
pprIdDetails IdDetails
other     = SDoc -> SDoc
brackets (IdDetails -> SDoc
pp IdDetails
other)
 where
   pp :: IdDetails -> SDoc
pp IdDetails
VanillaId               = forall a. String -> a
panic String
"pprIdDetails"
   pp (DataConWorkId DataCon
_)       = String -> SDoc
text String
"DataCon"
   pp (DataConWrapId DataCon
_)       = String -> SDoc
text String
"DataConWrapper"
   pp (ClassOpId {})          = String -> SDoc
text String
"ClassOp"
   pp (PrimOpId PrimOp
_)            = String -> SDoc
text String
"PrimOp"
   pp (FCallId ForeignCall
_)             = String -> SDoc
text String
"ForeignCall"
   pp (TickBoxOpId TickBoxOp
_)         = String -> SDoc
text String
"TickBoxOp"
   pp (DFunId Bool
nt)             = String -> SDoc
text String
"DFunId" SDoc -> SDoc -> SDoc
<> Bool -> SDoc -> SDoc
ppWhen Bool
nt (String -> SDoc
text String
"(nt)")
   pp (RecSelId { sel_naughty :: IdDetails -> Bool
sel_naughty = Bool
is_naughty })
                              = SDoc -> SDoc
brackets forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"RecSel" SDoc -> SDoc -> SDoc
<>
                                           Bool -> SDoc -> SDoc
ppWhen Bool
is_naughty (String -> SDoc
text String
"(naughty)")
   pp IdDetails
CoVarId                 = String -> SDoc
text String
"CoVarId"
   pp (JoinId Int
arity)          = String -> SDoc
text String
"JoinId" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Int -> SDoc
int Int
arity)

{-
************************************************************************
*                                                                      *
\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
unfoldingInfo   :: 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 -> StrictSig
strictnessInfo  :: StrictSig,
        -- ^ A strictness signature. Digests how a function uses its arguments
        -- if applied to at least 'arityInfo' arguments.
        IdInfo -> CprSig
cprInfo         :: 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, LevityInfo, 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)
    }

-- | Encodes arities, OneShotInfo, CafInfo and LevityInfo.
-- From least-significant to most-significant bits:
--
-- - Bit   0   (1):  OneShotInfo
-- - Bit   1   (1):  CafInfo
-- - Bit   2   (1):  LevityInfo
-- - 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 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 forall a. Bits a => a -> Int -> Bool
testBit Word64
bits Int
1 then CafInfo
NoCafRefs else CafInfo
MayHaveCafRefs

bitfieldGetLevityInfo :: BitField -> LevityInfo
bitfieldGetLevityInfo :: BitField -> LevityInfo
bitfieldGetLevityInfo (BitField Word64
bits) =
    if forall a. Bits a => a -> Int -> Bool
testBit Word64
bits Int
2 then LevityInfo
NeverLevityPolymorphic else LevityInfo
NoLevityInfo

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

bitfieldGetArityInfo :: BitField -> ArityInfo
bitfieldGetArityInfo :: BitField -> Int
bitfieldGetArityInfo (BitField Word64
bits) =
    forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
bits 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 (forall a. Bits a => a -> Int -> a
clearBit Word64
bits Int
0)
      OneShotInfo
OneShotLam -> Word64 -> BitField
BitField (forall 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 (forall a. Bits a => a -> Int -> a
clearBit Word64
bits Int
1)
      CafInfo
NoCafRefs -> Word64 -> BitField
BitField (forall a. Bits a => a -> Int -> a
setBit Word64
bits Int
1)

bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField
bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField
bitfieldSetLevityInfo LevityInfo
info (BitField Word64
bits) =
    case LevityInfo
info of
      LevityInfo
NoLevityInfo -> Word64 -> BitField
BitField (forall a. Bits a => a -> Int -> a
clearBit Word64
bits Int
2)
      LevityInfo
NeverLevityPolymorphic -> Word64 -> BitField
BitField (forall a. Bits a => a -> Int -> a
setBit Word64
bits Int
2)

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

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

-- Getters

-- | When applied, will this Id ever have a levity-polymorphic type?
levityInfo :: IdInfo -> LevityInfo
levityInfo :: IdInfo -> LevityInfo
levityInfo = BitField -> LevityInfo
bitfieldGetLevityInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> BitField
bitfield

-- | Info about a lambda-bound variable, if the 'Id' is one
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo = BitField -> OneShotInfo
bitfieldGetOneShotInfo 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 doesn any meaningful work.
arityInfo :: IdInfo -> ArityInfo
arityInfo :: IdInfo -> Int
arityInfo = BitField -> Int
bitfieldGetArityInfo 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> BitField
bitfield

-- Setters

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

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 { unfoldingInfo :: Unfolding
unfoldingInfo = Unfolding
uf }

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

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

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

setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
setLFInfo IdInfo
info LambdaFormInfo
lf = IdInfo
info { lfInfo :: Maybe LambdaFormInfo
lfInfo = forall a. a -> Maybe a
Just LambdaFormInfo
lf }

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

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

setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo IdInfo
info StrictSig
dd = StrictSig
dd seq :: forall a b. a -> b -> b
`seq` IdInfo
info { strictnessInfo :: StrictSig
strictnessInfo = StrictSig
dd }

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

-- | Basic 'IdInfo' that carries no useful information whatsoever
vanillaIdInfo :: IdInfo
vanillaIdInfo :: IdInfo
vanillaIdInfo
  = IdInfo {
            ruleInfo :: RuleInfo
ruleInfo            = RuleInfo
emptyRuleInfo,
            unfoldingInfo :: Unfolding
unfoldingInfo       = Unfolding
noUnfolding,
            inlinePragInfo :: InlinePragma
inlinePragInfo      = InlinePragma
defaultInlinePragma,
            occInfo :: OccInfo
occInfo             = OccInfo
noOccInfo,
            demandInfo :: Demand
demandInfo          = Demand
topDmd,
            strictnessInfo :: StrictSig
strictnessInfo      = StrictSig
nopSig,
            cprInfo :: CprSig
cprInfo             = CprSig
topCprSig,
            bitfield :: BitField
bitfield            = CafInfo -> BitField -> BitField
bitfieldSetCafInfo CafInfo
vanillaCafInfo forall a b. (a -> b) -> a -> b
$
                                  Int -> BitField -> BitField
bitfieldSetArityInfo Int
unknownArity forall a b. (a -> b) -> a -> b
$
                                  Int -> BitField -> BitField
bitfieldSetCallArityInfo Int
unknownArity forall a b. (a -> b) -> a -> b
$
                                  OneShotInfo -> BitField -> BitField
bitfieldSetOneShotInfo OneShotInfo
NoOneShotInfo forall a b. (a -> b) -> a -> b
$
                                  LevityInfo -> BitField -> BitField
bitfieldSetLevityInfo LevityInfo
NoLevityInfo forall a b. (a -> b) -> a -> b
$
                                  BitField
emptyBitField,
            lfInfo :: Maybe LambdaFormInfo
lfInfo              = 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!)
-}

-- | 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.
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
empty
ppArityInfo Int
n = [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Arity", Int -> SDoc
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 :: StrictSig -> SDoc
pprStrictness :: StrictSig -> SDoc
pprStrictness StrictSig
sig = forall a. Outputable a => a -> SDoc
ppr StrictSig
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
_) = 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 (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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CafInfo -> CafInfo -> Bool
$c/= :: CafInfo -> CafInfo -> Bool
== :: CafInfo -> CafInfo -> Bool
$c== :: CafInfo -> CafInfo -> Bool
Eq, Eq 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
min :: CafInfo -> CafInfo -> CafInfo
$cmin :: CafInfo -> CafInfo -> CafInfo
max :: CafInfo -> CafInfo -> CafInfo
$cmax :: CafInfo -> CafInfo -> CafInfo
>= :: CafInfo -> CafInfo -> Bool
$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
compare :: CafInfo -> CafInfo -> Ordering
$ccompare :: CafInfo -> CafInfo -> Ordering
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
text String
"NoCafRefs"
ppCafInfo CafInfo
MayHaveCafRefs = SDoc
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
  = forall a. Maybe a
Nothing
  | Bool
otherwise
  = forall a. a -> Maybe a
Just (IdInfo
info {occInfo :: OccInfo
occInfo = OccInfo
safe_occ, demandInfo :: Demand
demandInfo = Demand
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 :: InsideLam
occ_in_lam = InsideLam
IsInsideLam
                                 , occ_tail :: TailCallInfo
occ_tail   = TailCallInfo
NoTailCallInfo }
                 IAmALoopBreaker{}
                          -> OccInfo
occ { occ_tail :: TailCallInfo
occ_tail   = TailCallInfo
NoTailCallInfo }
                 OccInfo
_other   -> OccInfo
occ

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

-- | Remove all demand info on the 'IdInfo'
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo IdInfo
info = forall a. a -> Maybe a
Just (IdInfo
info {demandInfo :: Demand
demandInfo = Demand
topDmd})

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

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

zapUsedOnceInfo :: IdInfo -> Maybe IdInfo
zapUsedOnceInfo :: IdInfo -> Maybe IdInfo
zapUsedOnceInfo IdInfo
info
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ IdInfo
info { strictnessInfo :: StrictSig
strictnessInfo = StrictSig -> StrictSig
zapUsedOnceSig    (IdInfo -> StrictSig
strictnessInfo IdInfo
info)
                  , demandInfo :: Demand
demandInfo     = Demand -> Demand
zapUsedOnceDemand (IdInfo -> Demand
demandInfo     IdInfo
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, unfoldingInfo :: IdInfo -> Unfolding
unfoldingInfo = Unfolding
unf })
  = Unfolding
new_unf seq :: 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
    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
zapFragileUnfolding :: Unfolding -> Unfolding
zapFragileUnfolding Unfolding
unf
 | Unfolding -> Bool
hasCoreUnfolding Unfolding
unf = Unfolding
noUnfolding
 | Bool
otherwise            = Unfolding
unf

zapUnfolding :: Unfolding -> Unfolding
-- Squash all unfolding info, preserving only evaluated-ness
zapUnfolding :: Unfolding -> Unfolding
zapUnfolding 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 -> forall a. a -> Maybe a
Just (IdInfo
info IdInfo -> OccInfo -> IdInfo
`setOccInfo` OccInfo
safe_occ)
          | Bool
otherwise              -> forall a. Maybe a
Nothing
        where
          safe_occ :: OccInfo
safe_occ = OccInfo
occ { occ_tail :: TailCallInfo
occ_tail = TailCallInfo
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
text String
"tick" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Module
mod,Int
n)

{-
************************************************************************
*                                                                      *
   Levity
*                                                                      *
************************************************************************

Note [Levity info]
~~~~~~~~~~~~~~~~~~

Ids store whether or not they can be levity-polymorphic at any amount
of saturation. This is helpful in optimizing the levity-polymorphism check
done in the desugarer, where we can usually learn that something is not
levity-polymorphic without actually figuring out its type. See
isExprLevPoly in GHC.Core.Utils for where this info is used. Storing
this is required to prevent perf/compiler/T5631 from blowing up.

-}

-- See Note [Levity info]
data LevityInfo = NoLevityInfo  -- always safe
                | NeverLevityPolymorphic
  deriving LevityInfo -> LevityInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LevityInfo -> LevityInfo -> Bool
$c/= :: LevityInfo -> LevityInfo -> Bool
== :: LevityInfo -> LevityInfo -> Bool
$c== :: LevityInfo -> LevityInfo -> Bool
Eq

instance Outputable LevityInfo where
  ppr :: LevityInfo -> SDoc
ppr LevityInfo
NoLevityInfo           = String -> SDoc
text String
"NoLevityInfo"
  ppr LevityInfo
NeverLevityPolymorphic = String -> SDoc
text String
"NeverLevityPolymorphic"

-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when
-- applied). The Type is only there for checking that it's really never levity
-- polymorphic
setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
setNeverLevPoly IdInfo
info Type
ty
  = ASSERT2( not (resultIsLevPoly ty), ppr ty )
    IdInfo
info { bitfield :: BitField
bitfield = LevityInfo -> BitField -> BitField
bitfieldSetLevityInfo LevityInfo
NeverLevityPolymorphic (IdInfo -> BitField
bitfield IdInfo
info) }

setLevityInfoWithType :: IdInfo -> Type -> IdInfo
setLevityInfoWithType :: IdInfo -> Type -> IdInfo
setLevityInfoWithType IdInfo
info Type
ty
  | Bool -> Bool
not (Type -> Bool
resultIsLevPoly Type
ty)
  = IdInfo
info { bitfield :: BitField
bitfield = LevityInfo -> BitField -> BitField
bitfieldSetLevityInfo LevityInfo
NeverLevityPolymorphic (IdInfo -> BitField
bitfield IdInfo
info) }
  | Bool
otherwise
  = IdInfo
info

isNeverLevPolyIdInfo :: IdInfo -> Bool
isNeverLevPolyIdInfo :: IdInfo -> Bool
isNeverLevPolyIdInfo IdInfo
info
  | LevityInfo
NeverLevityPolymorphic <- IdInfo -> LevityInfo
levityInfo IdInfo
info = Bool
True
  | Bool
otherwise                                 = Bool
False