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

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

{-# LANGUAGE CPP #-}

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

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

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

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

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

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

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

        -- ** Evidence variables
        DictId, isDictId, isEvVar,

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

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

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

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

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

        setIdSpecialisation,
        setIdCafInfo,
        setIdOccInfo, zapIdOccInfo,

        setIdDemandInfo,
        setIdStrictness,

        idDemandInfo,
        idStrictness,

    ) where

#include "HsVersions.h"

import GhcPrelude

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

import IdInfo
import BasicTypes

-- Imported and re-exported
import Var( Id, CoVar, DictId, JoinId,
            InId,  InVar,
            OutId, OutVar,
            idInfo, idDetails, setIdDetails, globaliseId, varType,
            isId, isLocalId, isGlobalId, isExportedId )
import qualified Var

import Type
import RepType
import TysPrim
import DataCon
import Demand
import Name
import Module
import Class
import {-# SOURCE #-} PrimOp (PrimOp)
import ForeignCall
import Maybes
import SrcLoc
import Outputable
import Unique
import UniqSupply
import FastString
import Util

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

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

          `setIdDemandInfo`,
          `setIdStrictness`,

          `asJoinId`,
          `asJoinId_maybe`

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

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

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

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

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

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

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

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

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

localiseId :: Id -> Id
-- Make an Id with the same unique and type as the
-- incoming Id, but with an *Internal* Name and *LocalId* flavour
localiseId id
  | ASSERT( isId id ) isLocalId id && isInternalName name
  = id
  | otherwise
  = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id)
  where
    name = idName id

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    -- proper ids only; no covars!
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info
        -- Note [Free type variables]

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

mkExportedVanillaId :: Name -> Type -> Id
mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
        -- Note [Free type variables]

-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")
-- that are created by the compiler out of thin air
mkSysLocal :: FastString -> Unique -> Type -> Id
mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) )
                        mkLocalId (mkSystemVarName uniq fs) ty

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

mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id
mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty))

mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id
mkSysLocalOrCoVarM fs ty
  = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty))

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

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

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

-- | Workers get local names. "CoreTidy" will externalise these if necessary
mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId uniq unwrkr ty
  = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty

-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty

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

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

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

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

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

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

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

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

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

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

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

-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise.
recordSelectorTyCon :: Id -> RecSelParent
recordSelectorTyCon id
  = case Var.idDetails id of
        RecSelId { sel_tycon = parent } -> parent
        _ -> panic "recordSelectorTyCon"

isRecordSelector        :: Id -> Bool
isNaughtyRecordSelector :: Id -> Bool
isPatSynRecordSelector  :: Id -> Bool
isDataConRecordSelector  :: Id -> Bool
isPrimOpId              :: Id -> Bool
isFCallId               :: Id -> Bool
isDataConWorkId         :: Id -> Bool
isDataConWrapId         :: Id -> Bool
isDFunId                :: Id -> Bool

isClassOpId_maybe       :: Id -> Maybe Class
isPrimOpId_maybe        :: Id -> Maybe PrimOp
isFCallId_maybe         :: Id -> Maybe ForeignCall
isDataConWorkId_maybe   :: Id -> Maybe DataCon
isDataConWrapId_maybe   :: Id -> Maybe DataCon

isRecordSelector id = case Var.idDetails id of
                        RecSelId {}     -> True
                        _               -> False

isDataConRecordSelector id = case Var.idDetails id of
                        RecSelId {sel_tycon = RecSelData _} -> True
                        _               -> False

isPatSynRecordSelector id = case Var.idDetails id of
                        RecSelId {sel_tycon = RecSelPatSyn _} -> True
                        _               -> False

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

isClassOpId_maybe id = case Var.idDetails id of
                        ClassOpId cls -> Just cls
                        _other        -> Nothing

isPrimOpId id = case Var.idDetails id of
                        PrimOpId _ -> True
                        _          -> False

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

isPrimOpId_maybe id = case Var.idDetails id of
                        PrimOpId op -> Just op
                        _           -> Nothing

isFCallId id = case Var.idDetails id of
                        FCallId _ -> True
                        _         -> False

isFCallId_maybe id = case Var.idDetails id of
                        FCallId call -> Just call
                        _            -> Nothing

isDataConWorkId id = case Var.idDetails id of
                        DataConWorkId _ -> True
                        _               -> False

isDataConWorkId_maybe id = case Var.idDetails id of
                        DataConWorkId con -> Just con
                        _                 -> Nothing

isDataConWrapId id = case Var.idDetails id of
                       DataConWrapId _ -> True
                       _               -> False

isDataConWrapId_maybe id = case Var.idDetails id of
                        DataConWrapId con -> Just con
                        _                 -> Nothing

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

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

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

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

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

-- Data constructor workers used to be things of this kind, but
-- they aren't any more.  Instead, we inject a binding for
-- them at the CorePrep stage.
-- EXCEPT: unboxed tuples, which definitely have no binding
hasNoBinding id = case Var.idDetails id of
                        PrimOpId _       -> True        -- See Note [Primop wrappers]
                        FCallId _        -> True
                        DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
                        _                -> isCompulsoryUnfolding (idUnfolding id)
                                            -- See Note [Levity-polymorphic Ids]

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

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

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

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

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

Note [Primop wrappers]
~~~~~~~~~~~~~~~~~~~~~~
Currently hasNoBinding claims that PrimOpIds don't have a curried
function definition.  But actually they do, in GHC.PrimopWrappers,
which is auto-generated from prelude/primops.txt.pp.  So actually, hasNoBinding
could return 'False' for PrimOpIds.

But we'd need to add something in CoreToStg to swizzle any unsaturated
applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#.

Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's
used by GHCi, which does not implement primops direct at all.
-}

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

{-
************************************************************************
*                                                                      *
              Evidence variables
*                                                                      *
************************************************************************
-}

isEvVar :: Var -> Bool
isEvVar var = isEvVarType (varType var)

isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)

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

idJoinArity :: JoinId -> JoinArity
idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)

asJoinId :: Id -> JoinArity -> JoinId
asJoinId id arity = WARN(not (isLocalId id),
                         text "global id being marked as join var:" <+> ppr id)
                    WARN(not (is_vanilla_or_join id),
                         ppr id <+> pprIdDetails (idDetails id))
                    id `setIdDetails` JoinId arity
  where
    is_vanilla_or_join id = case Var.idDetails id of
                              VanillaId -> True
                              JoinId {} -> True
                              _         -> False

