ghc/compiler/codeGen/CgStackery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgStackery.lhs,v 1.23 2002/12/11 15:36:27 simonmar Exp $
   5 %
   6 \section[CgStackery]{Stack management functions}
   7
   8 Stack-twiddling operations, which are pretty low-down and grimy.
   9 (This is the module that knows all about stack layouts, etc.)
  10
  11 \begin{code}
  12 module CgStackery (
  13         allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
  14         adjustStackHW, getFinalStackHW,
  15         setStackFrame, getStackFrame,
  16         mkVirtStkOffsets, mkStkAmodes,
  17         freeStackSlots, dataStackSlots, addFreeSlots,
  18         updateFrameSize,
  19         constructSlowCall, slowArgs,
  20     ) where
  21
  22 #include "HsVersions.h"
  23
  24 import CgMonad
  25 import AbsCSyn
  26 import CLabel           ( mkRtsApplyInfoLabel, mkRtsApplyEntryLabel )
  27
  28 import CgUsages         ( getRealSp )
  29 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  30 import PrimRep
  31 import CmdLineOpts      ( opt_SccProfilingOn, opt_GranMacros )
  32 import Constants
  33 import Util             ( sortLt )
  34 import FastString       ( LitString )
  35 import Panic
  36
  37 import TRACE            ( trace )
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection[CgStackery-layout]{Laying out a stack frame}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 'mkVirtStkOffsets' is given a list of arguments.  The first argument
  47 gets the /largest/ virtual stack offset (remember, virtual offsets
  48 increase towards the top of stack).
  49
  50 \begin{code}
  51 mkVirtStkOffsets
  52           :: VirtualSpOffset    -- Offset of the last allocated thing
  53           -> (a -> PrimRep)     -- to be able to grab kinds
  54           -> [a]                        -- things to make offsets for
  55           -> (VirtualSpOffset,          -- OUTPUTS: Topmost allocated word
  56               [(a, VirtualSpOffset)])   -- things with offsets
  57
  58 mkVirtStkOffsets init_Sp_offset kind_fun things
  59     = loop init_Sp_offset [] (reverse things)
  60   where
  61     loop offset offs [] = (offset,offs)
  62     loop offset offs (t:things) =
  63              let
  64                  size = getPrimRepSize (kind_fun t)
  65                  thing_slot = offset + size
  66              in
  67              loop thing_slot ((t,thing_slot):offs) things
  68     -- offset of thing is offset+size, because we're growing the stack
  69     -- *downwards* as the offsets increase.
  70
  71
  72 -- | 'mkStkAmodes' is a higher-level version of
  73 -- 'mkVirtStkOffsets'.  It starts from the tail-call locations.
  74 -- It returns a single list of addressing modes for the stack
  75 -- locations, and therefore is in the monad.  It /doesn't/ adjust the
  76 -- high water mark.
  77
  78 mkStkAmodes
  79         :: VirtualSpOffset          -- Tail call positions
  80         -> [CAddrMode]              -- things to make offsets for
  81         -> FCode (VirtualSpOffset,  -- OUTPUTS: Topmost allocated word
  82                   AbstractC)        -- Assignments to appropriate stk slots
  83
  84 mkStkAmodes tail_Sp things
  85   = getRealSp `thenFC` \ realSp ->
  86     let
  87       (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp getAmodeRep things
  88
  89       abs_cs =
  90           [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
  91           | (thing, offset) <- offsets
  92           ]
  93     in
  94     returnFC (last_Sp_offset, mkAbstractCs abs_cs)
  95 \end{code}
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection{Pushing the arguments for a slow call}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 For a slow call, we must take a bunch of arguments and intersperse
 104 some stg_ap_<pattern>_ret_info return addresses.
 105
 106 \begin{code}
 107 constructSlowCall :: [CAddrMode] -> (CAddrMode, [CAddrMode])
 108    -- don't forget the zero case
 109 constructSlowCall [] = (CLbl stg_ap_0 CodePtrRep , [])
 110 constructSlowCall amodes =
 111   -- traceSlowCall amodes $
 112   (CLbl lbl CodePtrRep, these ++ slowArgs rest)
 113   where (tag, these, rest) = matchSlowPattern amodes
 114         lbl = mkRtsApplyEntryLabel tag
 115
 116 stg_ap_0 = mkRtsApplyEntryLabel SLIT("0")
 117
 118 -- | 'slowArgs' takes a list of function arguments and prepares them for
 119 -- pushing on the stack for "extra" arguments to a function which requires
 120 -- fewer arguments than we currently have.
 121 slowArgs :: [CAddrMode] -> [CAddrMode]
 122 slowArgs [] = []
 123 slowArgs amodes = CLbl lbl RetRep : args ++ slowArgs rest
 124   where (tag, args, rest) = matchSlowPattern amodes
 125         lbl = mkRtsApplyInfoLabel tag
 126
 127 matchSlowPattern :: [CAddrMode] -> (LitString, [CAddrMode], [CAddrMode])
 128 matchSlowPattern amodes = (tag, these, rest)
 129   where reps = map getAmodeRep amodes
 130         (tag, n) = findMatch (map primRepToArgRep reps)
 131         (these, rest) = splitAt n amodes
 132
 133 -- These cases were found to cover about 99% of all slow calls:
 134 findMatch (RepP: RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppppp"), 7)
 135 findMatch (RepP: RepP: RepP: RepP: RepP: RepP: _)       = (SLIT("pppppp"), 6)
 136 findMatch (RepP: RepP: RepP: RepP: RepP: _)             = (SLIT("ppppp"), 5)
 137 findMatch (RepP: RepP: RepP: RepP: _)                   = (SLIT("pppp"), 4)
 138 findMatch (RepP: RepP: RepP: _)                         = (SLIT("ppp"), 3)
 139 findMatch (RepP: RepP: RepV: _)                         = (SLIT("ppv"), 3)
 140 findMatch (RepP: RepP: _)                               = (SLIT("pp"), 2)
 141 findMatch (RepP: RepV: _)                               = (SLIT("pv"), 2)
 142 findMatch (RepP: _)                                     = (SLIT("p"), 1)
 143 findMatch (RepV: _)                                     = (SLIT("v"), 1)
 144 findMatch (RepN: _)                                     = (SLIT("n"), 1)
 145 findMatch (RepF: _)                                     = (SLIT("f"), 1)
 146 findMatch (RepD: _)                                     = (SLIT("d"), 1)
 147 findMatch (RepL: _)                                     = (SLIT("l"), 1)
 148 findMatch _  = panic "CgStackery.findMatch"
 149
 150 #ifdef DEBUG
 151 primRepChar p | isFollowableRep p     = 'p'
 152 primRepChar VoidRep                   = 'v'
 153 primRepChar FloatRep                  = 'f'
 154 primRepChar DoubleRep                 = 'd'
 155 primRepChar p | getPrimRepSize p == 1 = 'n'
 156 primRepChar p | is64BitRep p          = 'l'
 157
 158 traceSlowCall amodes and_then
 159  = trace ("call: " ++ map primRepChar (map getAmodeRep amodes)) and_then
 160 #endif
 161 \end{code}
 162
 163 %************************************************************************
 164 %*                                                                      *
 165 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 Allocate a virtual offset for something.
 170
 171 \begin{code}
 172 allocStack :: FCode VirtualSpOffset
 173 allocStack = allocPrimStack 1
 174
 175 allocPrimStack :: Int -> FCode VirtualSpOffset
 176 allocPrimStack size = do
 177         ((virt_sp, frame, free_stk, real_sp, hw_sp),h_usage) <- getUsage
 178         let push_virt_sp = virt_sp + size
 179         let (chosen_slot, new_stk_usage) =
 180                 case find_block free_stk of
 181                    Nothing -> (push_virt_sp,
 182                                  (push_virt_sp, frame, free_stk, real_sp,
 183                                   hw_sp `max` push_virt_sp))
 184                                                 -- Adjust high water mark
 185                    Just slot -> (slot,
 186                                   (virt_sp, frame,
 187                                    delete_block free_stk slot,
 188                                    real_sp, hw_sp))
 189         setUsage (new_stk_usage, h_usage)
 190         return chosen_slot
 191
 192         where
 193                 -- find_block looks for a contiguous chunk of free slots
 194                 find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
 195                 find_block [] = Nothing
 196                 find_block ((off,free):slots)
 197                         | take size ((off,free):slots) ==
 198                           zip [off..top_slot] (repeat Free) = Just top_slot
 199                         | otherwise                                = find_block slots
 200                                 -- The stack grows downwards, with increasing virtual offsets.
 201                                 -- Therefore, the address of a multi-word object is the *highest*
 202                                 -- virtual offset it occupies (top_slot below).
 203                         where top_slot = off+size-1
 204
 205                 delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
 206                                            (s<=slot-size) || (s>slot) ]
 207                               -- Retain slots which are not in the range
 208                               -- slot-size+1..slot
 209 \end{code}
 210
 211 Allocate a chunk ON TOP OF the stack.
 212
 213 ToDo: should really register this memory as NonPointer stuff in the
 214 free list.
 215
 216 \begin{code}
 217 allocStackTop :: Int -> FCode VirtualSpOffset
 218 allocStackTop size = do
 219         ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
 220         let push_virt_sp = virt_sp + size
 221         let new_stk_usage = (push_virt_sp, frame, free_stk, real_sp,
 222                                 hw_sp `max` push_virt_sp)
 223         setUsage (new_stk_usage, h_usage)
 224         return push_virt_sp
 225 \end{code}
 226
 227 Pop some words from the current top of stack.  This is used for
 228 de-allocating the return address in a case alternative.
 229
 230 \begin{code}
 231 deAllocStackTop :: Int -> FCode VirtualSpOffset
 232 deAllocStackTop size = do
 233         ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
 234         let pop_virt_sp = virt_sp - size
 235         let new_stk_usage = (pop_virt_sp, frame, free_stk, real_sp, hw_sp)
 236         setUsage (new_stk_usage, h_usage)
 237         return pop_virt_sp
 238 \end{code}
 239
 240 \begin{code}
 241 adjustStackHW :: VirtualSpOffset -> Code
 242 adjustStackHW offset = do
 243         ((vSp,fTop,fSp,realSp,hwSp), h_usage) <- getUsage
 244         setUsage ((vSp, fTop, fSp, realSp, max offset hwSp), h_usage)
 245 \end{code}
 246
 247 A knot-tying beast.
 248
 249 \begin{code}
 250 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
 251 getFinalStackHW fcode = do
 252         fixC (\hwSp -> do
 253                 fcode hwSp
 254                 ((_,_,_,_, hwSp),_) <- getUsage
 255                 return hwSp)
 256         return ()
 257 \end{code}
 258
 259 \begin{code}
 260 setStackFrame :: VirtualSpOffset -> Code
 261 setStackFrame offset = do
 262         ((vSp,_,fSp,realSp,hwSp), h_usage) <- getUsage
 263         setUsage ((vSp, offset, fSp, realSp, hwSp), h_usage)
 264
 265 getStackFrame :: FCode VirtualSpOffset
 266 getStackFrame = do
 267         ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage
 268         return frame
 269 \end{code}
 270
 271 \begin{code}
 272 updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
 273                 | opt_GranMacros     = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
 274                 | otherwise          = uF_SIZE
 275 \end{code}
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsection[CgStackery-free]{Free stack slots}
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 Explicitly free some stack space.
 284
 285 \begin{code}
 286 addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
 287 addFreeStackSlots extra_free slot = do
 288         ((vsp, frame,free, real, hw),heap_usage) <- getUsage
 289         let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot))
 290         let (new_vsp, new_free) = trim vsp all_free
 291         let new_usage = ((new_vsp, frame, new_free, real, hw), heap_usage)
 292         setUsage new_usage
 293
 294 freeStackSlots :: [VirtualSpOffset] -> Code
 295 freeStackSlots slots = addFreeStackSlots slots Free
 296
 297 dataStackSlots :: [VirtualSpOffset] -> Code
 298 dataStackSlots slots = addFreeStackSlots slots NonPointer
 299
 300 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
 301 addFreeSlots cs [] = cs
 302 addFreeSlots [] ns = ns
 303 addFreeSlots ((c,s):cs) ((n,s'):ns)
 304  = if c < n then
 305         (c,s) : addFreeSlots cs ((n,s'):ns)
 306    else if c > n then
 307         (n,s') : addFreeSlots ((c,s):cs) ns
 308    else if s /= s' then -- c == n
 309         (c,s') : addFreeSlots cs ns
 310    else
 311         panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
 312                                              ++ show (n:map fst ns))
 313
 314 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
 315 trim current_sp free_slots
 316   = try current_sp free_slots
 317   where
 318         try csp [] = (csp,[])
 319
 320         try csp (slot@(off,state):slots) =
 321                 if state == Free && null slots' then
 322                     if csp' < off then
 323                         (csp', [])
 324                     else if csp' == off then
 325                         (csp'-1, [])
 326                     else
 327                         (csp',[slot])
 328                 else
 329                     (csp', slot:slots')
 330                 where
 331                     (csp',slots') = try csp slots
 332 \end{code}