CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
- stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
+ stableAmodeIdInfo, heapIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
addBindC, addBindsC,
bindNewToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
- bindNewToTemp, bindNewPrimToAmode,
+ bindNewToTemp,
getArgAmode, getArgAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
import CLabel ( mkClosureLabel,
mkBitmapLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
-import BitSet
+import Bitmap
import PrimRep ( isFollowableRep, getPrimRepSize )
import Id ( Id, idPrimRep, idType )
import Type ( typePrimRep )
import VarSet ( varSetElems )
import Literal ( Literal )
import Maybes ( catMaybes, maybeToBool, seqMaybe )
-import Name ( Name, isInternalName, NamedThing(..) )
-#ifdef DEBUG
-import PprAbsC ( pprAmode )
-#endif
+import Name ( isInternalName, NamedThing(..) )
+import PprAbsC ( pprAmode, pprMagicId )
import PrimRep ( PrimRep(..) )
import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
import Unique ( Unique, Uniquable(..) )
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}
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
-- 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 name)
- -- 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
arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
\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
-\end{code}
-
\begin{code}
rebindToStack :: Id -> VirtualSpOffset -> Code
rebindToStack name offset
- 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
- :: VirtualSpOffset -- offset from which the bitmap should start
- -> FCode LivenessMask -- mask for free/unlifted slots
+ :: VirtualSpOffset -- size of the stack frame
+ -> VirtualSpOffset -- offset from which the bitmap should start
+ -> FCode Bitmap -- mask for free/unlifted slots
-buildLivenessMask sp = do {
-
- -- find all unboxed stack-resident ids
+buildLivenessMask size sp = do {
+ -- find all live stack-resident pointers
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
+
+ let {
+ rel_slots = sortLt (<)
+ [ sp - ofs -- get slots relative to top of frame
+ | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ isFollowableRep (idPrimRep id)
];
-
- -- 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);
};
- ASSERT(all (>=0) rel_slots && rel_slots == sortLt (<) rel_slots)
- return (listToLivenessMask rel_slots)
+ 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.
-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
-\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 :: Name -> FCode Liveness
-buildContLivenessMask name = do
+buildContLivenessMask :: Id -> FCode Liveness
+ -- The Id is used just for its unique to make a label
+buildContLivenessMask id = do
realSp <- getRealSp
- mask <- buildLivenessMask (realSp-1)
-
- let lbl = mkBitmapLabel name
+ 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).
- frame_sp <- getStackFrame
- let liveness = Liveness lbl (realSp-1-frame_sp) mask
+ let frame_size = realSp - frame_sp - 1
+
+ mask <- buildLivenessMask frame_size (realSp-1)
- absC (CBitmap liveness)
+ let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask
+ absC (maybeLargeBitmap liveness)
return liveness
\end{code}
projects / ghc-hetmet.git / blobdiff