zapJoinId :: Id -> Id
-- May be a regular id already
zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId)
                                 -- Core Lint may complain if still marked
                                 -- as AlwaysTailCalled
              | otherwise    = jid

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

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

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

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

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

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

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

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

idStrictness :: Id -> StrictSig
idStrictness id = strictnessInfo (idInfo id)

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

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

-- | This predicate says whether the 'Id' has a strict demand placed on it or
-- has a type such that it can always be evaluated strictly (i.e an
-- unlifted type, as of GHC 7.6).  We need to
-- check separately whether the 'Id' has a so-called \"strict type\" because if
-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict
-- type, we still want @isStrictId id@ to be @True@.
isStrictId :: Id -> Bool
isStrictId id
  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
         not (isJoinId id) && (
           (isStrictType (idType id)) ||
           -- Take the best of both strictnesses - old and new
           (isStrictDmd (idDemandInfo id))
         )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

updOneShotInfo :: Id -> OneShotInfo -> Id
-- Combine the info in the Id with new info
updOneShotInfo id one_shot
  | do_upd    = setIdOneShotInfo id one_shot
  | otherwise = id
  where
    do_upd = case (idOneShotInfo id, one_shot) of
                (NoOneShotInfo, _) -> True
                (OneShotLam,    _) -> False

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

zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id

zapLamIdInfo :: Id -> Id
zapLamIdInfo = zapInfo zapLamInfo

zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo

zapIdDemandInfo :: Id -> Id
zapIdDemandInfo = zapInfo zapDemandInfo

zapIdUsageInfo :: Id -> Id
zapIdUsageInfo = zapInfo zapUsageInfo

zapIdUsageEnvInfo :: Id -> Id
zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo

zapIdUsedOnceInfo :: Id -> Id
zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo

zapIdTailCallInfo :: Id -> Id
zapIdTailCallInfo = zapInfo zapTailCallInfo

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

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

Consider the short-distance let-floating:

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

Then if we float thus

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

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

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

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

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

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

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

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

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

transferPolyIdInfo :: Id        -- Original Id
                   -> [Var]     -- Abstract wrt these variables
                   -> Id        -- New Id
                   -> Id
transferPolyIdInfo old_id abstract_wrt new_id
  = modifyIdInfo transfer new_id
  where
    arity_increase = count isId abstract_wrt    -- Arity increases by the
                                                -- number of value binders

    old_info        = idInfo old_id
    old_arity       = arityInfo old_info
    old_inline_prag = inlinePragInfo old_info
    old_occ_info    = occInfo old_info
    new_arity       = old_arity + arity_increase
    new_occ_info    = zapOccTailCallInfo old_occ_info

    old_strictness  = strictnessInfo old_info
    new_strictness  = increaseStrictSigArity arity_increase old_strictness

    transfer new_info = new_info `setArityInfo` new_arity
                                 `setInlinePragInfo` old_inline_prag
                                 `setOccInfo` new_occ_info
                                 `setStrictnessInfo` new_strictness

isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo


