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
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,f,realSp,hwsp), h_usage) <- getUsage
+ let new_usage = ((sp, 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}
%************************************************************************
\begin{code}
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
+adjustSpAndHp newRealSp = do
+ (MkCgInfoDown _ _ _ ticky_ctr _) <- getInfoDown
+ (MkCgState absC binds
+ ((vSp,fSp,realSp,hwSp),
+ (vHp, rHp))) <- getState
+ let 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)),
+ let 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))
+ [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
+ ]
+ let new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp))
+ setState $ MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage
\end{code}