%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
\section[CgBindery]{Utility functions related to doing @CgBindings@}
\begin{code}
module CgBindery (
CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
stableIdInfo, heapIdInfo,
taggedStableIdInfo, taggedHeapIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
addBindC, addBindsC,
nukeVolatileBinds,
nukeDeadBindings,
getLiveStackSlots,
getLiveStackBindings,
bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp,
getArgAmode, getArgAmodes,
getCgIdInfo,
getCAddrModeIfVolatile, getVolatileRegs,
maybeLetNoEscape,
) where
import CgMonad
import CgHeapery
import CgStackery
import CgUtils
import CLabel
import ClosureInfo
import Constants
import Cmm
import PprCmm ( )
import SMRep
import Id
import DataCon
import VarEnv
import VarSet
import Literal
import Maybes
import Name
import StgSyn
import Unique
import UniqSet
import Outputable
import FastString
\end{code}
%************************************************************************
%* *
\subsection[Binderydatatypes]{Data types}
%* *
%************************************************************************
@(CgBinding a b)@ is a type of finite maps from a to b.
The assumption used to be that @lookupCgBind@ must get exactly one
match. This is {\em completely wrong} in the case of compiling
letrecs (where knottying is used). An initial binding is fed in (and
never evaluated); eventually, a correct binding is put into the
environment. So there can be two bindings for a given name.
\begin{code}
type CgBindings = IdEnv CgIdInfo
data CgIdInfo
= CgIdInfo
{ cg_id :: Id
, cg_rep :: CgRep
, cg_vol :: VolatileLoc
, cg_stb :: StableLoc
, cg_lf :: LambdaFormInfo
, cg_tag :: !Int
}
mkCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo
mkCgIdInfo id vol stb lf
= CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag }
where
tag
| Just con <- isDataConWorkId_maybe id,
isNullaryRepDataCon con
= tagForCon con
| otherwise
= funTagLFInfo lf
voidIdInfo :: Id -> CgIdInfo
voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
, cg_stb = VoidLoc, cg_lf = mkLFArgument id
, cg_rep = VoidArg, cg_tag = 0 }
data VolatileLoc
= NoVolatileLoc
| RegLoc CmmReg
| VirHpLoc VirtualHpOffset
| VirNodeLoc ByteOff
mkTaggedCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon
-> CgIdInfo
mkTaggedCgIdInfo id vol stb lf con
= CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con }
\end{code}
@StableLoc@ encodes where an Id can be found, used by
the @CgBindings@ environment in @CgBindery@.
\begin{code}
data StableLoc
= NoStableLoc
| VirStkLoc VirtualSpOffset
| VirStkLNE VirtualSpOffset
| StableLoc CmmExpr
| VoidLoc
\end{code}
\begin{code}
instance Outputable CgIdInfo where
ppr (CgIdInfo id _ vol stb _ _)
= ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb]
instance Outputable VolatileLoc where
ppr NoVolatileLoc = empty
ppr (RegLoc r) = ptext (sLit "reg") <+> ppr r
ppr (VirHpLoc v) = ptext (sLit "vh") <+> ppr v
ppr (VirNodeLoc v) = ptext (sLit "vn") <+> ppr v
instance Outputable StableLoc where
ppr NoStableLoc = empty
ppr VoidLoc = ptext (sLit "void")
ppr (VirStkLoc v) = ptext (sLit "vs") <+> ppr v
ppr (VirStkLNE v) = ptext (sLit "lne") <+> ppr v
ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a
\end{code}
%************************************************************************
%* *
\subsection[BinderyidInfo]{Manipulating IdInfo}
%* *
%************************************************************************
\begin{code}
stableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo
stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
heapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo
heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
letNoEscapeIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo
nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info
regIdInfo :: Id -> CmmReg -> LambdaFormInfo -> CgIdInfo
regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
taggedStableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo
taggedStableIdInfo id amode lf_info con
= mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con
taggedHeapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon
-> CgIdInfo
taggedHeapIdInfo id offset lf_info con
= mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con
untagNodeIdInfo :: Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo
untagNodeIdInfo id offset lf_info tag
= mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset tag)) NoStableLoc lf_info
idInfoToAmode :: CgIdInfo -> FCode CmmExpr
idInfoToAmode info
= case cg_vol info of {
RegLoc reg -> returnFC (CmmReg reg) ;
VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off)
mach_rep) ;
VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off
; return $! maybeTag off };
NoVolatileLoc ->
case cg_stb info of
StableLoc amode -> returnFC $! maybeTag amode
VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
; return (CmmLoad sp_rel mach_rep) }
VirStkLNE sp_off -> getSpRelOffset sp_off
VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
}
where
mach_rep = argMachRep (cg_rep info)
maybeTag amode
| tag == 0 = amode
| otherwise = cmmOffsetB amode tag
where tag = cg_tag info
cgIdInfoId :: CgIdInfo -> Id
cgIdInfoId = cg_id
cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
cgIdInfoLF = cg_lf
cgIdInfoArgRep :: CgIdInfo -> CgRep
cgIdInfoArgRep = cg_rep
maybeLetNoEscape :: CgIdInfo -> Maybe VirtualSpOffset
maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
maybeLetNoEscape _ = Nothing
\end{code}
%************************************************************************
%* *
\subsection[CgMonadbindery]{Monad things for fiddling with @CgBindings@}
%* *
%************************************************************************
.There are three basic routines, for adding (@addBindC@), modifying
(@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
The name should not already be bound. (nice ASSERT, eh?)
\begin{code}
addBindC :: Id -> CgIdInfo -> Code
addBindC name stuff_to_bind = do
binds <- getBinds
setBinds $ extendVarEnv binds name stuff_to_bind
addBindsC :: [(Id, CgIdInfo)] -> Code
addBindsC new_bindings = do
binds <- getBinds
let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
binds
new_bindings
setBinds new_binds
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
modifyBindC name mangle_fn = do
binds <- getBinds
setBinds $ modifyVarEnv mangle_fn binds name
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 = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id))
return (stableIdInfo id ext_lbl (mkLFImported id))
else
if isVoidArg (idCgRep id) then
return (voidIdInfo id)
else
cgLookupPanic id
}}}}
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
= do static_binds <- getStaticBinds
local_binds <- getBinds
srt <- getSRTLabel
pprPanic "cgPanic"
(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
])
\end{code}
%************************************************************************
%* *
\subsection[Binderynukevolatile]{Nuking volatile bindings}
%* *
%************************************************************************
We sometimes want to nuke all the volatile bindings; we must be sure
we don't leave any (NoVolatile, NoStable) binds around...
\begin{code}
nukeVolatileBinds :: CgBindings -> CgBindings
nukeVolatileBinds binds
= mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
where
keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
keep_if_stable info acc
= (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
\end{code}
%************************************************************************
%* *
\subsection[lookupinterface]{Interface functions to looking up bindings}
%* *
%************************************************************************
\begin{code}
getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
getCAddrModeIfVolatile id
= do { info <- getCgIdInfo id
; case cg_stb info of
NoStableLoc -> do
amode <- idInfoToAmode info
return $ Just amode
_ -> return Nothing }
\end{code}
@getVolatileRegs@ gets a set of live variables, and returns a list of
all registers on which these variables depend. These are the regs
which must be saved and restored across any C calls. If a variable is
both in a volatile location (depending on a register) {\em and} a
stable one (notably, on the stack), we modify the current bindings to
forget the volatile one.
\begin{code}
getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
getVolatileRegs vars = do
do { stuff <- mapFCs snaffle_it (varSetElems vars)
; returnFC $ catMaybes stuff }
where
snaffle_it var = do
{ info <- getCgIdInfo var
; let
consider_reg reg
=
case cg_stb info of
NoStableLoc -> returnFC (Just reg)
_ -> do
{
modifyBindC var nuke_vol_bind
; return Nothing }
; case cg_vol info of
RegLoc (CmmGlobal reg) -> consider_reg reg
VirNodeLoc _ -> consider_reg node
_ -> returnFC Nothing
}
nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
\end{code}
\begin{code}
getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
getArgAmode (StgVarArg var)
= do { info <- getCgIdInfo var
; amode <- idInfoToAmode info
; return (cgIdInfoArgRep info, amode ) }
getArgAmode (StgLitArg lit)
= do { cmm_lit <- cgLit lit
; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
| isStgTypeArg atom = getArgAmodes atoms
| otherwise = do { amode <- getArgAmode atom
; amodes <- getArgAmodes atoms
; return ( amode : amodes ) }
\end{code}
%************************************************************************
%* *
\subsection[bindingandrebindinginterface]{Interface functions for binding and rebinding names}
%* *
%************************************************************************
\begin{code}
bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
bindArgsToStack args
= mapCs bind args
where
bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
bindArgsToRegs :: [(Id, GlobalReg)] -> Code
bindArgsToRegs args
= mapCs bind args
where
bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
bindNewToNode id offset lf_info
= addBindC id (nodeIdInfo id offset lf_info)
bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
bindNewToUntagNode id offset lf_info tag
= addBindC id (untagNodeIdInfo id offset lf_info tag)
bindNewToTemp :: Id -> FCode LocalReg
bindNewToTemp id
= do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
return temp_reg
where
uniq = getUnique id
temp_reg = LocalReg uniq (argMachRep (idCgRep id))
lf_info = mkLFArgument id
bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
bindNewToReg name reg lf_info
= addBindC name info
where
info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
\end{code}
\begin{code}
rebindToStack :: Id -> VirtualSpOffset -> Code
rebindToStack name offset
= modifyBindC name replace_stable_fn
where
replace_stable_fn info = info { cg_stb = VirStkLoc offset }
\end{code}
%************************************************************************
%* *
\subsection[CgMonaddeadslots]{Finding dead stack slots}
%* *
%************************************************************************
nukeDeadBindings does the following:
Removes all bindings from the environment other than those
for variables in the argument to nukeDeadBindings.
Collects any stack slots so freed, and returns them to the stack free
list.
Moves the virtual stack pointer to point to the topmost used
stack locations.
You can have multiword slots on the stack (where a Double# used to
be, for instance); if dead, such a slot will be reported as *several*
offsets (one per word).
Probably *naughty* to look inside monad...
\begin{code}
nukeDeadBindings :: StgLiveVars
-> Code
nukeDeadBindings live_vars = do
binds <- getBinds
let (dead_stk_slots, bs') =
dead_slots live_vars
[] []
[ (cg_id b, b) | b <- varEnvElts binds ]
setBinds $ mkVarEnv bs'
freeStackSlots dead_stk_slots
\end{code}
Several boring auxiliary functions to do the dirty work.
\begin{code}
dead_slots :: StgLiveVars
-> [(Id,CgIdInfo)]
-> [VirtualSpOffset]
-> [(Id,CgIdInfo)]
-> ([VirtualSpOffset], [(Id,CgIdInfo)])
dead_slots _ fbs ds []
= (ds, reverse fbs)
dead_slots live_vars fbs ds ((v,i):bs)
| v `elementOfUniqSet` live_vars
= dead_slots live_vars ((v,i):fbs) ds bs
| otherwise
= case cg_stb i of
VirStkLoc offset
| size > 0
-> dead_slots live_vars fbs ([offsetsize+1 .. offset] ++ ds) bs
_ -> dead_slots live_vars fbs ds bs
where
size :: WordOff
size = cgRepSizeW (cg_rep i)
\end{code}
\begin{code}
getLiveStackSlots :: FCode [VirtualSpOffset]
getLiveStackSlots
= do { binds <- getBinds
; return [off | CgIdInfo { cg_stb = VirStkLoc off,
cg_rep = rep } <- varEnvElts binds,
isFollowableArg rep] }
\end{code}
\begin{code}
getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
getLiveStackBindings
= do { binds <- getBinds
; return [(off, bind) |
bind <- varEnvElts binds,
CgIdInfo { cg_stb = VirStkLoc off,
cg_rep = rep} <- [bind],
isFollowableArg rep] }
\end{code}