X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=0f858777c273f06eafbdbb6f49eeea8c12c2afaa;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=8edd5bd9dc78f8f673031926a192d49582ef89e8;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 8edd5bd..0f85877 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -1,57 +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 ( - CgBindings(..), CgIdInfo(..){-dubiously concrete-}, + CgBindings, CgIdInfo, StableLoc, VolatileLoc, - maybeAStkLoc, maybeBStkLoc, + cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, - stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, + stableIdInfo, heapIdInfo, letNoEscapeIdInfo, idInfoToAmode, + addBindC, addBindsC, + nukeVolatileBinds, + nukeDeadBindings, + getLiveStackSlots, - bindNewToAStack, bindNewToBStack, + bindArgsToStack, rebindToStack, bindNewToNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, bindNewPrimToAmode, - getArgAmode, getArgAmodes, - getCAddrModeAndInfo, getCAddrMode, + bindNewToTemp, + getArgAmode, getArgAmodes, + getCgIdInfo, getCAddrModeIfVolatile, getVolatileRegs, - rebindToAStack, rebindToBStack + maybeLetNoEscape, ) 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 CgHeapery ( getHpRelOffset ) +import CgStackery ( freeStackSlots, getSpRelOffset ) +import CgUtils ( cgLit, cmmOffsetW ) +import CLabel ( mkClosureLabel, pprCLabel ) +import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) + +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 ( literalType ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined ) -#ifdef DEBUG -import PprAbsC ( pprAmode ) -#endif -import PprStyle ( PprStyle(..) ) -import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) ) -import Unpretty ( uppShow ) -import Util ( zipWithEqual, panic ) +import Name ( isExternalName ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg ) +import Unique ( Uniquable(..) ) +import UniqSet ( elementOfUniqSet ) +import Outputable \end{code} @@ -73,37 +73,69 @@ environment. So there can be two bindings for a given name. 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) + | 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} - | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node - -- ie *(Node+offset) +@StableLoc@ encodes where an Id can be found, used by +the @CgBindings@ environment in @CgBindery@. +\begin{code} data StableLoc = NoStableLoc - | VirAStkLoc VirtualSpAOffset - | VirBStkLoc VirtualSpBOffset - | LitLoc Literal - | StableAmodeLoc CAddrMode --- these are so StableLoc can be abstract: + | VirStkLoc VirtualSpOffset -- The thing is held in this + -- stack slot + + | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the + -- value is this stack pointer + -- (as opposed to the contents of the slot) -maybeAStkLoc (VirAStkLoc offset) = Just offset -maybeAStkLoc _ = Nothing + | 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} -maybeBStkLoc (VirBStkLoc offset) = Just offset -maybeBStkLoc _ = Nothing +\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} %************************************************************************ @@ -113,54 +145,124 @@ maybeBStkLoc _ = Nothing %************************************************************************ \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 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) +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 = uniqueOf 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 + mach_rep = argMachRep (cg_rep info) -idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode +cgIdInfoId :: CgIdInfo -> Id +cgIdInfoId = cg_id -idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind) -idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id) +cgIdInfoLF :: CgIdInfo -> LambdaFormInfo +cgIdInfoLF = cg_lf -idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit) -idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode +cgIdInfoArgRep :: CgIdInfo -> CgRep +cgIdInfoArgRep = cg_rep -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. +maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off +maybeLetNoEscape other = Nothing +\end{code} -idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc - = getHpRelOffset hp_off `thenFC` \ rel_hp -> - returnFC (CAddr rel_hp) +%************************************************************************ +%* * +\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@} +%* * +%************************************************************************ -idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i) - = getSpARelOffset i `thenFC` \ rel_spA -> - returnFC (CVal rel_spA kind) +.There are three basic routines, for adding (@addBindC@), modifying +(@modifyBindC@) and looking up (@getCgIdInfo@) bindings. -idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i) - = getSpBRelOffset i `thenFC` \ rel_spB -> - returnFC (CVal rel_spB kind) +A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple. +The name should not already be bound. (nice ASSERT, eh?) -#ifdef DEBUG -idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc" -#endif +\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 { -- 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 + = 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 <- rngVarEnv static_binds ], + ptext SLIT("local binds for:"), + vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ], + ptext SLIT("SRT label") <+> pprCLabel srt + ]) \end{code} %************************************************************************ @@ -175,11 +277,11 @@ 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 - = (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} @@ -189,45 +291,15 @@ nukeVolatileBinds binds %* * %************************************************************************ -I {\em think} all looking-up is done through @getCAddrMode(s)@. - \begin{code} -getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) - -getCAddrModeAndInfo name - | not (isLocallyDefined name) - = returnFC (global_amode, mkLFImported name) - - | isDataCon name - = returnFC (global_amode, mkConLFInfo name) - - | 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) - where - global_amode = CLbl (mkClosureLabel name) kind - kind = idPrimRep name - -getCAddrMode :: Id -> FCode CAddrMode -getCAddrMode name - = getCAddrModeAndInfo name `thenFC` \ (amode, _) -> - returnFC 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 +getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr) +getCAddrModeIfVolatile id + = do { info <- getCgIdInfo id + ; case cg_stb info of + NoStableLoc -> do -- Aha! So it is volatile! + amode <- idInfoToAmode info + return $ Just amode + a_stable_loc -> return Nothing } \end{code} @getVolatileRegs@ gets a set of live variables, and returns a list of @@ -238,54 +310,57 @@ stable one (notably, on the stack), we modify the current bindings to forget the volatile one. \begin{code} -getVolatileRegs :: StgLiveVars -> FCode [MagicId] +getVolatileRegs :: StgLiveVars -> FCode [GlobalReg] -getVolatileRegs vars - = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff -> - returnFC (catMaybes stuff) +getVolatileRegs vars = do + do { stuff <- mapFCs snaffle_it (varSetElems vars) + ; 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 + snaffle_it var = do + { info <- getCgIdInfo var + ; let + -- commoned-up code... + 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. - 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 + 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) - = getArgAmode atom `thenFC` \ amode -> - getArgAmodes atoms `thenFC` \ amodes -> - returnFC ( 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 -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} %************************************************************************ @@ -295,96 +370,122 @@ getArgAmode (StgLitArg lit) = returnFC (CLit lit) %************************************************************************ \begin{code} -bindNewToAStack :: (Id, VirtualSpAOffset) -> Code -bindNewToAStack (name, offset) - = addBindC name info +bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code +bindArgsToStack args + = mapCs bind args where - info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument + bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id)) -bindNewToBStack :: (Id, VirtualSpBOffset) -> Code -bindNewToBStack (name, offset) - = addBindC name info +bindArgsToRegs :: [(Id, GlobalReg)] -> Code +bindArgsToRegs args + = mapCs bind args where - info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack") - -- B-stack things shouldn't need lambda-form info! + bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg) -bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code -bindNewToNode name offset lf_info - = addBindC name info - where - info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info +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 - addBindC name id_info `thenC` - returnFC 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 -bindNewToLit name lit +bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code +bindNewToReg name reg lf_info = addBindC name info where - info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit") + info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info +\end{code} -bindArgsToRegs :: [Id] -> [MagicId] -> Code -bindArgsToRegs args regs - = listCs (zipWithEqual "bindArgsToRegs" bind args regs) +\begin{code} +rebindToStack :: Id -> VirtualSpOffset -> Code +rebindToStack name offset + = modifyBindC name replace_stable_fn where - arg `bind` reg = bindNewToReg arg reg mkLFArgument + replace_stable_fn info = info { cg_stb = VirStkLoc offset } \end{code} -@bindNewPrimToAmode@ works only for certain addressing modes, because -those are the only ones we've needed so far! +%************************************************************************ +%* * +\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} -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 - -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))) -#endif +nukeDeadBindings :: StgLiveVars -- All the *live* variables + -> Code +nukeDeadBindings live_vars = do + binds <- getBinds + let (dead_stk_slots, bs') = + dead_slots live_vars + [] [] + [ (cg_id b, b) | b <- 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 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 - replace_stable_fn (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i vol (VirBStkLoc offset) einfo + size :: WordOff + size = cgRepSizeW (cg_rep i) \end{code} +\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}