Commit 62812240 authored by simonmar's avatar simonmar
Browse files

[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.
parent 52d1681a
......@@ -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.
......
%
% (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
......
%
% (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))
......
%
% (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!
......
%
% (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
......
%
% (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}
%
% (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
......
......@@ -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
......
......@@ -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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment