X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=b195b5c8645d67f97953657e2edbd486a5c14bdd;hb=98232a6130f0661486899530fa3461e32499366f;hp=edfe45e6aa76dcb7459cf584dc7ea1903c617e79;hpb=cb43dfcd86ff1904bd70bf355f1658eb66489842;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index edfe45e..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,7 +18,7 @@ module CgBindery (
 
 	bindNewToStack,  rebindToStack,
 	bindNewToNode, bindNewToReg, bindArgsToRegs,
-	bindNewToTemp, bindNewPrimToAmode,
+	bindNewToTemp, 
 	getArgAmode, getArgAmodes,
 	getCAddrModeAndInfo, getCAddrMode,
 	getCAddrModeIfVolatile, getVolatileRegs,
@@ -36,7 +36,7 @@ import CgStackery	( freeStackSlots, getStackFrame )
 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 )
@@ -44,10 +44,8 @@ import VarEnv
 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(..) )
@@ -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
 
@@ -373,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 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
@@ -395,24 +404,6 @@ bindArgsToRegs args regs
     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
@@ -443,7 +434,7 @@ with initially all bits set (up to the size of the stack frame).
 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
@@ -458,30 +449,16 @@ buildLivenessMask size sp = do {
     	    ];
     };
 
-    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
@@ -492,8 +469,8 @@ buildContLivenessMask name = do
 
 	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}