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