X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=b195b5c8645d67f97953657e2edbd486a5c14bdd;hb=98232a6130f0661486899530fa3461e32499366f;hp=872c103e37cd9f5d3c2f6a6be6c4215ebbdcce4e;hpb=c31a55d1d200e9d1d72d0f09fce5204c425b801d;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 872c103..b195b5c 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -8,7 +8,7 @@ module CgBindery ( CgBindings, CgIdInfo, StableLoc, VolatileLoc, - stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, + stableAmodeIdInfo, heapIdInfo, letNoEscapeIdInfo, idInfoToAmode, addBindC, addBindsC, @@ -18,12 +18,12 @@ module CgBindery ( bindNewToStack, rebindToStack, bindNewToNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, bindNewPrimToAmode, + bindNewToTemp, getArgAmode, getArgAmodes, getCAddrModeAndInfo, getCAddrMode, getCAddrModeIfVolatile, getVolatileRegs, - buildLivenessMask, buildContLivenessMask + buildContLivenessMask ) where #include "HsVersions.h" @@ -32,22 +32,20 @@ import AbsCSyn import CgMonad import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp ) -import CgStackery ( freeStackSlots ) +import CgStackery ( freeStackSlots, getStackFrame ) import CLabel ( mkClosureLabel, mkBitmapLabel, pprCLabel ) import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) -import BitSet ( mkBS, emptyBS ) +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 ) -import Name ( isLocalName, NamedThing(..) ) -#ifdef DEBUG -import PprAbsC ( pprAmode ) -#endif +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(..) ) @@ -85,7 +83,7 @@ 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) @@ -109,6 +107,25 @@ maybeStkLoc (VirStkLoc offset) = Just offset maybeStkLoc _ = Nothing \end{code} +\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} + %************************************************************************ %* * \subsection[Bindery-idInfo]{Manipulating IdInfo} @@ -123,15 +140,6 @@ tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc l 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 = getUnique name - temp_amode = CTemp uniq (idPrimRep name) - temp_idinfo = tempIdInfo name uniq lf_info - idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab @@ -194,22 +202,26 @@ modifyBindC name mangle_fn = do setBinds $ modifyVarEnv mangle_fn binds name lookupBindC :: Id -> FCode CgIdInfo -lookupBindC name = do - static_binds <- getStaticBinds - local_binds <- getBinds - case (lookupVarEnv local_binds name) of - Nothing -> case (lookupVarEnv static_binds name) of - Nothing -> cgPanic (text "lookupBindC: no info for" <+> ppr name) - Just this -> return this - Just this -> return this +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) -cgPanic :: SDoc -> FCode a -cgPanic doc = do - static_binds <- getStaticBinds +cgLookupPanic :: Id -> FCode a +cgLookupPanic id + = do static_binds <- getStaticBinds local_binds <- getBinds srt <- getSRTLabel pprPanic "cgPanic" - (vcat [doc, + (vcat [ppr id, ptext SLIT("static binds for:"), vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ], ptext SLIT("local binds for:"), @@ -250,16 +262,17 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@. getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id - | not (isLocalName name) - = returnFC (id, global_amode, mkLFImported id) - -- deals with imported or locally defined but externally visible ids - -- (CoreTidy makes all these into global names). - - | otherwise = do -- *might* be a nested defn: in any case, it's something whose - -- definition we will know about... - (MkCgIdInfo id' volatile_loc stable_loc lf_info) <- lookupBindC id - amode <- idInfoPiecesToAmode kind volatile_loc stable_loc - return (id', 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 name) kind @@ -321,7 +334,6 @@ getVolatileRegs vars = do in case volatile_loc of RegLoc reg -> consider_reg reg - VirHpLoc _ -> consider_reg Hp VirNodeLoc _ -> consider_reg node non_reg_loc -> returnFC Nothing @@ -357,7 +369,7 @@ bindNewToStack :: (Id, VirtualSpOffset) -> Code bindNewToStack (name, offset) = addBindC name info where - info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument + info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name) bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code bindNewToNode name offset lf_info @@ -369,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 do - addBindC name id_info - return 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 @@ -388,25 +401,7 @@ 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 + arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg) \end{code} \begin{code} @@ -424,8 +419,6 @@ rebindToStack name offset %* * %************************************************************************ -ToDo: remove the dependency on 32-bit words. - There are four kinds of things on the stack: - pointer variables (bound in the environment) @@ -433,88 +426,52 @@ There are four kinds of things on the stack: - 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). +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} buildLivenessMask - :: Unique -- unique for for large bitmap label + :: VirtualSpOffset -- size of the stack frame -> VirtualSpOffset -- offset from which the bitmap should start - -> FCode Liveness -- mask for free/unlifted slots + -> 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 -buildLivenessMask uniq sp = ASSERT (all (>=0) rel_slots) 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 = 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} + 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 -In a continuation, we want a liveness mask that starts from just after -the return address, which is on the stack at realSp. + mask <- buildLivenessMask frame_size (realSp-1) -\begin{code} -buildContLivenessMask - :: Unique - -> FCode Liveness -buildContLivenessMask uniq = do - realSp <- getRealSp - buildLivenessMask uniq (realSp-1) + let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask + absC (maybeLargeBitmap liveness) + return liveness \end{code} %************************************************************************ @@ -547,9 +504,8 @@ nukeDeadBindings live_vars = do dead_slots live_vars [] [] [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ] - let extra_free = sortLt (<) dead_stk_slots setBinds $ mkVarEnv bs' - freeStackSlots extra_free + freeStackSlots dead_stk_slots \end{code} Several boring auxiliary functions to do the dirty work.