X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=b195b5c8645d67f97953657e2edbd486a5c14bdd;hb=3cf18a5382d49f5a7ecce365bbd59ebe07a407fe;hp=a5feb794c90b1134a60add2b405519a0b75b8357;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index a5feb79..b195b5c 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -1,62 +1,57 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CgBindery]{Utility functions related to doing @CgBindings@} \begin{code} -#include "HsVersions.h" - module CgBindery ( - SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-}, + CgBindings, CgIdInfo, StableLoc, VolatileLoc, - maybeAStkLoc, maybeBStkLoc, - - stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, + stableAmodeIdInfo, heapIdInfo, letNoEscapeIdInfo, idInfoToAmode, + addBindC, addBindsC, + nukeVolatileBinds, + nukeDeadBindings, - bindNewToAStack, bindNewToBStack, + bindNewToStack, rebindToStack, bindNewToNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, bindNewPrimToAmode, + bindNewToTemp, getArgAmode, getArgAmodes, getCAddrModeAndInfo, getCAddrMode, getCAddrModeIfVolatile, getVolatileRegs, - rebindToAStack, rebindToBStack + + buildContLivenessMask ) where -IMP_Ubiq(){-uitous-} ---IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking +#include "HsVersions.h" import AbsCSyn import CgMonad -import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset ) -import CLabel ( mkStaticClosureLabel, mkClosureLabel ) -import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo ) -import HeapOffs ( SYN_IE(VirtualHeapOffset), - SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) - ) -import Id ( idPrimRep, toplevelishId, isDataCon, - mkIdEnv, rngIdEnv, SYN_IE(IdEnv), - idSetToList, - GenId{-instance NamedThing-}, SYN_IE(Id) - ) -import Literal ( Literal ) -import Maybes ( catMaybes ) -import Name ( isLocallyDefined, isWiredInName, - Name{-instance NamedThing-}, NamedThing(..) ) -#ifdef DEBUG -import PprAbsC ( pprAmode ) -#endif -import PprStyle ( PprStyle(..) ) -import Pretty ( Doc ) -import PrimRep ( PrimRep ) -import StgSyn ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) ) -import Unique ( Unique ) -import UniqFM ( Uniquable(..) ) -import Util ( zipWithEqual, panic ) +import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp ) +import CgStackery ( freeStackSlots, getStackFrame ) +import CLabel ( mkClosureLabel, + mkBitmapLabel, pprCLabel ) +import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) +import Bitmap +import PrimRep ( isFollowableRep, getPrimRepSize ) +import Id ( Id, idPrimRep, idType ) +import Type ( typePrimRep ) +import VarEnv +import VarSet ( varSetElems ) +import Literal ( Literal ) +import Maybes ( catMaybes, maybeToBool, seqMaybe ) +import Name ( isInternalName, NamedThing(..) ) +import PprAbsC ( pprAmode, pprMagicId ) +import PrimRep ( PrimRep(..) ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg ) +import Unique ( Unique, Uniquable(..) ) +import UniqSet ( elementOfUniqSet ) +import Util ( zipWithEqual, sortLt ) +import Outputable \end{code} @@ -88,27 +83,47 @@ data VolatileLoc | TempVarLoc Unique | RegLoc MagicId -- in one of the magic registers - -- (probably {Int,Float,Char,etc}Reg + -- (probably {Int,Float,Char,etc}Reg) | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure) | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node -- ie *(Node+offset) +\end{code} + +@StableLoc@ encodes where an Id can be found, used by +the @CgBindings@ environment in @CgBindery@. +\begin{code} data StableLoc = NoStableLoc - | VirAStkLoc VirtualSpAOffset - | VirBStkLoc VirtualSpBOffset + | VirStkLoc VirtualSpOffset | LitLoc Literal | StableAmodeLoc CAddrMode -- these are so StableLoc can be abstract: -maybeAStkLoc (VirAStkLoc offset) = Just offset -maybeAStkLoc _ = Nothing +maybeStkLoc (VirStkLoc offset) = Just offset +maybeStkLoc _ = Nothing +\end{code} -maybeBStkLoc (VirBStkLoc offset) = Just offset -maybeBStkLoc _ = Nothing +\begin{code} +instance Outputable CgIdInfo where + ppr (MkCgIdInfo id vol stb lf) + = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb] + +instance Outputable VolatileLoc where + ppr NoVolatileLoc = empty + ppr (TempVarLoc u) = ptext SLIT("tmp") <+> ppr u + ppr (RegLoc r) = ptext SLIT("reg") <+> pprMagicId 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 (VirStkLoc v) = ptext SLIT("vs") <+> ppr v + ppr (LitLoc l) = ptext SLIT("lit") <+> ppr l + ppr (StableAmodeLoc a) = ptext SLIT("amode") <+> pprAmode a \end{code} %************************************************************************ @@ -122,17 +137,8 @@ stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc a 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 spa spb lf_info - = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info - -newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo) - -newTempAmodeAndIdInfo name lf_info - = (temp_amode, temp_idinfo) - where - uniq = uniqueOf name - temp_amode = CTemp uniq (idPrimRep name) - temp_idinfo = tempIdInfo name uniq lf_info +letNoEscapeIdInfo i sp lf_info + = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab @@ -146,7 +152,7 @@ idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit l idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc - = returnFC (CVal (NodeRel nd_off) kind) + = 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. @@ -155,13 +161,9 @@ idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc = getHpRelOffset hp_off `thenFC` \ rel_hp -> returnFC (CAddr rel_hp) -idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i) - = getSpARelOffset i `thenFC` \ rel_spA -> - returnFC (CVal rel_spA kind) - -idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i) - = getSpBRelOffset i `thenFC` \ rel_spB -> - returnFC (CVal rel_spB kind) +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" @@ -170,6 +172,66 @@ idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: %************************************************************************ %* * +\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@} +%* * +%************************************************************************ + +There are three basic routines, for adding (@addBindC@), modifying +(@modifyBindC@) and looking up (@lookupBindC@) 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 + +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) + +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 i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ], + ptext SLIT("local binds for:"), + vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ], + ptext SLIT("SRT label") <+> pprCLabel srt + ]) +\end{code} + +%************************************************************************ +%* * \subsection[Bindery-nuke-volatile]{Nuking volatile bindings} %* * %************************************************************************ @@ -180,7 +242,7 @@ we don't leave any (NoVolatile, NoStable) binds around... \begin{code} nukeVolatileBinds :: CgBindings -> CgBindings nukeVolatileBinds binds - = mkIdEnv (foldr keep_if_stable [] (rngIdEnv 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 @@ -197,49 +259,43 @@ nukeVolatileBinds binds I {\em think} all looking-up is done through @getCAddrMode(s)@. \begin{code} -getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) +getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id - | not (isLocallyDefined name) || isWiredInName name - {- Why the "isWiredInName"? - Imagine you are compiling PrelBase.hs (a module that - supplies some of the wired-in values). What can - happen is that the compiler will inject calls to - (e.g.) GHCbase.unpackPS, where-ever it likes -- it - assumes those values are ubiquitously available. - The main point is: it may inject calls to them earlier - in GHCbase.hs than the actual definition... - -} - = returnFC (global_amode, mkLFImported id) - - | otherwise = -- *might* be a nested defn: in any case, it's something whose - -- definition we will know about... - lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> - idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode -> - returnFC (amode, lf_info) + = 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 id) kind + global_amode = CLbl (mkClosureLabel name) kind kind = idPrimRep id getCAddrMode :: Id -> FCode CAddrMode -getCAddrMode name - = getCAddrModeAndInfo name `thenFC` \ (amode, _) -> - returnFC amode +getCAddrMode name = do + (_, amode, _) <- getCAddrModeAndInfo name + return amode \end{code} \begin{code} getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode) getCAddrModeIfVolatile name - | toplevelishId name = returnFC Nothing - | otherwise - = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) -> - case stable_loc of - NoStableLoc -> -- Aha! So it is volatile! - idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode -> - returnFC (Just amode) - - a_stable_loc -> returnFC Nothing +-- | toplevelishId name = returnFC Nothing +-- | otherwise + = do + (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name + case stable_loc of + NoStableLoc -> do -- Aha! So it is volatile! + amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc + return $ Just amode + a_stable_loc -> return Nothing \end{code} @getVolatileRegs@ gets a set of live variables, and returns a list of @@ -252,86 +308,53 @@ forget the volatile one. \begin{code} getVolatileRegs :: StgLiveVars -> FCode [MagicId] -getVolatileRegs vars - = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff -> - returnFC (catMaybes stuff) - where - snaffle_it var - = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> - 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 -> - -- has both volatile & stable locations; - -- force it to rely on the stable location - modifyBindC var nuke_vol_bind `thenC` - returnFC Nothing - in - case volatile_loc of - RegLoc reg -> consider_reg reg - VirHpLoc _ -> consider_reg Hp - 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 +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 + -- 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 \end{code} \begin{code} getArgAmodes :: [StgArg] -> FCode [CAddrMode] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) - = getArgAmode atom `thenFC` \ amode -> - getArgAmodes atoms `thenFC` \ amodes -> - returnFC ( amode : amodes ) + | isStgTypeArg atom + = getArgAmodes atoms + | otherwise = do + amode <- getArgAmode atom + amodes <- getArgAmodes atoms + return ( amode : amodes ) getArgAmode :: StgArg -> FCode CAddrMode -getArgAmode (StgConArg var) - {- Why does this case differ from StgVarArg? - Because the program might look like this: - data Foo a = Empty | Baz a - f a x = let c = Empty! a - in h c - Now, when we go Core->Stg, we drop the type applications, - so we can inline c, giving - f x = h Empty - Now we are referring to Empty as an argument (rather than in an STGCon), - so we'll look it up with getCAddrMode. We want to return an amode for - the static closure that we make for nullary constructors. But if we blindly - go ahead with getCAddrMode we end up looking in the environment, and it ain't there! - - This special case used to be in getCAddrModeAndInfo, but it doesn't work there. - Consider: - f a x = Baz a x - If the constructor Baz isn't inlined we simply want to treat it like any other - identifier, with a top level definition. We don't want to spot that it's a constructor. - - In short - StgApp con args - and - StgCon con args - are treated differently; the former is a call to a bog standard function while the - latter uses the specially-labelled, pre-defined info tables etc for the constructor. - - The way to think of this case in getArgAmode is that - SApp f Empty - is really - App f (StgCon Empty []) - -} - = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var)) - getArgAmode (StgVarArg var) = getCAddrMode var -- The common case - getArgAmode (StgLitArg lit) = returnFC (CLit lit) \end{code} @@ -342,18 +365,11 @@ getArgAmode (StgLitArg lit) = returnFC (CLit lit) %************************************************************************ \begin{code} -bindNewToAStack :: (Id, VirtualSpAOffset) -> Code -bindNewToAStack (name, offset) - = addBindC name info - where - info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument - -bindNewToBStack :: (Id, VirtualSpBOffset) -> Code -bindNewToBStack (name, offset) +bindNewToStack :: (Id, VirtualSpOffset) -> Code +bindNewToStack (name, offset) = addBindC name info where - info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack") - -- B-stack things shouldn't need lambda-form info! + info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name) bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code bindNewToNode name offset lf_info @@ -365,14 +381,15 @@ bindNewToNode name offset lf_info -- 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 - addBindC name id_info `thenC` - returnFC temp_amode +bindNewToTemp id + = do addBindC id id_info + return temp_amode + where + uniq = getUnique id + temp_amode = CTemp uniq (idPrimRep id) + id_info = tempIdInfo id uniq lf_info + lf_info = mkLFArgument id -- Always used of things we + -- know nothing about bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code bindNewToReg name magic_id lf_info @@ -380,58 +397,151 @@ bindNewToReg name magic_id lf_info where info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info -bindNewToLit name lit - = addBindC name info - where - info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit") - bindArgsToRegs :: [Id] -> [MagicId] -> Code bindArgsToRegs args regs = listCs (zipWithEqual "bindArgsToRegs" bind args regs) where - arg `bind` reg = bindNewToReg arg reg mkLFArgument + arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg) \end{code} -@bindNewPrimToAmode@ works only for certain addressing modes, because -those are the only ones we've needed so far! +\begin{code} +rebindToStack :: Id -> VirtualSpOffset -> 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 searching the environment +for all the pointer variables, and subtracting these from a bitmap +with initially all bits set (up to the size of the stack frame). \begin{code} -bindNewPrimToAmode :: Id -> CAddrMode -> Code -bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode") - -- was: mkLFArgument - -- LFinfo is irrelevant for primitives -bindNewPrimToAmode name (CTemp uniq kind) - = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode")) - -- LFinfo is irrelevant for primitives +buildLivenessMask + :: VirtualSpOffset -- size of the stack frame + -> VirtualSpOffset -- offset from which the bitmap should start + -> FCode Bitmap -- mask for free/unlifted slots + +buildLivenessMask size sp = do { + -- find all live stack-resident pointers + binds <- getBinds; + ((vsp, _, free, _, _), heap_usage) <- getUsage; + + let { + rel_slots = sortLt (<) + [ sp - ofs -- get slots relative to top of frame + | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds, + isFollowableRep (idPrimRep id) + ]; + }; + + WARN( not (all (>=0) rel_slots), ppr size $$ ppr sp $$ ppr rel_slots $$ ppr binds ) + return (intsToReverseBitmap size rel_slots) + } + +-- In a continuation, we want a liveness mask that starts from just after +-- the return address, which is on the stack at realSp. + +buildContLivenessMask :: Id -> FCode Liveness + -- The Id is used just for its unique to make a label +buildContLivenessMask id = do + realSp <- getRealSp + + frame_sp <- getStackFrame + -- realSp points to the frame-header for the current stack frame, + -- and the end of this frame is frame_sp. The size is therefore + -- realSp - frame_sp - 1 (subtract one for the frame-header). + let frame_size = realSp - frame_sp - 1 + + mask <- buildLivenessMask frame_size (realSp-1) + + let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask + absC (maybeLargeBitmap liveness) + return liveness +\end{code} -bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit +%************************************************************************ +%* * +\subsection[CgMonad-deadslots]{Finding dead stack slots} +%* * +%************************************************************************ -bindNewPrimToAmode name (CVal (SpBRel _ offset) _) - = bindNewToBStack (name, offset) +nukeDeadBindings does the following: -bindNewPrimToAmode name (CVal (NodeRel offset) _) - = bindNewToNode name offset (panic "bindNewPrimToAmode node") - -- See comment on idInfoPiecesToAmode for VirNodeLoc + - 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. -#ifdef DEBUG -bindNewPrimToAmode name amode - = panic ("bindNew...:"++(show (pprAmode PprDebug amode))) -#endif +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 -- All the *live* variables + -> Code +nukeDeadBindings live_vars = do + binds <- getBinds + let (dead_stk_slots, bs') = + dead_slots live_vars + [] [] + [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ] + setBinds $ mkVarEnv bs' + freeStackSlots dead_stk_slots \end{code} +Several boring auxiliary functions to do the dirty work. + \begin{code} -rebindToAStack :: Id -> VirtualSpAOffset -> Code -rebindToAStack name offset - = modifyBindC name replace_stable_fn - where - replace_stable_fn (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i vol (VirAStkLoc offset) einfo +dead_slots :: StgLiveVars + -> [(Id,CgIdInfo)] + -> [VirtualSpOffset] + -> [(Id,CgIdInfo)] + -> ([VirtualSpOffset], [(Id,CgIdInfo)]) + +-- dead_slots carries accumulating parameters for +-- filtered bindings, dead slots +dead_slots live_vars fbs ds [] + = (ds, reverse fbs) -- Finished; rm the dups, if any + +dead_slots live_vars fbs ds ((v,i):bs) + | v `elementOfUniqSet` live_vars + = dead_slots live_vars ((v,i):fbs) ds bs + -- Live, so don't record it in dead slots + -- Instead keep it in the filtered bindings -rebindToBStack :: Id -> VirtualSpBOffset -> Code -rebindToBStack name offset - = modifyBindC name replace_stable_fn + | 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 + + _ -> dead_slots live_vars fbs ds bs where - replace_stable_fn (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i vol (VirBStkLoc offset) einfo -\end{code} + size :: Int + size = (getPrimRepSize . typePrimRep . idType) v + +\end{code}