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)
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))
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))
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
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
getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo Id
id
= do { Platform
platform <- FCode Platform
getPlatform
; CgBindings
local_binds <- FCode CgBindings
getBinds
; case CgBindings -> Id -> Maybe CgIdInfo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CgBindings
local_binds Id
id of {
Just CgIdInfo
info ->
CgIdInfo -> FCode CgIdInfo
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CgIdInfo
info ;
Maybe CgIdInfo
Nothing -> do {
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)
= 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
mkLFImported Id
id) (CLabel -> CmmLit
CmmLabel CLabel
ext_lbl)
else
Id -> FCode CgIdInfo
forall a. Id -> FCode a
cgLookupPanic Id
id
}}}
getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)
getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)
getCgInfo_maybe Name
name
= do { CgBindings
local_binds <- FCode CgBindings
getBinds
; 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
forall doc. IsDoc doc => [doc] -> doc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id,
String -> SDoc
forall doc. IsLine doc => String -> doc
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
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 ]
])
bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode 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
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
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))