    {-# LANGUAGE CPP #-}

    -----------------------------------------------------------------------------
    --
    -- 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,
            maybeLetNoEscape,
        ) where

    #include "HsVersions.h"

    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.Misc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import GHC.Driver.Session

    -------------------------------------
    --        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 (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 <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    gcWord Platform
    platform)
           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
      = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "idInfoToAmode" (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
    platform CmmExpr
    expr DynTag
    tag = Platform -> CmmExpr -> DynTag -> CmmExpr
    cmmOffsetB Platform
    platform CmmExpr
    expr DynTag
    tag

    maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
    maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
    maybeLetNoEscape (CgIdInfo { cg_loc :: CgIdInfo -> CgLoc
    cg_loc = LneLoc BlockId
    blk_id [LocalReg]
    args}) = forall a. a -> Maybe a
    Just (BlockId
    blk_id, [LocalReg]
    args)
    maybeLetNoEscape CgIdInfo
    _other                                      = 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 forall a b. (a -> b) -> a -> b
    $ 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 = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\ CgBindings
    binds CgIdInfo
    info -> 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

    getCgIdInfo :: Id -> FCode CgIdInfo
    getCgIdInfo :: Id -> FCode CgIdInfo
    getCgIdInfo Id
    id
      = do  { Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            ; CgBindings
    local_binds <- FCode CgBindings
    getBinds -- Try local bindings first
            ; case forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv CgBindings
    local_binds Id
    id of {
                Just CgIdInfo
    info -> 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 forall a b. (a -> b) -> a -> b
    $ Id -> CafInfo
    idCafInfo Id
    id
                          | HasDebugCallStack => 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".
                          = ASSERT( idType id `eqType` addrPrimTy )
                            Name -> CLabel
    mkBytesLabel Name
    name
                          | Bool
    otherwise
                          = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToCmm.Env: label not found" (forall a. Outputable a => a -> SDoc
    ppr Id
    id SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    id))
                  in forall (m :: * -> *) a. Monad m => a -> m a
    return 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
                  forall a. Id -> FCode a
    cgLookupPanic Id
    id -- Bug
            }}}

    cgLookupPanic :: Id -> FCode a
    cgLookupPanic :: forall a. Id -> FCode a
    cgLookupPanic Id
    id
      = do  CgBindings
    local_binds <- FCode CgBindings
    getBinds
            forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToCmm.Env: variable not found"
                    ([SDoc] -> SDoc
    vcat [forall a. Outputable a => a -> SDoc
    ppr Id
    id,
                    String -> SDoc
    text String
    "local binds for:",
                    forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
    pprUFM CgBindings
    local_binds forall a b. (a -> b) -> a -> b
    $ \[CgIdInfo]
    infos ->
                      [SDoc] -> SDoc
    vcat [ 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)))
           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]
    args = forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM NonVoid Id -> FCode LocalReg
    bindArgToReg [NonVoid Id]
    args

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