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
buildLivenessMask
:: VirtualSpOffset -- size of the stack frame
-> VirtualSpOffset -- offset from which the bitmap should start
- -> FCode LivenessMask -- mask for free/unlifted slots
+ -> FCode Bitmap -- mask for free/unlifted slots
buildLivenessMask size sp = do {
-- find all live stack-resident pointers
];
};
- ASSERT(all (>=0) rel_slots)
- return (listToLivenessMask size rel_slots)
+ WARN( not (all (>=0) rel_slots), ppr size $$ ppr sp $$ ppr rel_slots $$ ppr binds )
+ return (intsToReverseBitmap size rel_slots)
}
--- make a bitmap where the slots specified are the *zeros* in the bitmap.
--- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero,
--- just to make the bitmap easier to read).
-listToLivenessMask :: Int -> [Int] -> [BitSet]
-listToLivenessMask size slots{- must be sorted -}
- | size <= 0 = []
- | otherwise = init `minusBS` mkBS these :
- listToLivenessMask (size - 32) (map (\x -> x - 32) rest)
- where (these,rest) = span (<32) slots
- init
- | size >= 32 = all_ones
- | otherwise = mkBS [0..size-1]
-
- all_ones = mkBS [0..31]
-
-- In a continuation, we want a liveness mask that starts from just after
-- the return address, which is on the stack at realSp.
-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
frame_sp <- getStackFrame
mask <- buildLivenessMask frame_size (realSp-1)
- let liveness = Liveness (mkBitmapLabel name) frame_size mask
- absC (CBitmap liveness)
+ let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask
+ absC (maybeLargeBitmap liveness)
return liveness
\end{code}
projects / ghc-hetmet.git / blobdiff