{-
(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 #-}

module IdInfo (
        -- * 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,
        demandInfo, setDemandInfo, pprStrictness,

        -- ** Unfolding Info
        unfoldingInfo, setUnfoldingInfo,

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

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

        InsideLam, OneBranch,
        insideLam, notInsideLam, oneBranch, notOneBranch,

        TailCallInfo(..),
        tailCallInfo, isAlwaysTailCalled,

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

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

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

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

#include "HsVersions.h"

import GhcPrelude

import CoreSyn

import Class
import {-# SOURCE #-} PrimOp (PrimOp)
import Name
import VarSet
import BasicTypes
import DataCon
import TyCon
import PatSyn
import Type
import ForeignCall
import Outputable
import Module
import Demand
import Util

-- infixl so you can say (id `set` a `set` b)
infixl  1 `setRuleInfo`,
          `setArityInfo`,
          `setInlinePragInfo`,
          `setUnfoldingInfo`,
          `setOneShotInfo`,
          `setOccInfo`,
          `setCafInfo`,
          `setStrictnessInfo`,
          `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
    { sel_tycon   :: RecSelParent
    , 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 TcTyClsDecls

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

-- | Recursive Selector Parent
data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving 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 p = case p of
            RecSelData ty_con -> ppr ty_con
            RecSelPatSyn ps   -> ppr ps

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

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

isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity
isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity
isJoinIdDetails_maybe _                   = Nothing

instance Outputable IdDetails where
    ppr = pprIdDetails

pprIdDetails :: IdDetails -> SDoc
pprIdDetails VanillaId = empty
pprIdDetails other     = brackets (pp other)
 where
   pp VanillaId               = panic "pprIdDetails"
   pp (DataConWorkId _)       = text "DataCon"
   pp (DataConWrapId _)       = text "DataConWrapper"
   pp (ClassOpId {})          = text "ClassOp"
   pp (PrimOpId _)            = text "PrimOp"
   pp (FCallId _)             = text "ForeignCall"
   pp (TickBoxOpId _)         = text "TickBoxOp"
   pp (DFunId nt)             = text "DFunId" <> ppWhen nt (text "(nt)")
   pp (RecSelId { sel_naughty = is_naughty })
                              = brackets $ text "RecSel" <>
                                           ppWhen is_naughty (text "(naughty)")
   pp CoVarId                 = text "CoVarId"
   pp (JoinId arity)          = text "JoinId" <> parens (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 {
        arityInfo       :: !ArityInfo,          -- ^ 'Id' arity
        ruleInfo        :: RuleInfo,            -- ^ Specialisations of the 'Id's function which exist
                                                -- See Note [Specialisations and RULES in IdInfo]
        unfoldingInfo   :: Unfolding,           -- ^ The 'Id's unfolding
        cafInfo         :: CafInfo,             -- ^ 'Id' CAF info
        oneShotInfo     :: OneShotInfo,         -- ^ Info about a lambda-bound variable, if the 'Id' is one
        inlinePragInfo  :: InlinePragma,        -- ^ Any inline pragma atached to the 'Id'
        occInfo         :: OccInfo,             -- ^ How the 'Id' occurs in the program

        strictnessInfo  :: StrictSig,      --  ^ A strictness signature

        demandInfo      :: Demand,       -- ^ ID demand information
        callArityInfo   :: !ArityInfo,   -- ^ How this is called.
                                         -- n <=> all calls have at least n arguments

        levityInfo      :: LevityInfo    -- ^ when applied, will this Id ever have a levity-polymorphic type?
    }

-- Setters

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

setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo info 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`
    info { unfoldingInfo = uf }

setArityInfo :: IdInfo -> ArityInfo -> IdInfo
setArityInfo      info ar  = info { arityInfo = ar  }
setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo
setCallArityInfo info ar  = info { callArityInfo = ar  }
setCafInfo :: IdInfo -> CafInfo -> IdInfo
setCafInfo        info caf = info { cafInfo = caf }

setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
setOneShotInfo      info lb = {-lb `seq`-} info { oneShotInfo = lb }

setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }

setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }

-- | Basic 'IdInfo' that carries no useful information whatsoever
vanillaIdInfo :: IdInfo
vanillaIdInfo
  = IdInfo {
            cafInfo             = vanillaCafInfo,
            arityInfo           = unknownArity,
            ruleInfo            = emptyRuleInfo,
            unfoldingInfo       = noUnfolding,
            oneShotInfo         = NoOneShotInfo,
            inlinePragInfo      = defaultInlinePragma,
            occInfo             = noOccInfo,
            demandInfo          = topDmd,
            strictnessInfo      = nopSig,
            callArityInfo       = unknownArity,
            levityInfo          = NoLevityInfo
           }

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

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

ppArityInfo :: Int -> SDoc
ppArityInfo 0 = empty
ppArityInfo n = hsep [text "Arity", 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 sig = ppr 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
jsut 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 TidyPgm, 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 OccurAnal

-- | Assume that no specilizations exist: always safe
emptyRuleInfo :: RuleInfo
emptyRuleInfo = RuleInfo [] emptyDVarSet

isEmptyRuleInfo :: RuleInfo -> Bool
isEmptyRuleInfo (RuleInfo rs _) = null rs

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

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

-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's
setRuleInfoHead :: Name -> RuleInfo -> RuleInfo
setRuleInfoHead fn (RuleInfo rules fvs)
  = RuleInfo (map (setRuleIdName fn) rules) 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 (Eq, Ord)

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

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

instance Outputable CafInfo where
   ppr = ppCafInfo

ppCafInfo :: CafInfo -> SDoc
ppCafInfo NoCafRefs = text "NoCafRefs"
ppCafInfo MayHaveCafRefs = 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 info@(IdInfo {occInfo = occ, demandInfo = demand})
  | is_safe_occ occ && is_safe_dmd demand
  = Nothing
  | otherwise
  = Just (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 occ | isAlwaysTailCalled occ     = False
    is_safe_occ (OneOcc { occ_in_lam = in_lam }) = in_lam
    is_safe_occ _other                           = True

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

    is_safe_dmd dmd = not (isStrictDmd dmd)

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

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

-- | Remove usage environment info from the strictness signature on the 'IdInfo'
zapUsageEnvInfo :: IdInfo -> Maybe IdInfo
zapUsageEnvInfo info
    | hasDemandEnvSig (strictnessInfo info)
    = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})
    | otherwise
    = Nothing

zapUsedOnceInfo :: IdInfo -> Maybe IdInfo
zapUsedOnceInfo info
    = Just $ info { strictnessInfo = zapUsedOnceSig    (strictnessInfo info)
                  , demandInfo     = zapUsedOnceDemand (demandInfo     info) }

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

zapFragileUnfolding :: Unfolding -> Unfolding
zapFragileUnfolding unf
 | isFragileUnfolding unf = noUnfolding
 | otherwise              = unf

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

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

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

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

type TickBoxId = Int

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

instance Outputable TickBoxOp where
    ppr (TickBox mod n)         = text "tick" <+> ppr (mod,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 CoreUtils 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 Eq

instance Outputable LevityInfo where
  ppr NoLevityInfo           = text "NoLevityInfo"
  ppr NeverLevityPolymorphic = text "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 info ty
  = ASSERT2( not (resultIsLevPoly ty), ppr ty )
    info { levityInfo = NeverLevityPolymorphic }

setLevityInfoWithType :: IdInfo -> Type -> IdInfo
setLevityInfoWithType info ty
  | not (resultIsLevPoly ty)
  = info { levityInfo = NeverLevityPolymorphic }
  | otherwise
  = info

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


-- (c) The GHC Team
--
-- Functions to evaluate whether or not a string is a valid identifier.
-- There is considerable overlap between the logic here and the logic
-- in Lexer.x, but sadly there seems to be no way to merge them.

module Lexeme (
          -- * Lexical characteristics of Haskell names

          -- | Use these functions to figure what kind of name a 'FastString'
          -- represents; these functions do /not/ check that the identifier
          -- is valid.

        isLexCon, isLexVar, isLexId, isLexSym,
        isLexConId, isLexConSym, isLexVarId, isLexVarSym,
        startsVarSym, startsVarId, startsConSym, startsConId,

          -- * Validating identifiers

          -- | These functions (working over plain old 'String's) check
          -- to make sure that the identifier is valid.
        okVarOcc, okConOcc, okTcOcc,
        okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc

        -- Some of the exports above are not used within GHC, but may
        -- be of value to GHC API users.

  ) where

import GhcPrelude

import FastString

import Data.Char
import qualified Data.Set as Set

import GHC.Lexeme

{-

************************************************************************
*                                                                      *
    Lexical categories
*                                                                      *
************************************************************************

These functions test strings to see if they fit the lexical categories
defined in the Haskell report.

Note [Classification of generated names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Some names generated for internal use can show up in debugging output,
e.g.  when using -ddump-simpl. These generated names start with a $
but should still be pretty-printed using prefix notation. We make sure
this is the case in isLexVarSym by only classifying a name as a symbol
if all its characters are symbols, not just its first one.
-}

isLexCon,   isLexVar,    isLexId,    isLexSym    :: FastString -> Bool
isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool

isLexCon cs = isLexConId  cs || isLexConSym cs
isLexVar cs = isLexVarId  cs || isLexVarSym cs

isLexId  cs = isLexConId  cs || isLexVarId  cs
isLexSym cs = isLexConSym cs || isLexVarSym cs

-------------
isLexConId cs                           -- Prefix type or data constructors
  | nullFS cs          = False          --      e.g. "Foo", "[]", "(,)"
  | cs == (fsLit "[]") = True
  | otherwise          = startsConId (headFS cs)

isLexVarId cs                           -- Ordinary prefix identifiers
  | nullFS cs         = False           --      e.g. "x", "_x"
  | otherwise         = startsVarId (headFS cs)

isLexConSym cs                          -- Infix type or data constructors
  | nullFS cs          = False          --      e.g. ":-:", ":", "->"
  | cs == (fsLit "->") = True
  | otherwise          = startsConSym (headFS cs)

isLexVarSym fs                          -- Infix identifiers e.g. "+"
  | fs == (fsLit "~R#") = True
  | otherwise
  = case (if nullFS fs then [] else unpackFS fs) of
      [] -> False
      (c:cs) -> startsVarSym c && all isVarSymChar cs
        -- See Note [Classification of generated names]

{-

************************************************************************
*                                                                      *
    Detecting valid names for Template Haskell
*                                                                      *
************************************************************************

-}

----------------------
-- External interface
----------------------

-- | Is this an acceptable variable name?
okVarOcc :: String -> Bool
okVarOcc str@(c:_)
  | startsVarId c
  = okVarIdOcc str
  | startsVarSym c
  = okVarSymOcc str
okVarOcc _ = False

-- | Is this an acceptable constructor name?
okConOcc :: String -> Bool
okConOcc str@(c:_)
  | startsConId c
  = okConIdOcc str
  | startsConSym c
  = okConSymOcc str
  | str == "[]"
  = True
okConOcc _ = False

-- | Is this an acceptable type name?
okTcOcc :: String -> Bool
okTcOcc "[]" = True
okTcOcc "->" = True
okTcOcc "~"  = True
okTcOcc str@(c:_)
  | startsConId c
  = okConIdOcc str
  | startsConSym c
  = okConSymOcc str
  | startsVarSym c
  = okVarSymOcc str
okTcOcc _ = False

-- | Is this an acceptable alphanumeric variable name, assuming it starts
-- with an acceptable letter?
okVarIdOcc :: String -> Bool
okVarIdOcc str = okIdOcc str &&
                 -- admit "_" as a valid identifier.  Required to support typed
                 -- holes in Template Haskell.  See #10267
                 (str == "_" || not (str `Set.member` reservedIds))

-- | Is this an acceptable symbolic variable name, assuming it starts
-- with an acceptable character?
okVarSymOcc :: String -> Bool
okVarSymOcc str = all okSymChar str &&
                  not (str `Set.member` reservedOps) &&
                  not (isDashes str)

-- | Is this an acceptable alphanumeric constructor name, assuming it
-- starts with an acceptable letter?
okConIdOcc :: String -> Bool
okConIdOcc str = okIdOcc str ||
                 is_tuple_name1 True  str ||
                   -- Is it a boxed tuple...
                 is_tuple_name1 False str ||
                   -- ...or an unboxed tuple (Trac #12407)...
                 is_sum_name1 str
                   -- ...or an unboxed sum (Trac #12514)?
  where
    -- check for tuple name, starting at the beginning
    is_tuple_name1 True  ('(' : rest)       = is_tuple_name2 True  rest
    is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest
    is_tuple_name1 _     _                  = False

    -- check for tuple tail
    is_tuple_name2 True  ")"          = True
    is_tuple_name2 False "#)"         = True
    is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest
    is_tuple_name2 boxed (ws  : rest)
      | isSpace ws                    = is_tuple_name2 boxed rest
    is_tuple_name2 _     _            = False

    -- check for sum name, starting at the beginning
    is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest
    is_sum_name1 _                  = False

    -- check for sum tail, only allowing at most one underscore
    is_sum_name2 _          "#)"         = True
    is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest
    is_sum_name2 False      ('_' : rest) = is_sum_name2 True rest
    is_sum_name2 underscore (ws  : rest)
      | isSpace ws                       = is_sum_name2 underscore rest
    is_sum_name2 _          _            = False

-- | Is this an acceptable symbolic constructor name, assuming it
-- starts with an acceptable character?
okConSymOcc :: String -> Bool
okConSymOcc ":" = True
okConSymOcc str = all okSymChar str &&
                  not (str `Set.member` reservedOps)

----------------------
-- Internal functions
----------------------

-- | Is this string an acceptable id, possibly with a suffix of hashes,
-- but not worrying about case or clashing with reserved words?
okIdOcc :: String -> Bool
okIdOcc str
  = let hashes = dropWhile okIdChar str in
    all (== '#') hashes   -- -XMagicHash allows a suffix of hashes
                          -- of course, `all` says "True" to an empty list

-- | Is this character acceptable in an identifier (after the first letter)?
-- See alexGetByte in Lexer.x
okIdChar :: Char -> Bool
okIdChar c = case generalCategory c of
  UppercaseLetter -> True
  LowercaseLetter -> True
  TitlecaseLetter -> True
  ModifierLetter  -> True -- See #10196
  OtherLetter     -> True -- See #1103
  NonSpacingMark  -> True -- See #7650
  DecimalNumber   -> True
  OtherNumber     -> True -- See #4373
  _               -> c == '\'' || c == '_'

-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.
reservedIds :: Set.Set String
reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"
                           , "do", "else", "foreign", "if", "import", "in"
                           , "infix", "infixl", "infixr", "instance", "let"
                           , "module", "newtype", "of", "then", "type", "where"
                           , "_" ]

-- | All reserved operators. Taken from section 2.4 of the 2010 Report.
reservedOps :: Set.Set String
reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->"
                           , "@", "~", "=>" ]

-- | Does this string contain only dashes and has at least 2 of them?
isDashes :: String -> Bool
isDashes ('-' : '-' : rest) = all (== '-') rest
isDashes _                  = False


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

\section[Literal]{@Literal@: literals}
-}

{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}

module Literal
        (
        -- * Main data type
          Literal(..)           -- Exported to ParseIface
        , LitNumType(..)

        -- ** Creating Literals
        , mkLitInt, mkLitIntWrap, mkLitIntWrapC
        , mkLitWord, mkLitWordWrap, mkLitWordWrapC
        , mkLitInt64, mkLitInt64Wrap
        , mkLitWord64, mkLitWord64Wrap
        , mkLitFloat, mkLitDouble
        , mkLitChar, mkLitString
        , mkLitInteger, mkLitNatural
        , mkLitNumber, mkLitNumberWrap

        -- ** Operations on Literals
        , literalType
        , absentLiteralOf
        , pprLiteral
        , litNumIsSigned
        , litNumCheckRange

        -- ** Predicates on Literals and their contents
        , litIsDupable, litIsTrivial, litIsLifted
        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
        , isZeroLit
        , litFitsInChar
        , litValue, isLitValue, isLitValue_maybe, mapLitValue

        -- ** Coercions
        , word2IntLit, int2WordLit
        , narrowLit
        , narrow8IntLit, narrow16IntLit, narrow32IntLit
        , narrow8WordLit, narrow16WordLit, narrow32WordLit
        , char2IntLit, int2CharLit
        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
        , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit
        ) where

#include "HsVersions.h"

import GhcPrelude

import TysPrim
import PrelNames
import Type
import TyCon
import Outputable
import FastString
import BasicTypes
import Binary
import Constants
import DynFlags
import Platform
import UniqFM
import Util

import Data.ByteString (ByteString)
import Data.Int
import Data.Word
import Data.Char
import Data.Maybe ( isJust )
import Data.Data ( Data )
import Data.Proxy
import Numeric ( fromRat )

{-
************************************************************************
*                                                                      *
\subsection{Literals}
*                                                                      *
************************************************************************
-}

-- | So-called 'Literal's are one of:
--
-- * An unboxed numeric literal or floating-point literal which is presumed
--   to be surrounded by appropriate constructors (@Int#@, etc.), so that
--   the overall thing makes sense.
--
--   We maintain the invariant that the 'Integer' in the 'LitNumber'
--   constructor is actually in the (possibly target-dependent) range.
--   The mkLit{Int,Word}*Wrap smart constructors ensure this by applying
--   the target machine's wrapping semantics. Use these in situations
--   where you know the wrapping semantics are correct.
--
-- * The literal derived from the label mentioned in a \"foreign label\"
--   declaration ('LitLabel')
--
-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep'
--   (i.e. 'MutVar#') when the the value is never used.
--
-- * A character
-- * A string
-- * The NULL pointer
--
data Literal
  = LitChar    Char             -- ^ @Char#@ - at least 31 bits. Create with
                                -- 'mkLitChar'

  | LitNumber !LitNumType !Integer Type
                                -- ^ Any numeric literal that can be
                                -- internally represented with an Integer

  | LitString  ByteString       -- ^ A string-literal: stored and emitted
                                -- UTF-8 encoded, we'll arrange to decode it
                                -- at runtime.  Also emitted with a @\'\\0\'@
                                -- terminator. Create with 'mkLitString'

  | LitNullAddr                 -- ^ The @NULL@ pointer, the only pointer value
                                -- that can be represented as a Literal. Create
                                -- with 'nullAddrLit'

  | LitRubbish                  -- ^ A nonsense value, used when an unlifted
                                -- binding is absent and has type
                                -- @forall (a :: 'TYPE' 'UnliftedRep'). a@.
                                -- May be lowered by code-gen to any possible
                                -- value. Also see Note [Rubbish literals]

  | LitFloat   Rational         -- ^ @Float#@. Create with 'mkLitFloat'
  | LitDouble  Rational         -- ^ @Double#@. Create with 'mkLitDouble'

  | LitLabel   FastString (Maybe Int) FunctionOrData
                                -- ^ A label literal. Parameters:
                                --
                                -- 1) The name of the symbol mentioned in the
                                --    declaration
                                --
                                -- 2) The size (in bytes) of the arguments
                                --    the label expects. Only applicable with
                                --    @stdcall@ labels. @Just x@ => @\<x\>@ will
                                --    be appended to label name when emitting
                                --    assembly.
                                --
                                -- 3) Flag indicating whether the symbol
                                --    references a function or a data
  deriving Data

-- | Numeric literal type
data LitNumType
  = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])
  | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])
  | LitNumInt     -- ^ @Int#@ - according to target machine
  | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits
  | LitNumWord    -- ^ @Word#@ - according to target machine
  | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits
  deriving (Data,Enum,Eq,Ord)

