CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
- stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
+ cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
+
+ stableIdInfo, heapIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
addBindC, addBindsC,
nukeVolatileBinds,
nukeDeadBindings,
+ getLiveStackSlots,
- bindNewToStack, rebindToStack,
+ bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
- bindNewToTemp, bindNewPrimToAmode,
- getArgAmode, getArgAmodes,
- getCAddrModeAndInfo, getCAddrMode,
+ bindNewToTemp,
+ getArgAmode, getArgAmodes,
+ getCgIdInfo,
getCAddrModeIfVolatile, getVolatileRegs,
-
- buildLivenessMask, buildContLivenessMask
+ maybeLetNoEscape,
) where
#include "HsVersions.h"
-import AbsCSyn
import CgMonad
-
-import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
-import CgStackery ( freeStackSlots )
-import CLabel ( mkClosureLabel,
- mkBitmapLabel, pprCLabel )
+import CgHeapery ( getHpRelOffset )
+import CgStackery ( freeStackSlots, getSpRelOffset )
+import CgUtils ( cgLit, cmmOffsetW )
+import CLabel ( mkClosureLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
-import BitSet
-import PrimRep ( isFollowableRep, getPrimRepSize )
-import Id ( Id, idPrimRep, idType )
-import Type ( typePrimRep )
+
+import Cmm
+import PprCmm ( {- instance Outputable -} )
+import SMRep ( CgRep(..), WordOff, isFollowableArg,
+ isVoidArg, cgRepSizeW, argMachRep,
+ idCgRep, typeCgRep )
+import Id ( Id, idName )
import VarEnv
import VarSet ( varSetElems )
-import Literal ( Literal )
-import Maybes ( catMaybes, maybeToBool, seqMaybe )
-import Name ( isInternalName, NamedThing(..) )
-#ifdef DEBUG
-import PprAbsC ( pprAmode )
-#endif
-import PrimRep ( PrimRep(..) )
+import Literal ( literalType )
+import Maybes ( catMaybes )
+import Name ( isExternalName )
import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
-import Unique ( Unique, Uniquable(..) )
+import Unique ( Uniquable(..) )
import UniqSet ( elementOfUniqSet )
-import Util ( zipWithEqual, sortLt )
import Outputable
\end{code}
type CgBindings = IdEnv CgIdInfo
data CgIdInfo
- = MkCgIdInfo Id -- Id that this is the info for
- VolatileLoc
- StableLoc
- LambdaFormInfo
+ = CgIdInfo
+ { cg_id :: Id -- Id that this is the info for
+ -- Can differ from the Id at occurrence sites by
+ -- virtue of being externalised, for splittable C
+ , cg_rep :: CgRep
+ , cg_vol :: VolatileLoc
+ , cg_stb :: StableLoc
+ , cg_lf :: LambdaFormInfo }
+
+mkCgIdInfo id vol stb lf
+ = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
+ cg_lf = lf, cg_rep = idCgRep id }
+
+voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
+ , cg_stb = VoidLoc, cg_lf = mkLFArgument id
+ , cg_rep = VoidArg }
+ -- Used just for VoidRep things
data VolatileLoc
= NoVolatileLoc
- | TempVarLoc Unique
-
- | RegLoc MagicId -- in one of the magic registers
- -- (probably {Int,Float,Char,etc}Reg
-
- | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
-
- | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node
- -- ie *(Node+offset)
+ | RegLoc CmmReg -- In one of the registers (global or local)
+ | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure)
+ | VirNodeLoc VirtualHpOffset -- Cts of offset indirect from Node
+ -- ie *(Node+offset)
\end{code}
@StableLoc@ encodes where an Id can be found, used by
\begin{code}
data StableLoc
= NoStableLoc
- | VirStkLoc VirtualSpOffset
- | LitLoc Literal
- | StableAmodeLoc CAddrMode
--- these are so StableLoc can be abstract:
+ | VirStkLoc VirtualSpOffset -- The thing is held in this
+ -- stack slot
-maybeStkLoc (VirStkLoc offset) = Just offset
-maybeStkLoc _ = Nothing
+ | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the
+ -- value is this stack pointer
+ -- (as opposed to the contents of the slot)
+
+ | StableLoc CmmExpr
+ | VoidLoc -- Used only for VoidRep variables. They never need to
+ -- be saved, so it makes sense to treat treat them as
+ -- having a stable location
+\end{code}
+
+\begin{code}
+instance Outputable CgIdInfo where
+ ppr (CgIdInfo id rep vol stb lf)
+ = 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}
%************************************************************************
%************************************************************************
\begin{code}
-stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
-heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
-tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
-
-letNoEscapeIdInfo i sp lf_info
- = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
-
-newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
-
-newTempAmodeAndIdInfo name lf_info
- = (temp_amode, temp_idinfo)
+stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
+heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
+letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
+stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
+nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info
+regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
+
+idInfoToAmode :: CgIdInfo -> FCode CmmExpr
+idInfoToAmode info
+ = case cg_vol info of {
+ RegLoc reg -> returnFC (CmmReg reg) ;
+ VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ;
+ VirHpLoc hp_off -> getHpRelOffset hp_off ;
+ NoVolatileLoc ->
+
+ case cg_stb info of
+ StableLoc amode -> returnFC 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))
+ -- We return a 'bottom' amode, rather than panicing now
+ -- In this way getArgAmode returns a pair of (VoidArg, bottom)
+ -- and that's exactly what we want
+
+ NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
+ }
where
- uniq = getUnique name
- temp_amode = CTemp uniq (idPrimRep name)
- temp_idinfo = tempIdInfo name uniq lf_info
-
-idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
-idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
-
-idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
-
-idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind)
-idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id)
+ mach_rep = argMachRep (cg_rep info)
-idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit)
-idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
+cgIdInfoId :: CgIdInfo -> Id
+cgIdInfoId = cg_id
-idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
- = returnFC (CVal (nodeRel nd_off) kind)
- -- Virtual offsets from Node increase into the closures,
- -- and so do Node-relative offsets (which we want in the CVal),
- -- so there is no mucking about to do to the offset.
+cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
+cgIdInfoLF = cg_lf
-idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
- = getHpRelOffset hp_off `thenFC` \ rel_hp ->
- returnFC (CAddr rel_hp)
+cgIdInfoArgRep :: CgIdInfo -> CgRep
+cgIdInfoArgRep = cg_rep
-idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
- = getSpRelOffset i `thenFC` \ rel_sp ->
- returnFC (CVal rel_sp kind)
-
-#ifdef DEBUG
-idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
-#endif
+maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
+maybeLetNoEscape other = Nothing
\end{code}
%************************************************************************
%* *
%************************************************************************
-There are three basic routines, for adding (@addBindC@), modifying
-(@modifyBindC@) and looking up (@lookupBindC@) bindings.
+.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?)
addBindsC new_bindings = do
binds <- getBinds
let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
- binds
- new_bindings
+ binds
+ new_bindings
setBinds new_binds
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
binds <- getBinds
setBinds $ modifyVarEnv mangle_fn binds name
-lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC id = do maybe_info <- lookupBindC_maybe id
- case maybe_info of
- Just info -> return info
- Nothing -> cgLookupPanic id
-
-lookupBindC_maybe :: Id -> FCode (Maybe CgIdInfo)
-lookupBindC_maybe id
- = do static_binds <- getStaticBinds
- local_binds <- getBinds
- return (lookupVarEnv local_binds id
- `seqMaybe`
- lookupVarEnv static_binds id)
+getCgIdInfo :: Id -> FCode CgIdInfo
+getCgIdInfo id
+ = do { -- Try local bindings first
+ ; local_binds <- getBinds
+ ; case lookupVarEnv local_binds id of {
+ Just info -> return info ;
+ Nothing -> do
+
+ { -- Try top-level bindings
+ static_binds <- getStaticBinds
+ ; case lookupVarEnv static_binds id of {
+ Just info -> return info ;
+ Nothing ->
+
+ -- Should be imported; make up a CgIdInfo for it
+ if isExternalName name then
+ return (stableIdInfo id ext_lbl (mkLFImported id))
+ else
+ if isVoidArg (idCgRep id) then
+ -- Void things are never in the environment
+ return (voidIdInfo id)
+ else
+ -- Bug
+ cgLookupPanic id
+ }}}}
+ where
+ name = idName id
+ ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
pprPanic "cgPanic"
(vcat [ppr id,
ptext SLIT("static binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
+ vcat [ ppr (cg_id info) | info <- rngVarEnv static_binds ],
ptext SLIT("local binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
+ vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ],
ptext SLIT("SRT label") <+> pprCLabel srt
])
\end{code}
nukeVolatileBinds binds
= mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
where
- keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
- keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
- = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
+ keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
+ keep_if_stable info acc
+ = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
\end{code}
%* *
%************************************************************************
-I {\em think} all looking-up is done through @getCAddrMode(s)@.
-
\begin{code}
-getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
-
-getCAddrModeAndInfo id
- = do
- maybe_cg_id_info <- lookupBindC_maybe id
- case maybe_cg_id_info of
-
- -- Nothing => not in the environment, so should be imported
- Nothing | isInternalName name -> cgLookupPanic id
- | otherwise -> returnFC (id, global_amode, mkLFImported id)
-
- Just (MkCgIdInfo id' volatile_loc stable_loc lf_info)
- -> do amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
- return (id', amode, lf_info)
- where
- name = getName id
- global_amode = CLbl (mkClosureLabel name) kind
- kind = idPrimRep id
-
-getCAddrMode :: Id -> FCode CAddrMode
-getCAddrMode name = do
- (_, amode, _) <- getCAddrModeAndInfo name
- return amode
-\end{code}
-
-\begin{code}
-getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
-getCAddrModeIfVolatile name
--- | toplevelishId name = returnFC Nothing
--- | otherwise
- = do
- (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
- case stable_loc of
+getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
+getCAddrModeIfVolatile id
+ = do { info <- getCgIdInfo id
+ ; case cg_stb info of
NoStableLoc -> do -- Aha! So it is volatile!
- amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
+ amode <- idInfoToAmode info
return $ Just amode
- a_stable_loc -> return Nothing
+ a_stable_loc -> return Nothing }
\end{code}
@getVolatileRegs@ gets a set of live variables, and returns a list of
forget the volatile one.
\begin{code}
-getVolatileRegs :: StgLiveVars -> FCode [MagicId]
+getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
getVolatileRegs vars = do
- stuff <- mapFCs snaffle_it (varSetElems vars)
- returnFC $ catMaybes stuff
- where
- snaffle_it var = do
- (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var
- let
+ do { stuff <- mapFCs snaffle_it (varSetElems vars)
+ ; returnFC $ catMaybes stuff }
+ where
+ snaffle_it var = do
+ { info <- getCgIdInfo var
+ ; let
-- commoned-up code...
- consider_reg reg =
- if not (isVolatileReg reg) then
- -- Potentially dies across C calls
- -- For now, that's everything; we leave
- -- it to the save-macros to decide which
- -- regs *really* need to be saved.
- returnFC Nothing
- else
- case stable_loc of
- NoStableLoc -> returnFC (Just reg) -- got one!
- is_a_stable_loc -> do
- -- has both volatile & stable locations;
- -- force it to rely on the stable location
- modifyBindC var nuke_vol_bind
- return Nothing
- in
- case volatile_loc of
- RegLoc reg -> consider_reg reg
- VirNodeLoc _ -> consider_reg node
- non_reg_loc -> returnFC Nothing
-
- nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
- = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
+ consider_reg reg
+ = -- We assume that all regs can die across C calls
+ -- We leave it to the save-macros to decide which
+ -- regs *really* need to be saved.
+ case cg_stb info of
+ NoStableLoc -> returnFC (Just reg) -- got one!
+ is_a_stable_loc -> do
+ { -- has both volatile & stable locations;
+ -- force it to rely on the stable location
+ modifyBindC var nuke_vol_bind
+ ; return Nothing }
+
+ ; case cg_vol info of
+ RegLoc (CmmGlobal reg) -> consider_reg reg
+ VirNodeLoc _ -> consider_reg node
+ other_loc -> returnFC Nothing -- Local registers
+ }
+
+ nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
\end{code}
\begin{code}
-getArgAmodes :: [StgArg] -> FCode [CAddrMode]
-getArgAmodes [] = returnFC []
-getArgAmodes (atom:atoms)
- | isStgTypeArg atom
- = getArgAmodes atoms
- | otherwise = do
- amode <- getArgAmode atom
- amodes <- getArgAmodes atoms
- return ( amode : amodes )
+getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
+getArgAmode (StgVarArg var)
+ = do { info <- getCgIdInfo var
+ ; amode <- idInfoToAmode info
+ ; return (cgIdInfoArgRep info, amode ) }
-getArgAmode :: StgArg -> FCode CAddrMode
+getArgAmode (StgLitArg lit)
+ = do { cmm_lit <- cgLit lit
+ ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
-getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
-getArgAmode (StgLitArg lit) = returnFC (CLit 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}
%************************************************************************
%************************************************************************
\begin{code}
-bindNewToStack :: (Id, VirtualSpOffset) -> Code
-bindNewToStack (name, offset)
- = addBindC name info
+bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
+bindArgsToStack args
+ = mapCs bind args
where
- info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
+ bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
-bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
-bindNewToNode name offset lf_info
- = addBindC name info
+bindArgsToRegs :: [(Id, GlobalReg)] -> Code
+bindArgsToRegs args
+ = mapCs bind args
where
- info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
+ 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)
-- Create a new temporary whose unique is that in the id,
-- bind the id to it, and return the addressing mode for the
-- temporary.
-bindNewToTemp :: Id -> FCode CAddrMode
-bindNewToTemp name
- = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
- -- This is used only for things we don't know
- -- anything about; values returned by a case statement,
- -- for example.
- in do
- addBindC name id_info
- return temp_amode
-
-bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
-bindNewToReg name magic_id lf_info
- = addBindC name info
+bindNewToTemp :: Id -> FCode CmmReg
+bindNewToTemp id
+ = do addBindC id (regIdInfo id temp_reg lf_info)
+ return temp_reg
where
- info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
+ uniq = getUnique id
+ temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id)))
+ lf_info = mkLFArgument id -- Always used of things we
+ -- know nothing about
-bindArgsToRegs :: [Id] -> [MagicId] -> Code
-bindArgsToRegs args regs
- = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
+bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
+bindNewToReg name reg lf_info
+ = addBindC name info
where
- arg `bind` reg = bindNewToReg arg reg mkLFArgument
-\end{code}
-
-@bindNewPrimToAmode@ works only for certain addressing modes. Making
-this work for stack offsets is non-trivial (virt vs. real stack offset
-difficulties).
-
-\begin{code}
-bindNewPrimToAmode :: Id -> CAddrMode -> Code
-bindNewPrimToAmode name (CReg reg)
- = bindNewToReg name reg (panic "bindNewPrimToAmode")
-
-bindNewPrimToAmode name (CTemp uniq kind)
- = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
-
-#ifdef DEBUG
-bindNewPrimToAmode name amode
- = pprPanic "bindNew...:" (pprAmode amode)
-#endif
+ info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
\end{code}
\begin{code}
rebindToStack name offset
= modifyBindC name replace_stable_fn
where
- replace_stable_fn (MkCgIdInfo i vol stab einfo)
- = MkCgIdInfo i vol (VirStkLoc offset) einfo
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
-%* *
-%************************************************************************
-
-There are four kinds of things on the stack:
-
- - pointer variables (bound in the environment)
- - non-pointer variables (boudn in the environment)
- - free slots (recorded in the stack free list)
- - non-pointer data slots (recorded in the stack free list)
-
-We build up a bitmap of non-pointer slots by looking down the
-environment for all the non-pointer variables, and merging this with
-the slots recorded in the stack free list.
-
-There's a bit of a hack here to do with update frames: since nothing
-is recorded in either the environment or the stack free list for an
-update frame, the code below defaults to assuming the slots taken up
-by an update frame contain pointers. Furthermore, update frames are
-always in slots 0-2 at the bottom of the stack. The bitmap will
-therefore end at slot 3, which is what we want (the update frame info
-pointer has its own bitmap to describe the update frame).
-
-\begin{code}
-buildLivenessMask
- :: Unique -- unique for for large bitmap label
- -> VirtualSpOffset -- offset from which the bitmap should start
- -> FCode Liveness -- mask for free/unlifted slots
-
-buildLivenessMask uniq sp = do
-
- -- find all unboxed stack-resident ids
- binds <- getBinds
- ((vsp, free, _, _), heap_usage) <- getUsage
-
- let unboxed_slots =
- [ (ofs, size) |
- (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
- let rep = idPrimRep id; size = getPrimRepSize rep,
- not (isFollowableRep rep),
- size > 0
- ]
-
- -- flatten this list into a list of unboxed stack slots
- let flatten_slots = sortLt (<)
- (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
- unboxed_slots)
-
- -- merge in the free slots
- let all_slots = mergeSlots flatten_slots (map fst free) ++
- if vsp < sp then [vsp+1 .. sp] else []
-
- -- recalibrate the list to be sp-relative
- let rel_slots = reverse (map (sp-) all_slots)
-
- -- build the bitmap
- let liveness_mask
- = ASSERT(all (>=0) rel_slots
- && rel_slots == sortLt (<) rel_slots)
- (listToLivenessMask rel_slots)
-
- livenessToAbsC uniq liveness_mask
-
-mergeSlots :: [Int] -> [Int] -> [Int]
-mergeSlots cs [] = cs
-mergeSlots [] ns = ns
-mergeSlots (c:cs) (n:ns)
- = if c < n then
- c : mergeSlots cs (n:ns)
- else if c > n then
- n : mergeSlots (c:cs) ns
- else
- panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
-
-listToLivenessMask :: [Int] -> LivenessMask
-listToLivenessMask [] = []
-listToLivenessMask slots =
- mkBS this : listToLivenessMask (map (\x -> x-32) rest)
- where (this,rest) = span (<32) slots
-
-livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
-livenessToAbsC uniq mask =
- absC (CBitmap lbl mask) `thenC`
- returnFC (Liveness lbl mask)
- where lbl = mkBitmapLabel uniq
-\end{code}
-
-In a continuation, we want a liveness mask that starts from just after
-the return address, which is on the stack at realSp.
-
-\begin{code}
-buildContLivenessMask
- :: Unique
- -> FCode Liveness
-buildContLivenessMask uniq = do
- realSp <- getRealSp
- buildLivenessMask uniq (realSp-1)
+ replace_stable_fn info = info { cg_stb = VirStkLoc offset }
\end{code}
%************************************************************************
let (dead_stk_slots, bs') =
dead_slots live_vars
[] []
- [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
+ [ (cg_id b, b) | b <- rngVarEnv binds ]
setBinds $ mkVarEnv bs'
freeStackSlots dead_stk_slots
\end{code}
-- Instead keep it in the filtered bindings
| otherwise
- = case i of
- MkCgIdInfo _ _ stable_loc _
- | is_stk_loc && size > 0 ->
- dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
- where
- maybe_stk_loc = maybeStkLoc stable_loc
- is_stk_loc = maybeToBool maybe_stk_loc
- (Just offset) = maybe_stk_loc
+ = case cg_stb i of
+ VirStkLoc offset
+ | size > 0
+ -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
_ -> dead_slots live_vars fbs ds bs
where
+ size :: WordOff
+ size = cgRepSizeW (cg_rep i)
+\end{code}
- size :: Int
- size = (getPrimRepSize . typePrimRep . idType) v
-
+\begin{code}
+getLiveStackSlots :: FCode [VirtualSpOffset]
+-- Return the offsets of slots in stack containig live pointers
+getLiveStackSlots
+ = do { binds <- getBinds
+ ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
+ cg_rep = rep } <- rngVarEnv binds,
+ isFollowableArg rep] }
\end{code}