X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgStackery.lhs;h=12b96a8cd1a564ed8004e60ddf2026db69257fae;hb=ba2843abdfe6f055777e4e66e8add769fce31d29;hp=a5479fe3c9e45f34d95cd4784e4061300d0b9806;hpb=6281224046c9fc2bba358d42c7688a8314dc5bb6;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index a5479fe..12b96a8 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.11 1999/06/08 15:56:47 simonmar Exp $ +% $Id: CgStackery.lhs,v 1.23 2002/12/11 15:36:27 simonmar Exp $ % \section[CgStackery]{Stack management functions} @@ -11,21 +11,30 @@ Stack-twiddling operations, which are pretty low-down and grimy. \begin{code} module CgStackery ( allocStack, allocPrimStack, allocStackTop, deAllocStackTop, - adjustStackHW, getFinalStackHW, - mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts, - freeStackSlots, dataStackSlots, addFreeSlots + adjustStackHW, getFinalStackHW, + setStackFrame, getStackFrame, + mkVirtStkOffsets, mkStkAmodes, + freeStackSlots, dataStackSlots, addFreeSlots, + updateFrameSize, + constructSlowCall, slowArgs, ) where #include "HsVersions.h" import CgMonad import AbsCSyn +import CLabel ( mkRtsApplyInfoLabel, mkRtsApplyEntryLabel ) import CgUsages ( getRealSp ) -import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep ) -import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep ) -import Panic ( panic ) -import IOExts ( trace ) +import AbsCUtils ( mkAbstractCs, getAmodeRep ) +import PrimRep +import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) +import Constants +import Util ( sortLt ) +import FastString ( LitString ) +import Panic + +import TRACE ( trace ) \end{code} %************************************************************************ @@ -34,93 +43,121 @@ import IOExts ( trace ) %* * %************************************************************************ -@mkTaggedVirtStkOffsets@ 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). This function -also computes the correct tagging arrangement for standard function -entry points. Each non-pointer on the stack is preceded by a tag word -indicating the number of non-pointer words above it on the stack. - - offset --> | | <---- last allocated stack word - --------- < - | | . - --------- . - | | total_nptrs (words) - --------- . - | | . - --------- < -offset + tot_nptrs + 1 --> | tag | - --------- +'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} -mkTaggedVirtStkOffsets +mkVirtStkOffsets :: VirtualSpOffset -- Offset of the last allocated thing -> (a -> PrimRep) -- to be able to grab kinds -> [a] -- things to make offsets for -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word - [(a, VirtualSpOffset)], -- things with offsets - [(VirtualSpOffset,Int)]) -- offsets for tags + [(a, VirtualSpOffset)]) -- things with offsets -mkTaggedVirtStkOffsets init_Sp_offset kind_fun things - = loop init_Sp_offset [] [] (reverse things) +mkVirtStkOffsets init_Sp_offset kind_fun things + = loop init_Sp_offset [] (reverse things) where - loop offset tags offs [] = (offset,offs,tags) - loop offset tags offs (t:things) - | isFollowableRep (kind_fun t) = - loop (offset+1) tags ((t,offset+1):offs) things - | otherwise = + loop offset offs [] = (offset,offs) + loop offset offs (t:things) = let size = getPrimRepSize (kind_fun t) - tag_slot = offset+size+1 + thing_slot = offset + size in - loop tag_slot ((tag_slot,size):tags) ((t,offset+size):offs) things + loop thing_slot ((t,thing_slot):offs) things -- offset of thing is offset+size, because we're growing the stack -- *downwards* as the offsets increase. -\end{code} -@mkTaggedStkAmodes@ is a higher-level version of -@mkTaggedVirtStkOffsets@. 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' 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. -\begin{code} -mkTaggedStkAmodes +mkStkAmodes :: VirtualSpOffset -- Tail call positions -> [CAddrMode] -- things to make offsets for -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word - AbstractC, -- Assignments to appropriate stk slots - AbstractC) -- Assignments for tagging + AbstractC) -- Assignments to appropriate stk slots -mkTaggedStkAmodes tail_Sp things +mkStkAmodes tail_Sp things = getRealSp `thenFC` \ realSp -> let - (last_Sp_offset, offsets, tags) - = mkTaggedVirtStkOffsets tail_Sp getAmodeRep things + (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp getAmodeRep things abs_cs = [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing | (thing, offset) <- offsets ] - - tag_cs = - [ CAssign (CVal (spRel realSp offset) WordRep) - (CMacroExpr WordRep ARG_TAG [mkIntCLit size]) - | (offset,size) <- tags - ] in - returnFC (last_Sp_offset, mkAbstractCs abs_cs, mkAbstractCs tag_cs) + returnFC (last_Sp_offset, mkAbstractCs abs_cs) +\end{code} + +%************************************************************************ +%* * +\subsection{Pushing the arguments for a slow call} +%* * +%************************************************************************ -mkTagAssts :: [(VirtualSpOffset,Int)] -> FCode AbstractC -mkTagAssts tags = - getRealSp `thenFC` \realSp -> - returnFC (mkAbstractCs - [ CAssign (CVal (spRel realSp offset) WordRep) - (CMacroExpr WordRep ARG_TAG [mkIntCLit size]) - | (offset,size) <- tags - ]) +For a slow call, we must take a bunch of arguments and intersperse +some stg_ap__ret_info return addresses. +\begin{code} +constructSlowCall :: [CAddrMode] -> (CAddrMode, [CAddrMode]) + -- don't forget the zero case +constructSlowCall [] = (CLbl stg_ap_0 CodePtrRep , []) +constructSlowCall amodes = + -- traceSlowCall amodes $ + (CLbl lbl CodePtrRep, these ++ slowArgs rest) + where (tag, these, rest) = matchSlowPattern amodes + lbl = mkRtsApplyEntryLabel tag + +stg_ap_0 = mkRtsApplyEntryLabel SLIT("0") + +-- | 'slowArgs' takes a list of function arguments and prepares them for +-- pushing on the stack for "extra" arguments to a function which requires +-- fewer arguments than we currently have. +slowArgs :: [CAddrMode] -> [CAddrMode] +slowArgs [] = [] +slowArgs amodes = CLbl lbl RetRep : args ++ slowArgs rest + where (tag, args, rest) = matchSlowPattern amodes + lbl = mkRtsApplyInfoLabel tag + +matchSlowPattern :: [CAddrMode] -> (LitString, [CAddrMode], [CAddrMode]) +matchSlowPattern amodes = (tag, these, rest) + where reps = map getAmodeRep amodes + (tag, n) = findMatch (map primRepToArgRep reps) + (these, rest) = splitAt n amodes + +-- These cases were found to cover about 99% of all slow calls: +findMatch (RepP: RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppppp"), 7) +findMatch (RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("pppppp"), 6) +findMatch (RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppp"), 5) +findMatch (RepP: RepP: RepP: RepP: _) = (SLIT("pppp"), 4) +findMatch (RepP: RepP: RepP: _) = (SLIT("ppp"), 3) +findMatch (RepP: RepP: RepV: _) = (SLIT("ppv"), 3) +findMatch (RepP: RepP: _) = (SLIT("pp"), 2) +findMatch (RepP: RepV: _) = (SLIT("pv"), 2) +findMatch (RepP: _) = (SLIT("p"), 1) +findMatch (RepV: _) = (SLIT("v"), 1) +findMatch (RepN: _) = (SLIT("n"), 1) +findMatch (RepF: _) = (SLIT("f"), 1) +findMatch (RepD: _) = (SLIT("d"), 1) +findMatch (RepL: _) = (SLIT("l"), 1) +findMatch _ = panic "CgStackery.findMatch" + +#ifdef DEBUG +primRepChar p | isFollowableRep p = 'p' +primRepChar VoidRep = 'v' +primRepChar FloatRep = 'f' +primRepChar DoubleRep = 'd' +primRepChar p | getPrimRepSize p == 1 = 'n' +primRepChar p | is64BitRep p = 'l' + +traceSlowCall amodes and_then + = trace ("call: " ++ map primRepChar (map getAmodeRep amodes)) and_then +#endif \end{code} %************************************************************************ @@ -136,34 +173,36 @@ allocStack :: FCode VirtualSpOffset allocStack = allocPrimStack 1 allocPrimStack :: Int -> FCode VirtualSpOffset -allocPrimStack size info_down (MkCgState absC binds - ((virt_sp, free_stk, real_sp, hw_sp), h_usage)) - = (chosen_slot, MkCgState absC binds (new_stk_usage, h_usage)) - where - push_virt_sp = virt_sp + size - - (chosen_slot, new_stk_usage) - = case find_block free_stk of - Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp, - hw_sp `max` push_virt_sp)) - -- Adjust high water mark - - Just slot -> (slot, (virt_sp, - delete_block free_stk slot, real_sp, hw_sp)) - - -- find_block looks for a contiguous chunk of free slots - find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset - find_block [] = Nothing - 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 = off+size-1 - - delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk, +allocPrimStack size = do + ((virt_sp, frame, free_stk, real_sp, hw_sp),h_usage) <- getUsage + let push_virt_sp = virt_sp + size + let (chosen_slot, new_stk_usage) = + case find_block free_stk of + Nothing -> (push_virt_sp, + (push_virt_sp, frame, free_stk, real_sp, + hw_sp `max` push_virt_sp)) + -- Adjust high water mark + Just slot -> (slot, + (virt_sp, frame, + delete_block free_stk slot, + real_sp, hw_sp)) + setUsage (new_stk_usage, h_usage) + return chosen_slot + + where + -- find_block looks for a contiguous chunk of free slots + find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset + find_block [] = Nothing + 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 = off+size-1 + + 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 @@ -176,13 +215,13 @@ 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)) - = (push_virt_sp, MkCgState absC binds (new_stk_usage, h_usage)) - where - push_virt_sp = virt_sp + size - new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp) - -- Adjust high water mark +allocStackTop size = do + ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage + let push_virt_sp = virt_sp + size + let new_stk_usage = (push_virt_sp, frame, free_stk, real_sp, + hw_sp `max` push_virt_sp) + setUsage (new_stk_usage, h_usage) + return push_virt_sp \end{code} Pop some words from the current top of stack. This is used for @@ -190,35 +229,50 @@ de-allocating the return address in a case alternative. \begin{code} deAllocStackTop :: Int -> FCode VirtualSpOffset -deAllocStackTop size info_down (MkCgState absC binds - ((virt_sp, free_stk, real_sp, hw_sp), h_usage)) - = (pop_virt_sp, MkCgState absC binds (new_stk_usage, h_usage)) - where - pop_virt_sp = virt_sp - size - new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp) +deAllocStackTop size = do + ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage + let pop_virt_sp = virt_sp - size + let new_stk_usage = (pop_virt_sp, frame, free_stk, real_sp, hw_sp) + setUsage (new_stk_usage, h_usage) + return pop_virt_sp \end{code} \begin{code} adjustStackHW :: VirtualSpOffset -> Code -adjustStackHW offset info_down (MkCgState absC binds usage) - = MkCgState absC binds new_usage - where - ((vSp,fSp,realSp,hwSp), h_usage) = usage - new_usage = ((vSp, fSp, realSp, max offset hwSp), h_usage) - -- No need to fiddle with virtual Sp etc because this call is - -- only done just before the end of a block +adjustStackHW offset = do + ((vSp,fTop,fSp,realSp,hwSp), h_usage) <- getUsage + setUsage ((vSp, fTop, fSp, realSp, max offset hwSp), h_usage) \end{code} A knot-tying beast. \begin{code} getFinalStackHW :: (VirtualSpOffset -> Code) -> Code -getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1 - where - state1 = fcode hwSp info_down (MkCgState absC binds usages) - (MkCgState _ _ ((_,_,_, hwSp), _)) = state1 +getFinalStackHW fcode = do + fixC (\hwSp -> do + fcode hwSp + ((_,_,_,_, hwSp),_) <- getUsage + return hwSp) + return () \end{code} +\begin{code} +setStackFrame :: VirtualSpOffset -> Code +setStackFrame offset = do + ((vSp,_,fSp,realSp,hwSp), h_usage) <- getUsage + setUsage ((vSp, offset, fSp, realSp, hwSp), h_usage) + +getStackFrame :: FCode VirtualSpOffset +getStackFrame = do + ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage + return frame +\end{code} + +\begin{code} +updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE + | opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE + | otherwise = uF_SIZE +\end{code} %************************************************************************ %* * @@ -230,13 +284,12 @@ Explicitly free some stack space. \begin{code} 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 all_free - all_free = addFreeSlots free (zip extra_free (repeat slot)) +addFreeStackSlots extra_free slot = do + ((vsp, frame,free, real, hw),heap_usage) <- getUsage + let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot)) + let (new_vsp, new_free) = trim vsp all_free + let new_usage = ((new_vsp, frame, new_free, real, hw), heap_usage) + setUsage new_usage freeStackSlots :: [VirtualSpOffset] -> Code freeStackSlots slots = addFreeStackSlots slots Free