-- | Indicate if a numeric literal type supports negative numbers
litNumIsSigned :: LitNumType -> Bool
litNumIsSigned nt = case nt of
  LitNumInteger -> True
  LitNumNatural -> False
  LitNumInt     -> True
  LitNumInt64   -> True
  LitNumWord    -> False
  LitNumWord64  -> False

{-
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
easier to write RULEs for them. They also contain the Integer type, so
that e.g. literalType can return the right Type for them.

They only get converted into real Core,
    mkInteger [c1, c2, .., cn]
during the CorePrep phase, although TidyPgm looks ahead at what the
core will be, so that it can see whether it involves CAFs.

When we initally build an Integer literal, notably when
deserialising it from an interface file (see the Binary instance
below), we don't have convenient access to the mkInteger Id.  So we
just use an error thunk, and fill in the real Id when we do tcIfaceLit
in TcIface.

Note [Natural literals]
~~~~~~~~~~~~~~~~~~~~~~~
Similar to Integer literals.

-}

instance Binary LitNumType where
   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
   get bh = do
      h <- getByte bh
      return (toEnum (fromIntegral h))

instance Binary Literal where
    put_ bh (LitChar aa)     = do putByte bh 0; put_ bh aa
    put_ bh (LitString ab)   = do putByte bh 1; put_ bh ab
    put_ bh (LitNullAddr)    = do putByte bh 2
    put_ bh (LitFloat ah)    = do putByte bh 3; put_ bh ah
    put_ bh (LitDouble ai)   = do putByte bh 4; put_ bh ai
    put_ bh (LitLabel aj mb fod)
        = do putByte bh 5
             put_ bh aj
             put_ bh mb
             put_ bh fod
    put_ bh (LitNumber nt i _)
        = do putByte bh 6
             put_ bh nt
             put_ bh i
    put_ bh (LitRubbish)     = do putByte bh 7
    get bh = do
            h <- getByte bh
            case h of
              0 -> do
                    aa <- get bh
                    return (LitChar aa)
              1 -> do
                    ab <- get bh
                    return (LitString ab)
              2 -> do
                    return (LitNullAddr)
              3 -> do
                    ah <- get bh
                    return (LitFloat ah)
              4 -> do
                    ai <- get bh
                    return (LitDouble ai)
              5 -> do
                    aj <- get bh
                    mb <- get bh
                    fod <- get bh
                    return (LitLabel aj mb fod)
              6 -> do
                    nt <- get bh
                    i  <- get bh
                    let t = case nt of
                            LitNumInt     -> intPrimTy
                            LitNumInt64   -> int64PrimTy
                            LitNumWord    -> wordPrimTy
                            LitNumWord64  -> word64PrimTy
                            -- See Note [Integer literals]
                            LitNumInteger ->
                              panic "Evaluated the place holder for mkInteger"
                            -- and Note [Natural literals]
                            LitNumNatural ->
                              panic "Evaluated the place holder for mkNatural"
                    return (LitNumber nt i t)
              _ -> do
                    return (LitRubbish)

