From 6281224046c9fc2bba358d42c7688a8314dc5bb6 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Tue, 8 Jun 1999 15:56:48 +0000
Subject: [PATCH] [project @ 1999-06-08 15:56:44 by simonmar] Allow reserving
of stack slots for non-pointer data (eg. cost centres). This means the
previous hacks to keep the stack bitmaps correct in the presence of cost
centres are now unnecessary, and case-of-case expressions will be compiled
properly with profiling on.
---
ghc/compiler/codeGen/CgBindery.lhs | 15 ++-
ghc/compiler/codeGen/CgCase.lhs | 24 +++--
ghc/compiler/codeGen/CgClosure.lhs | 11 ++-
ghc/compiler/codeGen/CgExpr.lhs | 5 +-
ghc/compiler/codeGen/CgMonad.lhs | 15 ++-
ghc/compiler/codeGen/CgStackery.lhs | 137 +++++++++++-----------------
ghc/compiler/codeGen/CgTailCall.lhs | 18 ++--
ghc/compiler/codeGen/CgUpdate.lhs | 15 ++-
ghc/compiler/codeGen/CgUsages.lhs | 44 ++++++++-
9 files changed, 151 insertions(+), 133 deletions(-)
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 49b907e2e29b..1d2ff671d30f 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -422,7 +422,7 @@ problems.
1) Find all the pointer words by searching through the binding list.
Invert this to find the non-pointer words and build the bitmap.
- 2) Find all the non-pointer words by search through the binding list.
+ 2) Find all the non-pointer words by searching through the binding list.
Merge this with the list of currently free slots. Build the
bitmap.
@@ -473,7 +473,7 @@ buildLivenessMask uniq sp info_down
unboxed_slots)
-- merge in the free slots
- all_slots = addFreeSlots flatten_slots free ++
+ all_slots = mergeSlots flatten_slots (map fst free) ++
if vsp < sp then [vsp+1 .. sp] else []
-- recalibrate the list to be sp-relative
@@ -482,6 +482,17 @@ buildLivenessMask uniq sp info_down
-- build the bitmap
liveness_mask = listToLivenessMask rel_slots
+mergeSlots :: [Int] -> [Int] -> [Int]
+mergeSlots cs [] = cs
+mergeSlots [] ns = ns
+mergeSlots (c:cs) (n:ns)
+ = if c < n then
+ c : mergeSlots cs (n:ns)
+ else if c > n then
+ n : mergeSlots (c:cs) ns
+ else
+ panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
+
{- ALTERNATE version that doesn't work because update frames aren't
recorded in the environment.
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index b02e248c1d9e..2ad8e996174a 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.29 1999/05/18 15:03:46 simonpj Exp $
+% $Id: CgCase.lhs,v 1.30 1999/06/08 15:56:45 simonmar Exp $
%
%********************************************************
%* *
@@ -10,8 +10,7 @@
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre, freeCostCentreSlot
+module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
) where
#include "HsVersions.h"
@@ -39,7 +38,7 @@ import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
CtrlReturnConvention(..)
)
import CgStackery ( allocPrimStack, allocStackTop,
- deAllocStackTop, freeStackSlots
+ deAllocStackTop, freeStackSlots, dataStackSlots
)
import CgTailCall ( tailCallFun )
import CgUsages ( getSpRelOffset, getRealSp )
@@ -434,9 +433,6 @@ cgEvalAlts cc_slot bndr srt alts
=
let uniq = getUnique bndr in
- -- get the stack liveness for the info table (after the CC slot has
- -- been freed - this is important).
- freeCostCentreSlot cc_slot `thenC`
buildContLivenessMask uniq `thenFC` \ liveness_mask ->
case alts of
@@ -500,12 +496,14 @@ cgEvalAlts cc_slot bndr srt alts
-- primitive alts...
(StgPrimAlts ty alts deflt) ->
+ -- Restore the cost centre
+ restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+
-- Generate the switch
getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
getSRTLabel `thenFC` \srt_label ->
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
(srt_label,srt) liveness_mask) `thenC`
@@ -855,19 +853,19 @@ saveCurrentCostCentre
= if not opt_SccProfilingOn then
returnFC (Nothing, AbsCNop)
else
- allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
+ allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
+ dataStackSlots [slot] `thenC`
getSpRelOffset slot `thenFC` \ sp_rel ->
returnFC (Just slot,
CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
-freeCostCentreSlot :: Maybe VirtualSpOffset -> Code
-freeCostCentreSlot Nothing = nopC
-freeCostCentreSlot (Just slot) = freeStackSlots [slot]
-
restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
restoreCurrentCostCentre Nothing = returnFC AbsCNop
restoreCurrentCostCentre (Just slot)
= getSpRelOffset slot `thenFC` \ sp_rel ->
+ freeStackSlots [slot] `thenC`
+ (\info_down state@(MkCgState abs_c binds ((vsp, free, real, hw), heap_usage))
+ -> trace (show slot ++ " " ++ show vsp ++ " " ++ show free) $ state) `thenC`
returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
-- we use the RESTORE_CCCS macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCC
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 7d532bad1160..8646051f7632 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.31 1999/05/18 15:03:47 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.32 1999/06/08 15:56:46 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
@@ -35,8 +35,8 @@ import CgHeapery ( allocDynClosure,
fetchAndReschedule, yield, -- HWL
fastEntryChecks, thunkChecks
)
-import CgStackery ( adjustRealSp, mkTaggedVirtStkOffsets, freeStackSlots )
-import CgUsages ( setRealAndVirtualSp, getVirtSp,
+import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots )
+import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp,
getSpRelOffset, getHpRelOffset
)
import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
@@ -357,8 +357,9 @@ closureCodeBody binder_info closure_info cc all_args body
absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
`thenC`
- -- Now adjust real stack pointers
- adjustRealSp sp_stk_args `thenC`
+ -- Now adjust real stack pointers (no need to adjust Hp,
+ -- but call this function for convenience).
+ adjustSpAndHp sp_stk_args `thenC`
absC (CFallThrough (CLbl fast_label CodePtrRep))
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 4490a8174837..a57ee94f4262 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.25 1999/05/18 15:03:49 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.26 1999/06/08 15:56:47 simonmar Exp $
%
%********************************************************
%* *
@@ -24,7 +24,7 @@ import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo, nukeDeadBindings)
import CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre, freeCostCentreSlot )
+ restoreCurrentCostCentre )
import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgLetNoEscape ( cgLetNoEscapeClosure )
@@ -225,7 +225,6 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
-- ToDo: cost centre???
- freeCostCentreSlot maybe_cc_slot `thenC`
restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
-- Save those variables right now!
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index 06a9a52b7df4..df41f44dba8b 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.20 1999/05/18 15:03:49 simonpj Exp $
+% $Id: CgMonad.lhs,v 1.21 1999/06/08 15:56:47 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
@@ -27,7 +27,7 @@ module CgMonad (
setSRTLabel, getSRTLabel,
- StackUsage, HeapUsage,
+ StackUsage, Slot(..), HeapUsage,
profCtrC, cgPanic,
@@ -182,9 +182,11 @@ sequelToAmode (SeqFrame _ _) = cgPanic (text "sequelToAmode: SeqFrame")
type CgStksAndHeapUsage -- stacks and heap usage information
= (StackUsage, HeapUsage)
+data Slot = Free | NonPointer deriving (Eq,Show)
+
type StackUsage =
(Int, -- virtSp: Virtual offset of topmost allocated slot
- [Int], -- free: List of free slots, in increasing order
+ [(Int,Slot)], -- free: List of free slots, in increasing order
Int, -- realSp: Virtual offset of real stack pointer
Int) -- hwSp: Highest value ever taken by virtSp
@@ -203,9 +205,7 @@ Initialisation.
initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
initUsage :: CgStksAndHeapUsage
-initUsage = ((0,[],0,0), (initVirtHp, initRealHp))
-initVirtHp = panic "Uninitialised virtual Hp"
-initRealHp = panic "Uninitialised real Hp"
+initUsage = ((0,[],0,0), (0,0))
\end{code}
"envInitForAlternatives" initialises the environment for a case alternative,
@@ -462,8 +462,7 @@ forkEvalHelp body_eob_info env_code body_code
state_for_body = MkCgState AbsCNop
(nukeVolatileBinds binds)
- ((v,f,v,v),
- (initVirtHp, initRealHp))
+ ((v,f,v,v), (0,0))
stateIncUsageEval :: CgState -> CgState -> CgState
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index 41ec06a885ef..a5479fe3c9e4 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.10 1998/12/18 17:40:53 simonpj Exp $
+% $Id: CgStackery.lhs,v 1.11 1999/06/08 15:56:47 simonmar Exp $
%
\section[CgStackery]{Stack management functions}
@@ -11,10 +11,9 @@ Stack-twiddling operations, which are pretty low-down and grimy.
\begin{code}
module CgStackery (
allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
- allocUpdateFrame,
- adjustRealSp, adjustStackHW, getFinalStackHW,
+ adjustStackHW, getFinalStackHW,
mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts,
- freeStackSlots, addFreeSlots
+ freeStackSlots, dataStackSlots, addFreeSlots
) where
#include "HsVersions.h"
@@ -26,6 +25,7 @@ import CgUsages ( getRealSp )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import Panic ( panic )
+import IOExts ( trace )
\end{code}
%************************************************************************
@@ -152,21 +152,29 @@ allocPrimStack size info_down (MkCgState absC binds
delete_block free_stk slot, real_sp, hw_sp))
-- find_block looks for a contiguous chunk of free slots
- find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset
+ find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
find_block [] = Nothing
- find_block (slot:slots)
- | take size (slot:slots) == [slot..top_slot] = Just top_slot
+ find_block ((off,free):slots)
+ | take size ((off,free):slots) ==
+ zip [off..top_slot] (repeat Free) = Just top_slot
| otherwise = find_block slots
-- The stack grows downwards, with increasing virtual offsets.
-- Therefore, the address of a multi-word object is the *highest*
-- virtual offset it occupies (top_slot below).
- where top_slot = slot+size-1
+ where top_slot = off+size-1
- delete_block free_stk slot = [s | s <- free_stk, (s<=slot-size) || (s>slot)]
+ delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
+ (s<=slot-size) || (s>slot) ]
-- Retain slots which are not in the range
-- slot-size+1..slot
+\end{code}
+
+Allocate a chunk ON TOP OF the stack.
--- Allocate a chunk ON TOP OF the stack
+ToDo: should really register this memory as NonPointer stuff in the
+free list.
+
+\begin{code}
allocStackTop :: Int -> FCode VirtualSpOffset
allocStackTop size info_down (MkCgState absC binds
((virt_sp, free_stk, real_sp, hw_sp), h_usage))
@@ -190,33 +198,6 @@ deAllocStackTop size info_down (MkCgState absC binds
new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
\end{code}
-@allocUpdateFrame@ allocates enough space for an update frame on the
-stack, records the fact in the end-of-block info (in the ``args''
-fields), and passes on the old ``args'' fields to the enclosed code.
-
-This is all a bit disgusting.
-
-\begin{code}
-allocUpdateFrame :: Int -- Size of frame
- -> Code -- Scope of update
- -> Code
-
-allocUpdateFrame size code
- (MkCgInfoDown c_info statics srt (EndOfBlockInfo args_Sp sequel))
- (MkCgState absc binds ((vSp,rr,qq,hwSp),h_usage))
- = case sequel of
-
- OnStack _ -> code (MkCgInfoDown c_info statics srt new_eob_info)
- (MkCgState absc binds new_usage)
-
- other -> panic "allocUpdateFrame"
-
- where
- new_vSp = vSp + size
- new_eob_info = EndOfBlockInfo new_vSp UpdateCode
- new_usage = ((new_vSp,rr,qq,hwSp `max` new_vSp), h_usage)
-\end{code}
-
\begin{code}
adjustStackHW :: VirtualSpOffset -> Code
adjustStackHW offset info_down (MkCgState absC binds usage)
@@ -239,34 +220,6 @@ getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
\end{code}
-%************************************************************************
-%* *
-\subsection[CgStackery-adjust]{Adjusting the stack pointers}
-%* *
-%************************************************************************
-
-@adjustRealSpX@ generates code to alter the actual stack pointer, and
-adjusts the environment accordingly. We are careful to push the
-conditional inside the abstract C code to avoid black holes.
-ToDo: combine together?
-
-These functions {\em do not} deal with high-water-mark adjustment.
-That's done by functions which allocate stack space.
-
-\begin{code}
-adjustRealSp :: VirtualSpOffset -- New offset for Arg stack ptr
- -> Code
-adjustRealSp newRealSp info_down (MkCgState absC binds
- ((vSp,fSp,realSp,hwSp), h_usage))
- = MkCgState (mkAbsCStmts absC move_instr) binds new_usage
- where
- move_instr = if (newRealSp == realSp) then AbsCNop
- else (CAssign
- (CReg Sp)
- (CAddr (spRel realSp newRealSp)))
- new_usage = ((vSp, fSp, newRealSp, hwSp), h_usage)
-\end{code}
-
%************************************************************************
%* *
\subsection[CgStackery-free]{Free stack slots}
@@ -276,37 +229,51 @@ adjustRealSp newRealSp info_down (MkCgState absC binds
Explicitly free some stack space.
\begin{code}
-freeStackSlots :: [VirtualSpOffset] -> Code
-freeStackSlots extra_free info_down
+addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
+addFreeStackSlots extra_free slot info_down
state@(MkCgState abs_c binds ((vsp, free, real, hw), heap_usage))
= MkCgState abs_c binds new_usage
where
new_usage = ((new_vsp, new_free, real, hw), heap_usage)
- (new_vsp, new_free) = trim vsp (addFreeSlots free extra_free)
+ (new_vsp, new_free) = trim vsp all_free
+ all_free = addFreeSlots free (zip extra_free (repeat slot))
+
+freeStackSlots :: [VirtualSpOffset] -> Code
+freeStackSlots slots = addFreeStackSlots slots Free
-addFreeSlots :: [Int] -> [Int] -> [Int]
+dataStackSlots :: [VirtualSpOffset] -> Code
+dataStackSlots slots = addFreeStackSlots slots NonPointer
+
+addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
addFreeSlots cs [] = cs
addFreeSlots [] ns = ns
-addFreeSlots (c:cs) (n:ns)
+addFreeSlots ((c,s):cs) ((n,s'):ns)
= if c < n then
- c : addFreeSlots cs (n:ns)
+ (c,s) : addFreeSlots cs ((n,s'):ns)
else if c > n then
- n : addFreeSlots (c:cs) ns
+ (n,s') : addFreeSlots ((c,s):cs) ns
+ else if s /= s' then -- c == n
+ (c,s') : addFreeSlots cs ns
else
- panic ("addFreeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
+ panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
+ ++ show (n:map fst ns))
-trim :: Int{-offset-} -> [Int] -> (Int{-offset-}, [Int])
+trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
trim current_sp free_slots
- = try current_sp (reverse free_slots)
+ = try current_sp free_slots
where
- try csp [] = (csp, [])
- try csp (slot:slots)
- = if csp < slot then
- try csp slots -- Free slot off top of stk; ignore
-
- else if csp == slot then
- try (csp-1) slots -- Free slot at top of stk; trim
-
- else
- (csp, reverse (slot:slots)) -- Otherwise gap; give up
+ try csp [] = (csp,[])
+
+ try csp (slot@(off,state):slots) =
+ if state == Free && null slots' then
+ if csp' < off then
+ (csp', [])
+ else if csp' == off then
+ (csp'-1, [])
+ else
+ (csp',[slot])
+ else
+ (csp', slot:slots')
+ where
+ (csp',slots') = try csp slots
\end{code}
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 96ceff561b5c..e98f66b39a41 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.20 1999/05/28 19:24:28 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.21 1999/06/08 15:56:48 simonmar Exp $
%
%********************************************************
%* *
@@ -35,8 +35,8 @@ import CgRetConv ( dataReturnConvPrim,
ctrlReturnConvAlg, CtrlReturnConvention(..),
assignAllRegs, assignRegs
)
-import CgStackery ( adjustRealSp, mkTaggedStkAmodes, adjustStackHW )
-import CgUsages ( getSpRelOffset )
+import CgStackery ( mkTaggedStkAmodes, adjustStackHW )
+import CgUsages ( getSpRelOffset, adjustSpAndHp )
import CgUpdate ( pushSeqFrame )
import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel )
import ClosureInfo ( nodeMustPointToIt,
@@ -266,8 +266,8 @@ performReturn sim_assts finish_code
-- stack location)
pushReturnAddress eob `thenC`
- -- Adjust stack pointer
- adjustRealSp args_sp `thenC`
+ -- Adjust Sp/Hp
+ adjustSpAndHp args_sp `thenC`
-- Do the return
finish_code sequel -- "sequel" is `robust' in that it doesn't
@@ -299,8 +299,8 @@ returnUnboxedTuple amodes before_jump
pushReturnAddress eob `thenC`
setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
- -- Adjust stack pointer
- adjustRealSp args_sp `thenC`
+ -- Adjust Sp/Hp
+ adjustSpAndHp args_sp `thenC`
before_jump `thenC`
@@ -458,8 +458,8 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
then nopC
else pushReturnAddress eob) `thenC`
- -- Final adjustment of stack pointer
- adjustRealSp final_sp `thenC`
+ -- Final adjustment of Sp/Hp
+ adjustSpAndHp final_sp `thenC`
-- Now decide about semi-tagging
let
diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs
index 1eec8f6be916..621e480ffa25 100644
--- a/ghc/compiler/codeGen/CgUpdate.lhs
+++ b/ghc/compiler/codeGen/CgUpdate.lhs
@@ -13,8 +13,8 @@ import AbsCSyn
import Constants ( uF_SIZE, sCC_UF_SIZE, sEQ_FRAME_SIZE, sCC_SEQ_FRAME_SIZE )
import PrimRep ( PrimRep(..) )
-import CgStackery ( allocUpdateFrame )
-import CgUsages ( getSpRelOffset )
+import CgStackery ( allocStackTop )
+import CgUsages ( getVirtSp, getSpRelOffset )
import CmdLineOpts ( opt_SccProfilingOn )
import Panic ( assertPanic )
\end{code}
@@ -44,21 +44,26 @@ pushUpdateFrame updatee code
then sCC_UF_SIZE
else uF_SIZE
in
+#ifdef DEBUG
getEndOfBlockInfo `thenFC` \ eob_info ->
ASSERT(case eob_info of { EndOfBlockInfo _ (OnStack _) -> True;
_ -> False})
- allocUpdateFrame frame_size (
+#endif
+
+ allocStackTop frame_size `thenFC` \ _ ->
+ getVirtSp `thenFC` \ vsp ->
+
+ setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) (
-- Emit the push macro
absC (CMacroStmt PUSH_UPD_FRAME [
updatee,
- int_CLit0 -- Known to be zero because we have just
+ int_CLit0 -- we just entered a closure, so must be zero
])
`thenC` code
)
int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh)
-
\end{code}
We push a SEQ frame just before evaluating the scrutinee of a case, if
diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index a3fd37a0742d..ce20791ee7d4 100644
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -13,13 +13,15 @@ module CgUsages (
getVirtSp, getRealSp,
- getHpRelOffset, getSpRelOffset
+ getHpRelOffset, getSpRelOffset,
+
+ adjustSpAndHp
) where
#include "HsVersions.h"
-import AbsCSyn ( RegRelative(..), VirtualHeapOffset, VirtualSpOffset,
- hpRel, spRel )
+import AbsCSyn
+import AbsCUtils ( mkAbstractCs )
import CgMonad
\end{code}
@@ -121,3 +123,39 @@ 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}
+adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr
+ -> Code
+adjustSpAndHp newRealSp info_down (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)))
+
+ move_hp = if (rHp == vHp) then AbsCNop
+ else (CAssign (CReg Hp)
+ (CAddr (hpRel rHp vHp)))
+
+ new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp))
+\end{code}
--
GitLab