module StgCmmEnv (
CgIdInfo,
cgIdInfoId, cgIdInfoLF,
litIdInfo, lneIdInfo, regIdInfo,
idInfoToAmode,
NonVoid(..), isVoidId, nonVoidIds,
addBindC, addBindsC,
bindArgsToRegs, bindToReg, rebindToReg,
bindArgToReg, idToReg,
getArgAmode, getNonVoidArgAmodes,
getCgIdInfo,
maybeLetNoEscape,
) where
#include "HsVersions.h"
import TyCon
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
import CLabel
import BlockId
import Cmm
import CmmUtils
import FastString
import PprCmm ( )
import Id
import VarEnv
import Control.Monad
import Name
import StgSyn
import Outputable
newtype NonVoid a = NonVoid a
deriving (Eq, Show)
instance (Outputable a) => Outputable (NonVoid a) where
ppr (NonVoid a) = ppr a
isVoidId :: Id -> Bool
isVoidId = isVoidRep . idPrimRep
nonVoidIds :: [Id] -> [NonVoid Id]
nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo id lf expr
= CgIdInfo { cg_id = id, cg_loc = CmmLoc expr,
cg_lf = lf, cg_rep = idPrimRep id,
cg_tag = lfDynTag lf }
lneIdInfo :: Id -> [LocalReg] -> CgIdInfo
lneIdInfo id regs
= CgIdInfo { cg_id = id, cg_loc = LneLoc blk_id regs,
cg_lf = lf, cg_rep = idPrimRep id,
cg_tag = lfDynTag lf }
where
lf = mkLFLetNoEscape
blk_id = mkBlockId (idUnique id)
litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo id lf_info lit =
mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info))
regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo
regIdInfo id lf_info reg =
mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
idInfoToAmode :: CgIdInfo -> CmmExpr
idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
idInfoToAmode cg_info
= pprPanic "idInfoToAmode" (ppr (cg_id cg_info))
addDynTag :: CmmExpr -> DynTag -> CmmExpr
addDynTag expr tag = cmmOffsetB expr tag
cgIdInfoId :: CgIdInfo -> Id
cgIdInfoId = cg_id
cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
cgIdInfoLF = cg_lf
maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
maybeLetNoEscape _other = Nothing
addBindC :: Id -> CgIdInfo -> FCode ()
addBindC name stuff_to_bind = do
binds <- getBinds
setBinds $ extendVarEnv binds name stuff_to_bind
addBindsC :: [CgIdInfo] -> FCode ()
addBindsC new_bindings = do
binds <- getBinds
let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
binds
new_bindings
setBinds new_binds
getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo id
= do {
; local_binds <- getBinds
; case lookupVarEnv local_binds id of {
Just info -> return info ;
Nothing -> do
{
static_binds <- getStaticBinds
; case lookupVarEnv static_binds id of {
Just info -> return info ;
Nothing ->
let
name = idName id
in
if isExternalName name then do
let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
return (litIdInfo id (mkLFImported id) ext_lbl)
else
cgLookupPanic id
}}}}
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
= do static_binds <- getStaticBinds
local_binds <- getBinds
srt <- getSRTLabel
pprPanic "StgCmmEnv: variable not found"
(vcat [ppr id,
ptext (sLit "static binds for:"),
vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
ptext (sLit "local binds for:"),
vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
ptext (sLit "SRT label") <+> pprCLabel srt
])
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode (NonVoid (StgVarArg var)) =
do { info <- getCgIdInfo var; return (idInfoToAmode info) }
getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg"
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [] = return []
getNonVoidArgAmodes (arg:args)
| isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
| otherwise = do { amode <- getArgAmode (NonVoid arg)
; amodes <- getNonVoidArgAmodes args
; return ( amode : amodes ) }
bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg nvid@(NonVoid id) lf_info
= do { let reg = idToReg nvid
; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
; return reg }
rebindToReg :: NonVoid Id -> FCode LocalReg
rebindToReg nvid@(NonVoid id)
= do { info <- getCgIdInfo id
; bindToReg nvid (cgIdInfoLF info) }
bindArgToReg :: NonVoid Id -> FCode LocalReg
bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs args = mapM bindArgToReg args
idToReg :: NonVoid Id -> LocalReg
idToReg (NonVoid id) = LocalReg (idUnique id)
(case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
_ -> primRepCmmType (idPrimRep id))