X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=7414569b28b22a7e6db4dfb0b150f2c16a898ac2;hb=9ef74223b4755d107b412ed7e6416231a5f65d46;hp=8edd5bd9dc78f8f673031926a192d49582ef89e8;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 8edd5bd..7414569 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -1,57 +1,59 @@ % -% (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 ( - CgBindings(..), CgIdInfo(..){-dubiously concrete-}, + CgBindings, CgIdInfo, StableLoc, VolatileLoc, - maybeAStkLoc, maybeBStkLoc, - stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, letNoEscapeIdInfo, idInfoToAmode, + addBindC, addBindsC, + nukeVolatileBinds, + nukeDeadBindings, - bindNewToAStack, bindNewToBStack, + bindNewToStack, rebindToStack, bindNewToNode, bindNewToReg, bindArgsToRegs, bindNewToTemp, bindNewPrimToAmode, getArgAmode, getArgAmodes, getCAddrModeAndInfo, getCAddrMode, getCAddrModeIfVolatile, getVolatileRegs, - rebindToAStack, rebindToBStack + + buildLivenessMask, 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 ( mkClosureLabel ) -import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument ) -import HeapOffs ( VirtualHeapOffset(..), - VirtualSpAOffset(..), VirtualSpBOffset(..) - ) -import Id ( idPrimRep, toplevelishId, isDataCon, - mkIdEnv, rngIdEnv, IdEnv(..), - idSetToList, - GenId{-instance NamedThing-} - ) -import Maybes ( catMaybes ) -import Name ( isLocallyDefined ) +import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp ) +import CgStackery ( freeStackSlots ) +import CLabel ( mkClosureLabel, + mkBitmapLabel, pprCLabel ) +import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) +import BitSet +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 ( isLocalName, NamedThing(..) ) #ifdef DEBUG import PprAbsC ( pprAmode ) #endif -import PprStyle ( PprStyle(..) ) -import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) ) -import Unpretty ( uppShow ) -import Util ( zipWithEqual, panic ) +import PrimRep ( PrimRep(..) ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg ) +import Unique ( Unique, Uniquable(..) ) +import UniqSet ( elementOfUniqSet ) +import Util ( zipWithEqual, sortLt ) +import Outputable \end{code} @@ -89,21 +91,22 @@ data VolatileLoc | 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 - -maybeBStkLoc (VirBStkLoc offset) = Just offset -maybeBStkLoc _ = Nothing +maybeStkLoc (VirStkLoc offset) = Just offset +maybeStkLoc _ = Nothing \end{code} %************************************************************************ @@ -117,15 +120,15 @@ 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 +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) where - uniq = uniqueOf name + uniq = getUnique name temp_amode = CTemp uniq (idPrimRep name) temp_idinfo = tempIdInfo name uniq lf_info @@ -141,7 +144,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. @@ -150,13 +153,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" @@ -165,6 +164,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} %* * %************************************************************************ @@ -175,7 +234,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 @@ -192,42 +251,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 name - | not (isLocallyDefined name) - = returnFC (global_amode, mkLFImported name) +getCAddrModeAndInfo id + = do + maybe_cg_id_info <- lookupBindC_maybe id + case maybe_cg_id_info of - | isDataCon name - = returnFC (global_amode, mkConLFInfo name) + -- Nothing => not in the environment, so should be imported + Nothing | isLocalName name -> cgLookupPanic id + | otherwise -> returnFC (id, global_amode, mkLFImported id) - | otherwise = -- *might* be a nested defn: in any case, it's something whose - -- definition we will know about... - lookupBindC name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> - idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode -> - returnFC (amode, lf_info) + 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 name + 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 @@ -240,51 +300,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 (StgVarArg var) = getCAddrMode var +getArgAmode (StgVarArg var) = getCAddrMode var -- The common case getArgAmode (StgLitArg lit) = returnFC (CLit lit) \end{code} @@ -295,18 +357,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 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code bindNewToNode name offset lf_info @@ -323,9 +378,9 @@ bindNewToTemp name -- 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 + in do + addBindC name id_info + return temp_amode bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code bindNewToReg name magic_id lf_info @@ -333,11 +388,6 @@ 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) @@ -345,46 +395,202 @@ bindArgsToRegs args regs arg `bind` reg = bindNewToReg arg reg mkLFArgument \end{code} -@bindNewPrimToAmode@ works only for certain addressing modes, because -those are the only ones we've needed so far! +@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") - -- was: mkLFArgument - -- LFinfo is irrelevant for primitives +bindNewPrimToAmode name (CReg reg) + = bindNewToReg name reg (panic "bindNewPrimToAmode") + bindNewPrimToAmode name (CTemp uniq kind) = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode")) - -- LFinfo is irrelevant for primitives - -bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit - -bindNewPrimToAmode name (CVal (SpBRel _ offset) _) - = bindNewToBStack (name, offset) - -bindNewPrimToAmode name (CVal (NodeRel offset) _) - = bindNewToNode name offset (panic "bindNewPrimToAmode node") - -- See comment on idInfoPiecesToAmode for VirNodeLoc #ifdef DEBUG bindNewPrimToAmode name amode - = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug amode))) + = pprPanic "bindNew...:" (pprAmode amode) #endif \end{code} \begin{code} -rebindToAStack :: Id -> VirtualSpAOffset -> Code -rebindToAStack name offset +rebindToStack :: Id -> VirtualSpOffset -> Code +rebindToStack name offset = modifyBindC name replace_stable_fn where replace_stable_fn (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i vol (VirAStkLoc offset) einfo + = MkCgIdInfo i vol (VirStkLoc offset) einfo +\end{code} -rebindToBStack :: Id -> VirtualSpBOffset -> Code -rebindToBStack name offset - = modifyBindC name replace_stable_fn - where - replace_stable_fn (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i vol (VirBStkLoc offset) einfo +%************************************************************************ +%* * +\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) +\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 -- 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} +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 + + | 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 + + size :: Int + size = (getPrimRepSize . typePrimRep . idType) v + +\end{code}