instance Outputable Literal where
    ppr lit = pprLiteral (\d -> d) lit

instance Eq Literal where
    a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
    a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }

-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in
-- 'TrieMap.CoreMap'.
instance Ord Literal where
    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
    compare a b = cmpLit a b

{-
        Construction
        ~~~~~~~~~~~~
-}

{- Note [Word/Int underflow/overflow]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
the number of bits in the type."

GHC stores Word# and Int# constant values as Integer. Core optimizations such
as constant folding must ensure that the Integer value remains in the valid
target Word/Int range (see #13172). The following functions are used to
ensure this.

Note that we *don't* warn the user about overflow. It's not done at runtime
either, and compilation of completely harmless things like
   ((124076834 :: Word32) + (2147483647 :: Word32))
doesn't yield a warning. Instead we simply squash the value into the *target*
Int/Word range.
-}

-- | Wrap a literal number according to its type
wrapLitNumber :: DynFlags -> Literal -> Literal
wrapLitNumber dflags v@(LitNumber nt i t) = case nt of
  LitNumInt -> case platformWordSize (targetPlatform dflags) of
    4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t
    8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
  LitNumWord -> case platformWordSize (targetPlatform dflags) of
    4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t
    8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
  LitNumInteger -> v
  LitNumNatural -> v
wrapLitNumber _ x = x

-- | Create a numeric 'Literal' of the given type
mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)

