{-# LANGUAGE CPP #-}
module GHC.StgToCmm.Env (
CgIdInfo,
litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
idInfoToAmode,
addBindC, addBindsC,
bindArgsToRegs, bindToReg, rebindToReg,
bindArgToReg, idToReg,
getArgAmode, getNonVoidArgAmodes,
getCgIdInfo,
maybeLetNoEscape,
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Core.TyCon
import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
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.Stg.Syntax
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
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
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))
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
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
; 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 {
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)
= 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
}}}
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 ]
])
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode (NonVoid (StgVarArg Id
var)) = CgIdInfo -> CmmExpr
idInfoToAmode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> FCode CgIdInfo
getCgIdInfo Id
var
getArgAmode (NonVoid (StgLitArg Literal
lit)) = CmmLit -> CmmExpr
CmmLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> FCode CmmLit
cgLit Literal
lit
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
getNonVoidArgAmodes (StgArg
arg:[StgArg]
args)
| PrimRep -> Bool
isVoidRep (StgArg -> PrimRep
argPrimRep StgArg
arg) = [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args
| Bool
otherwise = do { CmmExpr
amode <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (forall a. a -> NonVoid a
NonVoid StgArg
arg)
; [CmmExpr]
amodes <- [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args
; forall (m :: * -> *) a. Monad m => a -> m a
return ( CmmExpr
amode forall a. a -> [a] -> [a]
: [CmmExpr]
amodes ) }
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)))
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]
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
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))