X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=8cda07b53789dae4d4c66c4412f343e2378a9e24;hb=5c67176de89fee19a02056216a7c58579e765148;hp=a5feb794c90b1134a60add2b405519a0b75b8357;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index a5feb79..8cda07b 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -1,62 +1,60 @@ % -% (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, 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 ( 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(..) ) +import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp ) +import CgStackery ( freeStackSlots, addFreeSlots ) +import CLabel ( mkStaticClosureLabel, mkClosureLabel, + mkBitmapLabel, 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 VarEnv +import VarSet ( varSetElems ) +import Const ( Con(..), Literal ) +import Maybes ( catMaybes, maybeToBool ) +import Name ( isLocallyDefined, isWiredInName, 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 PrimRep ( PrimRep(..) ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) ) +import Unique ( Unique, Uniquable(..) ) +import UniqSet ( elementOfUniqSet ) +import Util ( zipWithEqual, sortLt ) +import Outputable \end{code} @@ -94,21 +92,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} %************************************************************************ @@ -122,15 +121,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 @@ -146,7 +145,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 +154,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 +165,63 @@ 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 info_down (MkCgState absC binds usage) + = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage + +addBindsC :: [(Id, CgIdInfo)] -> Code +addBindsC new_bindings info_down (MkCgState absC binds usage) + = MkCgState absC new_binds usage + where + new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) + binds + new_bindings + +modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code +modifyBindC name mangle_fn info_down (MkCgState absC binds usage) + = MkCgState absC (modifyVarEnv mangle_fn binds name) usage + +lookupBindC :: Id -> FCode CgIdInfo +lookupBindC name info_down@(MkCgInfoDown _ static_binds srt ticky _) + state@(MkCgState absC local_binds usage) + = (val, state) + where + val = case (lookupVarEnv local_binds name) of + Nothing -> try_static + Just this -> this + + try_static = + case (lookupVarEnv static_binds name) of + Just this -> this + Nothing + -> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state + +cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a +cgPanic doc info_down@(MkCgInfoDown _ static_binds srt ticky _) + state@(MkCgState absC local_binds usage) + = pprPanic "cgPanic" + (vcat [doc, + 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 +232,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 @@ -219,7 +271,7 @@ getCAddrModeAndInfo id returnFC (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 @@ -231,8 +283,8 @@ getCAddrMode name \begin{code} getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode) getCAddrModeIfVolatile name - | toplevelishId name = returnFC Nothing - | otherwise +-- | 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! @@ -253,7 +305,7 @@ forget the volatile one. getVolatileRegs :: StgLiveVars -> FCode [MagicId] getVolatileRegs vars - = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff -> + = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff -> returnFC (catMaybes stuff) where snaffle_it var @@ -296,7 +348,9 @@ getArgAmodes (atom:atoms) getArgAmode :: StgArg -> FCode CAddrMode -getArgAmode (StgConArg var) +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 @@ -328,11 +382,10 @@ getArgAmode (StgConArg var) is really App f (StgCon Empty []) -} - = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var)) + = returnFC (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep) -getArgAmode (StgVarArg var) = getCAddrMode var -- The common case -getArgAmode (StgLitArg lit) = returnFC (CLit lit) +getArgAmode (StgConArg (Literal lit)) = returnFC (CLit lit) \end{code} %************************************************************************ @@ -342,18 +395,11 @@ getArgAmode (StgLitArg lit) = returnFC (CLit lit) %************************************************************************ \begin{code} -bindNewToAStack :: (Id, VirtualSpAOffset) -> Code -bindNewToAStack (name, offset) +bindNewToStack :: (Id, VirtualSpOffset) -> Code +bindNewToStack (name, offset) = addBindC name info where - info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument - -bindNewToBStack :: (Id, VirtualSpBOffset) -> Code -bindNewToBStack (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 @@ -392,46 +438,203 @@ 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...:"++(show (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 +%************************************************************************ +%* * +\subsection[CgBindery-liveness]{Build a liveness mask for the current stack} +%* * +%************************************************************************ + +ToDo: remove the dependency on 32-bit words. + +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 info_down + state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage)) + = ASSERT(all (>=0) rel_slots) + livenessToAbsC uniq liveness_mask info_down state where - replace_stable_fn (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i vol (VirBStkLoc offset) einfo + -- 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)) + +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) +\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 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 \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}