%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\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[Bindery-datatypes]{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 knot-tying 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[Bindery-idInfo]{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[CgMonad-bindery]{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[Bindery-nuke-volatile]{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[lookup-interface]{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[binding-and-rebinding-interface]{Interface functions for binding and re-binding 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[CgMonad-deadslots]{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 multi-word 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}