%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgStackery.lhs,v 1.26 2004/08/17 15:23:48 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
(This is the module that knows all about stack layouts, etc.)
\begin{code}
-#include "HsVersions.h"
-
module CgStackery (
- allocAStack, allocBStack, allocUpdateFrame,
- adjustRealSps, getFinalStackHW,
- mkVirtStkOffsets, mkStkAmodes
+ spRel, getVirtSp, getRealSp, setRealSp,
+ setRealAndVirtualSp, getSpRelOffset,
+
+ allocPrimStack, allocStackTop, deAllocStackTop,
+ adjustStackHW, getFinalStackHW,
+ setStackFrame, getStackFrame,
+ mkVirtStkOffsets, mkStkAmodes,
+ freeStackSlots,
+ pushUpdateFrame, emitPushUpdateFrame,
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
import CgMonad
-import AbsCSyn
-
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
-import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) )
-import PrimRep ( getPrimRepSize, separateByPtrFollowness,
- PrimRep(..)
- )
-import Util ( mapAccumR, panic )
+import CgUtils ( cmmOffsetB, cmmRegOffW )
+import CgProf ( initUpdFrameProf )
+import SMRep
+import Cmm
+import CmmUtils ( CmmStmts, mkLblExpr )
+import CLabel ( mkUpdInfoLabel )
+import Constants
+import Util ( sortLe )
+import FastString ( LitString )
+import OrdList ( toOL )
+import Outputable
\end{code}
%************************************************************************
%* *
-\subsection[CgStackery-layout]{Laying out a stack frame}
+\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage}
%* *
%************************************************************************
-@mkVirtStkOffsets@ is given a list of arguments. The first argument
-gets the {\em largest} virtual stack offset (remember, virtual offsets
-increase towards the top of stack).
+spRel is a little function that abstracts the stack direction. Note that most
+of the code generator is dependent on the stack direction anyway, so
+changing this on its own spells certain doom. ToDo: remove?
-\begin{code}
-mkVirtStkOffsets :: VirtualSpAOffset -- Offset of the last allocated thing
- -> VirtualSpBOffset -- ditto
- -> (a -> PrimRep) -- to be able to grab kinds
- -> [a] -- things to make offsets for
- -> (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
- VirtualSpBOffset, -- ditto
- [(a, VirtualSpAOffset)], -- boxed things with offsets
- [(a, VirtualSpBOffset)]) -- unboxed things with offsets
-
-mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
- = let (boxeds, unboxeds)
- = separateByPtrFollowness kind_fun things
- (last_SpA_offset, boxd_w_offsets)
- = mapAccumR computeOffset init_SpA_offset boxeds
- (last_SpB_offset, ubxd_w_offsets)
- = mapAccumR computeOffset init_SpB_offset unboxeds
- in
- (last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
- where
- computeOffset offset thing
- = (offset + (getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
-\end{code}
+ THIS IS DIRECTION SENSITIVE!
-@mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
-It starts from the tail-call locations.
-It returns a single list of addressing modes for the stack locations,
-and therefore is in the monad.
-
-It also adjusts the high water mark if necessary.
+Stack grows down, positive virtual offsets correspond to negative
+additions to the stack pointer.
\begin{code}
-mkStkAmodes :: VirtualSpAOffset -- Tail call positions
- -> VirtualSpBOffset
- -> [CAddrMode] -- things to make offsets for
- -> FCode (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
- VirtualSpBOffset, -- ditto
- AbstractC) -- Assignments to appropriate stk slots
-
-mkStkAmodes tail_spa tail_spb things
- info_down (MkCgState absC binds usage)
- = (result, MkCgState absC binds new_usage)
- where
- result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
+spRel :: VirtualSpOffset -- virtual offset of Sp
+ -> VirtualSpOffset -- virtual offset of The Thing
+ -> WordOff -- integer offset
+spRel sp off = sp - off
+\end{code}
- (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
- = mkVirtStkOffsets tail_spa tail_spb getAmodeRep things
+@setRealAndVirtualSp@ sets into the environment the offsets of the
+current position of the real and virtual stack pointers in the current
+stack frame. The high-water mark is set too. It generates no code.
+It is used to initialise things at the beginning of a closure body.
- abs_cs
- = [ CAssign (CVal (SpARel realSpA offset) PtrRep) thing
- | (thing, offset) <- ptrs_w_offsets
- ]
- ++
- [ CAssign (CVal (SpBRel realSpB offset) (getAmodeRep thing)) thing
- | (thing, offset) <- non_ptrs_w_offsets
- ]
+\begin{code}
+setRealAndVirtualSp :: VirtualSpOffset -- New real Sp
+ -> Code
+
+setRealAndVirtualSp new_sp
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg {virtSp = new_sp,
+ realSp = new_sp,
+ hwSp = new_sp}) }
+
+getVirtSp :: FCode VirtualSpOffset
+getVirtSp
+ = do { stk_usg <- getStkUsage
+ ; return (virtSp stk_usg) }
+
+getRealSp :: FCode VirtualSpOffset
+getRealSp
+ = do { stk_usg <- getStkUsage
+ ; return (realSp stk_usg) }
+
+setRealSp :: VirtualSpOffset -> Code
+setRealSp new_real_sp
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg {realSp = new_real_sp}) }
+
+getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr
+getSpRelOffset virtual_offset
+ = do { real_sp <- getRealSp
+ ; return (cmmRegOffW spReg (spRel real_sp virtual_offset)) }
+\end{code}
- ((vspA,fspA,realSpA,hwSpA), (vspB,fspB,realSpB,hwSpB), h_usage) = usage
- new_usage = ((vspA,fspA,realSpA,max last_SpA_offset hwSpA),
- (vspB,fspB,realSpB,max last_SpB_offset hwSpB),
- h_usage)
- -- No need to fiddle with virtual SpA etc because this call is
- -- only done just before the end of a block
+%************************************************************************
+%* *
+\subsection[CgStackery-layout]{Laying out a stack frame}
+%* *
+%************************************************************************
+'mkVirtStkOffsets' is given a list of arguments. The first argument
+gets the /largest/ virtual stack offset (remember, virtual offsets
+increase towards the top of stack).
+\begin{code}
+mkVirtStkOffsets
+ :: VirtualSpOffset -- Offset of the last allocated thing
+ -> [(CgRep,a)] -- things to make offsets for
+ -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
+ [(a, VirtualSpOffset)]) -- things with offsets (voids filtered out)
+
+mkVirtStkOffsets init_Sp_offset things
+ = loop init_Sp_offset [] (reverse things)
+ where
+ loop offset offs [] = (offset,offs)
+ loop offset offs ((VoidArg,t):things) = loop offset offs things
+ -- ignore Void arguments
+ loop offset offs ((rep,t):things)
+ = loop thing_slot ((t,thing_slot):offs) things
+ where
+ thing_slot = offset + cgRepSizeW rep
+ -- offset of thing is offset+size, because we're
+ -- growing the stack *downwards* as the offsets increase.
+
+-- | 'mkStkAmodes' is a higher-level version of
+-- 'mkVirtStkOffsets'. It starts from the tail-call locations.
+-- It returns a single list of addressing modes for the stack
+-- locations, and therefore is in the monad. It /doesn't/ adjust the
+-- high water mark.
+
+mkStkAmodes
+ :: VirtualSpOffset -- Tail call positions
+ -> [(CgRep,CmmExpr)] -- things to make offsets for
+ -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
+ CmmStmts) -- Assignments to appropriate stk slots
+
+mkStkAmodes tail_Sp things
+ = do { rSp <- getRealSp
+ ; let (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp things
+ abs_cs = [ CmmStore (cmmRegOffW spReg (spRel rSp offset)) amode
+ | (amode, offset) <- offsets
+ ]
+ ; returnFC (last_Sp_offset, toOL abs_cs) }
\end{code}
%************************************************************************
%************************************************************************
Allocate a virtual offset for something.
-\begin{code}
-allocAStack :: FCode VirtualSpAOffset
-allocAStack info_down (MkCgState absC binds
- ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
- = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
- where
- push_virt_a = virt_a + 1
-
- (chosen_slot, new_a_usage)
- = if null free_a then
- -- No free slots, so push a new one
- -- We need to adjust the high-water mark
- (push_virt_a, (push_virt_a, [], real_a, hw_a `max` push_virt_a))
- else
- -- Free slots available, so use one
- (free_slot, (virt_a, new_free_a, real_a, hw_a))
-
- (free_slot, _) = head ([f | f@(slot, st) <- free_a, not (isStubbed st)] ++ free_a)
- -- Try to find an un-stubbed location;
- -- if none, return the first in the free list
- -- We'll only try this if free_a is known to be non-empty
-
- -- Free list with the free_slot deleted
- new_free_a = [ f | f@(s,_) <- free_a, s /= free_slot ]
-
-allocBStack :: Int -> FCode VirtualSpBOffset
-allocBStack size info_down (MkCgState absC binds
- (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
- = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
+\begin{code}
+allocPrimStack :: CgRep -> FCode VirtualSpOffset
+allocPrimStack rep
+ = do { stk_usg <- getStkUsage
+ ; let free_stk = freeStk stk_usg
+ ; case find_block free_stk of
+ Nothing -> do
+ { let push_virt_sp = virtSp stk_usg + size
+ ; setStkUsage (stk_usg { virtSp = push_virt_sp,
+ hwSp = hwSp stk_usg `max` push_virt_sp })
+ -- Adjust high water mark
+ ; return push_virt_sp }
+ Just slot -> do
+ { setStkUsage (stk_usg { freeStk = delete_block free_stk slot })
+ ; return slot }
+ }
where
- push_virt_b = virt_b + size
+ size :: WordOff
+ size = cgRepSizeW rep
- (chosen_slot, new_b_usage)
- = case find_block free_b of
- Nothing -> (virt_b+1, (push_virt_b, free_b, real_b,
- hw_b `max` push_virt_b))
- -- Adjust high water mark
-
- Just slot -> (slot, (virt_b, delete_block free_b slot, real_b, hw_b))
-
- -- find_block looks for a contiguous chunk of free slots
- find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset
+ -- Find_block looks for a contiguous chunk of free slots
+ -- returning the offset of its topmost word
+ find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset
find_block [] = Nothing
find_block (slot:slots)
- | take size (slot:slots) == [slot..slot+size-1]
- = Just slot
- | otherwise
- = find_block slots
-
- delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
- -- Retain slots which are not in the range
- -- slot..slot+size-1
+ | take size (slot:slots) == [slot..top_slot]
+ = Just top_slot
+ | otherwise
+ = find_block slots
+ where -- 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).
+ top_slot = slot+size-1
+
+ delete_block free_stk slot = [ s | s <- free_stk,
+ (s<=slot-size) || (s>slot) ]
+ -- Retain slots which are not in the range
+ -- slot-size+1..slot
\end{code}
-@allocUpdateFrame@ allocates enough space for an update frame
-on the B 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.
+Allocate a chunk ON TOP OF the stack.
-This is all a bit disgusting.
+\begin{code}
+allocStackTop :: WordOff -> FCode VirtualSpOffset
+allocStackTop size
+ = do { stk_usg <- getStkUsage
+ ; let push_virt_sp = virtSp stk_usg + size
+ ; setStkUsage (stk_usg { virtSp = push_virt_sp,
+ hwSp = hwSp stk_usg `max` push_virt_sp })
+ ; return push_virt_sp }
+\end{code}
+
+Pop some words from the current top of stack. This is used for
+de-allocating the return address in a case alternative.
\begin{code}
-allocUpdateFrame :: Int -- Size of frame
- -> CAddrMode -- Return address which is to be the
- -- top word of frame
- -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
- -- Scope of update
- -> Code
+deAllocStackTop :: WordOff -> FCode VirtualSpOffset
+deAllocStackTop size
+ = do { stk_usg <- getStkUsage
+ ; let pop_virt_sp = virtSp stk_usg - size
+ ; setStkUsage (stk_usg { virtSp = pop_virt_sp })
+ ; return pop_virt_sp }
+\end{code}
-allocUpdateFrame size update_amode code
- (MkCgInfoDown c_info statics (EndOfBlockInfo args_spa args_spb sequel))
- (MkCgState absc binds (a_usage, (vB,rr,qq,hwB),h_usage))
- = case sequel of
+\begin{code}
+adjustStackHW :: VirtualSpOffset -> Code
+adjustStackHW offset
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg { hwSp = hwSp stk_usg `max` offset }) }
+\end{code}
- InRetReg -> code (args_spa, args_spb, vB)
- (MkCgInfoDown c_info statics new_eob_info)
- (MkCgState absc binds new_usage)
+A knot-tying beast.
- other -> panic "allocUpdateFrame"
+\begin{code}
+getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
+getFinalStackHW fcode
+ = do { fixC (\hw_sp -> do
+ { fcode hw_sp
+ ; stk_usg <- getStkUsage
+ ; return (hwSp stk_usg) })
+ ; return () }
+\end{code}
- where
- new_vB = vB + size
- new_eob_info = EndOfBlockInfo args_spa new_vB (UpdateCode update_amode)
- new_usage = (a_usage, (new_vB,rr,qq,hwB `max` new_vB), h_usage)
+\begin{code}
+setStackFrame :: VirtualSpOffset -> Code
+setStackFrame offset
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg { frameSp = offset }) }
+
+getStackFrame :: FCode VirtualSpOffset
+getStackFrame
+ = do { stk_usg <- getStkUsage
+ ; return (frameSp stk_usg) }
\end{code}
-A knot-tying beast.
+%********************************************************
+%* *
+%* Setting up update frames *
+%* *
+%********************************************************
+
+@pushUpdateFrame@ $updatee$ pushes a general update frame which
+points to $updatee$ as the thing to be updated. It is only used
+when a thunk has just been entered, so the (real) stack pointers
+are guaranteed to be nicely aligned with the top of stack.
+@pushUpdateFrame@ adjusts the virtual and tail stack pointers
+to reflect the frame pushed.
\begin{code}
-getFinalStackHW :: (VirtualSpAOffset -> VirtualSpBOffset -> Code) -> Code
-getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
- where
- state1 = fcode hwSpA hwSpB info_down (MkCgState absC binds usages)
- (MkCgState _ _ ((_,_,_, hwSpA), (_,_,_, hwSpB), _)) = state1
-\end{code}
+pushUpdateFrame :: CmmExpr -> Code -> Code
+
+pushUpdateFrame updatee code
+ = do {
+#ifdef DEBUG
+ EndOfBlockInfo _ sequel <- getEndOfBlockInfo ;
+ ASSERT(case sequel of { OnStack -> True; _ -> False})
+#endif
+
+ allocStackTop (fixedHdrSize +
+ sIZEOF_StgUpdateFrame_NoHdr `quot` wORD_SIZE)
+ ; vsp <- getVirtSp
+ ; setStackFrame vsp
+ ; frame_addr <- getSpRelOffset vsp
+ -- The location of the lowest-address
+ -- word of the update frame itself
+
+ ; setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) $
+ do { emitPushUpdateFrame frame_addr updatee
+ ; code }
+ }
+
+emitPushUpdateFrame :: CmmExpr -> CmmExpr -> Code
+emitPushUpdateFrame frame_addr updatee = do
+ stmtsC [ -- Set the info word
+ CmmStore frame_addr (mkLblExpr mkUpdInfoLabel)
+ , -- And the updatee
+ CmmStore (cmmOffsetB frame_addr off_updatee) updatee ]
+ initUpdFrameProf frame_addr
+
+off_updatee :: ByteOff
+off_updatee = fixedHdrSize*wORD_SIZE + oFFSET_StgUpdateFrame_updatee
+\end{code}
%************************************************************************
%* *
-\subsection[CgStackery-adjust]{Adjusting the stack pointers}
+\subsection[CgStackery-free]{Free stack slots}
%* *
%************************************************************************
-@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.
+Explicitly free some stack space.
\begin{code}
-adjustRealSpA :: VirtualSpAOffset -- New offset for Arg stack ptr
- -> Code
-adjustRealSpA newRealSpA info_down (MkCgState absC binds
- ((vspA,fA,realSpA,hwspA),
- b_usage, h_usage))
- = MkCgState (mkAbsCStmts absC move_instrA) binds new_usage
- where
- move_instrA = if (newRealSpA == realSpA) then AbsCNop
- else (CAssign
- (CReg SpA)
- (CAddr (SpARel realSpA newRealSpA)))
- new_usage = ((vspA, fA, newRealSpA, hwspA),
- b_usage, h_usage)
-
-adjustRealSpB :: VirtualSpBOffset -- New offset for Basic/Control stack ptr
- -> Code
-adjustRealSpB newRealSpB info_down (MkCgState absC binds
- (a_usage,
- (vspB,fB,realSpB,hwspB),
- h_usage))
- = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
- where
- move_instrB = if (newRealSpB == realSpB) then AbsCNop
- else (CAssign {-PtrRep-}
- (CReg SpB)
- (CAddr (SpBRel realSpB newRealSpB)))
- new_usage = (a_usage,
- (vspB, fB, newRealSpB, hwspB),
- h_usage)
-
-adjustRealSps :: VirtualSpAOffset -- New offset for Arg stack ptr
- -> VirtualSpBOffset -- Ditto B stack
- -> Code
-adjustRealSps newRealSpA newRealSpB
- = adjustRealSpA newRealSpA `thenC` adjustRealSpB newRealSpB
+freeStackSlots :: [VirtualSpOffset] -> Code
+freeStackSlots extra_free
+ = do { stk_usg <- getStkUsage
+ ; let all_free = addFreeSlots (freeStk stk_usg) (sortLe (<=) extra_free)
+ ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free
+ ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) }
+
+addFreeSlots :: [VirtualSpOffset] -> [VirtualSpOffset] -> [VirtualSpOffset]
+-- Merge the two, assuming both are in increasing order
+addFreeSlots cs [] = cs
+addFreeSlots [] ns = ns
+addFreeSlots (c:cs) (n:ns)
+ | c < n = c : addFreeSlots cs (n:ns)
+ | otherwise = n : addFreeSlots (c:cs) ns
+
+trim :: VirtualSpOffset -> [VirtualSpOffset] -> (VirtualSpOffset, [VirtualSpOffset])
+-- Try to trim back the virtual stack pointer, where there is a
+-- continuous bunch of free slots at the end of the free list
+trim vsp [] = (vsp, [])
+trim vsp (slot:slots)
+ = case trim vsp slots of
+ (vsp', [])
+ | vsp' < slot -> pprTrace "trim: strange" (ppr vsp <+> ppr (slot:slots))
+ (vsp', [])
+ | vsp' == slot -> (vsp'-1, [])
+ | otherwise -> (vsp', [slot])
+ (vsp', slots') -> (vsp', slot:slots')
\end{code}
projects / ghc-hetmet.git / blobdiff