X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgUsages.lhs;h=6f3353d8dd156f56ce577ab953a1f9a9cafa7635;hb=cf2b7f7b4e945e27bda9baa020845bb965eea261;hp=eec6be60672ffd8f847cb11580b9553feecbea41;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index eec6be6..6f3353d 100644
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[CgUsages]{Accessing and modifying stacks and heap usage info}
 
@@ -9,26 +9,21 @@ modify (\tr{set*} functions) the stacks and heap usage information.
 \begin{code}
 module CgUsages (
 	initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
-	setRealAndVirtualSps,
+	setRealAndVirtualSp,
 
-	getVirtSps,
+	getVirtSp, getRealSp,
 
-	getHpRelOffset,	getSpARelOffset, getSpBRelOffset,
+	getHpRelOffset,	getSpRelOffset,
 
-	freeBStkSlot
+	adjustSpAndHp
     ) where
 
-import Ubiq{-uitous-}
-import CgLoop1	-- here for paranoia-checking
+#include "HsVersions.h"
 
-import AbsCSyn		( RegRelative(..), AbstractC, CAddrMode )
+import AbsCSyn
+import PrimRep		( PrimRep(..) )
+import AbsCUtils	( mkAbstractCs )
 import CgMonad
-import HeapOffs		( zeroOff,
-			  VirtualHeapOffset(..),
-			  VirtualSpAOffset(..),
-			  VirtualSpBOffset(..)
-			)
-import Id		( IdEnv(..) )
 \end{code}
 
 %************************************************************************
@@ -47,40 +42,40 @@ be in a tidy and consistent state.
 \begin{code}
 initHeapUsage :: (VirtualHeapOffset -> Code) -> Code
 
-initHeapUsage fcode info_down (MkCgState absC binds (a_usage, b_usage, heap_usage))
+initHeapUsage fcode info_down (MkCgState absC binds (stk_usage, heap_usage))
   = state3
   where
-    state1 = MkCgState absC binds (a_usage, b_usage, (zeroOff, zeroOff))
+    state1 = MkCgState absC binds (stk_usage, (0, 0))
     state2 = fcode (heapHWM heap_usage2) info_down state1
-    (MkCgState absC2 binds2 (a_usage2, b_usage2, heap_usage2)) = state2
+    (MkCgState absC2 binds2 (stk_usage2, heap_usage2)) = state2
     state3 = MkCgState  absC2
 			binds2
-			(a_usage2, b_usage2, heap_usage {- unchanged -})
+			(stk_usage2, heap_usage {- unchanged -})
 \end{code}
 
 \begin{code}
 setVirtHp :: VirtualHeapOffset -> Code
 setVirtHp new_virtHp info_down
-	  state@(MkCgState absC binds (a_stk, b_stk, (virtHp, realHp)))
-  = MkCgState absC binds (a_stk, b_stk, (new_virtHp, realHp))
+	  state@(MkCgState absC binds (stk, (virtHp, realHp)))
+  = MkCgState absC binds (stk, (new_virtHp, realHp))
 \end{code}
 
 \begin{code}
 getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset)
-getVirtAndRealHp info_down state@(MkCgState _ _ (au, bu, (virtHp, realHp)))
+getVirtAndRealHp info_down state@(MkCgState _ _ (_, (virtHp, realHp)))
   = ((virtHp, realHp), state)
 \end{code}
 
 \begin{code}
 setRealHp ::  VirtualHeapOffset -> Code
-setRealHp realHp info_down (MkCgState absC binds (au, bu, (vHp, _)))
-  = MkCgState absC binds (au, bu, (vHp, realHp))
+setRealHp realHp info_down (MkCgState absC binds (stk_usage, (vHp, _)))
+  = MkCgState absC binds (stk_usage, (vHp, realHp))
 \end{code}
 
 \begin{code}
 getHpRelOffset :: VirtualHeapOffset -> FCode RegRelative
-getHpRelOffset virtual_offset info_down state@(MkCgState _ _ (_,_,(_,realHp)))
-  = (HpRel realHp virtual_offset, state)
+getHpRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,realHp)))
+  = (hpRel realHp virtual_offset, state)
 \end{code}
 
 The heap high water mark is the larger of virtHp and hwHp.  The latter is
@@ -98,48 +93,76 @@ heapHWM (virtHp, realHp) = virtHp
 %*									*
 %************************************************************************
 
