X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=0f858777c273f06eafbdbb6f49eeea8c12c2afaa;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=1d2ff671d30f5537e2756f1d27bc808a1956a525;hpb=6281224046c9fc2bba358d42c7688a8314dc5bb6;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 1d2ff67..0f85877 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -5,55 +5,52 @@ \begin{code} module CgBindery ( - CgBindings, CgIdInfo(..){-dubiously concrete-}, + CgBindings, CgIdInfo, StableLoc, VolatileLoc, - maybeStkLoc, + cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, - stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, + 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, addFreeSlots ) -import CLabel ( mkStaticClosureLabel, mkClosureLabel, - mkBitmapLabel ) +import CgHeapery ( getHpRelOffset ) +import CgStackery ( freeStackSlots, getSpRelOffset ) +import CgUtils ( cgLit, cmmOffsetW ) +import CLabel ( mkClosureLabel, pprCLabel ) import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) -import BitSet ( mkBS, emptyBS ) -import PrimRep ( isFollowableRep, getPrimRepSize ) -import DataCon ( DataCon, dataConName ) -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 Const ( Con(..), Literal ) -import Maybes ( catMaybes, maybeToBool ) -import Name ( isLocallyDefined, isWiredInName, NamedThing(..) ) -#ifdef DEBUG -import PprAbsC ( pprAmode ) -#endif -import PrimRep ( PrimRep(..) ) -import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) ) -import Unique ( Unique, Uniquable(..) ) +import Literal ( literalType ) +import Maybes ( catMaybes ) +import Name ( isExternalName ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg ) +import Unique ( Uniquable(..) ) import UniqSet ( elementOfUniqSet ) -import Util ( zipWithEqual, sortLt ) import Outputable \end{code} @@ -76,22 +73,30 @@ 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) - - | 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 @@ -100,14 +105,37 @@ the @CgBindings@ environment in @CgBindery@. \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} %************************************************************************ @@ -117,50 +145,124 @@ maybeStkLoc _ = 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 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 + mach_rep = argMachRep (cg_rep info) -idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode -idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab +cgIdInfoId :: CgIdInfo -> Id +cgIdInfoId = cg_id -idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode +cgIdInfoLF :: CgIdInfo -> LambdaFormInfo +cgIdInfoLF = cg_lf -idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind) -idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id) +cgIdInfoArgRep :: CgIdInfo -> CgRep +cgIdInfoArgRep = cg_rep -idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit) -idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode +maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off +maybeLetNoEscape other = Nothing +\end{code} -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. +%************************************************************************ +%* * +\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@} +%* * +%************************************************************************ -idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc - = getHpRelOffset hp_off `thenFC` \ rel_hp -> - returnFC (CAddr rel_hp) +.There are three basic routines, for adding (@addBindC@), modifying +(@modifyBindC@) and looking up (@getCgIdInfo@) bindings. -idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i) - = getSpRelOffset i `thenFC` \ rel_sp -> - returnFC (CVal rel_sp 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} %************************************************************************ @@ -177,9 +279,9 @@ nukeVolatileBinds :: CgBindings -> CgBindings 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} @@ -189,52 +291,15 @@ nukeVolatileBinds binds %* * %************************************************************************ -I {\em think} all looking-up is done through @getCAddrMode(s)@. - -\begin{code} -getCAddrModeAndInfo :: Id -> FCode (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) - where - name = getName id - global_amode = CLbl (mkClosureLabel name) kind - kind = idPrimRep id - -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 @@ -245,90 +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 (varSetElems 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] +getArgAmode :: StgArg -> FCode (CgRep, CmmExpr) +getArgAmode (StgVarArg var) + = do { info <- getCgIdInfo var + ; amode <- idInfoToAmode info + ; return (cgIdInfoArgRep info, amode ) } + +getArgAmode (StgLitArg lit) + = do { cmm_lit <- cgLit lit + ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } + +getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" + +getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) - = getArgAmode atom `thenFC` \ amode -> - getArgAmodes atoms `thenFC` \ amodes -> - returnFC ( amode : amodes ) - -getArgAmode :: StgArg -> FCode CAddrMode - -getArgAmode (StgVarArg var) = getCAddrMode var -- The common case - -getArgAmode (StgConArg (DataCon con)) - {- 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 (dataConName con)) PtrRep) - - -getArgAmode (StgConArg (Literal lit)) = returnFC (CLit lit) + | isStgTypeArg atom = getArgAmodes atoms + | otherwise = do { amode <- getArgAmode atom + ; amodes <- getArgAmodes atoms + ; return ( amode : amodes ) } \end{code} %************************************************************************ @@ -338,65 +370,40 @@ getArgAmode (StgConArg (Literal lit)) = returnFC (CLit lit) %************************************************************************ \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 - 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") - -bindArgsToRegs :: [Id] -> [MagicId] -> Code -bindArgsToRegs args regs - = listCs (zipWithEqual "bindArgsToRegs" bind args regs) - 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} @@ -404,134 +411,7 @@ 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} -%* * -%************************************************************************ - -ToDo: remove the dependency on 32-bit words. - -There are two ways to build a liveness mask, and both appear to have -problems. - - 1) Find all the pointer words by searching through the binding list. - Invert this to find the non-pointer words and build the bitmap. - - 2) Find all the non-pointer words by searching through the binding list. - Merge this with the list of currently free slots. Build the - bitmap. - -Method (1) conflicts with update frames - these contain pointers but -have no bindings in the environment. We could bind the updatee to its -location in the update frame at the point when the update frame is -pushed, but this binding would be dropped by the first case expression -(nukeDeadBindings). - -Method (2) causes problems because we must make sure that every -non-pointer word on the stack is either a free stack slot or has a -binding in the environment. Things like cost centres break this (but -only for case-of-case expressions - because that's when there's a cost -centre on the stack from the outer case and we need to generate a -bitmap for the inner case's continuation). - -This method also works "by accident" for update frames: since all -unaccounted for slots on the stack are assumed to be pointers, and an -update frame always occurs at virtual Sp offsets 0-3 (i.e. the bottom -of the stack frame), the bitmap will simply end at the start of the -update frame. - -We use method (2) at the moment. - -\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 info_down - state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage)) - = ASSERT(all (>=0) rel_slots) - livenessToAbsC uniq liveness_mask info_down state - where - -- find all unboxed stack-resident ids - 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 - flatten_slots = sortLt (<) - (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) [] - unboxed_slots) - - -- merge in the free slots - all_slots = mergeSlots flatten_slots (map fst free) ++ - if vsp < sp then [vsp+1 .. sp] else [] - - -- recalibrate the list to be sp-relative - rel_slots = reverse (map (sp-) all_slots) - - -- build the bitmap - liveness_mask = listToLivenessMask rel_slots - -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)) - -{- ALTERNATE version that doesn't work because update frames aren't - recorded in the environment. - - -- find all boxed stack-resident ids - boxed_slots = - [ ofs | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds, - isFollowableRep (idPrimRep id) - ] - all_slots = [1..vsp] - - -- invert to get unboxed slots - unboxed_slots = filter (`notElem` boxed_slots) all_slots --} - -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 [] = returnFC (LvSmall emptyBS) -livenessToAbsC uniq [one] = returnFC (LvSmall one) -livenessToAbsC uniq many = - absC (CBitmap lbl many) `thenC` - returnFC (LvLarge lbl) - 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 - = getRealSp `thenFC` \ realSp -> - buildLivenessMask uniq (realSp-1) + replace_stable_fn info = info { cg_stb = VirStkLoc offset } \end{code} %************************************************************************ @@ -558,16 +438,14 @@ Probably *naughty* to look inside monad... \begin{code} nukeDeadBindings :: StgLiveVars -- All the *live* variables -> Code - -nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage) - = freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage) - where - (dead_stk_slots, bs') - = dead_slots live_vars - [] [] - [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ] - - extra_free = sortLt (<) dead_stk_slots +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. @@ -591,19 +469,23 @@ dead_slots live_vars fbs ds ((v,i):bs) -- 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}