-- | Check that a given number is in the range of a numeric literal
litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool
litNumCheckRange dflags nt i = case nt of
     LitNumInt     -> inIntRange dflags i
     LitNumWord    -> inWordRange dflags i
     LitNumInt64   -> inInt64Range i
     LitNumWord64  -> inWord64Range i
     LitNumNatural -> i >= 0
     LitNumInteger -> True

-- | Create a numeric 'Literal' of the given type
mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumber dflags nt i t =
  ASSERT2(litNumCheckRange dflags nt i, integer i)
  (LitNumber nt i t)

-- | Creates a 'Literal' of type @Int#@
mkLitInt :: DynFlags -> Integer -> Literal
mkLitInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
                       (mkLitIntUnchecked x)

-- | Creates a 'Literal' of type @Int#@.
--   If the argument is out of the (target-dependent) range, it is wrapped.
--   See Note [Word/Int underflow/overflow]
mkLitIntWrap :: DynFlags -> Integer -> Literal
mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i

-- | Creates a 'Literal' of type @Int#@ without checking its range.
mkLitIntUnchecked :: Integer -> Literal
mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy

-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
--   overflow. That is, if the argument is out of the (target-dependent) range
--   the argument is wrapped and the overflow flag will be set.
--   See Note [Word/Int underflow/overflow]
mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
mkLitIntWrapC dflags i = (n, i /= i')
  where
    n@(LitNumber _ i' _) = mkLitIntWrap dflags i

-- | Creates a 'Literal' of type @Word#@
mkLitWord :: DynFlags -> Integer -> Literal
mkLitWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
                        (mkLitWordUnchecked x)

-- | Creates a 'Literal' of type @Word#@.
--   If the argument is out of the (target-dependent) range, it is wrapped.
--   See Note [Word/Int underflow/overflow]
mkLitWordWrap :: DynFlags -> Integer -> Literal
mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i

-- | Creates a 'Literal' of type @Word#@ without checking its range.
mkLitWordUnchecked :: Integer -> Literal
mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy

-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
--   carry. That is, if the argument is out of the (target-dependent) range
--   the argument is wrapped and the carry flag will be set.
--   See Note [Word/Int underflow/overflow]
mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
mkLitWordWrapC dflags i = (n, i /= i')
  where
    n@(LitNumber _ i' _) = mkLitWordWrap dflags i

-- | Creates a 'Literal' of type @Int64#@
mkLitInt64 :: Integer -> Literal
mkLitInt64  x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)

-- | Creates a 'Literal' of type @Int64#@.
--   If the argument is out of the range, it is wrapped.
mkLitInt64Wrap :: DynFlags -> Integer -> Literal
mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i

-- | Creates a 'Literal' of type @Int64#@ without checking its range.
mkLitInt64Unchecked :: Integer -> Literal
mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy

-- | Creates a 'Literal' of type @Word64#@
mkLitWord64 :: Integer -> Literal
mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)

-- | Creates a 'Literal' of type @Word64#@.
--   If the argument is out of the range, it is wrapped.
mkLitWord64Wrap :: DynFlags -> Integer -> Literal
mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i

-- | Creates a 'Literal' of type @Word64#@ without checking its range.
mkLitWord64Unchecked :: Integer -> Literal
mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy

-- | Creates a 'Literal' of type @Float#@
mkLitFloat :: Rational -> Literal
mkLitFloat = LitFloat

-- | Creates a 'Literal' of type @Double#@
mkLitDouble :: Rational -> Literal
mkLitDouble = LitDouble

-- | Creates a 'Literal' of type @Char#@
mkLitChar :: Char -> Literal
mkLitChar = LitChar

-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
mkLitString :: String -> Literal
-- stored UTF-8 encoded
mkLitString s = LitString (bytesFS $ mkFastString s)

mkLitInteger :: Integer -> Type -> Literal
mkLitInteger x ty = LitNumber LitNumInteger x ty

mkLitNatural :: Integer -> Type -> Literal
mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )
                    (LitNumber LitNumNatural x ty)

inIntRange, inWordRange :: DynFlags -> Integer -> Bool
inIntRange  dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
inWordRange dflags x = x >= 0                     && x <= tARGET_MAX_WORD dflags

inNaturalRange :: Integer -> Bool
inNaturalRange x = x >= 0

inInt64Range, inWord64Range :: Integer -> Bool
inInt64Range x  = x >= toInteger (minBound :: Int64) &&
                  x <= toInteger (maxBound :: Int64)
inWord64Range x = x >= toInteger (minBound :: Word64) &&
                  x <= toInteger (maxBound :: Word64)

inCharRange :: Char -> Bool
inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR

-- | Tests whether the literal represents a zero of whatever type it is
isZeroLit :: Literal -> Bool
isZeroLit (LitNumber _ 0 _) = True
isZeroLit (LitFloat  0)     = True
isZeroLit (LitDouble 0)     = True
isZeroLit _                 = False

-- | Returns the 'Integer' contained in the 'Literal', for when that makes
-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.
litValue  :: Literal -> Integer
litValue l = case isLitValue_maybe l of
   Just x  -> x
   Nothing -> pprPanic "litValue" (ppr l)

-- | Returns the 'Integer' contained in the 'Literal', for when that makes
-- sense, i.e. for 'Char' and numbers.
isLitValue_maybe  :: Literal -> Maybe Integer
isLitValue_maybe (LitChar   c)     = Just $ toInteger $ ord c
isLitValue_maybe (LitNumber _ i _) = Just i
isLitValue_maybe _                 = Nothing

-- | Apply a function to the 'Integer' contained in the 'Literal', for when that
-- makes sense, e.g. for 'Char' and numbers.
-- For fixed-size integral literals, the result will be wrapped in accordance
-- with the semantics of the target type.
-- See Note [Word/Int underflow/overflow]
mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
mapLitValue _      f (LitChar   c)      = mkLitChar (fchar c)
   where fchar = chr . fromInteger . f . toInteger . ord
mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags
                                                        (LitNumber nt (f i) t)
mapLitValue _      _ l                  = pprPanic "mapLitValue" (ppr l)

-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
-- 'Int', 'Word', 'LitInteger' and 'LitNatural'.
isLitValue  :: Literal -> Bool
isLitValue = isJust . isLitValue_maybe

{-
        Coercions
        ~~~~~~~~~
-}

narrow8IntLit, narrow16IntLit, narrow32IntLit,
  narrow8WordLit, narrow16WordLit, narrow32WordLit,
  char2IntLit, int2CharLit,
  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
  float2DoubleLit, double2FloatLit
  :: Literal -> Literal

word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
word2IntLit dflags (LitNumber LitNumWord w _)
  -- Map Word range [max_int+1, max_word]
  -- to Int range   [min_int  , -1]
  -- Range [0,max_int] has the same representation with both Int and Word
  | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1)
  | otherwise                 = mkLitInt dflags w