-@setRealAndVirtualSps@ sets into the environment the offsets of the
+@setRealAndVirtualSp@ sets into the environment the offsets of the
 current position of the real and virtual stack pointers in the current
 stack frame.  The high-water mark is set too.  It generates no code.
 It is used to initialise things at the beginning of a closure body.
 
 \begin{code}
-setRealAndVirtualSps :: VirtualSpAOffset 	-- New real SpA
-	   	     -> VirtualSpBOffset 	-- Ditto B stack
+setRealAndVirtualSp :: VirtualSpOffset 	-- New real Sp
 		     -> Code
 
-setRealAndVirtualSps spA spB info_down (MkCgState absC binds
-					((vspA,fA,realSpA,hwspA),
-				 	 (vspB,fB,realSpB,hwspB),
-				 	 h_usage))
+setRealAndVirtualSp sp info_down (MkCgState absC binds
+					((vsp,f,realSp,hwsp), h_usage))
   = MkCgState absC binds new_usage
   where
-    new_usage = ((spA, fA, spA, spA),
-		 (spB, fB, spB, spB),
-		 h_usage)
+    new_usage = ((sp, f, sp, sp), h_usage)
 \end{code}
 
 \begin{code}
-getVirtSps :: FCode (VirtualSpAOffset,VirtualSpBOffset)
-getVirtSps info_down state@(MkCgState absC binds ((virtSpA,_,_,_), (virtSpB,_,_,_), _))
-  = ((virtSpA,virtSpB), state)
+getVirtSp :: FCode VirtualSpOffset
+getVirtSp info_down state@(MkCgState absC binds ((virtSp,_,_,_), _))
+  = (virtSp, state)
+
+getRealSp :: FCode VirtualSpOffset
+getRealSp info_down state@(MkCgState absC binds ((_,_,realSp,_),_)) 
+  = (realSp,state)
 \end{code}
 
 \begin{code}
-getSpARelOffset :: VirtualSpAOffset -> FCode RegRelative
-getSpARelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSpA,_),_,_))
-  = (SpARel realSpA virtual_offset, state)
-
-getSpBRelOffset :: VirtualSpBOffset -> FCode RegRelative
-getSpBRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,_,realSpB,_),_))
-  = (SpBRel realSpB virtual_offset, state)
+getSpRelOffset :: VirtualSpOffset -> FCode RegRelative
+getSpRelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSp,_),_))
+  = (spRel realSp virtual_offset, state)
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection[CgStackery-adjust]{Adjusting the stack pointers}
+%*									*
+%************************************************************************
+
+This function adjusts the stack and heap pointers just before a tail
+call or return.  The stack pointer is adjusted to its final position
+(i.e. to point to the last argument for a tail call, or the activation
+record for a return).  The heap pointer may be moved backwards, in
+cases where we overallocated at the beginning of the basic block (see
+CgCase.lhs for discussion).
+
+These functions {\em do not} deal with high-water-mark adjustment.
+That's done by functions which allocate stack space.
+
 \begin{code}
-freeBStkSlot :: VirtualSpBOffset -> Code
-freeBStkSlot b_slot info_down
-	state@(MkCgState absC binds (spa_usage, (virtSpB,free_b,realSpB,hwSpB), heap_usage))
-  = MkCgState absC binds (spa_usage, (virtSpB,new_free_b,realSpB,hwSpB), heap_usage)
-  where
-    new_free_b = addFreeBSlots free_b [b_slot]
+adjustSpAndHp :: VirtualSpOffset 	-- New offset for Arg stack ptr
+	      -> Code
+adjustSpAndHp newRealSp (MkCgInfoDown _ _ _ ticky_ctr _)
+			(MkCgState absC binds
+				   ((vSp,fSp,realSp,hwSp),	
+				   (vHp, rHp)))
+  = MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage
+    where
+
+    move_sp = if (newRealSp == realSp) then AbsCNop
+	      else (CAssign (CReg Sp)
+			    (CAddr (spRel realSp newRealSp)))
+
+	-- Adjust the heap pointer backwards in case we over-allocated
+	-- Analogously, we also remove bytes from the ticky counter
+    move_hp = if (rHp == vHp) then AbsCNop
+	      else mkAbstractCs [
+			CAssign (CReg Hp) (CAddr (hpRel rHp vHp)),
+			profCtrAbsC SLIT("TICK_ALLOC_HEAP") 
+			    [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
+	      ]
+
+    new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp))
 \end{code}