X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgStackery.lhs;h=2dddb3d34fc5bd1f21d0dbfc7c522353b807fe09;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=3759aa41e44ffe5fb81d7d40a637e6164699b300;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 3759aa4..2dddb3d 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,5 +1,7 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (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} @@ -7,102 +9,142 @@ Stack-twiddling operations, which are pretty low-down and grimy. (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 - - -- and to make the interface self-sufficient... + spRel, getVirtSp, getRealSp, setRealSp, + setRealAndVirtualSp, getSpRelOffset, + + allocPrimStack, allocStackTop, deAllocStackTop, + adjustStackHW, getFinalStackHW, + setStackFrame, getStackFrame, + mkVirtStkOffsets, mkStkAmodes, + freeStackSlots, + pushUpdateFrame, emitPushUpdateFrame, ) where -import StgSyn -import CgMonad -import AbsCSyn +#include "HsVersions.h" -import CgUsages ( getSpBRelOffset ) -import Maybes ( Maybe(..) ) -import PrimRep ( getPrimRepSize, retPrimRepSize, separateByPtrFollowness ) -import Util +import CgMonad +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} %************************************************************************ @@ -112,152 +154,186 @@ mkStkAmodes tail_spa tail_spb things %************************************************************************ 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 - - (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 + size :: WordOff + size = cgRepSizeW rep - 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+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. + +\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} -This is all a bit disgusting. +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}