word2IntLit _ l = pprPanic "word2IntLit" (ppr l)

int2WordLit dflags (LitNumber LitNumInt i _)
  -- Map Int range [min_int  , -1]
  -- to Word range [max_int+1, max_word]
  -- Range [0,max_int] has the same representation with both Int and Word
  | i < 0     = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i)
  | otherwise = mkLitWord dflags i
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)

-- | Narrow a literal number (unchecked result range)
narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t
narrowLit _ l                  = pprPanic "narrowLit" (ppr l)

narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)
narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)
narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)
narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)
narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
narrow32WordLit = narrowLit (Proxy :: Proxy Word32)

char2IntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c))
char2IntLit l                 = pprPanic "char2IntLit" (ppr l)
int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i))
int2CharLit l                 = pprPanic "int2CharLit" (ppr l)

float2IntLit (LitFloat f)      = mkLitIntUnchecked (truncate f)
float2IntLit l                 = pprPanic "float2IntLit" (ppr l)
int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i)
int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)

double2IntLit (LitDouble f)     = mkLitIntUnchecked (truncate f)
double2IntLit l                 = pprPanic "double2IntLit" (ppr l)
int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i)
int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)

float2DoubleLit (LitFloat  f) = LitDouble f
float2DoubleLit l             = pprPanic "float2DoubleLit" (ppr l)
double2FloatLit (LitDouble d) = LitFloat  d
double2FloatLit l             = pprPanic "double2FloatLit" (ppr l)

nullAddrLit :: Literal
nullAddrLit = LitNullAddr

-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@.
rubbishLit :: Literal
rubbishLit = LitRubbish

{-
        Predicates
        ~~~~~~~~~~
-}

-- | True if there is absolutely no penalty to duplicating the literal.
-- False principally of strings.
--
-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would
-- blow up code sizes. Not only this, it's also unsafe.
--
-- Consider a program that wants to traverse a string. One way it might do this
-- is to first compute the Addr# pointing to the end of the string, and then,
-- starting from the beginning, bump a pointer using eqAddr# to determine the
-- end. For instance,
--
-- @
-- -- Given pointers to the start and end of a string, count how many zeros
-- -- the string contains.
-- countZeros :: Addr# -> Addr# -> -> Int
-- countZeros start end = go start 0
--   where
--     go off n
--       | off `addrEq#` end = n
--       | otherwise         = go (off `plusAddr#` 1) n'
--       where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1
--                | otherwise                                 = n
-- @
--
-- Consider what happens if we considered strings to be trivial (and therefore
-- duplicable) and emitted a call like @countZeros "hello"# ("hello"#
-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same
-- string, meaning that an iteration like the above would blow up terribly.
-- This is what happened in #12757.
--
-- Ultimately the solution here is to make primitive strings a bit more
-- structured, ensuring that the compiler can't inline in ways that will break
-- user code. One approach to this is described in #8472.
litIsTrivial :: Literal -> Bool
--      c.f. CoreUtils.exprIsTrivial
litIsTrivial (LitString _)      = False
litIsTrivial (LitNumber nt _ _) = case nt of
  LitNumInteger -> False
  LitNumNatural -> False
  LitNumInt     -> True
  LitNumInt64   -> True
  LitNumWord    -> True
  LitNumWord64  -> True
litIsTrivial _                  = True

-- | True if code space does not go bad if we duplicate this literal
litIsDupable :: DynFlags -> Literal -> Bool
--      c.f. CoreUtils.exprIsDupable
litIsDupable _      (LitString _)      = False
litIsDupable dflags (LitNumber nt i _) = case nt of
  LitNumInteger -> inIntRange dflags i
  LitNumNatural -> inIntRange dflags i
  LitNumInt     -> True
  LitNumInt64   -> True
  LitNumWord    -> True
  LitNumWord64  -> True
litIsDupable _      _                  = True

litFitsInChar :: Literal -> Bool
litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
                               && i <= toInteger (ord maxBound)
litFitsInChar _                 = False

litIsLifted :: Literal -> Bool
litIsLifted (LitNumber nt _ _) = case nt of
  LitNumInteger -> True
  LitNumNatural -> True
  LitNumInt     -> False
  LitNumInt64   -> False
  LitNumWord    -> False
  LitNumWord64  -> False
litIsLifted _                  = False

{-
        Types
        ~~~~~
-}

