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

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