    -----------------------------------------------------------------------------
    --
    -- Stg to C-- code generation: the binding environment
    --
    -- (c) The University of Glasgow 2004-2006
    --
    -----------------------------------------------------------------------------
    module GHC.StgToCmm.Env (
            CgIdInfo,

            litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
            idInfoToAmode,

            addBindC, addBindsC,

            bindArgsToRegs, bindToReg, rebindToReg,
            bindArgToReg, idToReg,
            getCgIdInfo, getCgInfo_maybe,
            maybeLetNoEscape,
            ) where

    import GHC.Prelude

    import GHC.Platform
    import GHC.StgToCmm.Monad
    import GHC.StgToCmm.Closure

    import GHC.Cmm.CLabel

    import GHC.Cmm.BlockId
    import GHC.Cmm.Expr
    import GHC.Cmm.Utils
    import GHC.Types.Id
    import GHC.Cmm.Graph
    import GHC.Types.Name
    import GHC.Core.Type
    import GHC.Builtin.Types.Prim
    import GHC.Types.Unique.FM
    import GHC.Types.Var.Env

    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Panic.Plain

    import GHC.Builtin.Names (getUnique)

    -------------------------------------
    --        Manipulating CgIdInfo
    -------------------------------------

    mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
    mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
    mkCgIdInfo Id
    id LambdaFormInfo
    lf CmmExpr
    expr
      = CgIdInfo { cg_id :: Id
    cg_id = Id
    id, cg_lf :: LambdaFormInfo
    cg_lf = LambdaFormInfo
    lf
                 , cg_loc :: CgLoc
    cg_loc = CmmExpr -> CgLoc
    CmmLoc CmmExpr
    expr }

    litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
    litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
    litIdInfo Platform
    platform Id
    id LambdaFormInfo
    lf CmmLit
    lit
      = CgIdInfo { cg_id :: Id
    cg_id = Id
    id, cg_lf :: LambdaFormInfo
    cg_lf = LambdaFormInfo
    lf
                 , cg_loc :: CgLoc
    cg_loc = CmmExpr -> CgLoc
    CmmLoc (Platform -> CmmExpr -> DynTag -> CmmExpr
    addDynTag Platform
    platform (CmmLit -> CmmExpr
    CmmLit CmmLit
    lit) DynTag
    tag) }
      where
        tag :: DynTag
    tag = Platform -> LambdaFormInfo -> DynTag
    lfDynTag Platform
    platform LambdaFormInfo
    lf

    lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo
    lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo
    lneIdInfo Platform
    platform Id
    id [NonVoid Id]
    regs
      = CgIdInfo { cg_id :: Id
    cg_id = Id
    id, cg_lf :: LambdaFormInfo
    cg_lf = LambdaFormInfo
    lf
                 , cg_loc :: CgLoc
    cg_loc = BlockId -> [LocalReg] -> CgLoc
    LneLoc BlockId
    blk_id ((NonVoid Id -> LocalReg) -> [NonVoid Id] -> [LocalReg]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> NonVoid Id -> LocalReg
    idToReg Platform
    platform) [NonVoid Id]
    regs) }
      where
        lf :: LambdaFormInfo
    lf     = LambdaFormInfo
    mkLFLetNoEscape
        blk_id :: BlockId
    blk_id = Unique -> BlockId
    mkBlockId (Id -> Unique
    idUnique Id
    id)

    rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
    rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
    rhsIdInfo Id
    id LambdaFormInfo
    lf_info
      = do Platform
    platform <- FCode Platform
    getPlatform
           LocalReg
    reg <- CmmType -> FCode LocalReg
    forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    gcWord Platform
    platform)
           (CgIdInfo, LocalReg) -> FCode (CgIdInfo, LocalReg)
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
    mkCgIdInfo Id
    id LambdaFormInfo
    lf_info (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg)), LocalReg
    reg)

    mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
    mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
    mkRhsInit Platform
    platform LocalReg
    reg LambdaFormInfo
    lf_info CmmExpr
    expr
      = CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg) (Platform -> CmmExpr -> DynTag -> CmmExpr
    addDynTag Platform
    platform CmmExpr
    expr (Platform -> LambdaFormInfo -> DynTag
    lfDynTag Platform
    platform LambdaFormInfo
    lf_info))

    idInfoToAmode :: CgIdInfo -> CmmExpr
    -- Returns a CmmExpr for the *tagged* pointer
    idInfoToAmode :: CgIdInfo -> CmmExpr
    idInfoToAmode CgIdInfo { cg_loc :: CgIdInfo -> CgLoc
    cg_loc = CmmLoc CmmExpr
    e } = CmmExpr
    e
    idInfoToAmode CgIdInfo
    cg_info
      = String -> SDoc -> CmmExpr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "idInfoToAmode" (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CgIdInfo -> Id
    cg_id CgIdInfo
    cg_info))        -- LneLoc

    -- | A tag adds a byte offset to the pointer
    addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
    addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
    addDynTag = Platform -> CmmExpr -> DynTag -> CmmExpr
    cmmOffsetB

    maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
    maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
    maybeLetNoEscape CgIdInfo { cg_loc :: CgIdInfo -> CgLoc
    cg_loc = LneLoc BlockId
    blk_id [LocalReg]
    args} = (BlockId, [LocalReg]) -> Maybe (BlockId, [LocalReg])
    forall a. a -> Maybe a
    Just (BlockId
    blk_id, [LocalReg]
    args)
    maybeLetNoEscape CgIdInfo
    _other                                      = Maybe (BlockId, [LocalReg])
    forall a. Maybe a
    Nothing

    ---------------------------------------------------------
    --        The binding environment
    --
    -- There are three basic routines, for adding (addBindC),
    -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
    ---------------------------------------------------------

    addBindC :: CgIdInfo -> FCode ()
    addBindC :: CgIdInfo -> FCode ()
    addBindC CgIdInfo
    stuff_to_bind = do
            CgBindings
    binds <- FCode CgBindings
    getBinds
            CgBindings -> FCode ()
    setBinds (CgBindings -> FCode ()) -> CgBindings -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ CgBindings -> Id -> CgIdInfo -> CgBindings
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv CgBindings
    binds (CgIdInfo -> Id
    cg_id CgIdInfo
    stuff_to_bind) CgIdInfo
    stuff_to_bind

    addBindsC :: [CgIdInfo] -> FCode ()
    addBindsC :: [CgIdInfo] -> FCode ()
    addBindsC [CgIdInfo]
    new_bindings = do
            CgBindings
    binds <- FCode CgBindings
    getBinds
            let new_binds :: CgBindings
    new_binds = (CgBindings -> CgIdInfo -> CgBindings)
    -> CgBindings -> [CgIdInfo] -> CgBindings
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\ CgBindings
    binds CgIdInfo
    info -> CgBindings -> Id -> CgIdInfo -> CgBindings
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv CgBindings
    binds (CgIdInfo -> Id
    cg_id CgIdInfo
    info) CgIdInfo
    info)
                                   CgBindings
    binds
                                   [CgIdInfo]
    new_bindings
            CgBindings -> FCode ()
    setBinds CgBindings
    new_binds

    -- Inside GHC the average module creates 385 external references
    -- with noteable cgIdInfo (so not generated by mkLFArgument).
    -- On average 200 of these are covered by True/False/[]
    -- and nullary constructors make up ~80.
    -- One would think it would be worthwhile to cache these.
    -- Sadly it's not. See #16937

    getCgIdInfo :: Id -> FCode CgIdInfo
    getCgIdInfo :: Id -> FCode CgIdInfo
    getCgIdInfo Id
    id
      = do  { Platform
    platform <- FCode Platform
    getPlatform
            ; CgBindings
    local_binds <- FCode CgBindings
    getBinds -- Try local bindings first
            ; case CgBindings -> Id -> Maybe CgIdInfo
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv CgBindings
    local_binds Id
    id of {
                Just CgIdInfo
    info -> -- pprTrace "getCgIdInfoLocal" (ppr id) $
                  CgIdInfo -> FCode CgIdInfo
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CgIdInfo
    info ;
                Maybe CgIdInfo
    Nothing   -> do {

                    -- Should be imported; make up a CgIdInfo for it
              let name :: Name
    name = Id -> Name
    idName Id
    id
            ; if Name -> Bool
    isExternalName Name
    name then
                  let ext_lbl :: CLabel
    ext_lbl
                          | Kind -> Bool
    isBoxedType (Id -> Kind
    idType Id
    id)
                          = Name -> CafInfo -> CLabel
    mkClosureLabel Name
    name (CafInfo -> CLabel) -> CafInfo -> CLabel
    forall a b. (a -> b) -> a -> b
    $ Id -> CafInfo
    idCafInfo Id
    id
                          | (() :: Constraint) => Kind -> Bool
    Kind -> Bool
    isUnliftedType (Id -> Kind
    idType Id
    id)
                              -- An unlifted external Id must refer to a top-level
                              -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".
                          = Bool -> CLabel -> CLabel
    forall a. HasCallStack => Bool -> a -> a
    assert (Id -> Kind
    idType Id
    id Kind -> Kind -> Bool
    `eqType` Kind
    addrPrimTy) (CLabel -> CLabel) -> CLabel -> CLabel
    forall a b. (a -> b) -> a -> b
    $
                            Name -> CLabel
    mkBytesLabel Name
    name
                          | Bool
    otherwise
                          = String -> SDoc -> CLabel
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToCmm.Env: label not found" (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    id SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    id))
                  in CgIdInfo -> FCode CgIdInfo
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CgIdInfo -> FCode CgIdInfo) -> CgIdInfo -> FCode CgIdInfo
    forall a b. (a -> b) -> a -> b
    $
                      Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
    litIdInfo Platform
    platform Id
    id (Id -> LambdaFormInfo
    mkLFImported Id
    id) (CLabel -> CmmLit
    CmmLabel CLabel
    ext_lbl)
              else
                  Id -> FCode CgIdInfo
    forall a. Id -> FCode a
    cgLookupPanic Id
    id -- Bug
            }}}

    -- | Retrieve cg info for a name if it already exists.
    getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)
    getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)
    getCgInfo_maybe Name
    name
      = do  { CgBindings
    local_binds <- FCode CgBindings
    getBinds -- Try local bindings first
            ; Maybe CgIdInfo -> FCode (Maybe CgIdInfo)
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe CgIdInfo -> FCode (Maybe CgIdInfo))
    -> Maybe CgIdInfo -> FCode (Maybe CgIdInfo)
    forall a b. (a -> b) -> a -> b
    $ CgBindings -> Unique -> Maybe CgIdInfo
    forall a. VarEnv a -> Unique -> Maybe a
    lookupVarEnv_Directly CgBindings
    local_binds (Name -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique Name
    name) }

    cgLookupPanic :: Id -> FCode a
    cgLookupPanic :: forall a. Id -> FCode a
    cgLookupPanic Id
    id
      = do  CgBindings
    local_binds <- FCode CgBindings
    getBinds
            String -> SDoc -> FCode a
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToCmm.Env: variable not found"
                    ([SDoc] -> SDoc
    vcat [Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    id,
                    String -> SDoc
    text String
    "local binds for:",
                    CgBindings -> ([CgIdInfo] -> SDoc) -> SDoc
    forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
    pprUFM CgBindings
    local_binds (([CgIdInfo] -> SDoc) -> SDoc) -> ([CgIdInfo] -> SDoc) -> SDoc
    forall a b. (a -> b) -> a -> b
    $ \[CgIdInfo]
    infos ->
                      [SDoc] -> SDoc
    vcat [ Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CgIdInfo -> Id
    cg_id CgIdInfo
    info) | CgIdInfo
    info <- [CgIdInfo]
    infos ]
                  ])

    ------------------------------------------------------------------------
    --        Interface functions for binding and re-binding names
    ------------------------------------------------------------------------

    bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
    -- Bind an Id to a fresh LocalReg
    bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
    bindToReg nvid :: NonVoid Id
    nvid@(NonVoid Id
    id) LambdaFormInfo
    lf_info
      = do Platform
    platform <- FCode Platform
    getPlatform
           let reg :: LocalReg
    reg = Platform -> NonVoid Id -> LocalReg
    idToReg Platform
    platform NonVoid Id
    nvid
           CgIdInfo -> FCode ()
    addBindC (Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
    mkCgIdInfo Id
    id LambdaFormInfo
    lf_info (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg)))
           LocalReg -> FCode LocalReg
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LocalReg
    reg

    rebindToReg :: NonVoid Id -> FCode LocalReg
    -- Like bindToReg, but the Id is already in scope, so
    -- get its LF info from the envt
    rebindToReg :: NonVoid Id -> FCode LocalReg
    rebindToReg nvid :: NonVoid Id
    nvid@(NonVoid Id
    id)
      = do  { CgIdInfo
    info <- Id -> FCode CgIdInfo
    getCgIdInfo Id
    id
            ; NonVoid Id -> LambdaFormInfo -> FCode LocalReg
    bindToReg NonVoid Id
    nvid (CgIdInfo -> LambdaFormInfo
    cg_lf CgIdInfo
    info) }

    bindArgToReg :: NonVoid Id -> FCode LocalReg
    bindArgToReg :: NonVoid Id -> FCode LocalReg
    bindArgToReg nvid :: NonVoid Id
    nvid@(NonVoid Id
    id) = NonVoid Id -> LambdaFormInfo -> FCode LocalReg
    bindToReg NonVoid Id
    nvid (Id -> LambdaFormInfo
    mkLFArgument Id
    id)

    bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
    bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
    bindArgsToRegs = (NonVoid Id -> FCode LocalReg) -> [NonVoid Id] -> FCode [LocalReg]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM NonVoid Id -> FCode LocalReg
    bindArgToReg

    idToReg :: Platform -> NonVoid Id -> LocalReg
    -- Make a register from an Id, typically a function argument,
    -- free variable, or case binder
    --
    -- We re-use the Unique from the Id to make it easier to see what is going on
    --
    -- By now the Ids should be uniquely named; else one would worry
    -- about accidental collision
    idToReg :: Platform -> NonVoid Id -> LocalReg
    idToReg Platform
    platform (NonVoid Id
    id)
                 = Unique -> CmmType -> LocalReg
    LocalReg (Id -> Unique
    idUnique Id
    id)
                            (Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform (Id -> PrimRep
    idPrimRep Id
    id))