[project @ 2003-07-24 13:57:20 by simonmar]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgUsages.lhs

diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index a3fd37a..c8b98f6 100644 (file)
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -13,13 +13,16 @@ module CgUsages (
 
        getVirtSp, getRealSp,
 
-       getHpRelOffset, getSpRelOffset
+       getHpRelOffset, getSpRelOffset,
+
+       adjustSpAndHp
     ) where
 
 #include "HsVersions.h"
 
-import AbsCSyn         ( RegRelative(..), VirtualHeapOffset, VirtualSpOffset,
-                         hpRel, spRel )
+import AbsCSyn
+import PrimRep         ( PrimRep(..) )
+import AbsCUtils       ( mkAbstractCs )
 import CgMonad
 \end{code}
 
@@ -36,43 +39,47 @@ heap usage.
 It is usually a prelude to performing a GC check, so everything must
 be in a tidy and consistent state.
 
+rje: Note the slightly suble fixed point behaviour needed here
 \begin{code}
 initHeapUsage :: (VirtualHeapOffset -> Code) -> Code
 
-initHeapUsage fcode info_down (MkCgState absC binds (stk_usage, heap_usage))
-  = state3
-  where
-    state1 = MkCgState absC binds (stk_usage, (0, 0))
-    state2 = fcode (heapHWM heap_usage2) info_down state1
-    (MkCgState absC2 binds2 (stk_usage2, heap_usage2)) = state2
-    state3 = MkCgState  absC2
-                       binds2
-                       (stk_usage2, heap_usage {- unchanged -})
+initHeapUsage fcode = do 
+       (stk_usage, heap_usage) <- getUsage
+       setUsage (stk_usage, (0,0))
+       fixC (\heap_usage2 -> do
+               fcode (heapHWM heap_usage2)
+               (_, heap_usage2) <- getUsage
+               return heap_usage2)
+       (stk_usage2, heap_usage2) <- getUsage
+       setUsage (stk_usage2, heap_usage {-unchanged -})
 \end{code}
 
 \begin{code}
 setVirtHp :: VirtualHeapOffset -> Code
-setVirtHp new_virtHp info_down
-         state@(MkCgState absC binds (stk, (virtHp, realHp)))
-  = MkCgState absC binds (stk, (new_virtHp, realHp))
+setVirtHp new_virtHp = do
+       (stk, (virtHp, realHp)) <- getUsage
+       setUsage (stk, (new_virtHp, realHp))
 \end{code}
 
 \begin{code}
 getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset)
-getVirtAndRealHp info_down state@(MkCgState _ _ (_, (virtHp, realHp)))
-  = ((virtHp, realHp), state)
+getVirtAndRealHp = do 
+       (_, (virtHp, realHp)) <- getUsage
+       return (virtHp, realHp)
 \end{code}
 
 \begin{code}
 setRealHp ::  VirtualHeapOffset -> Code
-setRealHp realHp info_down (MkCgState absC binds (stk_usage, (vHp, _)))
-  = MkCgState absC binds (stk_usage, (vHp, realHp))
+setRealHp realHp = do
+       (stk_usage, (vHp, _)) <- getUsage
+       setUsage (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 = do
+       (_,(_,realHp)) <- getUsage
+       return $ hpRel realHp virtual_offset
 \end{code}
 
 The heap high water mark is the larger of virtHp and hwHp.  The latter is
@@ -99,25 +106,65 @@ It is used to initialise things at the beginning of a closure body.
 setRealAndVirtualSp :: VirtualSpOffset         -- New real Sp
                     -> Code
 
-setRealAndVirtualSp sp info_down (MkCgState absC binds
-                                       ((vsp,f,realSp,hwsp), h_usage))
-  = MkCgState absC binds new_usage
-  where
-    new_usage = ((sp, f, sp, sp), h_usage)
+setRealAndVirtualSp sp = do
+       ((vsp,frame,f,realSp,hwsp), h_usage) <- getUsage
+       let new_usage = ((sp, frame, f, sp, sp), h_usage)
+       setUsage new_usage
 \end{code}
 
 \begin{code}
 getVirtSp :: FCode VirtualSpOffset
-getVirtSp info_down state@(MkCgState absC binds ((virtSp,_,_,_), _))
-  = (virtSp, state)
+getVirtSp = do 
+       ((virtSp,_,_,_,_), _) <- getUsage
+       return virtSp
 
 getRealSp :: FCode VirtualSpOffset
-getRealSp info_down state@(MkCgState absC binds ((_,_,realSp,_),_)) 
-  = (realSp,state)
+getRealSp = do
+       ((_,_,_,realSp,_),_) <- getUsage
+       return realSp
 \end{code}
 
 \begin{code}
 getSpRelOffset :: VirtualSpOffset -> FCode RegRelative
-getSpRelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSp,_),_))
-  = (spRel realSp virtual_offset, state)
+getSpRelOffset virtual_offset = do
+       ((_,_,_,realSp,_),_) <- getUsage
+       return $ spRel realSp virtual_offset
+\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}
+adjustSpAndHp :: VirtualSpOffset       -- New offset for Arg stack ptr
+             -> Code
+adjustSpAndHp newRealSp = do
+       (MkCgInfoDown _ _ _ ticky_ctr _) <- getInfoDown
+       (MkCgState absC binds
+                  ((vSp,frame,fSp,realSp,hwSp),        
+                  (vHp, rHp))) <- getState
+       let move_sp = if (newRealSp == realSp) then AbsCNop
+             else (CAssign (CReg Sp)
+                           (CAddr (spRel realSp newRealSp)))
+       let move_hp = 
+               if (rHp == vHp) then AbsCNop
+               else mkAbstractCs [
+               CAssign (CReg Hp) (CAddr (hpRel rHp vHp)),
+                       profCtrAbsC FSLIT("TICK_ALLOC_HEAP") 
+                       [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
+               ]
+       let new_usage = ((vSp, frame, fSp, newRealSp, hwSp), (vHp,vHp))
+       setState $ MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage
 \end{code}