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

-- | 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
  = 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 -> 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} = 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

-- 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
platform <- FCode Platform
getPlatform
        ; 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 -> -- pprTrace "getCgIdInfoLocal" (ppr id) $
              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".
                      = forall a. HasCallStack => Bool -> a -> a
assert (Id -> Kind
idType Id
id Kind -> Kind -> Bool
`eqType` Kind
addrPrimTy) forall a b. (a -> b) -> a -> b
$
                        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 forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> 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, 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  { CgBindings
local_binds <- FCode CgBindings
getBinds -- Try local bindings first
        ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. VarEnv a -> Unique -> Maybe a
lookupVarEnv_Directly CgBindings
local_binds (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
        forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToCmm.Env: variable not found"
                (forall doc. IsDoc doc => [doc] -> doc
vcat [forall a. Outputable a => a -> SDoc
ppr Id
id,
                forall doc. IsLine doc => String -> doc
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 ->
                  forall doc. IsDoc doc => [doc] -> doc
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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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))