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.
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
-- 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 $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre, freeCostCentreSlot
+module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
) where
#include "HsVersions.h"
CtrlReturnConvention(..)
)
import CgStackery ( allocPrimStack, allocStackTop,
- deAllocStackTop, freeStackSlots
+ deAllocStackTop, freeStackSlots, dataStackSlots
)
import CgTailCall ( tailCallFun )
import CgUsages ( getSpRelOffset, getRealSp )
=
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
-- 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`
= 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}
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,
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 $
%
%********************************************************
%* *
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 )
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}
setSRTLabel, getSRTLabel,
- StackUsage, HeapUsage,
+ StackUsage, Slot(..), HeapUsage,
profCtrC, cgPanic,
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
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,
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}
\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"
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import Panic ( panic )
+import IOExts ( trace )
\end{code}
%************************************************************************
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))
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)
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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 $
%
%********************************************************
%* *
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,
-- 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
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`
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
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}
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
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}
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}
projects / ghc-hetmet.git / commitdiff