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

            mkCgIdInfo, 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.Core.TyCo.Compare( eqType )
    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.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 <- FCode Platform
    getPlatform
           reg <- newTemp (gcWord platform)
           return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), 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))

    -- | Returns a 'CmmExpr' for the *tagged* pointer
    idInfoToAmode :: CgIdInfo -> CmmExpr
    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
            binds <- FCode CgBindings
    getBinds
            setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind

    addBindsC :: [CgIdInfo] -> FCode ()
    addBindsC :: [CgIdInfo] -> FCode ()
    addBindsC [CgIdInfo]
    new_bindings = do
            binds <- FCode CgBindings
    getBinds
            let 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
            setBinds new_binds

    -- Inside GHC the average module creates 385 external references
    -- with notable 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 <- FCode Platform
    getPlatform
            ; local_binds <- getBinds -- Try local bindings first
            ; case lookupVarEnv local_binds 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
                          | HasDebugCallStack => 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 HasCallStack => Kind -> Kind -> Bool
    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
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> 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
    importedIdLFInfo Id
    id) (CLabel -> CmmLit
    CmmLabel CLabel
    ext_lbl)
              else
                  Id -> FCode CgIdInfo
    forall a. Id -> FCode a
    cgLookupPanic Id
    id -- Bug, id is neither in local binds nor is external
            }}}

    -- | 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  { local_binds <- FCode CgBindings
    getBinds -- Try local bindings first
            ; return $ lookupVarEnv_Directly local_binds (getUnique name) }

    cgLookupPanic :: Id -> FCode a
    cgLookupPanic :: forall a. Id -> FCode a
    cgLookupPanic Id
    id
      = do  local_binds <- FCode CgBindings
    getBinds
            pprPanic "GHC.StgToCmm.Env: variable not found"
                    (vcat [ppr id,
                    text "local binds for:",
                    pprUFM local_binds $ \[CgIdInfo]
    infos ->
                      [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    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 <- FCode Platform
    getPlatform
           let reg = Platform -> NonVoid Id -> LocalReg
    idToReg Platform
    platform NonVoid Id
    nvid
           addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
           return 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  { info <- Id -> FCode CgIdInfo
    getCgIdInfo Id
    id
            ; bindToReg nvid (cg_lf 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
    idPrimRepU Id
    id))