-- | Find the Haskell 'Type' the literal occupies
literalType :: Literal -> Type
literalType LitNullAddr       = addrPrimTy
literalType (LitChar _)       = charPrimTy
literalType (LitString  _)    = addrPrimTy
literalType (LitFloat _)      = floatPrimTy
literalType (LitDouble _)     = doublePrimTy
literalType (LitLabel _ _ _)  = addrPrimTy
literalType (LitNumber _ _ t) = t
literalType (LitRubbish)      = mkForAllTy a Inferred (mkTyVarTy a)
  where
    a = alphaTyVarUnliftedRep

absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primitive
-- TyCon, to use as a placeholder when it doesn't matter
-- Rubbish literals are handled in WwLib, because
--  1. Looking at the TyCon is not enough, we need the actual type
--  2. This would need to return a type application to a literal
absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)

absent_lits :: UniqFM Literal
absent_lits = listToUFM [ (addrPrimTyConKey,    LitNullAddr)
                        , (charPrimTyConKey,    LitChar 'x')
                        , (intPrimTyConKey,     mkLitIntUnchecked 0)
                        , (int64PrimTyConKey,   mkLitInt64Unchecked 0)
                        , (wordPrimTyConKey,    mkLitWordUnchecked 0)
                        , (word64PrimTyConKey,  mkLitWord64Unchecked 0)
                        , (floatPrimTyConKey,   LitFloat 0)
                        , (doublePrimTyConKey,  LitDouble 0)
                        ]

{-
        Comparison
        ~~~~~~~~~~
-}

cmpLit :: Literal -> Literal -> Ordering
cmpLit (LitChar      a)     (LitChar       b)     = a `compare` b
cmpLit (LitString    a)     (LitString     b)     = a `compare` b
cmpLit (LitNullAddr)        (LitNullAddr)         = EQ
cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b
cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b
cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `compare` b
cmpLit (LitNumber nt1 a _)  (LitNumber nt2  b _)
  | nt1 == nt2 = a   `compare` b
  | otherwise  = nt1 `compare` nt2
cmpLit (LitRubbish)         (LitRubbish)          = EQ
cmpLit lit1 lit2
  | litTag lit1 < litTag lit2 = LT
  | otherwise                 = GT

litTag :: Literal -> Int
litTag (LitChar      _)   = 1
litTag (LitString    _)   = 2
litTag (LitNullAddr)      = 3
litTag (LitFloat     _)   = 4
litTag (LitDouble    _)   = 5
litTag (LitLabel _ _ _)   = 6
litTag (LitNumber  {})    = 7
litTag (LitRubbish)       = 8

{-
        Printing
        ~~~~~~~~
* See Note [Printing of literals in Core]
-}

pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
pprLiteral _       (LitChar c)     = pprPrimChar c
pprLiteral _       (LitString s)   = pprHsBytes s
pprLiteral _       (LitNullAddr)   = text "__NULL"
pprLiteral _       (LitFloat f)    = float (fromRat f) <> primFloatSuffix
pprLiteral _       (LitDouble d)   = double (fromRat d) <> primDoubleSuffix
pprLiteral add_par (LitNumber nt i _)
   = case nt of
       LitNumInteger -> pprIntegerVal add_par i
       LitNumNatural -> pprIntegerVal add_par i
       LitNumInt     -> pprPrimInt i
       LitNumInt64   -> pprPrimInt64 i
       LitNumWord    -> pprPrimWord i
       LitNumWord64  -> pprPrimWord64 i
pprLiteral add_par (LitLabel l mb fod) =
    add_par (text "__label" <+> b <+> ppr fod)
    where b = case mb of
              Nothing -> pprHsString l
              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
pprLiteral _       (LitRubbish)     = text "__RUBBISH"

pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
-- See Note [Printing of literals in Core].
pprIntegerVal add_par i | i < 0     = add_par (integer i)
                        | otherwise = integer i

{-
Note [Printing of literals in Core]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The function `add_par` is used to wrap parenthesis around negative integers
(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring
an atomic thing (for example function application).

Although not all Core literals would be valid Haskell, we are trying to stay
as close as possible to Haskell syntax in the printing of Core, to make it
easier for a Haskell user to read Core.

To that end:
  * We do print parenthesis around negative `LitInteger`, because we print
  `LitInteger` using plain number literals (no prefix or suffix), and plain
  number literals in Haskell require parenthesis in contexts like function
  application (i.e. `1 - -1` is not valid Haskell).

  * We don't print parenthesis around other (negative) literals, because they
  aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
  parser).

Literal         Output             Output if context requires
                                   an atom (if different)
-------         -------            ----------------------
LitChar         'a'#
LitString       "aaa"#
LitNullAddr     "__NULL"
LitInt          -1#
LitInt64        -1L#
LitWord          1##
LitWord64        1L##
LitFloat        -1.0#
LitDouble       -1.0##
LitInteger      -1                 (-1)
LitLabel        "__label" ...      ("__label" ...)
LitRubbish      "__RUBBISH"

Note [Rubbish literals]
~~~~~~~~~~~~~~~~~~~~~~~
During worker/wrapper after demand analysis, where an argument
is unused (absent) we do the following w/w split (supposing that
y is absent):

  f x y z = e
===>
  f x y z = $wf x z
  $wf x z = let y = <absent value>
            in e

Usually the binding for y is ultimately optimised away, and
even if not it should never be evaluated -- but that's the
way the w/w split starts off.

What is <absent value>?
* For lifted values <absent value> can be a call to 'error'.
* For primitive types like Int# or Word# we can use any random
  value of that type.
* But what about /unlifted/ but /boxed/ types like MutVar# or
  Array#?   We need a literal value of that type.

That is 'LitRubbish'.  Since we need a rubbish literal for
many boxed, unlifted types, we say that LitRubbish has type
  LitRubbish :: forall (a :: TYPE UnliftedRep). a

So we might see a w/w split like
  $wf x z = let y :: Array# Int = LitRubbish @(Array# Int)
            in e

Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted
heap pointers.

Here are the moving parts:

* We define LitRubbish as a constructor in Literal.Literal

* It is given its polymoprhic type by Literal.literalType

* WwLib.mk_absent_let introduces a LitRubbish for absent
  arguments of boxed, unlifted type.

* In CoreToSTG we convert (RubishLit @t) to just ().  STG is
  untyped, so it doesn't matter that it points to a lifted
  value. The important thing is that it is a heap pointer,
  which the garbage collector can follow if it encounters it.

  We considered maintaining LitRubbish in STG, and lowering
  it in the code genreators, but it seems simpler to do it
  once and for all in CoreToSTG.

  In ByteCodeAsm we just lower it as a 0 literal, because
  it's all boxed and lifted to the host GC anyway.
-}